4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
112 /* Used to avoid recursion through the op tree in scalarvoid() and
116 #define DEFERRED_OP_STEP 100
117 #define DEFER_OP(o) \
119 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
120 defer_stack_alloc += DEFERRED_OP_STEP; \
121 assert(defer_stack_alloc > 0); \
122 Renew(defer_stack, defer_stack_alloc, OP *); \
124 defer_stack[++defer_ix] = o; \
127 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
129 /* remove any leading "empty" ops from the op_next chain whose first
130 * node's address is stored in op_p. Store the updated address of the
131 * first node in op_p.
135 S_prune_chain_head(OP** op_p)
138 && ( (*op_p)->op_type == OP_NULL
139 || (*op_p)->op_type == OP_SCOPE
140 || (*op_p)->op_type == OP_SCALAR
141 || (*op_p)->op_type == OP_LINESEQ)
143 *op_p = (*op_p)->op_next;
147 /* See the explanatory comments above struct opslab in op.h. */
149 #ifdef PERL_DEBUG_READONLY_OPS
150 # define PERL_SLAB_SIZE 128
151 # define PERL_MAX_SLAB_SIZE 4096
152 # include <sys/mman.h>
155 #ifndef PERL_SLAB_SIZE
156 # define PERL_SLAB_SIZE 64
158 #ifndef PERL_MAX_SLAB_SIZE
159 # define PERL_MAX_SLAB_SIZE 2048
162 /* rounds up to nearest pointer */
163 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
164 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
167 S_new_slab(pTHX_ size_t sz)
169 #ifdef PERL_DEBUG_READONLY_OPS
170 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
171 PROT_READ|PROT_WRITE,
172 MAP_ANON|MAP_PRIVATE, -1, 0);
173 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
174 (unsigned long) sz, slab));
175 if (slab == MAP_FAILED) {
176 perror("mmap failed");
179 slab->opslab_size = (U16)sz;
181 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
184 /* The context is unused in non-Windows */
187 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
191 /* requires double parens and aTHX_ */
192 #define DEBUG_S_warn(args) \
194 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
198 Perl_Slab_Alloc(pTHX_ size_t sz)
206 /* We only allocate ops from the slab during subroutine compilation.
207 We find the slab via PL_compcv, hence that must be non-NULL. It could
208 also be pointing to a subroutine which is now fully set up (CvROOT()
209 pointing to the top of the optree for that sub), or a subroutine
210 which isn't using the slab allocator. If our sanity checks aren't met,
211 don't use a slab, but allocate the OP directly from the heap. */
212 if (!PL_compcv || CvROOT(PL_compcv)
213 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
215 o = (OP*)PerlMemShared_calloc(1, sz);
219 /* While the subroutine is under construction, the slabs are accessed via
220 CvSTART(), to avoid needing to expand PVCV by one pointer for something
221 unneeded at runtime. Once a subroutine is constructed, the slabs are
222 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
223 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
225 if (!CvSTART(PL_compcv)) {
227 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
228 CvSLABBED_on(PL_compcv);
229 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
231 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
233 opsz = SIZE_TO_PSIZE(sz);
234 sz = opsz + OPSLOT_HEADER_P;
236 /* The slabs maintain a free list of OPs. In particular, constant folding
237 will free up OPs, so it makes sense to re-use them where possible. A
238 freed up slot is used in preference to a new allocation. */
239 if (slab->opslab_freed) {
240 OP **too = &slab->opslab_freed;
242 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
243 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
244 DEBUG_S_warn((aTHX_ "Alas! too small"));
245 o = *(too = &o->op_next);
246 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
250 Zero(o, opsz, I32 *);
256 #define INIT_OPSLOT \
257 slot->opslot_slab = slab; \
258 slot->opslot_next = slab2->opslab_first; \
259 slab2->opslab_first = slot; \
260 o = &slot->opslot_op; \
263 /* The partially-filled slab is next in the chain. */
264 slab2 = slab->opslab_next ? slab->opslab_next : slab;
265 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
266 /* Remaining space is too small. */
268 /* If we can fit a BASEOP, add it to the free chain, so as not
270 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
271 slot = &slab2->opslab_slots;
273 o->op_type = OP_FREED;
274 o->op_next = slab->opslab_freed;
275 slab->opslab_freed = o;
278 /* Create a new slab. Make this one twice as big. */
279 slot = slab2->opslab_first;
280 while (slot->opslot_next) slot = slot->opslot_next;
281 slab2 = S_new_slab(aTHX_
282 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
284 : (DIFF(slab2, slot)+1)*2);
285 slab2->opslab_next = slab->opslab_next;
286 slab->opslab_next = slab2;
288 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
290 /* Create a new op slot */
291 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
292 assert(slot >= &slab2->opslab_slots);
293 if (DIFF(&slab2->opslab_slots, slot)
294 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
295 slot = &slab2->opslab_slots;
297 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
300 /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
302 assert(!o->op_sibling);
309 #ifdef PERL_DEBUG_READONLY_OPS
311 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
313 PERL_ARGS_ASSERT_SLAB_TO_RO;
315 if (slab->opslab_readonly) return;
316 slab->opslab_readonly = 1;
317 for (; slab; slab = slab->opslab_next) {
318 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
319 (unsigned long) slab->opslab_size, slab));*/
320 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
321 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
322 (unsigned long)slab->opslab_size, errno);
327 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
331 PERL_ARGS_ASSERT_SLAB_TO_RW;
333 if (!slab->opslab_readonly) return;
335 for (; slab2; slab2 = slab2->opslab_next) {
336 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
337 (unsigned long) size, slab2));*/
338 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
339 PROT_READ|PROT_WRITE)) {
340 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
341 (unsigned long)slab2->opslab_size, errno);
344 slab->opslab_readonly = 0;
348 # define Slab_to_rw(op) NOOP
351 /* This cannot possibly be right, but it was copied from the old slab
352 allocator, to which it was originally added, without explanation, in
355 # define PerlMemShared PerlMem
359 Perl_Slab_Free(pTHX_ void *op)
361 OP * const o = (OP *)op;
364 PERL_ARGS_ASSERT_SLAB_FREE;
366 if (!o->op_slabbed) {
368 PerlMemShared_free(op);
373 /* If this op is already freed, our refcount will get screwy. */
374 assert(o->op_type != OP_FREED);
375 o->op_type = OP_FREED;
376 o->op_next = slab->opslab_freed;
377 slab->opslab_freed = o;
378 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
379 OpslabREFCNT_dec_padok(slab);
383 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
385 const bool havepad = !!PL_comppad;
386 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
389 PAD_SAVE_SETNULLPAD();
396 Perl_opslab_free(pTHX_ OPSLAB *slab)
399 PERL_ARGS_ASSERT_OPSLAB_FREE;
401 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
402 assert(slab->opslab_refcnt == 1);
403 for (; slab; slab = slab2) {
404 slab2 = slab->opslab_next;
406 slab->opslab_refcnt = ~(size_t)0;
408 #ifdef PERL_DEBUG_READONLY_OPS
409 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
411 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
412 perror("munmap failed");
416 PerlMemShared_free(slab);
422 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
427 size_t savestack_count = 0;
429 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
432 for (slot = slab2->opslab_first;
434 slot = slot->opslot_next) {
435 if (slot->opslot_op.op_type != OP_FREED
436 && !(slot->opslot_op.op_savefree
442 assert(slot->opslot_op.op_slabbed);
443 op_free(&slot->opslot_op);
444 if (slab->opslab_refcnt == 1) goto free;
447 } while ((slab2 = slab2->opslab_next));
448 /* > 1 because the CV still holds a reference count. */
449 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
451 assert(savestack_count == slab->opslab_refcnt-1);
453 /* Remove the CV’s reference count. */
454 slab->opslab_refcnt--;
461 #ifdef PERL_DEBUG_READONLY_OPS
463 Perl_op_refcnt_inc(pTHX_ OP *o)
466 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
467 if (slab && slab->opslab_readonly) {
480 Perl_op_refcnt_dec(pTHX_ OP *o)
483 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
485 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
487 if (slab && slab->opslab_readonly) {
489 result = --o->op_targ;
492 result = --o->op_targ;
498 * In the following definition, the ", (OP*)0" is just to make the compiler
499 * think the expression is of the right type: croak actually does a Siglongjmp.
501 #define CHECKOP(type,o) \
502 ((PL_op_mask && PL_op_mask[type]) \
503 ? ( op_free((OP*)o), \
504 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
506 : PL_check[type](aTHX_ (OP*)o))
508 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
510 #define CHANGE_TYPE(o,type) \
512 o->op_type = (OPCODE)type; \
513 o->op_ppaddr = PL_ppaddr[type]; \
517 S_no_fh_allowed(pTHX_ OP *o)
519 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
521 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
527 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
529 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
530 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
535 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
537 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
539 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
544 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
546 PERL_ARGS_ASSERT_BAD_TYPE_PV;
548 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
549 (int)n, name, t, OP_DESC(kid)), flags);
553 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
555 SV * const namesv = cv_name((CV *)gv, NULL, 0);
556 PERL_ARGS_ASSERT_BAD_TYPE_GV;
558 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
559 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
563 S_no_bareword_allowed(pTHX_ OP *o)
565 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
567 qerror(Perl_mess(aTHX_
568 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
570 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
573 /* "register" allocation */
576 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
579 const bool is_our = (PL_parser->in_my == KEY_our);
581 PERL_ARGS_ASSERT_ALLOCMY;
583 if (flags & ~SVf_UTF8)
584 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
587 /* complain about "my $<special_var>" etc etc */
591 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
592 (name[1] == '_' && (*name == '$' || len > 2))))
594 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
595 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
596 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
597 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
598 PL_parser->in_my == KEY_state ? "state" : "my"));
600 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
601 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
604 else if (len == 2 && name[1] == '_' && !is_our)
605 /* diag_listed_as: Use of my $_ is experimental */
606 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
607 "Use of %s $_ is experimental",
608 PL_parser->in_my == KEY_state
612 /* allocate a spare slot and store the name in that slot */
614 off = pad_add_name_pvn(name, len,
615 (is_our ? padadd_OUR :
616 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
617 | ( flags & SVf_UTF8 ? SVf_UTF8 : 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 if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
719 assert(!(o->op_private & ~PL_op_private_valid[type]));
722 if (o->op_private & OPpREFCOUNTED) {
733 refcnt = OpREFCNT_dec(o);
736 /* Need to find and remove any pattern match ops from the list
737 we maintain for reset(). */
738 find_and_forget_pmops(o);
748 /* Call the op_free hook if it has been set. Do it now so that it's called
749 * at the right time for refcounted ops, but still before all of the kids
753 if (o->op_flags & OPf_KIDS) {
755 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
756 nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
757 if (!kid || kid->op_type == OP_FREED)
758 /* During the forced freeing of ops after
759 compilation failure, kidops may be freed before
762 if (!(kid->op_flags & OPf_KIDS))
763 /* If it has no kids, just free it now */
770 type = (OPCODE)o->op_targ;
773 Slab_to_rw(OpSLAB(o));
775 /* COP* is not cleared by op_clear() so that we may track line
776 * numbers etc even after null() */
777 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
783 #ifdef DEBUG_LEAKING_SCALARS
787 } while ( (o = POP_DEFERRED_OP()) );
789 Safefree(defer_stack);
793 Perl_op_clear(pTHX_ OP *o)
798 PERL_ARGS_ASSERT_OP_CLEAR;
800 switch (o->op_type) {
801 case OP_NULL: /* Was holding old type, if any. */
804 case OP_ENTEREVAL: /* Was holding hints. */
808 if (!(o->op_flags & OPf_REF)
809 || (PL_check[o->op_type] != Perl_ck_ftst))
816 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
821 /* It's possible during global destruction that the GV is freed
822 before the optree. Whilst the SvREFCNT_inc is happy to bump from
823 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
824 will trigger an assertion failure, because the entry to sv_clear
825 checks that the scalar is not already freed. A check of for
826 !SvIS_FREED(gv) turns out to be invalid, because during global
827 destruction the reference count can be forced down to zero
828 (with SVf_BREAK set). In which case raising to 1 and then
829 dropping to 0 triggers cleanup before it should happen. I
830 *think* that this might actually be a general, systematic,
831 weakness of the whole idea of SVf_BREAK, in that code *is*
832 allowed to raise and lower references during global destruction,
833 so any *valid* code that happens to do this during global
834 destruction might well trigger premature cleanup. */
835 bool still_valid = gv && SvREFCNT(gv);
838 SvREFCNT_inc_simple_void(gv);
840 if (cPADOPo->op_padix > 0) {
841 pad_swipe(cPADOPo->op_padix, TRUE);
842 cPADOPo->op_padix = 0;
845 SvREFCNT_dec(cSVOPo->op_sv);
846 cSVOPo->op_sv = NULL;
849 int try_downgrade = SvREFCNT(gv) == 2;
852 gv_try_downgrade(gv);
856 case OP_METHOD_NAMED:
857 case OP_METHOD_SUPER:
858 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
859 cMETHOPx(o)->op_u.op_meth_sv = NULL;
862 pad_swipe(o->op_targ, 1);
869 SvREFCNT_dec(cSVOPo->op_sv);
870 cSVOPo->op_sv = NULL;
873 Even if op_clear does a pad_free for the target of the op,
874 pad_free doesn't actually remove the sv that exists in the pad;
875 instead it lives on. This results in that it could be reused as
876 a target later on when the pad was reallocated.
879 pad_swipe(o->op_targ,1);
889 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
894 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
895 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
897 if (cPADOPo->op_padix > 0) {
898 pad_swipe(cPADOPo->op_padix, TRUE);
899 cPADOPo->op_padix = 0;
902 SvREFCNT_dec(cSVOPo->op_sv);
903 cSVOPo->op_sv = NULL;
907 PerlMemShared_free(cPVOPo->op_pv);
908 cPVOPo->op_pv = NULL;
912 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
916 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
917 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
920 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
926 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
927 op_free(cPMOPo->op_code_list);
928 cPMOPo->op_code_list = NULL;
930 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
931 /* we use the same protection as the "SAFE" version of the PM_ macros
932 * here since sv_clean_all might release some PMOPs
933 * after PL_regex_padav has been cleared
934 * and the clearing of PL_regex_padav needs to
935 * happen before sv_clean_all
938 if(PL_regex_pad) { /* We could be in destruction */
939 const IV offset = (cPMOPo)->op_pmoffset;
940 ReREFCNT_dec(PM_GETRE(cPMOPo));
941 PL_regex_pad[offset] = &PL_sv_undef;
942 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
946 ReREFCNT_dec(PM_GETRE(cPMOPo));
947 PM_SETRE(cPMOPo, NULL);
953 if (o->op_targ > 0) {
954 pad_free(o->op_targ);
960 S_cop_free(pTHX_ COP* cop)
962 PERL_ARGS_ASSERT_COP_FREE;
965 if (! specialWARN(cop->cop_warnings))
966 PerlMemShared_free(cop->cop_warnings);
967 cophh_free(CopHINTHASH_get(cop));
968 if (PL_curcop == cop)
973 S_forget_pmop(pTHX_ PMOP *const o
976 HV * const pmstash = PmopSTASH(o);
978 PERL_ARGS_ASSERT_FORGET_PMOP;
980 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
981 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
983 PMOP **const array = (PMOP**) mg->mg_ptr;
984 U32 count = mg->mg_len / sizeof(PMOP**);
989 /* Found it. Move the entry at the end to overwrite it. */
990 array[i] = array[--count];
991 mg->mg_len = count * sizeof(PMOP**);
992 /* Could realloc smaller at this point always, but probably
993 not worth it. Probably worth free()ing if we're the
996 Safefree(mg->mg_ptr);
1009 S_find_and_forget_pmops(pTHX_ OP *o)
1011 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1013 if (o->op_flags & OPf_KIDS) {
1014 OP *kid = cUNOPo->op_first;
1016 switch (kid->op_type) {
1021 forget_pmop((PMOP*)kid);
1023 find_and_forget_pmops(kid);
1024 kid = OP_SIBLING(kid);
1030 =for apidoc Am|void|op_null|OP *o
1032 Neutralizes an op when it is no longer needed, but is still linked to from
1039 Perl_op_null(pTHX_ OP *o)
1043 PERL_ARGS_ASSERT_OP_NULL;
1045 if (o->op_type == OP_NULL)
1048 o->op_targ = o->op_type;
1049 CHANGE_TYPE(o, OP_NULL);
1053 Perl_op_refcnt_lock(pTHX)
1058 PERL_UNUSED_CONTEXT;
1063 Perl_op_refcnt_unlock(pTHX)
1068 PERL_UNUSED_CONTEXT;
1074 =for apidoc op_sibling_splice
1076 A general function for editing the structure of an existing chain of
1077 op_sibling nodes. By analogy with the perl-level splice() function, allows
1078 you to delete zero or more sequential nodes, replacing them with zero or
1079 more different nodes. Performs the necessary op_first/op_last
1080 housekeeping on the parent node and op_sibling manipulation on the
1081 children. The last deleted node will be marked as as the last node by
1082 updating the op_sibling or op_lastsib field as appropriate.
1084 Note that op_next is not manipulated, and nodes are not freed; that is the
1085 responsibility of the caller. It also won't create a new list op for an
1086 empty list etc; use higher-level functions like op_append_elem() for that.
1088 parent is the parent node of the sibling chain.
1090 start is the node preceding the first node to be spliced. Node(s)
1091 following it will be deleted, and ops will be inserted after it. If it is
1092 NULL, the first node onwards is deleted, and nodes are inserted at the
1095 del_count is the number of nodes to delete. If zero, no nodes are deleted.
1096 If -1 or greater than or equal to the number of remaining kids, all
1097 remaining kids are deleted.
1099 insert is the first of a chain of nodes to be inserted in place of the nodes.
1100 If NULL, no nodes are inserted.
1102 The head of the chain of deleted ops is returned, or NULL if no ops were
1107 action before after returns
1108 ------ ----- ----- -------
1111 splice(P, A, 2, X-Y-Z) | | B-C
1115 splice(P, NULL, 1, X-Y) | | A
1119 splice(P, NULL, 3, NULL) | | A-B-C
1123 splice(P, B, 0, X-Y) | | NULL
1130 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1132 OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1134 OP *last_del = NULL;
1135 OP *last_ins = NULL;
1137 PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1139 assert(del_count >= -1);
1141 if (del_count && first) {
1143 while (--del_count && OP_HAS_SIBLING(last_del))
1144 last_del = OP_SIBLING(last_del);
1145 rest = OP_SIBLING(last_del);
1146 OP_SIBLING_set(last_del, NULL);
1147 last_del->op_lastsib = 1;
1154 while (OP_HAS_SIBLING(last_ins))
1155 last_ins = OP_SIBLING(last_ins);
1156 OP_SIBLING_set(last_ins, rest);
1157 last_ins->op_lastsib = rest ? 0 : 1;
1163 OP_SIBLING_set(start, insert);
1164 start->op_lastsib = insert ? 0 : 1;
1167 cLISTOPx(parent)->op_first = insert;
1170 /* update op_last etc */
1171 U32 type = parent->op_type;
1174 if (type == OP_NULL)
1175 type = parent->op_targ;
1176 type = PL_opargs[type] & OA_CLASS_MASK;
1178 lastop = last_ins ? last_ins : start ? start : NULL;
1179 if ( type == OA_BINOP
1180 || type == OA_LISTOP
1184 cLISTOPx(parent)->op_last = lastop;
1187 lastop->op_lastsib = 1;
1188 #ifdef PERL_OP_PARENT
1189 lastop->op_sibling = parent;
1193 return last_del ? first : NULL;
1197 =for apidoc op_parent
1199 returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1200 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1207 Perl_op_parent(OP *o)
1209 PERL_ARGS_ASSERT_OP_PARENT;
1210 #ifdef PERL_OP_PARENT
1211 while (OP_HAS_SIBLING(o))
1213 return o->op_sibling;
1221 /* replace the sibling following start with a new UNOP, which becomes
1222 * the parent of the original sibling; e.g.
1224 * op_sibling_newUNOP(P, A, unop-args...)
1232 * where U is the new UNOP.
1234 * parent and start args are the same as for op_sibling_splice();
1235 * type and flags args are as newUNOP().
1237 * Returns the new UNOP.
1241 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1245 kid = op_sibling_splice(parent, start, 1, NULL);
1246 newop = newUNOP(type, flags, kid);
1247 op_sibling_splice(parent, start, 0, newop);
1252 /* lowest-level newLOGOP-style function - just allocates and populates
1253 * the struct. Higher-level stuff should be done by S_new_logop() /
1254 * newLOGOP(). This function exists mainly to avoid op_first assignment
1255 * being spread throughout this file.
1259 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1264 NewOp(1101, logop, 1, LOGOP);
1265 CHANGE_TYPE(logop, type);
1266 logop->op_first = first;
1267 logop->op_other = other;
1268 logop->op_flags = OPf_KIDS;
1269 while (kid && OP_HAS_SIBLING(kid))
1270 kid = OP_SIBLING(kid);
1272 kid->op_lastsib = 1;
1273 #ifdef PERL_OP_PARENT
1274 kid->op_sibling = (OP*)logop;
1281 /* Contextualizers */
1284 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1286 Applies a syntactic context to an op tree representing an expression.
1287 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1288 or C<G_VOID> to specify the context to apply. The modified op tree
1295 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1297 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1299 case G_SCALAR: return scalar(o);
1300 case G_ARRAY: return list(o);
1301 case G_VOID: return scalarvoid(o);
1303 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1310 =for apidoc Am|OP*|op_linklist|OP *o
1311 This function is the implementation of the L</LINKLIST> macro. It should
1312 not be called directly.
1318 Perl_op_linklist(pTHX_ OP *o)
1322 PERL_ARGS_ASSERT_OP_LINKLIST;
1327 /* establish postfix order */
1328 first = cUNOPo->op_first;
1331 o->op_next = LINKLIST(first);
1334 OP *sibl = OP_SIBLING(kid);
1336 kid->op_next = LINKLIST(sibl);
1351 S_scalarkids(pTHX_ OP *o)
1353 if (o && o->op_flags & OPf_KIDS) {
1355 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1362 S_scalarboolean(pTHX_ OP *o)
1364 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1366 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1367 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1368 if (ckWARN(WARN_SYNTAX)) {
1369 const line_t oldline = CopLINE(PL_curcop);
1371 if (PL_parser && PL_parser->copline != NOLINE) {
1372 /* This ensures that warnings are reported at the first line
1373 of the conditional, not the last. */
1374 CopLINE_set(PL_curcop, PL_parser->copline);
1376 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1377 CopLINE_set(PL_curcop, oldline);
1384 S_op_varname(pTHX_ const OP *o)
1387 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1388 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1390 const char funny = o->op_type == OP_PADAV
1391 || o->op_type == OP_RV2AV ? '@' : '%';
1392 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1394 if (cUNOPo->op_first->op_type != OP_GV
1395 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1397 return varname(gv, funny, 0, NULL, 0, 1);
1400 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1405 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1406 { /* or not so pretty :-) */
1407 if (o->op_type == OP_CONST) {
1409 if (SvPOK(*retsv)) {
1411 *retsv = sv_newmortal();
1412 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1413 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1415 else if (!SvOK(*retsv))
1418 else *retpv = "...";
1422 S_scalar_slice_warning(pTHX_ const OP *o)
1426 o->op_type == OP_HSLICE ? '{' : '[';
1428 o->op_type == OP_HSLICE ? '}' : ']';
1430 SV *keysv = NULL; /* just to silence compiler warnings */
1431 const char *key = NULL;
1433 if (!(o->op_private & OPpSLICEWARNING))
1435 if (PL_parser && PL_parser->error_count)
1436 /* This warning can be nonsensical when there is a syntax error. */
1439 kid = cLISTOPo->op_first;
1440 kid = OP_SIBLING(kid); /* get past pushmark */
1441 /* weed out false positives: any ops that can return lists */
1442 switch (kid->op_type) {
1471 /* Don't warn if we have a nulled list either. */
1472 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1475 assert(OP_SIBLING(kid));
1476 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1477 if (!name) /* XS module fiddling with the op tree */
1479 S_op_pretty(aTHX_ kid, &keysv, &key);
1480 assert(SvPOK(name));
1481 sv_chop(name,SvPVX(name)+1);
1483 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1484 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1485 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1487 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1488 lbrack, key, rbrack);
1490 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1491 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1492 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1494 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1495 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1499 Perl_scalar(pTHX_ OP *o)
1503 /* assumes no premature commitment */
1504 if (!o || (PL_parser && PL_parser->error_count)
1505 || (o->op_flags & OPf_WANT)
1506 || o->op_type == OP_RETURN)
1511 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1513 switch (o->op_type) {
1515 scalar(cBINOPo->op_first);
1516 if (o->op_private & OPpREPEAT_DOLIST) {
1517 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1518 assert(kid->op_type == OP_PUSHMARK);
1519 if (OP_HAS_SIBLING(kid) && !OP_HAS_SIBLING(OP_SIBLING(kid))) {
1520 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1521 o->op_private &=~ OPpREPEAT_DOLIST;
1528 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1538 if (o->op_flags & OPf_KIDS) {
1539 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1545 kid = cLISTOPo->op_first;
1547 kid = OP_SIBLING(kid);
1550 OP *sib = OP_SIBLING(kid);
1551 if (sib && kid->op_type != OP_LEAVEWHEN
1552 && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL
1553 || ( sib->op_targ != OP_NEXTSTATE
1554 && sib->op_targ != OP_DBSTATE )))
1560 PL_curcop = &PL_compiling;
1565 kid = cLISTOPo->op_first;
1568 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1573 /* Warn about scalar context */
1574 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1575 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1578 const char *key = NULL;
1580 /* This warning can be nonsensical when there is a syntax error. */
1581 if (PL_parser && PL_parser->error_count)
1584 if (!ckWARN(WARN_SYNTAX)) break;
1586 kid = cLISTOPo->op_first;
1587 kid = OP_SIBLING(kid); /* get past pushmark */
1588 assert(OP_SIBLING(kid));
1589 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1590 if (!name) /* XS module fiddling with the op tree */
1592 S_op_pretty(aTHX_ kid, &keysv, &key);
1593 assert(SvPOK(name));
1594 sv_chop(name,SvPVX(name)+1);
1596 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1597 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1598 "%%%"SVf"%c%s%c in scalar context better written "
1600 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1601 lbrack, key, rbrack);
1603 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1604 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1605 "%%%"SVf"%c%"SVf"%c in scalar context better "
1606 "written as $%"SVf"%c%"SVf"%c",
1607 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1608 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1615 Perl_scalarvoid(pTHX_ OP *arg)
1621 SSize_t defer_stack_alloc = 0;
1622 SSize_t defer_ix = -1;
1623 OP **defer_stack = NULL;
1626 PERL_ARGS_ASSERT_SCALARVOID;
1629 SV *useless_sv = NULL;
1630 const char* useless = NULL;
1632 if (o->op_type == OP_NEXTSTATE
1633 || o->op_type == OP_DBSTATE
1634 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1635 || o->op_targ == OP_DBSTATE)))
1636 PL_curcop = (COP*)o; /* for warning below */
1638 /* assumes no premature commitment */
1639 want = o->op_flags & OPf_WANT;
1640 if ((want && want != OPf_WANT_SCALAR)
1641 || (PL_parser && PL_parser->error_count)
1642 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1647 if ((o->op_private & OPpTARGET_MY)
1648 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1650 /* newASSIGNOP has already applied scalar context, which we
1651 leave, as if this op is inside SASSIGN. */
1655 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1657 switch (o->op_type) {
1659 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1663 if (o->op_flags & OPf_STACKED)
1667 if (o->op_private == 4)
1702 case OP_GETSOCKNAME:
1703 case OP_GETPEERNAME:
1708 case OP_GETPRIORITY:
1733 useless = OP_DESC(o);
1743 case OP_AELEMFAST_LEX:
1747 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1748 /* Otherwise it's "Useless use of grep iterator" */
1749 useless = OP_DESC(o);
1753 kid = cLISTOPo->op_first;
1754 if (kid && kid->op_type == OP_PUSHRE
1756 && !(o->op_flags & OPf_STACKED)
1758 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1760 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1763 useless = OP_DESC(o);
1767 kid = cUNOPo->op_first;
1768 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1769 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1772 useless = "negative pattern binding (!~)";
1776 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1777 useless = "non-destructive substitution (s///r)";
1781 useless = "non-destructive transliteration (tr///r)";
1788 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1789 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1790 useless = "a variable";
1795 if (cSVOPo->op_private & OPpCONST_STRICT)
1796 no_bareword_allowed(o);
1798 if (ckWARN(WARN_VOID)) {
1800 /* don't warn on optimised away booleans, eg
1801 * use constant Foo, 5; Foo || print; */
1802 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1804 /* the constants 0 and 1 are permitted as they are
1805 conventionally used as dummies in constructs like
1806 1 while some_condition_with_side_effects; */
1807 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1809 else if (SvPOK(sv)) {
1810 SV * const dsv = newSVpvs("");
1812 = Perl_newSVpvf(aTHX_
1814 pv_pretty(dsv, SvPVX_const(sv),
1815 SvCUR(sv), 32, NULL, NULL,
1817 | PERL_PV_ESCAPE_NOCLEAR
1818 | PERL_PV_ESCAPE_UNI_DETECT));
1819 SvREFCNT_dec_NN(dsv);
1821 else if (SvOK(sv)) {
1822 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1825 useless = "a constant (undef)";
1828 op_null(o); /* don't execute or even remember it */
1832 CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
1836 CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
1840 CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
1844 CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
1849 UNOP *refgen, *rv2cv;
1852 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1855 rv2gv = ((BINOP *)o)->op_last;
1856 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1859 refgen = (UNOP *)((BINOP *)o)->op_first;
1861 if (!refgen || (refgen->op_type != OP_REFGEN
1862 && refgen->op_type != OP_SREFGEN))
1865 exlist = (LISTOP *)refgen->op_first;
1866 if (!exlist || exlist->op_type != OP_NULL
1867 || exlist->op_targ != OP_LIST)
1870 if (exlist->op_first->op_type != OP_PUSHMARK
1871 && exlist->op_first != exlist->op_last)
1874 rv2cv = (UNOP*)exlist->op_last;
1876 if (rv2cv->op_type != OP_RV2CV)
1879 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1880 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1881 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1883 o->op_private |= OPpASSIGN_CV_TO_GV;
1884 rv2gv->op_private |= OPpDONT_INIT_GV;
1885 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1897 kid = cLOGOPo->op_first;
1898 if (kid->op_type == OP_NOT
1899 && (kid->op_flags & OPf_KIDS)) {
1900 if (o->op_type == OP_AND) {
1901 CHANGE_TYPE(o, OP_OR);
1903 CHANGE_TYPE(o, OP_AND);
1913 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1914 if (!(kid->op_flags & OPf_KIDS))
1921 if (o->op_flags & OPf_STACKED)
1928 if (!(o->op_flags & OPf_KIDS))
1939 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1940 if (!(kid->op_flags & OPf_KIDS))
1946 /* If the first kid after pushmark is something that the padrange
1947 optimisation would reject, then null the list and the pushmark.
1949 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
1950 && ( !(kid = OP_SIBLING(kid))
1951 || ( kid->op_type != OP_PADSV
1952 && kid->op_type != OP_PADAV
1953 && kid->op_type != OP_PADHV)
1954 || kid->op_private & ~OPpLVAL_INTRO
1955 || !(kid = OP_SIBLING(kid))
1956 || ( kid->op_type != OP_PADSV
1957 && kid->op_type != OP_PADAV
1958 && kid->op_type != OP_PADHV)
1959 || kid->op_private & ~OPpLVAL_INTRO)
1961 op_null(cUNOPo->op_first); /* NULL the pushmark */
1962 op_null(o); /* NULL the list */
1974 /* mortalise it, in case warnings are fatal. */
1975 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1976 "Useless use of %"SVf" in void context",
1977 SVfARG(sv_2mortal(useless_sv)));
1980 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1981 "Useless use of %s in void context",
1984 } while ( (o = POP_DEFERRED_OP()) );
1986 Safefree(defer_stack);
1992 S_listkids(pTHX_ OP *o)
1994 if (o && o->op_flags & OPf_KIDS) {
1996 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2003 Perl_list(pTHX_ OP *o)
2007 /* assumes no premature commitment */
2008 if (!o || (o->op_flags & OPf_WANT)
2009 || (PL_parser && PL_parser->error_count)
2010 || o->op_type == OP_RETURN)
2015 if ((o->op_private & OPpTARGET_MY)
2016 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2018 return o; /* As if inside SASSIGN */
2021 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2023 switch (o->op_type) {
2025 list(cBINOPo->op_first);
2028 if (o->op_private & OPpREPEAT_DOLIST
2029 && !(o->op_flags & OPf_STACKED))
2031 list(cBINOPo->op_first);
2032 kid = cBINOPo->op_last;
2033 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2034 && SvIVX(kSVOP_sv) == 1)
2036 op_null(o); /* repeat */
2037 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2039 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2046 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2054 if (!(o->op_flags & OPf_KIDS))
2056 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2057 list(cBINOPo->op_first);
2058 return gen_constant_list(o);
2064 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2065 op_null(cUNOPo->op_first); /* NULL the pushmark */
2066 op_null(o); /* NULL the list */
2071 kid = cLISTOPo->op_first;
2073 kid = OP_SIBLING(kid);
2076 OP *sib = OP_SIBLING(kid);
2077 if (sib && kid->op_type != OP_LEAVEWHEN)
2083 PL_curcop = &PL_compiling;
2087 kid = cLISTOPo->op_first;
2094 S_scalarseq(pTHX_ OP *o)
2097 const OPCODE type = o->op_type;
2099 if (type == OP_LINESEQ || type == OP_SCOPE ||
2100 type == OP_LEAVE || type == OP_LEAVETRY)
2103 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2104 if ((sib = OP_SIBLING(kid))
2105 && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL
2106 || ( sib->op_targ != OP_NEXTSTATE
2107 && sib->op_targ != OP_DBSTATE )))
2112 PL_curcop = &PL_compiling;
2114 o->op_flags &= ~OPf_PARENS;
2115 if (PL_hints & HINT_BLOCK_SCOPE)
2116 o->op_flags |= OPf_PARENS;
2119 o = newOP(OP_STUB, 0);
2124 S_modkids(pTHX_ OP *o, I32 type)
2126 if (o && o->op_flags & OPf_KIDS) {
2128 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2129 op_lvalue(kid, type);
2135 =for apidoc finalize_optree
2137 This function finalizes the optree. Should be called directly after
2138 the complete optree is built. It does some additional
2139 checking which can't be done in the normal ck_xxx functions and makes
2140 the tree thread-safe.
2145 Perl_finalize_optree(pTHX_ OP* o)
2147 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2150 SAVEVPTR(PL_curcop);
2158 /* Relocate sv to the pad for thread safety.
2159 * Despite being a "constant", the SV is written to,
2160 * for reference counts, sv_upgrade() etc. */
2161 PERL_STATIC_INLINE void
2162 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2165 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2167 ix = pad_alloc(OP_CONST, SVf_READONLY);
2168 SvREFCNT_dec(PAD_SVl(ix));
2169 PAD_SETSV(ix, *svp);
2170 /* XXX I don't know how this isn't readonly already. */
2171 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2179 S_finalize_op(pTHX_ OP* o)
2181 PERL_ARGS_ASSERT_FINALIZE_OP;
2184 switch (o->op_type) {
2187 PL_curcop = ((COP*)o); /* for warnings */
2190 if (OP_HAS_SIBLING(o)) {
2191 OP *sib = OP_SIBLING(o);
2192 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2193 && ckWARN(WARN_EXEC)
2194 && OP_HAS_SIBLING(sib))
2196 const OPCODE type = OP_SIBLING(sib)->op_type;
2197 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2198 const line_t oldline = CopLINE(PL_curcop);
2199 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2200 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2201 "Statement unlikely to be reached");
2202 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2203 "\t(Maybe you meant system() when you said exec()?)\n");
2204 CopLINE_set(PL_curcop, oldline);
2211 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2212 GV * const gv = cGVOPo_gv;
2213 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2214 /* XXX could check prototype here instead of just carping */
2215 SV * const sv = sv_newmortal();
2216 gv_efullname3(sv, gv, NULL);
2217 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2218 "%"SVf"() called too early to check prototype",
2225 if (cSVOPo->op_private & OPpCONST_STRICT)
2226 no_bareword_allowed(o);
2230 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2235 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2236 case OP_METHOD_NAMED:
2237 case OP_METHOD_SUPER:
2238 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2250 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2253 rop = (UNOP*)((BINOP*)o)->op_first;
2258 S_scalar_slice_warning(aTHX_ o);
2262 kid = OP_SIBLING(cLISTOPo->op_first);
2263 if (/* I bet there's always a pushmark... */
2264 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2265 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2270 key_op = (SVOP*)(kid->op_type == OP_CONST
2272 : OP_SIBLING(kLISTOP->op_first));
2274 rop = (UNOP*)((LISTOP*)o)->op_last;
2277 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2279 else if (rop->op_first->op_type == OP_PADSV)
2280 /* @$hash{qw(keys here)} */
2281 rop = (UNOP*)rop->op_first;
2283 /* @{$hash}{qw(keys here)} */
2284 if (rop->op_first->op_type == OP_SCOPE
2285 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2287 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2293 lexname = NULL; /* just to silence compiler warnings */
2294 fields = NULL; /* just to silence compiler warnings */
2298 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2299 SvPAD_TYPED(lexname))
2300 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2301 && isGV(*fields) && GvHV(*fields);
2303 key_op = (SVOP*)OP_SIBLING(key_op)) {
2305 if (key_op->op_type != OP_CONST)
2307 svp = cSVOPx_svp(key_op);
2309 /* Make the CONST have a shared SV */
2310 if ((!SvIsCOW_shared_hash(sv = *svp))
2311 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2313 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2314 SV *nsv = newSVpvn_share(key,
2315 SvUTF8(sv) ? -keylen : keylen, 0);
2316 SvREFCNT_dec_NN(sv);
2321 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2322 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2323 "in variable %"SVf" of type %"HEKf,
2324 SVfARG(*svp), SVfARG(lexname),
2325 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2331 S_scalar_slice_warning(aTHX_ o);
2335 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2336 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2343 if (o->op_flags & OPf_KIDS) {
2347 /* check that op_last points to the last sibling, and that
2348 * the last op_sibling field points back to the parent, and
2349 * that the only ops with KIDS are those which are entitled to
2351 U32 type = o->op_type;
2355 if (type == OP_NULL) {
2357 /* ck_glob creates a null UNOP with ex-type GLOB
2358 * (which is a list op. So pretend it wasn't a listop */
2359 if (type == OP_GLOB)
2362 family = PL_opargs[type] & OA_CLASS_MASK;
2364 has_last = ( family == OA_BINOP
2365 || family == OA_LISTOP
2366 || family == OA_PMOP
2367 || family == OA_LOOP
2369 assert( has_last /* has op_first and op_last, or ...
2370 ... has (or may have) op_first: */
2371 || family == OA_UNOP
2372 || family == OA_LOGOP
2373 || family == OA_BASEOP_OR_UNOP
2374 || family == OA_FILESTATOP
2375 || family == OA_LOOPEXOP
2376 || family == OA_METHOP
2377 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2378 || type == OP_SASSIGN
2379 || type == OP_CUSTOM
2380 || type == OP_NULL /* new_logop does this */
2382 /* XXX list form of 'x' is has a null op_last. This is wrong,
2383 * but requires too much hacking (e.g. in Deparse) to fix for
2385 if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2390 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2391 # ifdef PERL_OP_PARENT
2392 if (!OP_HAS_SIBLING(kid)) {
2394 assert(kid == cLISTOPo->op_last);
2395 assert(kid->op_sibling == o);
2398 if (OP_HAS_SIBLING(kid)) {
2399 assert(!kid->op_lastsib);
2402 assert(kid->op_lastsib);
2404 assert(kid == cLISTOPo->op_last);
2410 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2416 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2418 Propagate lvalue ("modifiable") context to an op and its children.
2419 I<type> represents the context type, roughly based on the type of op that
2420 would do the modifying, although C<local()> is represented by OP_NULL,
2421 because it has no op type of its own (it is signalled by a flag on
2424 This function detects things that can't be modified, such as C<$x+1>, and
2425 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2426 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2428 It also flags things that need to behave specially in an lvalue context,
2429 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2435 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2438 PadnameLVALUE_on(pn);
2439 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2442 assert(CvPADLIST(cv));
2444 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2445 assert(PadnameLEN(pn));
2446 PadnameLVALUE_on(pn);
2451 S_vivifies(const OPCODE type)
2454 case OP_RV2AV: case OP_ASLICE:
2455 case OP_RV2HV: case OP_KVASLICE:
2456 case OP_RV2SV: case OP_HSLICE:
2457 case OP_AELEMFAST: case OP_KVHSLICE:
2466 S_lvref(pTHX_ OP *o, I32 type)
2470 switch (o->op_type) {
2472 for (kid = OP_SIBLING(cUNOPo->op_first); kid;
2473 kid = OP_SIBLING(kid))
2474 S_lvref(aTHX_ kid, type);
2479 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2480 o->op_flags |= OPf_STACKED;
2481 if (o->op_flags & OPf_PARENS) {
2482 if (o->op_private & OPpLVAL_INTRO) {
2483 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2484 "localized parenthesized array in list assignment"));
2488 CHANGE_TYPE(o, OP_LVAVREF);
2489 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2490 o->op_flags |= OPf_MOD|OPf_REF;
2493 o->op_private |= OPpLVREF_AV;
2496 kid = cUNOPo->op_first;
2497 if (kid->op_type == OP_NULL)
2498 kid = cUNOPx(kUNOP->op_first->op_sibling)
2500 o->op_private = OPpLVREF_CV;
2501 if (kid->op_type == OP_GV)
2502 o->op_flags |= OPf_STACKED;
2503 else if (kid->op_type == OP_PADCV) {
2504 o->op_targ = kid->op_targ;
2506 op_free(cUNOPo->op_first);
2507 cUNOPo->op_first = NULL;
2508 o->op_flags &=~ OPf_KIDS;
2513 if (o->op_flags & OPf_PARENS) {
2515 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2516 "parenthesized hash in list assignment"));
2519 o->op_private |= OPpLVREF_HV;
2523 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2524 o->op_flags |= OPf_STACKED;
2527 if (o->op_flags & OPf_PARENS) goto parenhash;
2528 o->op_private |= OPpLVREF_HV;
2531 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2534 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2535 if (o->op_flags & OPf_PARENS) goto slurpy;
2536 o->op_private |= OPpLVREF_AV;
2540 o->op_private |= OPpLVREF_ELEM;
2541 o->op_flags |= OPf_STACKED;
2545 CHANGE_TYPE(o, OP_LVREFSLICE);
2546 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2549 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2551 else if (!(o->op_flags & OPf_KIDS))
2553 if (o->op_targ != OP_LIST) {
2554 S_lvref(aTHX_ cBINOPo->op_first, type);
2559 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2560 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2561 S_lvref(aTHX_ kid, type);
2565 if (o->op_flags & OPf_PARENS)
2570 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2571 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2572 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2578 CHANGE_TYPE(o, OP_LVREF);
2580 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2581 if (type == OP_ENTERLOOP)
2582 o->op_private |= OPpLVREF_ITER;
2586 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2590 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2593 if (!o || (PL_parser && PL_parser->error_count))
2596 if ((o->op_private & OPpTARGET_MY)
2597 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2602 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2604 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2606 switch (o->op_type) {
2611 if ((o->op_flags & OPf_PARENS))
2615 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2616 !(o->op_flags & OPf_STACKED)) {
2617 CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
2618 assert(cUNOPo->op_first->op_type == OP_NULL);
2619 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2622 else { /* lvalue subroutine call */
2623 o->op_private |= OPpLVAL_INTRO;
2624 PL_modcount = RETURN_UNLIMITED_NUMBER;
2625 if (type == OP_GREPSTART || type == OP_ENTERSUB
2626 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
2627 /* Potential lvalue context: */
2628 o->op_private |= OPpENTERSUB_INARGS;
2631 else { /* Compile-time error message: */
2632 OP *kid = cUNOPo->op_first;
2636 if (kid->op_type != OP_PUSHMARK) {
2637 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2639 "panic: unexpected lvalue entersub "
2640 "args: type/targ %ld:%"UVuf,
2641 (long)kid->op_type, (UV)kid->op_targ);
2642 kid = kLISTOP->op_first;
2644 while (OP_HAS_SIBLING(kid))
2645 kid = OP_SIBLING(kid);
2646 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2647 break; /* Postpone until runtime */
2650 kid = kUNOP->op_first;
2651 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2652 kid = kUNOP->op_first;
2653 if (kid->op_type == OP_NULL)
2655 "Unexpected constant lvalue entersub "
2656 "entry via type/targ %ld:%"UVuf,
2657 (long)kid->op_type, (UV)kid->op_targ);
2658 if (kid->op_type != OP_GV) {
2665 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2666 ? MUTABLE_CV(SvRV(gv))
2677 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2678 /* grep, foreach, subcalls, refgen */
2679 if (type == OP_GREPSTART || type == OP_ENTERSUB
2680 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2682 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2683 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2685 : (o->op_type == OP_ENTERSUB
2686 ? "non-lvalue subroutine call"
2688 type ? PL_op_desc[type] : "local"));
2701 case OP_RIGHT_SHIFT:
2710 if (!(o->op_flags & OPf_STACKED))
2716 if (o->op_flags & OPf_STACKED) {
2720 if (!(o->op_private & OPpREPEAT_DOLIST))
2723 const I32 mods = PL_modcount;
2724 modkids(cBINOPo->op_first, type);
2725 if (type != OP_AASSIGN)
2727 kid = cBINOPo->op_last;
2728 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2729 const IV iv = SvIV(kSVOP_sv);
2730 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2732 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2735 PL_modcount = RETURN_UNLIMITED_NUMBER;
2741 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2742 op_lvalue(kid, type);
2747 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2748 PL_modcount = RETURN_UNLIMITED_NUMBER;
2749 return o; /* Treat \(@foo) like ordinary list. */
2753 if (scalar_mod_type(o, type))
2755 ref(cUNOPo->op_first, o->op_type);
2762 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2763 if (type == OP_LEAVESUBLV && (
2764 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2765 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2767 o->op_private |= OPpMAYBE_LVSUB;
2771 PL_modcount = RETURN_UNLIMITED_NUMBER;
2775 if (type == OP_LEAVESUBLV)
2776 o->op_private |= OPpMAYBE_LVSUB;
2779 PL_hints |= HINT_BLOCK_SCOPE;
2780 if (type == OP_LEAVESUBLV)
2781 o->op_private |= OPpMAYBE_LVSUB;
2785 ref(cUNOPo->op_first, o->op_type);
2789 PL_hints |= HINT_BLOCK_SCOPE;
2799 case OP_AELEMFAST_LEX:
2806 PL_modcount = RETURN_UNLIMITED_NUMBER;
2807 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2808 return o; /* Treat \(@foo) like ordinary list. */
2809 if (scalar_mod_type(o, type))
2811 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2812 && type == OP_LEAVESUBLV)
2813 o->op_private |= OPpMAYBE_LVSUB;
2817 if (!type) /* local() */
2818 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2819 PAD_COMPNAME_SV(o->op_targ));
2820 if (!(o->op_private & OPpLVAL_INTRO)
2821 || ( type != OP_SASSIGN && type != OP_AASSIGN
2822 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
2823 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2832 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2836 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2842 if (type == OP_LEAVESUBLV)
2843 o->op_private |= OPpMAYBE_LVSUB;
2844 if (o->op_flags & OPf_KIDS)
2845 op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2850 ref(cBINOPo->op_first, o->op_type);
2851 if (type == OP_ENTERSUB &&
2852 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2853 o->op_private |= OPpLVAL_DEFER;
2854 if (type == OP_LEAVESUBLV)
2855 o->op_private |= OPpMAYBE_LVSUB;
2862 o->op_private |= OPpLVALUE;
2868 if (o->op_flags & OPf_KIDS)
2869 op_lvalue(cLISTOPo->op_last, type);
2874 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2876 else if (!(o->op_flags & OPf_KIDS))
2878 if (o->op_targ != OP_LIST) {
2879 op_lvalue(cBINOPo->op_first, type);
2885 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2886 /* elements might be in void context because the list is
2887 in scalar context or because they are attribute sub calls */
2888 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2889 op_lvalue(kid, type);
2897 if (type == OP_LEAVESUBLV
2898 || !S_vivifies(cLOGOPo->op_first->op_type))
2899 op_lvalue(cLOGOPo->op_first, type);
2900 if (type == OP_LEAVESUBLV
2901 || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2902 op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2906 if (type != OP_AASSIGN && type != OP_SASSIGN
2907 && type != OP_ENTERLOOP)
2909 /* Don’t bother applying lvalue context to the ex-list. */
2910 kid = cUNOPx(cUNOPo->op_first)->op_first;
2911 assert (!OP_HAS_SIBLING(kid));
2914 if (type != OP_AASSIGN) goto nomod;
2915 kid = cUNOPo->op_first;
2918 const U8 ec = PL_parser ? PL_parser->error_count : 0;
2919 S_lvref(aTHX_ kid, type);
2920 if (!PL_parser || PL_parser->error_count == ec) {
2921 if (!FEATURE_REFALIASING_IS_ENABLED)
2923 "Experimental aliasing via reference not enabled");
2924 Perl_ck_warner_d(aTHX_
2925 packWARN(WARN_EXPERIMENTAL__REFALIASING),
2926 "Aliasing via reference is experimental");
2929 if (o->op_type == OP_REFGEN)
2930 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
2935 kid = cLISTOPo->op_first;
2936 if (kid && kid->op_type == OP_PUSHRE &&
2938 || o->op_flags & OPf_STACKED
2940 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
2942 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
2945 /* This is actually @array = split. */
2946 PL_modcount = RETURN_UNLIMITED_NUMBER;
2952 /* [20011101.069] File test operators interpret OPf_REF to mean that
2953 their argument is a filehandle; thus \stat(".") should not set
2955 if (type == OP_REFGEN &&
2956 PL_check[o->op_type] == Perl_ck_ftst)
2959 if (type != OP_LEAVESUBLV)
2960 o->op_flags |= OPf_MOD;
2962 if (type == OP_AASSIGN || type == OP_SASSIGN)
2963 o->op_flags |= OPf_SPECIAL|OPf_REF;
2964 else if (!type) { /* local() */
2967 o->op_private |= OPpLVAL_INTRO;
2968 o->op_flags &= ~OPf_SPECIAL;
2969 PL_hints |= HINT_BLOCK_SCOPE;
2974 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2975 "Useless localization of %s", OP_DESC(o));
2978 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2979 && type != OP_LEAVESUBLV)
2980 o->op_flags |= OPf_REF;
2985 S_scalar_mod_type(const OP *o, I32 type)
2990 if (o && o->op_type == OP_RV2GV)
3014 case OP_RIGHT_SHIFT:
3035 S_is_handle_constructor(const OP *o, I32 numargs)
3037 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3039 switch (o->op_type) {
3047 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3060 S_refkids(pTHX_ OP *o, I32 type)
3062 if (o && o->op_flags & OPf_KIDS) {
3064 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3071 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3076 PERL_ARGS_ASSERT_DOREF;
3078 if (!o || (PL_parser && PL_parser->error_count))
3081 switch (o->op_type) {
3083 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3084 !(o->op_flags & OPf_STACKED)) {
3085 CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
3086 assert(cUNOPo->op_first->op_type == OP_NULL);
3087 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3088 o->op_flags |= OPf_SPECIAL;
3090 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3091 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3092 : type == OP_RV2HV ? OPpDEREF_HV
3094 o->op_flags |= OPf_MOD;
3100 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
3101 doref(kid, type, set_op_ref);
3104 if (type == OP_DEFINED)
3105 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3106 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3109 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3110 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3111 : type == OP_RV2HV ? OPpDEREF_HV
3113 o->op_flags |= OPf_MOD;
3120 o->op_flags |= OPf_REF;
3123 if (type == OP_DEFINED)
3124 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3125 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3131 o->op_flags |= OPf_REF;
3136 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3138 doref(cBINOPo->op_first, type, set_op_ref);
3142 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3143 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3144 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3145 : type == OP_RV2HV ? OPpDEREF_HV
3147 o->op_flags |= OPf_MOD;
3157 if (!(o->op_flags & OPf_KIDS))
3159 doref(cLISTOPo->op_last, type, set_op_ref);
3169 S_dup_attrlist(pTHX_ OP *o)
3173 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3175 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3176 * where the first kid is OP_PUSHMARK and the remaining ones
3177 * are OP_CONST. We need to push the OP_CONST values.
3179 if (o->op_type == OP_CONST)
3180 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3182 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3184 for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
3185 if (o->op_type == OP_CONST)
3186 rop = op_append_elem(OP_LIST, rop,
3187 newSVOP(OP_CONST, o->op_flags,
3188 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3195 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3197 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3199 PERL_ARGS_ASSERT_APPLY_ATTRS;
3201 /* fake up C<use attributes $pkg,$rv,@attrs> */
3203 #define ATTRSMODULE "attributes"
3204 #define ATTRSMODULE_PM "attributes.pm"
3206 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3207 newSVpvs(ATTRSMODULE),
3209 op_prepend_elem(OP_LIST,
3210 newSVOP(OP_CONST, 0, stashsv),
3211 op_prepend_elem(OP_LIST,
3212 newSVOP(OP_CONST, 0,
3214 dup_attrlist(attrs))));
3218 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3220 OP *pack, *imop, *arg;
3221 SV *meth, *stashsv, **svp;
3223 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3228 assert(target->op_type == OP_PADSV ||
3229 target->op_type == OP_PADHV ||
3230 target->op_type == OP_PADAV);
3232 /* Ensure that attributes.pm is loaded. */
3233 /* Don't force the C<use> if we don't need it. */
3234 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3235 if (svp && *svp != &PL_sv_undef)
3236 NOOP; /* already in %INC */
3238 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3239 newSVpvs(ATTRSMODULE), NULL);
3241 /* Need package name for method call. */
3242 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3244 /* Build up the real arg-list. */
3245 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3247 arg = newOP(OP_PADSV, 0);
3248 arg->op_targ = target->op_targ;
3249 arg = op_prepend_elem(OP_LIST,
3250 newSVOP(OP_CONST, 0, stashsv),
3251 op_prepend_elem(OP_LIST,
3252 newUNOP(OP_REFGEN, 0,
3253 op_lvalue(arg, OP_REFGEN)),
3254 dup_attrlist(attrs)));
3256 /* Fake up a method call to import */
3257 meth = newSVpvs_share("import");
3258 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3259 op_append_elem(OP_LIST,
3260 op_prepend_elem(OP_LIST, pack, arg),
3261 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3263 /* Combine the ops. */
3264 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3268 =notfor apidoc apply_attrs_string
3270 Attempts to apply a list of attributes specified by the C<attrstr> and
3271 C<len> arguments to the subroutine identified by the C<cv> argument which
3272 is expected to be associated with the package identified by the C<stashpv>
3273 argument (see L<attributes>). It gets this wrong, though, in that it
3274 does not correctly identify the boundaries of the individual attribute
3275 specifications within C<attrstr>. This is not really intended for the
3276 public API, but has to be listed here for systems such as AIX which
3277 need an explicit export list for symbols. (It's called from XS code
3278 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3279 to respect attribute syntax properly would be welcome.
3285 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3286 const char *attrstr, STRLEN len)
3290 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3293 len = strlen(attrstr);
3297 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3299 const char * const sstr = attrstr;
3300 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3301 attrs = op_append_elem(OP_LIST, attrs,
3302 newSVOP(OP_CONST, 0,
3303 newSVpvn(sstr, attrstr-sstr)));
3307 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3308 newSVpvs(ATTRSMODULE),
3309 NULL, op_prepend_elem(OP_LIST,
3310 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3311 op_prepend_elem(OP_LIST,
3312 newSVOP(OP_CONST, 0,
3313 newRV(MUTABLE_SV(cv))),
3318 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3320 OP *new_proto = NULL;
3325 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3331 if (o->op_type == OP_CONST) {
3332 pv = SvPV(cSVOPo_sv, pvlen);
3333 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3334 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3335 SV ** const tmpo = cSVOPx_svp(o);
3336 SvREFCNT_dec(cSVOPo_sv);
3341 } else if (o->op_type == OP_LIST) {
3343 assert(o->op_flags & OPf_KIDS);
3344 lasto = cLISTOPo->op_first;
3345 assert(lasto->op_type == OP_PUSHMARK);
3346 for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3347 if (o->op_type == OP_CONST) {
3348 pv = SvPV(cSVOPo_sv, pvlen);
3349 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3350 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3351 SV ** const tmpo = cSVOPx_svp(o);
3352 SvREFCNT_dec(cSVOPo_sv);
3354 if (new_proto && ckWARN(WARN_MISC)) {
3356 const char * newp = SvPV(cSVOPo_sv, new_len);
3357 Perl_warner(aTHX_ packWARN(WARN_MISC),
3358 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3359 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3365 /* excise new_proto from the list */
3366 op_sibling_splice(*attrs, lasto, 1, NULL);
3373 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3374 would get pulled in with no real need */
3375 if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3384 svname = sv_newmortal();
3385 gv_efullname3(svname, name, NULL);
3387 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3388 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3390 svname = (SV *)name;
3391 if (ckWARN(WARN_ILLEGALPROTO))
3392 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3393 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3394 STRLEN old_len, new_len;
3395 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3396 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3398 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3399 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3401 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3402 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3412 S_cant_declare(pTHX_ OP *o)
3414 if (o->op_type == OP_NULL
3415 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3416 o = cUNOPo->op_first;
3417 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3418 o->op_type == OP_NULL
3419 && o->op_flags & OPf_SPECIAL
3422 PL_parser->in_my == KEY_our ? "our" :
3423 PL_parser->in_my == KEY_state ? "state" :
3428 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3431 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3433 PERL_ARGS_ASSERT_MY_KID;
3435 if (!o || (PL_parser && PL_parser->error_count))
3440 if (type == OP_LIST) {
3442 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3443 my_kid(kid, attrs, imopsp);
3445 } else if (type == OP_UNDEF || type == OP_STUB) {
3447 } else if (type == OP_RV2SV || /* "our" declaration */
3449 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3450 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3451 S_cant_declare(aTHX_ o);
3453 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3455 PL_parser->in_my = FALSE;
3456 PL_parser->in_my_stash = NULL;
3457 apply_attrs(GvSTASH(gv),
3458 (type == OP_RV2SV ? GvSV(gv) :
3459 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3460 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3463 o->op_private |= OPpOUR_INTRO;
3466 else if (type != OP_PADSV &&
3469 type != OP_PUSHMARK)
3471 S_cant_declare(aTHX_ o);
3474 else if (attrs && type != OP_PUSHMARK) {
3478 PL_parser->in_my = FALSE;
3479 PL_parser->in_my_stash = NULL;
3481 /* check for C<my Dog $spot> when deciding package */
3482 stash = PAD_COMPNAME_TYPE(o->op_targ);
3484 stash = PL_curstash;
3485 apply_attrs_my(stash, o, attrs, imopsp);
3487 o->op_flags |= OPf_MOD;
3488 o->op_private |= OPpLVAL_INTRO;
3490 o->op_private |= OPpPAD_STATE;
3495 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3498 int maybe_scalar = 0;
3500 PERL_ARGS_ASSERT_MY_ATTRS;
3502 /* [perl #17376]: this appears to be premature, and results in code such as
3503 C< our(%x); > executing in list mode rather than void mode */
3505 if (o->op_flags & OPf_PARENS)
3515 o = my_kid(o, attrs, &rops);
3517 if (maybe_scalar && o->op_type == OP_PADSV) {
3518 o = scalar(op_append_list(OP_LIST, rops, o));
3519 o->op_private |= OPpLVAL_INTRO;
3522 /* The listop in rops might have a pushmark at the beginning,
3523 which will mess up list assignment. */
3524 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3525 if (rops->op_type == OP_LIST &&
3526 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3528 OP * const pushmark = lrops->op_first;
3529 /* excise pushmark */
3530 op_sibling_splice(rops, NULL, 1, NULL);
3533 o = op_append_list(OP_LIST, o, rops);
3536 PL_parser->in_my = FALSE;
3537 PL_parser->in_my_stash = NULL;
3542 Perl_sawparens(pTHX_ OP *o)
3544 PERL_UNUSED_CONTEXT;
3546 o->op_flags |= OPf_PARENS;
3551 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3555 const OPCODE ltype = left->op_type;
3556 const OPCODE rtype = right->op_type;
3558 PERL_ARGS_ASSERT_BIND_MATCH;
3560 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3561 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3563 const char * const desc
3565 rtype == OP_SUBST || rtype == OP_TRANS
3566 || rtype == OP_TRANSR
3568 ? (int)rtype : OP_MATCH];
3569 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3571 S_op_varname(aTHX_ left);
3573 Perl_warner(aTHX_ packWARN(WARN_MISC),
3574 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3575 desc, SVfARG(name), SVfARG(name));
3577 const char * const sample = (isary
3578 ? "@array" : "%hash");
3579 Perl_warner(aTHX_ packWARN(WARN_MISC),
3580 "Applying %s to %s will act on scalar(%s)",
3581 desc, sample, sample);
3585 if (rtype == OP_CONST &&
3586 cSVOPx(right)->op_private & OPpCONST_BARE &&
3587 cSVOPx(right)->op_private & OPpCONST_STRICT)
3589 no_bareword_allowed(right);
3592 /* !~ doesn't make sense with /r, so error on it for now */
3593 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3595 /* diag_listed_as: Using !~ with %s doesn't make sense */
3596 yyerror("Using !~ with s///r doesn't make sense");
3597 if (rtype == OP_TRANSR && type == OP_NOT)
3598 /* diag_listed_as: Using !~ with %s doesn't make sense */
3599 yyerror("Using !~ with tr///r doesn't make sense");
3601 ismatchop = (rtype == OP_MATCH ||
3602 rtype == OP_SUBST ||
3603 rtype == OP_TRANS || rtype == OP_TRANSR)
3604 && !(right->op_flags & OPf_SPECIAL);
3605 if (ismatchop && right->op_private & OPpTARGET_MY) {
3607 right->op_private &= ~OPpTARGET_MY;
3609 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3610 if (left->op_type == OP_PADSV
3611 && !(left->op_private & OPpLVAL_INTRO))
3613 right->op_targ = left->op_targ;
3618 right->op_flags |= OPf_STACKED;
3619 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3620 ! (rtype == OP_TRANS &&
3621 right->op_private & OPpTRANS_IDENTICAL) &&
3622 ! (rtype == OP_SUBST &&
3623 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3624 left = op_lvalue(left, rtype);
3625 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3626 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3628 o = op_prepend_elem(rtype, scalar(left), right);
3631 return newUNOP(OP_NOT, 0, scalar(o));
3635 return bind_match(type, left,
3636 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3640 Perl_invert(pTHX_ OP *o)
3644 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3648 =for apidoc Amx|OP *|op_scope|OP *o
3650 Wraps up an op tree with some additional ops so that at runtime a dynamic
3651 scope will be created. The original ops run in the new dynamic scope,
3652 and then, provided that they exit normally, the scope will be unwound.
3653 The additional ops used to create and unwind the dynamic scope will
3654 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3655 instead if the ops are simple enough to not need the full dynamic scope
3662 Perl_op_scope(pTHX_ OP *o)
3666 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3667 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3668 CHANGE_TYPE(o, OP_LEAVE);
3670 else if (o->op_type == OP_LINESEQ) {
3672 CHANGE_TYPE(o, OP_SCOPE);
3673 kid = ((LISTOP*)o)->op_first;
3674 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3677 /* The following deals with things like 'do {1 for 1}' */
3678 kid = OP_SIBLING(kid);
3680 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3685 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3691 Perl_op_unscope(pTHX_ OP *o)
3693 if (o && o->op_type == OP_LINESEQ) {
3694 OP *kid = cLISTOPo->op_first;
3695 for(; kid; kid = OP_SIBLING(kid))
3696 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3703 =for apidoc Am|int|block_start|int full
3705 Handles compile-time scope entry.
3706 Arranges for hints to be restored on block
3707 exit and also handles pad sequence numbers to make lexical variables scope
3708 right. Returns a savestack index for use with C<block_end>.
3714 Perl_block_start(pTHX_ int full)
3716 const int retval = PL_savestack_ix;
3718 PL_compiling.cop_seq = PL_cop_seqmax;
3720 pad_block_start(full);
3722 PL_hints &= ~HINT_BLOCK_SCOPE;
3723 SAVECOMPILEWARNINGS();
3724 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3725 SAVEI32(PL_compiling.cop_seq);
3726 PL_compiling.cop_seq = 0;
3728 CALL_BLOCK_HOOKS(bhk_start, full);
3734 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3736 Handles compile-time scope exit. I<floor>
3737 is the savestack index returned by
3738 C<block_start>, and I<seq> is the body of the block. Returns the block,
3745 Perl_block_end(pTHX_ I32 floor, OP *seq)
3747 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3748 OP* retval = scalarseq(seq);
3751 /* XXX Is the null PL_parser check necessary here? */
3752 assert(PL_parser); /* Let’s find out under debugging builds. */
3753 if (PL_parser && PL_parser->parsed_sub) {
3754 o = newSTATEOP(0, NULL, NULL);
3756 retval = op_append_elem(OP_LINESEQ, retval, o);
3759 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3763 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3767 /* pad_leavemy has created a sequence of introcv ops for all my
3768 subs declared in the block. We have to replicate that list with
3769 clonecv ops, to deal with this situation:
3774 sub s1 { state sub foo { \&s2 } }
3777 Originally, I was going to have introcv clone the CV and turn
3778 off the stale flag. Since &s1 is declared before &s2, the
3779 introcv op for &s1 is executed (on sub entry) before the one for
3780 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3781 cloned, since it is a state sub) closes over &s2 and expects
3782 to see it in its outer CV’s pad. If the introcv op clones &s1,
3783 then &s2 is still marked stale. Since &s1 is not active, and
3784 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3785 ble will not stay shared’ warning. Because it is the same stub
3786 that will be used when the introcv op for &s2 is executed, clos-
3787 ing over it is safe. Hence, we have to turn off the stale flag
3788 on all lexical subs in the block before we clone any of them.
3789 Hence, having introcv clone the sub cannot work. So we create a
3790 list of ops like this:
3814 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3815 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3816 for (;; kid = OP_SIBLING(kid)) {
3817 OP *newkid = newOP(OP_CLONECV, 0);
3818 newkid->op_targ = kid->op_targ;
3819 o = op_append_elem(OP_LINESEQ, o, newkid);
3820 if (kid == last) break;
3822 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3825 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3831 =head1 Compile-time scope hooks
3833 =for apidoc Aox||blockhook_register
3835 Register a set of hooks to be called when the Perl lexical scope changes
3836 at compile time. See L<perlguts/"Compile-time scope hooks">.
3842 Perl_blockhook_register(pTHX_ BHK *hk)
3844 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3846 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3850 Perl_newPROG(pTHX_ OP *o)
3852 PERL_ARGS_ASSERT_NEWPROG;
3859 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3860 ((PL_in_eval & EVAL_KEEPERR)
3861 ? OPf_SPECIAL : 0), o);
3863 cx = &cxstack[cxstack_ix];
3864 assert(CxTYPE(cx) == CXt_EVAL);
3866 if ((cx->blk_gimme & G_WANT) == G_VOID)
3867 scalarvoid(PL_eval_root);
3868 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3871 scalar(PL_eval_root);
3873 PL_eval_start = op_linklist(PL_eval_root);
3874 PL_eval_root->op_private |= OPpREFCOUNTED;
3875 OpREFCNT_set(PL_eval_root, 1);
3876 PL_eval_root->op_next = 0;
3877 i = PL_savestack_ix;
3880 CALL_PEEP(PL_eval_start);
3881 finalize_optree(PL_eval_root);
3882 S_prune_chain_head(&PL_eval_start);
3884 PL_savestack_ix = i;
3887 if (o->op_type == OP_STUB) {
3888 /* This block is entered if nothing is compiled for the main
3889 program. This will be the case for an genuinely empty main
3890 program, or one which only has BEGIN blocks etc, so already
3893 Historically (5.000) the guard above was !o. However, commit
3894 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3895 c71fccf11fde0068, changed perly.y so that newPROG() is now
3896 called with the output of block_end(), which returns a new
3897 OP_STUB for the case of an empty optree. ByteLoader (and
3898 maybe other things) also take this path, because they set up
3899 PL_main_start and PL_main_root directly, without generating an
3902 If the parsing the main program aborts (due to parse errors,
3903 or due to BEGIN or similar calling exit), then newPROG()
3904 isn't even called, and hence this code path and its cleanups
3905 are skipped. This shouldn't make a make a difference:
3906 * a non-zero return from perl_parse is a failure, and
3907 perl_destruct() should be called immediately.
3908 * however, if exit(0) is called during the parse, then
3909 perl_parse() returns 0, and perl_run() is called. As
3910 PL_main_start will be NULL, perl_run() will return
3911 promptly, and the exit code will remain 0.
3914 PL_comppad_name = 0;
3916 S_op_destroy(aTHX_ o);
3919 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3920 PL_curcop = &PL_compiling;
3921 PL_main_start = LINKLIST(PL_main_root);
3922 PL_main_root->op_private |= OPpREFCOUNTED;
3923 OpREFCNT_set(PL_main_root, 1);
3924 PL_main_root->op_next = 0;
3925 CALL_PEEP(PL_main_start);
3926 finalize_optree(PL_main_root);
3927 S_prune_chain_head(&PL_main_start);
3928 cv_forget_slab(PL_compcv);
3931 /* Register with debugger */
3933 CV * const cv = get_cvs("DB::postponed", 0);
3937 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3939 call_sv(MUTABLE_SV(cv), G_DISCARD);
3946 Perl_localize(pTHX_ OP *o, I32 lex)
3948 PERL_ARGS_ASSERT_LOCALIZE;
3950 if (o->op_flags & OPf_PARENS)
3951 /* [perl #17376]: this appears to be premature, and results in code such as
3952 C< our(%x); > executing in list mode rather than void mode */
3959 if ( PL_parser->bufptr > PL_parser->oldbufptr
3960 && PL_parser->bufptr[-1] == ','
3961 && ckWARN(WARN_PARENTHESIS))
3963 char *s = PL_parser->bufptr;
3966 /* some heuristics to detect a potential error */
3967 while (*s && (strchr(", \t\n", *s)))
3971 if (*s && strchr("@$%*", *s) && *++s
3972 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3975 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3977 while (*s && (strchr(", \t\n", *s)))
3983 if (sigil && (*s == ';' || *s == '=')) {
3984 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3985 "Parentheses missing around \"%s\" list",
3987 ? (PL_parser->in_my == KEY_our
3989 : PL_parser->in_my == KEY_state
3999 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4000 PL_parser->in_my = FALSE;
4001 PL_parser->in_my_stash = NULL;
4006 Perl_jmaybe(pTHX_ OP *o)
4008 PERL_ARGS_ASSERT_JMAYBE;
4010 if (o->op_type == OP_LIST) {
4012 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4013 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4018 PERL_STATIC_INLINE OP *
4019 S_op_std_init(pTHX_ OP *o)
4021 I32 type = o->op_type;
4023 PERL_ARGS_ASSERT_OP_STD_INIT;
4025 if (PL_opargs[type] & OA_RETSCALAR)
4027 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4028 o->op_targ = pad_alloc(type, SVs_PADTMP);
4033 PERL_STATIC_INLINE OP *
4034 S_op_integerize(pTHX_ OP *o)
4036 I32 type = o->op_type;
4038 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4040 /* integerize op. */
4041 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4044 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4047 if (type == OP_NEGATE)
4048 /* XXX might want a ck_negate() for this */
4049 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4055 S_fold_constants(pTHX_ OP *o)
4060 VOL I32 type = o->op_type;
4066 SV * const oldwarnhook = PL_warnhook;
4067 SV * const olddiehook = PL_diehook;
4069 U8 oldwarn = PL_dowarn;
4072 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4074 if (!(PL_opargs[type] & OA_FOLDCONST))
4083 #ifdef USE_LOCALE_CTYPE
4084 if (IN_LC_COMPILETIME(LC_CTYPE))
4093 #ifdef USE_LOCALE_COLLATE
4094 if (IN_LC_COMPILETIME(LC_COLLATE))
4099 /* XXX what about the numeric ops? */
4100 #ifdef USE_LOCALE_NUMERIC
4101 if (IN_LC_COMPILETIME(LC_NUMERIC))
4106 if (!OP_HAS_SIBLING(cLISTOPo->op_first)
4107 || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4110 SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
4111 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4113 const char *s = SvPVX_const(sv);
4114 while (s < SvEND(sv)) {
4115 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4122 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4125 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4126 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4130 if (PL_parser && PL_parser->error_count)
4131 goto nope; /* Don't try to run w/ errors */
4133 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4134 const OPCODE type = curop->op_type;
4135 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4137 type != OP_SCALAR &&
4139 type != OP_PUSHMARK)
4145 curop = LINKLIST(o);
4146 old_next = o->op_next;
4150 oldscope = PL_scopestack_ix;
4151 create_eval_scope(G_FAKINGEVAL);
4153 /* Verify that we don't need to save it: */
4154 assert(PL_curcop == &PL_compiling);
4155 StructCopy(&PL_compiling, ¬_compiling, COP);
4156 PL_curcop = ¬_compiling;
4157 /* The above ensures that we run with all the correct hints of the
4158 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4159 assert(IN_PERL_RUNTIME);
4160 PL_warnhook = PERL_WARNHOOK_FATAL;
4164 /* Effective $^W=1. */
4165 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4166 PL_dowarn |= G_WARN_ON;
4171 sv = *(PL_stack_sp--);
4172 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4173 pad_swipe(o->op_targ, FALSE);
4175 else if (SvTEMP(sv)) { /* grab mortal temp? */
4176 SvREFCNT_inc_simple_void(sv);
4179 else { assert(SvIMMORTAL(sv)); }
4182 /* Something tried to die. Abandon constant folding. */
4183 /* Pretend the error never happened. */
4185 o->op_next = old_next;
4189 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4190 PL_warnhook = oldwarnhook;
4191 PL_diehook = olddiehook;
4192 /* XXX note that this croak may fail as we've already blown away
4193 * the stack - eg any nested evals */
4194 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4197 PL_dowarn = oldwarn;
4198 PL_warnhook = oldwarnhook;
4199 PL_diehook = olddiehook;
4200 PL_curcop = &PL_compiling;
4202 if (PL_scopestack_ix > oldscope)
4203 delete_eval_scope();
4208 folded = cBOOL(o->op_folded);
4211 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
4212 else if (!SvIMMORTAL(sv)) {
4216 if (type == OP_RV2GV)
4217 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
4220 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4221 /* OP_STRINGIFY and constant folding are used to implement qq.
4222 Here the constant folding is an implementation detail that we
4223 want to hide. If the stringify op is itself already marked
4224 folded, however, then it is actually a folded join. */
4225 if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
4234 S_gen_constant_list(pTHX_ OP *o)
4238 const SSize_t oldtmps_floor = PL_tmps_floor;
4243 if (PL_parser && PL_parser->error_count)
4244 return o; /* Don't attempt to run with errors */
4246 curop = LINKLIST(o);
4249 S_prune_chain_head(&curop);
4251 Perl_pp_pushmark(aTHX);
4254 assert (!(curop->op_flags & OPf_SPECIAL));
4255 assert(curop->op_type == OP_RANGE);
4256 Perl_pp_anonlist(aTHX);
4257 PL_tmps_floor = oldtmps_floor;
4259 CHANGE_TYPE(o, OP_RV2AV);
4260 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4261 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4262 o->op_opt = 0; /* needs to be revisited in rpeep() */
4263 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4265 /* replace subtree with an OP_CONST */
4266 curop = ((UNOP*)o)->op_first;
4267 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4270 if (AvFILLp(av) != -1)
4271 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4274 SvREADONLY_on(*svp);
4281 =head1 Optree Manipulation Functions
4284 /* List constructors */
4287 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4289 Append an item to the list of ops contained directly within a list-type
4290 op, returning the lengthened list. I<first> is the list-type op,
4291 and I<last> is the op to append to the list. I<optype> specifies the
4292 intended opcode for the list. If I<first> is not already a list of the
4293 right type, it will be upgraded into one. If either I<first> or I<last>
4294 is null, the other is returned unchanged.
4300 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4308 if (first->op_type != (unsigned)type
4309 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4311 return newLISTOP(type, 0, first, last);
4314 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4315 first->op_flags |= OPf_KIDS;
4320 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4322 Concatenate the lists of ops contained directly within two list-type ops,
4323 returning the combined list. I<first> and I<last> are the list-type ops
4324 to concatenate. I<optype> specifies the intended opcode for the list.
4325 If either I<first> or I<last> is not already a list of the right type,
4326 it will be upgraded into one. If either I<first> or I<last> is null,
4327 the other is returned unchanged.
4333 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4341 if (first->op_type != (unsigned)type)
4342 return op_prepend_elem(type, first, last);
4344 if (last->op_type != (unsigned)type)
4345 return op_append_elem(type, first, last);
4347 ((LISTOP*)first)->op_last->op_lastsib = 0;
4348 OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4349 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4350 ((LISTOP*)first)->op_last->op_lastsib = 1;
4351 #ifdef PERL_OP_PARENT
4352 ((LISTOP*)first)->op_last->op_sibling = first;
4354 first->op_flags |= (last->op_flags & OPf_KIDS);
4357 S_op_destroy(aTHX_ last);
4363 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4365 Prepend an item to the list of ops contained directly within a list-type
4366 op, returning the lengthened list. I<first> is the op to prepend to the
4367 list, and I<last> is the list-type op. I<optype> specifies the intended
4368 opcode for the list. If I<last> is not already a list of the right type,
4369 it will be upgraded into one. If either I<first> or I<last> is null,
4370 the other is returned unchanged.
4376 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4384 if (last->op_type == (unsigned)type) {
4385 if (type == OP_LIST) { /* already a PUSHMARK there */
4386 /* insert 'first' after pushmark */
4387 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4388 if (!(first->op_flags & OPf_PARENS))
4389 last->op_flags &= ~OPf_PARENS;
4392 op_sibling_splice(last, NULL, 0, first);
4393 last->op_flags |= OPf_KIDS;
4397 return newLISTOP(type, 0, first, last);
4401 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4403 Converts I<o> into a list op if it is not one already, and then converts it
4404 into the specified I<type>, calling its check function, allocating a target if
4405 it needs one, and folding constants.
4407 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4408 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4409 C<op_convert> to make it the right type.
4415 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4418 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4419 if (!o || o->op_type != OP_LIST)
4420 o = force_list(o, 0);
4422 o->op_flags &= ~OPf_WANT;
4424 if (!(PL_opargs[type] & OA_MARK))
4425 op_null(cLISTOPo->op_first);
4427 OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
4428 if (kid2 && kid2->op_type == OP_COREARGS) {
4429 op_null(cLISTOPo->op_first);
4430 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4434 CHANGE_TYPE(o, type);
4435 o->op_flags |= flags;
4437 o = CHECKOP(type, o);
4438 if (o->op_type != (unsigned)type)
4441 return fold_constants(op_integerize(op_std_init(o)));
4448 =head1 Optree construction
4450 =for apidoc Am|OP *|newNULLLIST
4452 Constructs, checks, and returns a new C<stub> op, which represents an
4453 empty list expression.
4459 Perl_newNULLLIST(pTHX)
4461 return newOP(OP_STUB, 0);
4464 /* promote o and any siblings to be a list if its not already; i.e.
4472 * pushmark - o - A - B
4474 * If nullit it true, the list op is nulled.
4478 S_force_list(pTHX_ OP *o, bool nullit)
4480 if (!o || o->op_type != OP_LIST) {
4483 /* manually detach any siblings then add them back later */
4484 rest = OP_SIBLING(o);
4485 OP_SIBLING_set(o, NULL);
4488 o = newLISTOP(OP_LIST, 0, o, NULL);
4490 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4498 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4500 Constructs, checks, and returns an op of any list type. I<type> is
4501 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4502 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4503 supply up to two ops to be direct children of the list op; they are
4504 consumed by this function and become part of the constructed op tree.
4510 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4515 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4517 NewOp(1101, listop, 1, LISTOP);
4519 CHANGE_TYPE(listop, type);
4522 listop->op_flags = (U8)flags;
4526 else if (!first && last)
4529 OP_SIBLING_set(first, last);
4530 listop->op_first = first;
4531 listop->op_last = last;
4532 if (type == OP_LIST) {
4533 OP* const pushop = newOP(OP_PUSHMARK, 0);
4534 pushop->op_lastsib = 0;
4535 OP_SIBLING_set(pushop, first);
4536 listop->op_first = pushop;
4537 listop->op_flags |= OPf_KIDS;
4539 listop->op_last = pushop;
4542 first->op_lastsib = 0;
4543 if (listop->op_last) {
4544 listop->op_last->op_lastsib = 1;
4545 #ifdef PERL_OP_PARENT
4546 listop->op_last->op_sibling = (OP*)listop;
4550 return CHECKOP(type, listop);
4554 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4556 Constructs, checks, and returns an op of any base type (any type that
4557 has no extra fields). I<type> is the opcode. I<flags> gives the
4558 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4565 Perl_newOP(pTHX_ I32 type, I32 flags)
4570 if (type == -OP_ENTEREVAL) {
4571 type = OP_ENTEREVAL;
4572 flags |= OPpEVAL_BYTES<<8;
4575 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4576 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4577 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4578 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4580 NewOp(1101, o, 1, OP);
4581 CHANGE_TYPE(o, type);
4582 o->op_flags = (U8)flags;
4585 o->op_private = (U8)(0 | (flags >> 8));
4586 if (PL_opargs[type] & OA_RETSCALAR)
4588 if (PL_opargs[type] & OA_TARGET)
4589 o->op_targ = pad_alloc(type, SVs_PADTMP);
4590 return CHECKOP(type, o);
4594 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4596 Constructs, checks, and returns an op of any unary type. I<type> is
4597 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4598 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4599 bits, the eight bits of C<op_private>, except that the bit with value 1
4600 is automatically set. I<first> supplies an optional op to be the direct
4601 child of the unary op; it is consumed by this function and become part
4602 of the constructed op tree.
4608 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4613 if (type == -OP_ENTEREVAL) {
4614 type = OP_ENTEREVAL;
4615 flags |= OPpEVAL_BYTES<<8;
4618 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4619 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4620 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4621 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4622 || type == OP_SASSIGN
4623 || type == OP_ENTERTRY
4624 || type == OP_NULL );
4627 first = newOP(OP_STUB, 0);
4628 if (PL_opargs[type] & OA_MARK)
4629 first = force_list(first, 1);
4631 NewOp(1101, unop, 1, UNOP);
4632 CHANGE_TYPE(unop, type);
4633 unop->op_first = first;
4634 unop->op_flags = (U8)(flags | OPf_KIDS);
4635 unop->op_private = (U8)(1 | (flags >> 8));
4637 #ifdef PERL_OP_PARENT
4638 if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4639 first->op_sibling = (OP*)unop;
4642 unop = (UNOP*) CHECKOP(type, unop);
4646 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4650 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4652 Constructs, checks, and returns an op of method type with a method name
4653 evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
4654 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4655 and, shifted up eight bits, the eight bits of C<op_private>, except that
4656 the bit with value 1 is automatically set. I<dynamic_meth> supplies an
4657 op which evaluates method name; it is consumed by this function and
4658 become part of the constructed op tree.
4659 Supported optypes: OP_METHOD.
4665 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4669 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP);
4671 NewOp(1101, methop, 1, METHOP);
4673 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4674 methop->op_flags = (U8)(flags | OPf_KIDS);
4675 methop->op_u.op_first = dynamic_meth;
4676 methop->op_private = (U8)(1 | (flags >> 8));
4678 #ifdef PERL_OP_PARENT
4679 if (!OP_HAS_SIBLING(dynamic_meth))
4680 dynamic_meth->op_sibling = (OP*)methop;
4685 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4686 methop->op_u.op_meth_sv = const_meth;
4687 methop->op_private = (U8)(0 | (flags >> 8));
4688 methop->op_next = (OP*)methop;
4691 CHANGE_TYPE(methop, type);
4692 methop = (METHOP*) CHECKOP(type, methop);
4694 if (methop->op_next) return (OP*)methop;
4696 return fold_constants(op_integerize(op_std_init((OP *) methop)));
4700 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4701 PERL_ARGS_ASSERT_NEWMETHOP;
4702 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4706 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4708 Constructs, checks, and returns an op of method type with a constant
4709 method name. I<type> is the opcode. I<flags> gives the eight bits of
4710 C<op_flags>, and, shifted up eight bits, the eight bits of
4711 C<op_private>. I<const_meth> supplies a constant method name;
4712 it must be a shared COW string.
4713 Supported optypes: OP_METHOD_NAMED.
4719 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4720 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4721 return newMETHOP_internal(type, flags, NULL, const_meth);
4725 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4727 Constructs, checks, and returns an op of any binary type. I<type>
4728 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4729 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4730 the eight bits of C<op_private>, except that the bit with value 1 or
4731 2 is automatically set as required. I<first> and I<last> supply up to
4732 two ops to be the direct children of the binary op; they are consumed
4733 by this function and become part of the constructed op tree.
4739 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4744 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4745 || type == OP_SASSIGN || type == OP_NULL );
4747 NewOp(1101, binop, 1, BINOP);
4750 first = newOP(OP_NULL, 0);
4752 CHANGE_TYPE(binop, type);
4753 binop->op_first = first;
4754 binop->op_flags = (U8)(flags | OPf_KIDS);
4757 binop->op_private = (U8)(1 | (flags >> 8));
4760 binop->op_private = (U8)(2 | (flags >> 8));
4761 OP_SIBLING_set(first, last);
4762 first->op_lastsib = 0;
4765 #ifdef PERL_OP_PARENT
4766 if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4767 last->op_sibling = (OP*)binop;
4770 binop->op_last = OP_SIBLING(binop->op_first);
4771 #ifdef PERL_OP_PARENT
4773 binop->op_last->op_sibling = (OP*)binop;
4776 binop = (BINOP*)CHECKOP(type, binop);
4777 if (binop->op_next || binop->op_type != (OPCODE)type)
4780 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4783 static int uvcompare(const void *a, const void *b)
4784 __attribute__nonnull__(1)
4785 __attribute__nonnull__(2)
4786 __attribute__pure__;
4787 static int uvcompare(const void *a, const void *b)
4789 if (*((const UV *)a) < (*(const UV *)b))
4791 if (*((const UV *)a) > (*(const UV *)b))
4793 if (*((const UV *)a+1) < (*(const UV *)b+1))
4795 if (*((const UV *)a+1) > (*(const UV *)b+1))
4801 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4803 SV * const tstr = ((SVOP*)expr)->op_sv;
4805 ((SVOP*)repl)->op_sv;
4808 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4809 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4815 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4816 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4817 I32 del = o->op_private & OPpTRANS_DELETE;
4820 PERL_ARGS_ASSERT_PMTRANS;
4822 PL_hints |= HINT_BLOCK_SCOPE;
4825 o->op_private |= OPpTRANS_FROM_UTF;
4828 o->op_private |= OPpTRANS_TO_UTF;
4830 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4831 SV* const listsv = newSVpvs("# comment\n");
4833 const U8* tend = t + tlen;
4834 const U8* rend = r + rlen;
4850 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4851 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4854 const U32 flags = UTF8_ALLOW_DEFAULT;
4858 t = tsave = bytes_to_utf8(t, &len);
4861 if (!to_utf && rlen) {
4863 r = rsave = bytes_to_utf8(r, &len);
4867 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4868 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4872 U8 tmpbuf[UTF8_MAXBYTES+1];
4875 Newx(cp, 2*tlen, UV);
4877 transv = newSVpvs("");
4879 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4881 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4883 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4887 cp[2*i+1] = cp[2*i];
4891 qsort(cp, i, 2*sizeof(UV), uvcompare);
4892 for (j = 0; j < i; j++) {
4894 diff = val - nextmin;
4896 t = uvchr_to_utf8(tmpbuf,nextmin);
4897 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4899 U8 range_mark = ILLEGAL_UTF8_BYTE;
4900 t = uvchr_to_utf8(tmpbuf, val - 1);
4901 sv_catpvn(transv, (char *)&range_mark, 1);
4902 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4909 t = uvchr_to_utf8(tmpbuf,nextmin);
4910 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4912 U8 range_mark = ILLEGAL_UTF8_BYTE;
4913 sv_catpvn(transv, (char *)&range_mark, 1);
4915 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4916 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4917 t = (const U8*)SvPVX_const(transv);
4918 tlen = SvCUR(transv);
4922 else if (!rlen && !del) {
4923 r = t; rlen = tlen; rend = tend;
4926 if ((!rlen && !del) || t == r ||
4927 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4929 o->op_private |= OPpTRANS_IDENTICAL;
4933 while (t < tend || tfirst <= tlast) {
4934 /* see if we need more "t" chars */
4935 if (tfirst > tlast) {
4936 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4938 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4940 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4947 /* now see if we need more "r" chars */
4948 if (rfirst > rlast) {
4950 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4952 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4954 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4963 rfirst = rlast = 0xffffffff;
4967 /* now see which range will peter our first, if either. */
4968 tdiff = tlast - tfirst;
4969 rdiff = rlast - rfirst;
4970 tcount += tdiff + 1;
4971 rcount += rdiff + 1;
4978 if (rfirst == 0xffffffff) {
4979 diff = tdiff; /* oops, pretend rdiff is infinite */
4981 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4982 (long)tfirst, (long)tlast);
4984 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4988 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4989 (long)tfirst, (long)(tfirst + diff),
4992 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4993 (long)tfirst, (long)rfirst);
4995 if (rfirst + diff > max)
4996 max = rfirst + diff;
4998 grows = (tfirst < rfirst &&
4999 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
5011 else if (max > 0xff)
5016 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5018 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5019 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5020 PAD_SETSV(cPADOPo->op_padix, swash);
5022 SvREADONLY_on(swash);
5024 cSVOPo->op_sv = swash;
5026 SvREFCNT_dec(listsv);
5027 SvREFCNT_dec(transv);
5029 if (!del && havefinal && rlen)
5030 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5031 newSVuv((UV)final), 0);
5040 else if (rlast == 0xffffffff)
5046 tbl = (short*)PerlMemShared_calloc(
5047 (o->op_private & OPpTRANS_COMPLEMENT) &&
5048 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5050 cPVOPo->op_pv = (char*)tbl;
5052 for (i = 0; i < (I32)tlen; i++)
5054 for (i = 0, j = 0; i < 256; i++) {
5056 if (j >= (I32)rlen) {
5065 if (i < 128 && r[j] >= 128)
5075 o->op_private |= OPpTRANS_IDENTICAL;
5077 else if (j >= (I32)rlen)
5082 PerlMemShared_realloc(tbl,
5083 (0x101+rlen-j) * sizeof(short));
5084 cPVOPo->op_pv = (char*)tbl;
5086 tbl[0x100] = (short)(rlen - j);
5087 for (i=0; i < (I32)rlen - j; i++)
5088 tbl[0x101+i] = r[j+i];
5092 if (!rlen && !del) {
5095 o->op_private |= OPpTRANS_IDENTICAL;
5097 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5098 o->op_private |= OPpTRANS_IDENTICAL;
5100 for (i = 0; i < 256; i++)
5102 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5103 if (j >= (I32)rlen) {
5105 if (tbl[t[i]] == -1)
5111 if (tbl[t[i]] == -1) {
5112 if (t[i] < 128 && r[j] >= 128)
5120 if(del && rlen == tlen) {
5121 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5122 } else if(rlen > tlen && !complement) {
5123 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5127 o->op_private |= OPpTRANS_GROWS;
5135 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5137 Constructs, checks, and returns an op of any pattern matching type.
5138 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
5139 and, shifted up eight bits, the eight bits of C<op_private>.
5145 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5150 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
5152 NewOp(1101, pmop, 1, PMOP);
5153 CHANGE_TYPE(pmop, type);
5154 pmop->op_flags = (U8)flags;
5155 pmop->op_private = (U8)(0 | (flags >> 8));
5157 if (PL_hints & HINT_RE_TAINT)
5158 pmop->op_pmflags |= PMf_RETAINT;
5159 #ifdef USE_LOCALE_CTYPE
5160 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5161 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5166 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5168 if (PL_hints & HINT_RE_FLAGS) {
5169 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5170 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5172 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5173 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5174 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5176 if (reflags && SvOK(reflags)) {
5177 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5183 assert(SvPOK(PL_regex_pad[0]));
5184 if (SvCUR(PL_regex_pad[0])) {
5185 /* Pop off the "packed" IV from the end. */
5186 SV *const repointer_list = PL_regex_pad[0];
5187 const char *p = SvEND(repointer_list) - sizeof(IV);
5188 const IV offset = *((IV*)p);
5190 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5192 SvEND_set(repointer_list, p);
5194 pmop->op_pmoffset = offset;
5195 /* This slot should be free, so assert this: */
5196 assert(PL_regex_pad[offset] == &PL_sv_undef);
5198 SV * const repointer = &PL_sv_undef;
5199 av_push(PL_regex_padav, repointer);
5200 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5201 PL_regex_pad = AvARRAY(PL_regex_padav);
5205 return CHECKOP(type, pmop);
5213 /* Any pad names in scope are potentially lvalues. */
5214 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5215 PADNAME *pn = PAD_COMPNAME_SV(i);
5216 if (!pn || !PadnameLEN(pn))
5218 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5219 S_mark_padname_lvalue(aTHX_ pn);
5223 /* Given some sort of match op o, and an expression expr containing a
5224 * pattern, either compile expr into a regex and attach it to o (if it's
5225 * constant), or convert expr into a runtime regcomp op sequence (if it's
5228 * isreg indicates that the pattern is part of a regex construct, eg
5229 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5230 * split "pattern", which aren't. In the former case, expr will be a list
5231 * if the pattern contains more than one term (eg /a$b/) or if it contains
5232 * a replacement, ie s/// or tr///.
5234 * When the pattern has been compiled within a new anon CV (for
5235 * qr/(?{...})/ ), then floor indicates the savestack level just before
5236 * the new sub was created
5240 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
5245 I32 repl_has_vars = 0;
5247 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5248 bool is_compiletime;
5251 PERL_ARGS_ASSERT_PMRUNTIME;
5253 /* for s/// and tr///, last element in list is the replacement; pop it */
5255 if (is_trans || o->op_type == OP_SUBST) {
5257 repl = cLISTOPx(expr)->op_last;
5258 kid = cLISTOPx(expr)->op_first;
5259 while (OP_SIBLING(kid) != repl)
5260 kid = OP_SIBLING(kid);
5261 op_sibling_splice(expr, kid, 1, NULL);
5264 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
5269 assert(expr->op_type == OP_LIST);
5270 first = cLISTOPx(expr)->op_first;
5271 last = cLISTOPx(expr)->op_last;
5272 assert(first->op_type == OP_PUSHMARK);
5273 assert(OP_SIBLING(first) == last);
5275 /* cut 'last' from sibling chain, then free everything else */
5276 op_sibling_splice(expr, first, 1, NULL);
5279 return pmtrans(o, last, repl);
5282 /* find whether we have any runtime or code elements;
5283 * at the same time, temporarily set the op_next of each DO block;
5284 * then when we LINKLIST, this will cause the DO blocks to be excluded
5285 * from the op_next chain (and from having LINKLIST recursively
5286 * applied to them). We fix up the DOs specially later */
5290 if (expr->op_type == OP_LIST) {
5292 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5293 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5295 assert(!o->op_next);
5296 if (UNLIKELY(!OP_HAS_SIBLING(o))) {
5297 assert(PL_parser && PL_parser->error_count);
5298 /* This can happen with qr/ (?{(^{})/. Just fake up
5299 the op we were expecting to see, to avoid crashing
5301 op_sibling_splice(expr, o, 0,
5302 newSVOP(OP_CONST, 0, &PL_sv_no));
5304 o->op_next = OP_SIBLING(o);
5306 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5310 else if (expr->op_type != OP_CONST)
5315 /* fix up DO blocks; treat each one as a separate little sub;
5316 * also, mark any arrays as LIST/REF */
5318 if (expr->op_type == OP_LIST) {
5320 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5322 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5323 assert( !(o->op_flags & OPf_WANT));
5324 /* push the array rather than its contents. The regex
5325 * engine will retrieve and join the elements later */
5326 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5330 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5332 o->op_next = NULL; /* undo temporary hack from above */
5335 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5336 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5338 assert(leaveop->op_first->op_type == OP_ENTER);
5339 assert(OP_HAS_SIBLING(leaveop->op_first));
5340 o->op_next = OP_SIBLING(leaveop->op_first);
5342 assert(leaveop->op_flags & OPf_KIDS);
5343 assert(leaveop->op_last->op_next == (OP*)leaveop);
5344 leaveop->op_next = NULL; /* stop on last op */
5345 op_null((OP*)leaveop);
5349 OP *scope = cLISTOPo->op_first;
5350 assert(scope->op_type == OP_SCOPE);
5351 assert(scope->op_flags & OPf_KIDS);
5352 scope->op_next = NULL; /* stop on last op */
5355 /* have to peep the DOs individually as we've removed it from
5356 * the op_next chain */
5358 S_prune_chain_head(&(o->op_next));
5360 /* runtime finalizes as part of finalizing whole tree */
5364 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5365 assert( !(expr->op_flags & OPf_WANT));
5366 /* push the array rather than its contents. The regex
5367 * engine will retrieve and join the elements later */
5368 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5371 PL_hints |= HINT_BLOCK_SCOPE;
5373 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5375 if (is_compiletime) {
5376 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5377 regexp_engine const *eng = current_re_engine();
5379 if (o->op_flags & OPf_SPECIAL)
5380 rx_flags |= RXf_SPLIT;
5382 if (!has_code || !eng->op_comp) {
5383 /* compile-time simple constant pattern */
5385 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5386 /* whoops! we guessed that a qr// had a code block, but we
5387 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5388 * that isn't required now. Note that we have to be pretty
5389 * confident that nothing used that CV's pad while the
5390 * regex was parsed */
5391 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
5392 /* But we know that one op is using this CV's slab. */
5393 cv_forget_slab(PL_compcv);
5395 pm->op_pmflags &= ~PMf_HAS_CV;
5400 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5401 rx_flags, pm->op_pmflags)
5402 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5403 rx_flags, pm->op_pmflags)
5408 /* compile-time pattern that includes literal code blocks */
5409 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5412 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5415 if (pm->op_pmflags & PMf_HAS_CV) {
5417 /* this QR op (and the anon sub we embed it in) is never
5418 * actually executed. It's just a placeholder where we can
5419 * squirrel away expr in op_code_list without the peephole
5420 * optimiser etc processing it for a second time */
5421 OP *qr = newPMOP(OP_QR, 0);
5422 ((PMOP*)qr)->op_code_list = expr;
5424 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5425 SvREFCNT_inc_simple_void(PL_compcv);
5426 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5427 ReANY(re)->qr_anoncv = cv;
5429 /* attach the anon CV to the pad so that
5430 * pad_fixup_inner_anons() can find it */
5431 (void)pad_add_anon(cv, o->op_type);
5432 SvREFCNT_inc_simple_void(cv);
5435 pm->op_code_list = expr;
5440 /* runtime pattern: build chain of regcomp etc ops */
5442 PADOFFSET cv_targ = 0;
5444 reglist = isreg && expr->op_type == OP_LIST;
5449 pm->op_code_list = expr;
5450 /* don't free op_code_list; its ops are embedded elsewhere too */
5451 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5454 if (o->op_flags & OPf_SPECIAL)
5455 pm->op_pmflags |= PMf_SPLIT;
5457 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5458 * to allow its op_next to be pointed past the regcomp and
5459 * preceding stacking ops;
5460 * OP_REGCRESET is there to reset taint before executing the
5462 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5463 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5465 if (pm->op_pmflags & PMf_HAS_CV) {
5466 /* we have a runtime qr with literal code. This means
5467 * that the qr// has been wrapped in a new CV, which
5468 * means that runtime consts, vars etc will have been compiled
5469 * against a new pad. So... we need to execute those ops
5470 * within the environment of the new CV. So wrap them in a call
5471 * to a new anon sub. i.e. for
5475 * we build an anon sub that looks like
5477 * sub { "a", $b, '(?{...})' }
5479 * and call it, passing the returned list to regcomp.
5480 * Or to put it another way, the list of ops that get executed
5484 * ------ -------------------
5485 * pushmark (for regcomp)
5486 * pushmark (for entersub)
5490 * regcreset regcreset
5492 * const("a") const("a")
5494 * const("(?{...})") const("(?{...})")
5499 SvREFCNT_inc_simple_void(PL_compcv);
5500 /* these lines are just an unrolled newANONATTRSUB */
5501 expr = newSVOP(OP_ANONCODE, 0,
5502 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5503 cv_targ = expr->op_targ;
5504 expr = newUNOP(OP_REFGEN, 0, expr);
5506 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5509 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5510 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5511 | (reglist ? OPf_STACKED : 0);
5512 rcop->op_targ = cv_targ;
5514 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5515 if (PL_hints & HINT_RE_EVAL)
5516 S_set_haseval(aTHX);
5518 /* establish postfix order */
5519 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5521 rcop->op_next = expr;
5522 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5525 rcop->op_next = LINKLIST(expr);
5526 expr->op_next = (OP*)rcop;
5529 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5535 /* If we are looking at s//.../e with a single statement, get past
5536 the implicit do{}. */
5537 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5538 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5539 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5542 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5543 if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
5544 && !OP_HAS_SIBLING(sib))
5547 if (curop->op_type == OP_CONST)
5549 else if (( (curop->op_type == OP_RV2SV ||
5550 curop->op_type == OP_RV2AV ||
5551 curop->op_type == OP_RV2HV ||
5552 curop->op_type == OP_RV2GV)
5553 && cUNOPx(curop)->op_first
5554 && cUNOPx(curop)->op_first->op_type == OP_GV )
5555 || curop->op_type == OP_PADSV
5556 || curop->op_type == OP_PADAV
5557 || curop->op_type == OP_PADHV
5558 || curop->op_type == OP_PADANY) {
5566 || !RX_PRELEN(PM_GETRE(pm))
5567 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5569 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5570 op_prepend_elem(o->op_type, scalar(repl), o);
5573 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5574 rcop->op_private = 1;
5576 /* establish postfix order */
5577 rcop->op_next = LINKLIST(repl);
5578 repl->op_next = (OP*)rcop;
5580 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5581 assert(!(pm->op_pmflags & PMf_ONCE));
5582 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5591 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5593 Constructs, checks, and returns an op of any type that involves an
5594 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
5595 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
5596 takes ownership of one reference to it.
5602 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5607 PERL_ARGS_ASSERT_NEWSVOP;
5609 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5610 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5611 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5613 NewOp(1101, svop, 1, SVOP);
5614 CHANGE_TYPE(svop, type);
5616 svop->op_next = (OP*)svop;
5617 svop->op_flags = (U8)flags;
5618 svop->op_private = (U8)(0 | (flags >> 8));
5619 if (PL_opargs[type] & OA_RETSCALAR)
5621 if (PL_opargs[type] & OA_TARGET)
5622 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5623 return CHECKOP(type, svop);
5627 =for apidoc Am|OP *|newDEFSVOP|
5629 Constructs and returns an op to access C<$_>, either as a lexical
5630 variable (if declared as C<my $_>) in the current scope, or the
5637 Perl_newDEFSVOP(pTHX)
5639 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5640 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5641 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5644 OP * const o = newOP(OP_PADSV, 0);
5645 o->op_targ = offset;
5653 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5655 Constructs, checks, and returns an op of any type that involves a
5656 reference to a pad element. I<type> is the opcode. I<flags> gives the
5657 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5658 is populated with I<sv>; this function takes ownership of one reference
5661 This function only exists if Perl has been compiled to use ithreads.
5667 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5672 PERL_ARGS_ASSERT_NEWPADOP;
5674 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5675 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5676 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5678 NewOp(1101, padop, 1, PADOP);
5679 CHANGE_TYPE(padop, type);
5681 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5682 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5683 PAD_SETSV(padop->op_padix, sv);
5685 padop->op_next = (OP*)padop;
5686 padop->op_flags = (U8)flags;
5687 if (PL_opargs[type] & OA_RETSCALAR)
5689 if (PL_opargs[type] & OA_TARGET)
5690 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5691 return CHECKOP(type, padop);
5694 #endif /* USE_ITHREADS */
5697 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5699 Constructs, checks, and returns an op of any type that involves an
5700 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5701 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5702 reference; calling this function does not transfer ownership of any
5709 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5711 PERL_ARGS_ASSERT_NEWGVOP;
5714 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5716 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5721 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5723 Constructs, checks, and returns an op of any type that involves an
5724 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5725 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
5726 must have been allocated using C<PerlMemShared_malloc>; the memory will
5727 be freed when the op is destroyed.
5733 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5736 const bool utf8 = cBOOL(flags & SVf_UTF8);
5741 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5743 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5745 NewOp(1101, pvop, 1, PVOP);
5746 CHANGE_TYPE(pvop, type);
5748 pvop->op_next = (OP*)pvop;
5749 pvop->op_flags = (U8)flags;
5750 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5751 if (PL_opargs[type] & OA_RETSCALAR)
5753 if (PL_opargs[type] & OA_TARGET)
5754 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5755 return CHECKOP(type, pvop);
5759 Perl_package(pTHX_ OP *o)
5761 SV *const sv = cSVOPo->op_sv;
5763 PERL_ARGS_ASSERT_PACKAGE;
5765 SAVEGENERICSV(PL_curstash);
5766 save_item(PL_curstname);
5768 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5770 sv_setsv(PL_curstname, sv);
5772 PL_hints |= HINT_BLOCK_SCOPE;
5773 PL_parser->copline = NOLINE;
5779 Perl_package_version( pTHX_ OP *v )
5781 U32 savehints = PL_hints;
5782 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5783 PL_hints &= ~HINT_STRICT_VARS;
5784 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5785 PL_hints = savehints;
5790 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5795 SV *use_version = NULL;
5797 PERL_ARGS_ASSERT_UTILIZE;
5799 if (idop->op_type != OP_CONST)
5800 Perl_croak(aTHX_ "Module name must be constant");
5805 SV * const vesv = ((SVOP*)version)->op_sv;
5807 if (!arg && !SvNIOKp(vesv)) {
5814 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5815 Perl_croak(aTHX_ "Version number must be a constant number");
5817 /* Make copy of idop so we don't free it twice */
5818 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5820 /* Fake up a method call to VERSION */
5821 meth = newSVpvs_share("VERSION");
5822 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5823 op_append_elem(OP_LIST,
5824 op_prepend_elem(OP_LIST, pack, version),
5825 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5829 /* Fake up an import/unimport */
5830 if (arg && arg->op_type == OP_STUB) {
5831 imop = arg; /* no import on explicit () */
5833 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5834 imop = NULL; /* use 5.0; */
5836 use_version = ((SVOP*)idop)->op_sv;
5838 idop->op_private |= OPpCONST_NOVER;
5843 /* Make copy of idop so we don't free it twice */
5844 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5846 /* Fake up a method call to import/unimport */
5848 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5849 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5850 op_append_elem(OP_LIST,
5851 op_prepend_elem(OP_LIST, pack, arg),
5852 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
5856 /* Fake up the BEGIN {}, which does its thing immediately. */
5858 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5861 op_append_elem(OP_LINESEQ,
5862 op_append_elem(OP_LINESEQ,
5863 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5864 newSTATEOP(0, NULL, veop)),
5865 newSTATEOP(0, NULL, imop) ));
5869 * feature bundle that corresponds to the required version. */
5870 use_version = sv_2mortal(new_version(use_version));
5871 S_enable_feature_bundle(aTHX_ use_version);
5873 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5874 if (vcmp(use_version,
5875 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5876 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5877 PL_hints |= HINT_STRICT_REFS;
5878 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5879 PL_hints |= HINT_STRICT_SUBS;
5880 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5881 PL_hints |= HINT_STRICT_VARS;
5883 /* otherwise they are off */
5885 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5886 PL_hints &= ~HINT_STRICT_REFS;
5887 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5888 PL_hints &= ~HINT_STRICT_SUBS;
5889 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5890 PL_hints &= ~HINT_STRICT_VARS;
5894 /* The "did you use incorrect case?" warning used to be here.
5895 * The problem is that on case-insensitive filesystems one
5896 * might get false positives for "use" (and "require"):
5897 * "use Strict" or "require CARP" will work. This causes
5898 * portability problems for the script: in case-strict
5899 * filesystems the script will stop working.
5901 * The "incorrect case" warning checked whether "use Foo"
5902 * imported "Foo" to your namespace, but that is wrong, too:
5903 * there is no requirement nor promise in the language that
5904 * a Foo.pm should or would contain anything in package "Foo".
5906 * There is very little Configure-wise that can be done, either:
5907 * the case-sensitivity of the build filesystem of Perl does not
5908 * help in guessing the case-sensitivity of the runtime environment.
5911 PL_hints |= HINT_BLOCK_SCOPE;
5912 PL_parser->copline = NOLINE;
5913 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
5917 =head1 Embedding Functions
5919 =for apidoc load_module
5921 Loads the module whose name is pointed to by the string part of name.
5922 Note that the actual module name, not its filename, should be given.
5923 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5924 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5925 (or 0 for no flags). ver, if specified
5926 and not NULL, provides version semantics
5927 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5928 arguments can be used to specify arguments to the module's import()
5929 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5930 terminated with a final NULL pointer. Note that this list can only
5931 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5932 Otherwise at least a single NULL pointer to designate the default
5933 import list is required.
5935 The reference count for each specified C<SV*> parameter is decremented.
5940 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5944 PERL_ARGS_ASSERT_LOAD_MODULE;
5946 va_start(args, ver);
5947 vload_module(flags, name, ver, &args);
5951 #ifdef PERL_IMPLICIT_CONTEXT
5953 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5957 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5958 va_start(args, ver);
5959 vload_module(flags, name, ver, &args);
5965 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5968 OP * const modname = newSVOP(OP_CONST, 0, name);
5970 PERL_ARGS_ASSERT_VLOAD_MODULE;
5972 modname->op_private |= OPpCONST_BARE;
5974 veop = newSVOP(OP_CONST, 0, ver);
5978 if (flags & PERL_LOADMOD_NOIMPORT) {
5979 imop = sawparens(newNULLLIST());
5981 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5982 imop = va_arg(*args, OP*);
5987 sv = va_arg(*args, SV*);
5989 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5990 sv = va_arg(*args, SV*);
5994 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5995 * that it has a PL_parser to play with while doing that, and also
5996 * that it doesn't mess with any existing parser, by creating a tmp
5997 * new parser with lex_start(). This won't actually be used for much,
5998 * since pp_require() will create another parser for the real work.
5999 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6002 SAVEVPTR(PL_curcop);
6003 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6004 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6005 veop, modname, imop);
6009 PERL_STATIC_INLINE OP *
6010 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6012 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6013 newLISTOP(OP_LIST, 0, arg,
6014 newUNOP(OP_RV2CV, 0,
6015 newGVOP(OP_GV, 0, gv))));
6019 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6024 PERL_ARGS_ASSERT_DOFILE;
6026 if (!force_builtin && (gv = gv_override("do", 2))) {
6027 doop = S_new_entersubop(aTHX_ gv, term);
6030 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6036 =head1 Optree construction
6038 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6040 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
6041 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6042 be set automatically, and, shifted up eight bits, the eight bits of
6043 C<op_private>, except that the bit with value 1 or 2 is automatically
6044 set as required. I<listval> and I<subscript> supply the parameters of
6045 the slice; they are consumed by this function and become part of the
6046 constructed op tree.
6052 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6054 return newBINOP(OP_LSLICE, flags,
6055 list(force_list(subscript, 1)),
6056 list(force_list(listval, 1)) );
6059 #define ASSIGN_LIST 1
6060 #define ASSIGN_REF 2
6063 S_assignment_type(pTHX_ const OP *o)
6072 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6073 o = cUNOPo->op_first;
6075 flags = o->op_flags;
6077 if (type == OP_COND_EXPR) {
6078 OP * const sib = OP_SIBLING(cLOGOPo->op_first);
6079 const I32 t = assignment_type(sib);
6080 const I32 f = assignment_type(OP_SIBLING(sib));
6082 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6084 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6085 yyerror("Assignment to both a list and a scalar");
6089 if (type == OP_SREFGEN)
6091 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6092 type = kid->op_type;
6093 flags |= kid->op_flags;
6094 if (!(flags & OPf_PARENS)
6095 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6096 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6102 if (type == OP_LIST &&
6103 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6104 o->op_private & OPpLVAL_INTRO)
6107 if (type == OP_LIST || flags & OPf_PARENS ||
6108 type == OP_RV2AV || type == OP_RV2HV ||
6109 type == OP_ASLICE || type == OP_HSLICE ||
6110 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6113 if (type == OP_PADAV || type == OP_PADHV)
6116 if (type == OP_RV2SV)
6123 Helper function for newASSIGNOP to detect commonality between the
6124 lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
6125 flags the op and the peephole optimizer calls this helper function
6126 if the flag is set.) Marks all variables with PL_generation. If it
6127 returns TRUE the assignment must be able to handle common variables.
6129 PL_generation sorcery:
6130 An assignment like ($a,$b) = ($c,$d) is easier than
6131 ($a,$b) = ($c,$a), since there is no need for temporary vars.
6132 To detect whether there are common vars, the global var
6133 PL_generation is incremented for each assign op we compile.
6134 Then, while compiling the assign op, we run through all the
6135 variables on both sides of the assignment, setting a spare slot
6136 in each of them to PL_generation. If any of them already have
6137 that value, we know we've got commonality. Also, if the
6138 generation number is already set to PERL_INT_MAX, then
6139 the variable is involved in aliasing, so we also have
6140 potential commonality in that case. We could use a
6141 single bit marker, but then we'd have to make 2 passes, first
6142 to clear the flag, then to test and set it. And that
6143 wouldn't help with aliasing, either. To find somewhere
6144 to store these values, evil chicanery is done with SvUVX().
6146 PERL_STATIC_INLINE bool
6147 S_aassign_common_vars(pTHX_ OP* o)
6150 for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
6151 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
6152 if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
6153 || curop->op_type == OP_AELEMFAST) {
6154 GV *gv = cGVOPx_gv(curop);
6156 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6158 GvASSIGN_GENERATION_set(gv, PL_generation);
6160 else if (curop->op_type == OP_PADSV ||
6161 curop->op_type == OP_PADAV ||
6162 curop->op_type == OP_PADHV ||
6163 curop->op_type == OP_AELEMFAST_LEX ||
6164 curop->op_type == OP_PADANY)
6167 if (PAD_COMPNAME_GEN(curop->op_targ)
6168 == (STRLEN)PL_generation
6169 || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6171 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
6174 else if (curop->op_type == OP_RV2CV)
6176 else if (curop->op_type == OP_RV2SV ||
6177 curop->op_type == OP_RV2AV ||
6178 curop->op_type == OP_RV2HV ||
6179 curop->op_type == OP_RV2GV) {
6180 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
6183 else if (curop->op_type == OP_PUSHRE) {
6186 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
6187 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
6190 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
6194 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6196 GvASSIGN_GENERATION_set(gv, PL_generation);
6198 else if (curop->op_targ)
6201 else if (curop->op_type == OP_PADRANGE)
6202 /* Ignore padrange; checking its siblings is sufficient. */
6207 else if (PL_opargs[curop->op_type] & OA_TARGLEX
6208 && curop->op_private & OPpTARGET_MY)
6211 if (curop->op_flags & OPf_KIDS) {
6212 if (aassign_common_vars(curop))
6219 /* This variant only handles lexical aliases. It is called when
6220 newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6221 ases trump that decision. */
6222 PERL_STATIC_INLINE bool
6223 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6226 for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
6227 if ((curop->op_type == OP_PADSV ||
6228 curop->op_type == OP_PADAV ||
6229 curop->op_type == OP_PADHV ||
6230 curop->op_type == OP_AELEMFAST_LEX ||
6231 curop->op_type == OP_PADANY ||
6232 ( PL_opargs[curop->op_type] & OA_TARGLEX
6233 && curop->op_private & OPpTARGET_MY ))
6234 && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6237 if (curop->op_type == OP_PUSHRE && curop->op_targ
6238 && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6241 if (curop->op_flags & OPf_KIDS) {
6242 if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6250 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6252 Constructs, checks, and returns an assignment op. I<left> and I<right>
6253 supply the parameters of the assignment; they are consumed by this
6254 function and become part of the constructed op tree.
6256 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6257 a suitable conditional optree is constructed. If I<optype> is the opcode
6258 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6259 performs the binary operation and assigns the result to the left argument.
6260 Either way, if I<optype> is non-zero then I<flags> has no effect.
6262 If I<optype> is zero, then a plain scalar or list assignment is
6263 constructed. Which type of assignment it is is automatically determined.
6264 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6265 will be set automatically, and, shifted up eight bits, the eight bits
6266 of C<op_private>, except that the bit with value 1 or 2 is automatically
6273 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6279 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6280 return newLOGOP(optype, 0,
6281 op_lvalue(scalar(left), optype),
6282 newUNOP(OP_SASSIGN, 0, scalar(right)));
6285 return newBINOP(optype, OPf_STACKED,
6286 op_lvalue(scalar(left), optype), scalar(right));
6290 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6291 static const char no_list_state[] = "Initialization of state variables"
6292 " in list context currently forbidden";
6294 bool maybe_common_vars = TRUE;
6296 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6297 left->op_private &= ~ OPpSLICEWARNING;
6300 left = op_lvalue(left, OP_AASSIGN);
6301 curop = list(force_list(left, 1));
6302 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6303 o->op_private = (U8)(0 | (flags >> 8));
6305 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6307 OP* lop = ((LISTOP*)left)->op_first;
6308 maybe_common_vars = FALSE;
6310 if (lop->op_type == OP_PADSV ||
6311 lop->op_type == OP_PADAV ||
6312 lop->op_type == OP_PADHV ||
6313 lop->op_type == OP_PADANY) {
6314 if (!(lop->op_private & OPpLVAL_INTRO))
6315 maybe_common_vars = TRUE;
6317 if (lop->op_private & OPpPAD_STATE) {
6318 if (left->op_private & OPpLVAL_INTRO) {
6319 /* Each variable in state($a, $b, $c) = ... */
6322 /* Each state variable in
6323 (state $a, my $b, our $c, $d, undef) = ... */
6325 yyerror(no_list_state);
6327 /* Each my variable in
6328 (state $a, my $b, our $c, $d, undef) = ... */
6330 } else if (lop->op_type == OP_UNDEF ||
6331 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6332 /* undef may be interesting in
6333 (state $a, undef, state $c) */
6335 /* Other ops in the list. */
6336 maybe_common_vars = TRUE;
6338 lop = OP_SIBLING(lop);
6341 else if ((left->op_private & OPpLVAL_INTRO)
6342 && ( left->op_type == OP_PADSV
6343 || left->op_type == OP_PADAV
6344 || left->op_type == OP_PADHV
6345 || left->op_type == OP_PADANY))
6347 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6348 if (left->op_private & OPpPAD_STATE) {
6349 /* All single variable list context state assignments, hence
6359 yyerror(no_list_state);
6363 if (maybe_common_vars) {
6364 /* The peephole optimizer will do the full check and pos-
6365 sibly turn this off. */
6366 o->op_private |= OPpASSIGN_COMMON;
6369 if (right && right->op_type == OP_SPLIT
6370 && !(right->op_flags & OPf_STACKED)) {
6371 OP* tmpop = ((LISTOP*)right)->op_first;
6372 PMOP * const pm = (PMOP*)tmpop;
6373 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6376 !pm->op_pmreplrootu.op_pmtargetoff
6378 !pm->op_pmreplrootu.op_pmtargetgv
6382 if (!(left->op_private & OPpLVAL_INTRO) &&
6383 ( (left->op_type == OP_RV2AV &&
6384 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6385 || left->op_type == OP_PADAV )
6387 if (tmpop != (OP *)pm) {
6389 pm->op_pmreplrootu.op_pmtargetoff
6390 = cPADOPx(tmpop)->op_padix;
6391 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6393 pm->op_pmreplrootu.op_pmtargetgv
6394 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6395 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6397 right->op_private |=
6398 left->op_private & OPpOUR_INTRO;
6401 pm->op_targ = left->op_targ;
6402 left->op_targ = 0; /* filch it */
6405 tmpop = cUNOPo->op_first; /* to list (nulled) */
6406 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6407 /* detach rest of siblings from o subtree,
6408 * and free subtree */
6409 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6410 op_free(o); /* blow off assign */
6411 right->op_flags &= ~OPf_WANT;
6412 /* "I don't know and I don't care." */
6415 else if (left->op_type == OP_RV2AV
6416 || left->op_type == OP_PADAV)
6418 /* Detach the array. */
6422 op_sibling_splice(cBINOPo->op_last,
6423 cUNOPx(cBINOPo->op_last)
6424 ->op_first, 1, NULL);
6425 assert(ary == left);
6426 /* Attach it to the split. */
6427 op_sibling_splice(right, cLISTOPx(right)->op_last,
6429 right->op_flags |= OPf_STACKED;
6430 /* Detach split and expunge aassign as above. */
6433 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6434 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6437 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6438 SV * const sv = *svp;
6439 if (SvIOK(sv) && SvIVX(sv) == 0)
6441 if (right->op_private & OPpSPLIT_IMPLIM) {
6442 /* our own SV, created in ck_split */
6444 sv_setiv(sv, PL_modcount+1);
6447 /* SV may belong to someone else */
6449 *svp = newSViv(PL_modcount+1);
6457 if (assign_type == ASSIGN_REF)
6458 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6460 right = newOP(OP_UNDEF, 0);
6461 if (right->op_type == OP_READLINE) {
6462 right->op_flags |= OPf_STACKED;
6463 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6467 o = newBINOP(OP_SASSIGN, flags,
6468 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6474 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6476 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6477 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6478 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6479 If I<label> is non-null, it supplies the name of a label to attach to
6480 the state op; this function takes ownership of the memory pointed at by
6481 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
6484 If I<o> is null, the state op is returned. Otherwise the state op is
6485 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
6486 is consumed by this function and becomes part of the returned op tree.
6492 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6495 const U32 seq = intro_my();
6496 const U32 utf8 = flags & SVf_UTF8;
6499 PL_parser->parsed_sub = 0;
6503 NewOp(1101, cop, 1, COP);
6504 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6505 CHANGE_TYPE(cop, OP_DBSTATE);
6508 CHANGE_TYPE(cop, OP_NEXTSTATE);
6510 cop->op_flags = (U8)flags;
6511 CopHINTS_set(cop, PL_hints);
6513 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6515 cop->op_next = (OP*)cop;
6518 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6519 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6521 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6523 PL_hints |= HINT_BLOCK_SCOPE;
6524 /* It seems that we need to defer freeing this pointer, as other parts
6525 of the grammar end up wanting to copy it after this op has been
6530 if (PL_parser->preambling != NOLINE) {
6531 CopLINE_set(cop, PL_parser->preambling);
6532 PL_parser->copline = NOLINE;
6534 else if (PL_parser->copline == NOLINE)
6535 CopLINE_set(cop, CopLINE(PL_curcop));
6537 CopLINE_set(cop, PL_parser->copline);
6538 PL_parser->copline = NOLINE;
6541 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6543 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6545 CopSTASH_set(cop, PL_curstash);
6547 if (cop->op_type == OP_DBSTATE) {
6548 /* this line can have a breakpoint - store the cop in IV */
6549 AV *av = CopFILEAVx(PL_curcop);
6551 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6552 if (svp && *svp != &PL_sv_undef ) {
6553 (void)SvIOK_on(*svp);
6554 SvIV_set(*svp, PTR2IV(cop));
6559 if (flags & OPf_SPECIAL)
6561 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6565 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6567 Constructs, checks, and returns a logical (flow control) op. I<type>
6568 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
6569 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6570 the eight bits of C<op_private>, except that the bit with value 1 is
6571 automatically set. I<first> supplies the expression controlling the
6572 flow, and I<other> supplies the side (alternate) chain of ops; they are
6573 consumed by this function and become part of the constructed op tree.
6579 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6581 PERL_ARGS_ASSERT_NEWLOGOP;
6583 return new_logop(type, flags, &first, &other);
6587 S_search_const(pTHX_ OP *o)
6589 PERL_ARGS_ASSERT_SEARCH_CONST;
6591 switch (o->op_type) {
6595 if (o->op_flags & OPf_KIDS)
6596 return search_const(cUNOPo->op_first);
6603 if (!(o->op_flags & OPf_KIDS))
6605 kid = cLISTOPo->op_first;
6607 switch (kid->op_type) {
6611 kid = OP_SIBLING(kid);
6614 if (kid != cLISTOPo->op_last)
6620 kid = cLISTOPo->op_last;
6622 return search_const(kid);
6630 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6638 int prepend_not = 0;
6640 PERL_ARGS_ASSERT_NEW_LOGOP;
6645 /* [perl #59802]: Warn about things like "return $a or $b", which
6646 is parsed as "(return $a) or $b" rather than "return ($a or
6647 $b)". NB: This also applies to xor, which is why we do it
6650 switch (first->op_type) {
6654 /* XXX: Perhaps we should emit a stronger warning for these.
6655 Even with the high-precedence operator they don't seem to do
6658 But until we do, fall through here.
6664 /* XXX: Currently we allow people to "shoot themselves in the
6665 foot" by explicitly writing "(return $a) or $b".
6667 Warn unless we are looking at the result from folding or if
6668 the programmer explicitly grouped the operators like this.
6669 The former can occur with e.g.
6671 use constant FEATURE => ( $] >= ... );
6672 sub { not FEATURE and return or do_stuff(); }
6674 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6675 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6676 "Possible precedence issue with control flow operator");
6677 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6683 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6684 return newBINOP(type, flags, scalar(first), scalar(other));
6686 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6688 scalarboolean(first);
6689 /* optimize AND and OR ops that have NOTs as children */
6690 if (first->op_type == OP_NOT
6691 && (first->op_flags & OPf_KIDS)
6692 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6693 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6695 if (type == OP_AND || type == OP_OR) {
6701 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6703 prepend_not = 1; /* prepend a NOT op later */
6707 /* search for a constant op that could let us fold the test */
6708 if ((cstop = search_const(first))) {
6709 if (cstop->op_private & OPpCONST_STRICT)
6710 no_bareword_allowed(cstop);
6711 else if ((cstop->op_private & OPpCONST_BARE))
6712 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6713 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6714 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6715 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6717 if (other->op_type == OP_CONST)
6718 other->op_private |= OPpCONST_SHORTCIRCUIT;
6720 if (other->op_type == OP_LEAVE)
6721 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6722 else if (other->op_type == OP_MATCH
6723 || other->op_type == OP_SUBST
6724 || other->op_type == OP_TRANSR
6725 || other->op_type == OP_TRANS)
6726 /* Mark the op as being unbindable with =~ */
6727 other->op_flags |= OPf_SPECIAL;
6729 other->op_folded = 1;
6733 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6734 const OP *o2 = other;
6735 if ( ! (o2->op_type == OP_LIST
6736 && (( o2 = cUNOPx(o2)->op_first))
6737 && o2->op_type == OP_PUSHMARK
6738 && (( o2 = OP_SIBLING(o2))) )
6741 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6742 || o2->op_type == OP_PADHV)
6743 && o2->op_private & OPpLVAL_INTRO
6744 && !(o2->op_private & OPpPAD_STATE))
6746 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6747 "Deprecated use of my() in false conditional");
6751 if (cstop->op_type == OP_CONST)
6752 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6757 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6758 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6760 const OP * const k1 = ((UNOP*)first)->op_first;
6761 const OP * const k2 = OP_SIBLING(k1);
6763 switch (first->op_type)
6766 if (k2 && k2->op_type == OP_READLINE
6767 && (k2->op_flags & OPf_STACKED)
6768 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6770 warnop = k2->op_type;
6775 if (k1->op_type == OP_READDIR
6776 || k1->op_type == OP_GLOB
6777 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6778 || k1->op_type == OP_EACH
6779 || k1->op_type == OP_AEACH)
6781 warnop = ((k1->op_type == OP_NULL)
6782 ? (OPCODE)k1->op_targ : k1->op_type);
6787 const line_t oldline = CopLINE(PL_curcop);
6788 /* This ensures that warnings are reported at the first line
6789 of the construction, not the last. */
6790 CopLINE_set(PL_curcop, PL_parser->copline);
6791 Perl_warner(aTHX_ packWARN(WARN_MISC),
6792 "Value of %s%s can be \"0\"; test with defined()",
6794 ((warnop == OP_READLINE || warnop == OP_GLOB)
6795 ? " construct" : "() operator"));
6796 CopLINE_set(PL_curcop, oldline);
6803 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6804 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6806 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6807 logop->op_flags |= (U8)flags;
6808 logop->op_private = (U8)(1 | (flags >> 8));
6810 /* establish postfix order */
6811 logop->op_next = LINKLIST(first);
6812 first->op_next = (OP*)logop;
6813 assert(!OP_HAS_SIBLING(first));
6814 op_sibling_splice((OP*)logop, first, 0, other);
6816 CHECKOP(type,logop);
6818 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6825 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6827 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6828 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6829 will be set automatically, and, shifted up eight bits, the eight bits of
6830 C<op_private>, except that the bit with value 1 is automatically set.
6831 I<first> supplies the expression selecting between the two branches,
6832 and I<trueop> and I<falseop> supply the branches; they are consumed by
6833 this function and become part of the constructed op tree.
6839 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6847 PERL_ARGS_ASSERT_NEWCONDOP;
6850 return newLOGOP(OP_AND, 0, first, trueop);
6852 return newLOGOP(OP_OR, 0, first, falseop);
6854 scalarboolean(first);
6855 if ((cstop = search_const(first))) {
6856 /* Left or right arm of the conditional? */
6857 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6858 OP *live = left ? trueop : falseop;
6859 OP *const dead = left ? falseop : trueop;
6860 if (cstop->op_private & OPpCONST_BARE &&
6861 cstop->op_private & OPpCONST_STRICT) {
6862 no_bareword_allowed(cstop);
6866 if (live->op_type == OP_LEAVE)
6867 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6868 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6869 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6870 /* Mark the op as being unbindable with =~ */
6871 live->op_flags |= OPf_SPECIAL;
6872 live->op_folded = 1;
6875 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6876 logop->op_flags |= (U8)flags;
6877 logop->op_private = (U8)(1 | (flags >> 8));
6878 logop->op_next = LINKLIST(falseop);
6880 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6883 /* establish postfix order */
6884 start = LINKLIST(first);
6885 first->op_next = (OP*)logop;
6887 /* make first, trueop, falseop siblings */
6888 op_sibling_splice((OP*)logop, first, 0, trueop);
6889 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6891 o = newUNOP(OP_NULL, 0, (OP*)logop);
6893 trueop->op_next = falseop->op_next = o;
6900 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6902 Constructs and returns a C<range> op, with subordinate C<flip> and
6903 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6904 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6905 for both the C<flip> and C<range> ops, except that the bit with value
6906 1 is automatically set. I<left> and I<right> supply the expressions
6907 controlling the endpoints of the range; they are consumed by this function
6908 and become part of the constructed op tree.
6914 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6923 PERL_ARGS_ASSERT_NEWRANGE;
6925 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6926 range->op_flags = OPf_KIDS;
6927 leftstart = LINKLIST(left);
6928 range->op_private = (U8)(1 | (flags >> 8));
6930 /* make left and right siblings */
6931 op_sibling_splice((OP*)range, left, 0, right);
6933 range->op_next = (OP*)range;
6934 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6935 flop = newUNOP(OP_FLOP, 0, flip);
6936 o = newUNOP(OP_NULL, 0, flop);
6938 range->op_next = leftstart;
6940 left->op_next = flip;
6941 right->op_next = flop;
6944 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
6945 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6947 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
6948 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6949 SvPADTMP_on(PAD_SV(flip->op_targ));
6951 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6952 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6954 /* check barewords before they might be optimized aways */
6955 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6956 no_bareword_allowed(left);
6957 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6958 no_bareword_allowed(right);
6961 if (!flip->op_private || !flop->op_private)
6962 LINKLIST(o); /* blow off optimizer unless constant */
6968 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6970 Constructs, checks, and returns an op tree expressing a loop. This is
6971 only a loop in the control flow through the op tree; it does not have
6972 the heavyweight loop structure that allows exiting the loop by C<last>
6973 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6974 top-level op, except that some bits will be set automatically as required.
6975 I<expr> supplies the expression controlling loop iteration, and I<block>
6976 supplies the body of the loop; they are consumed by this function and
6977 become part of the constructed op tree. I<debuggable> is currently
6978 unused and should always be 1.
6984 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6988 const bool once = block && block->op_flags & OPf_SPECIAL &&
6989 block->op_type == OP_NULL;
6991 PERL_UNUSED_ARG(debuggable);
6995 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6996 || ( expr->op_type == OP_NOT
6997 && cUNOPx(expr)->op_first->op_type == OP_CONST
6998 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7001 /* Return the block now, so that S_new_logop does not try to
7003 return block; /* do {} while 0 does once */
7004 if (expr->op_type == OP_READLINE
7005 || expr->op_type == OP_READDIR
7006 || expr->op_type == OP_GLOB
7007 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7008 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7009 expr = newUNOP(OP_DEFINED, 0,
7010 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7011 } else if (expr->op_flags & OPf_KIDS) {
7012 const OP * const k1 = ((UNOP*)expr)->op_first;
7013 const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL;
7014 switch (expr->op_type) {
7016 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7017 && (k2->op_flags & OPf_STACKED)
7018 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7019 expr = newUNOP(OP_DEFINED, 0, expr);
7023 if (k1 && (k1->op_type == OP_READDIR
7024 || k1->op_type == OP_GLOB
7025 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7026 || k1->op_type == OP_EACH
7027 || k1->op_type == OP_AEACH))
7028 expr = newUNOP(OP_DEFINED, 0, expr);
7034 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7035 * op, in listop. This is wrong. [perl #27024] */
7037 block = newOP(OP_NULL, 0);
7038 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7039 o = new_logop(OP_AND, 0, &expr, &listop);
7046 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7048 if (once && o != listop)
7050 assert(cUNOPo->op_first->op_type == OP_AND
7051 || cUNOPo->op_first->op_type == OP_OR);
7052 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7056 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7058 o->op_flags |= flags;
7060 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7065 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7067 Constructs, checks, and returns an op tree expressing a C<while> loop.
7068 This is a heavyweight loop, with structure that allows exiting the loop
7069 by C<last> and suchlike.
7071 I<loop> is an optional preconstructed C<enterloop> op to use in the
7072 loop; if it is null then a suitable op will be constructed automatically.
7073 I<expr> supplies the loop's controlling expression. I<block> supplies the
7074 main body of the loop, and I<cont> optionally supplies a C<continue> block
7075 that operates as a second half of the body. All of these optree inputs
7076 are consumed by this function and become part of the constructed op tree.
7078 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7079 op and, shifted up eight bits, the eight bits of C<op_private> for
7080 the C<leaveloop> op, except that (in both cases) some bits will be set
7081 automatically. I<debuggable> is currently unused and should always be 1.
7082 I<has_my> can be supplied as true to force the
7083 loop body to be enclosed in its own scope.
7089 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7090 OP *expr, OP *block, OP *cont, I32 has_my)
7099 PERL_UNUSED_ARG(debuggable);
7102 if (expr->op_type == OP_READLINE
7103 || expr->op_type == OP_READDIR
7104 || expr->op_type == OP_GLOB
7105 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7106 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7107 expr = newUNOP(OP_DEFINED, 0,
7108 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7109 } else if (expr->op_flags & OPf_KIDS) {
7110 const OP * const k1 = ((UNOP*)expr)->op_first;
7111 const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL;
7112 switch (expr->op_type) {
7114 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7115 && (k2->op_flags & OPf_STACKED)
7116 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7117 expr = newUNOP(OP_DEFINED, 0, expr);
7121 if (k1 && (k1->op_type == OP_READDIR
7122 || k1->op_type == OP_GLOB
7123 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7124 || k1->op_type == OP_EACH
7125 || k1->op_type == OP_AEACH))
7126 expr = newUNOP(OP_DEFINED, 0, expr);
7133 block = newOP(OP_NULL, 0);
7134 else if (cont || has_my) {
7135 block = op_scope(block);
7139 next = LINKLIST(cont);
7142 OP * const unstack = newOP(OP_UNSTACK, 0);
7145 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7149 listop = op_append_list(OP_LINESEQ, block, cont);
7151 redo = LINKLIST(listop);
7155 o = new_logop(OP_AND, 0, &expr, &listop);
7156 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7158 return expr; /* listop already freed by new_logop */
7161 ((LISTOP*)listop)->op_last->op_next =
7162 (o == listop ? redo : LINKLIST(o));
7168 NewOp(1101,loop,1,LOOP);
7169 CHANGE_TYPE(loop, OP_ENTERLOOP);
7170 loop->op_private = 0;
7171 loop->op_next = (OP*)loop;
7174 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7176 loop->op_redoop = redo;
7177 loop->op_lastop = o;
7178 o->op_private |= loopflags;
7181 loop->op_nextop = next;
7183 loop->op_nextop = o;
7185 o->op_flags |= flags;
7186 o->op_private |= (flags >> 8);
7191 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7193 Constructs, checks, and returns an op tree expressing a C<foreach>
7194 loop (iteration through a list of values). This is a heavyweight loop,
7195 with structure that allows exiting the loop by C<last> and suchlike.
7197 I<sv> optionally supplies the variable that will be aliased to each
7198 item in turn; if null, it defaults to C<$_> (either lexical or global).
7199 I<expr> supplies the list of values to iterate over. I<block> supplies
7200 the main body of the loop, and I<cont> optionally supplies a C<continue>
7201 block that operates as a second half of the body. All of these optree
7202 inputs are consumed by this function and become part of the constructed
7205 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7206 op and, shifted up eight bits, the eight bits of C<op_private> for
7207 the C<leaveloop> op, except that (in both cases) some bits will be set
7214 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7219 PADOFFSET padoff = 0;
7223 PERL_ARGS_ASSERT_NEWFOROP;
7226 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7227 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7228 CHANGE_TYPE(sv, OP_RV2GV);
7230 /* The op_type check is needed to prevent a possible segfault
7231 * if the loop variable is undeclared and 'strict vars' is in
7232 * effect. This is illegal but is nonetheless parsed, so we
7233 * may reach this point with an OP_CONST where we're expecting
7236 if (cUNOPx(sv)->op_first->op_type == OP_GV
7237 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7238 iterpflags |= OPpITER_DEF;
7240 else if (sv->op_type == OP_PADSV) { /* private variable */
7241 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7242 padoff = sv->op_targ;
7246 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7248 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7251 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7253 SV *const namesv = PAD_COMPNAME_SV(padoff);
7255 const char *const name = SvPV_const(namesv, len);
7257 if (len == 2 && name[0] == '$' && name[1] == '_')
7258 iterpflags |= OPpITER_DEF;
7262 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7263 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7264 sv = newGVOP(OP_GV, 0, PL_defgv);
7269 iterpflags |= OPpITER_DEF;
7272 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7273 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7274 iterflags |= OPf_STACKED;
7276 else if (expr->op_type == OP_NULL &&
7277 (expr->op_flags & OPf_KIDS) &&
7278 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7280 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7281 * set the STACKED flag to indicate that these values are to be
7282 * treated as min/max values by 'pp_enteriter'.
7284 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7285 LOGOP* const range = (LOGOP*) flip->op_first;
7286 OP* const left = range->op_first;
7287 OP* const right = OP_SIBLING(left);
7290 range->op_flags &= ~OPf_KIDS;
7291 /* detach range's children */
7292 op_sibling_splice((OP*)range, NULL, -1, NULL);
7294 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7295 listop->op_first->op_next = range->op_next;
7296 left->op_next = range->op_other;
7297 right->op_next = (OP*)listop;
7298 listop->op_next = listop->op_first;
7301 expr = (OP*)(listop);
7303 iterflags |= OPf_STACKED;
7306 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7309 loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
7310 op_append_elem(OP_LIST, expr, scalar(sv))));
7311 assert(!loop->op_next);
7312 /* for my $x () sets OPpLVAL_INTRO;
7313 * for our $x () sets OPpOUR_INTRO */
7314 loop->op_private = (U8)iterpflags;
7315 if (loop->op_slabbed
7316 && DIFF(loop, OpSLOT(loop)->opslot_next)
7317 < SIZE_TO_PSIZE(sizeof(LOOP)))
7320 NewOp(1234,tmp,1,LOOP);
7321 Copy(loop,tmp,1,LISTOP);
7322 #ifdef PERL_OP_PARENT
7323 assert(loop->op_last->op_sibling == (OP*)loop);
7324 loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
7326 S_op_destroy(aTHX_ (OP*)loop);
7329 else if (!loop->op_slabbed)
7331 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7332 #ifdef PERL_OP_PARENT
7333 loop->op_last->op_sibling = (OP *)loop;
7336 loop->op_targ = padoff;
7337 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7342 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7344 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7345 or C<last>). I<type> is the opcode. I<label> supplies the parameter
7346 determining the target of the op; it is consumed by this function and
7347 becomes part of the constructed op tree.
7353 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7357 PERL_ARGS_ASSERT_NEWLOOPEX;
7359 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7361 if (type != OP_GOTO) {
7362 /* "last()" means "last" */
7363 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7364 o = newOP(type, OPf_SPECIAL);
7368 /* Check whether it's going to be a goto &function */
7369 if (label->op_type == OP_ENTERSUB
7370 && !(label->op_flags & OPf_STACKED))
7371 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7374 /* Check for a constant argument */
7375 if (label->op_type == OP_CONST) {
7376 SV * const sv = ((SVOP *)label)->op_sv;
7378 const char *s = SvPV_const(sv,l);
7379 if (l == strlen(s)) {
7381 SvUTF8(((SVOP*)label)->op_sv),
7383 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7387 /* If we have already created an op, we do not need the label. */
7390 else o = newUNOP(type, OPf_STACKED, label);
7392 PL_hints |= HINT_BLOCK_SCOPE;
7396 /* if the condition is a literal array or hash
7397 (or @{ ... } etc), make a reference to it.
7400 S_ref_array_or_hash(pTHX_ OP *cond)
7403 && (cond->op_type == OP_RV2AV
7404 || cond->op_type == OP_PADAV
7405 || cond->op_type == OP_RV2HV
7406 || cond->op_type == OP_PADHV))
7408 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7411 && (cond->op_type == OP_ASLICE
7412 || cond->op_type == OP_KVASLICE
7413 || cond->op_type == OP_HSLICE
7414 || cond->op_type == OP_KVHSLICE)) {
7416 /* anonlist now needs a list from this op, was previously used in
7418 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
7419 cond->op_flags |= OPf_WANT_LIST;
7421 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7428 /* These construct the optree fragments representing given()
7431 entergiven and enterwhen are LOGOPs; the op_other pointer
7432 points up to the associated leave op. We need this so we
7433 can put it in the context and make break/continue work.
7434 (Also, of course, pp_enterwhen will jump straight to
7435 op_other if the match fails.)
7439 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7440 I32 enter_opcode, I32 leave_opcode,
7441 PADOFFSET entertarg)
7447 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7449 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7450 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7451 enterop->op_private = 0;
7453 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7456 /* prepend cond if we have one */
7457 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7459 o->op_next = LINKLIST(cond);
7460 cond->op_next = (OP *) enterop;
7463 /* This is a default {} block */
7464 enterop->op_flags |= OPf_SPECIAL;
7465 o ->op_flags |= OPf_SPECIAL;
7467 o->op_next = (OP *) enterop;
7470 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7471 entergiven and enterwhen both
7474 enterop->op_next = LINKLIST(block);
7475 block->op_next = enterop->op_other = o;
7480 /* Does this look like a boolean operation? For these purposes
7481 a boolean operation is:
7482 - a subroutine call [*]
7483 - a logical connective
7484 - a comparison operator
7485 - a filetest operator, with the exception of -s -M -A -C
7486 - defined(), exists() or eof()
7487 - /$re/ or $foo =~ /$re/
7489 [*] possibly surprising
7492 S_looks_like_bool(pTHX_ const OP *o)
7494 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7496 switch(o->op_type) {
7499 return looks_like_bool(cLOGOPo->op_first);
7503 OP* sibl = OP_SIBLING(cLOGOPo->op_first);
7506 looks_like_bool(cLOGOPo->op_first)
7507 && looks_like_bool(sibl));
7513 o->op_flags & OPf_KIDS
7514 && looks_like_bool(cUNOPo->op_first));
7518 case OP_NOT: case OP_XOR:
7520 case OP_EQ: case OP_NE: case OP_LT:
7521 case OP_GT: case OP_LE: case OP_GE:
7523 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7524 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7526 case OP_SEQ: case OP_SNE: case OP_SLT:
7527 case OP_SGT: case OP_SLE: case OP_SGE:
7531 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7532 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7533 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7534 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7535 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7536 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7537 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7538 case OP_FTTEXT: case OP_FTBINARY:
7540 case OP_DEFINED: case OP_EXISTS:
7541 case OP_MATCH: case OP_EOF:
7548 /* Detect comparisons that have been optimized away */
7549 if (cSVOPo->op_sv == &PL_sv_yes
7550 || cSVOPo->op_sv == &PL_sv_no)
7563 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7565 Constructs, checks, and returns an op tree expressing a C<given> block.
7566 I<cond> supplies the expression that will be locally assigned to a lexical
7567 variable, and I<block> supplies the body of the C<given> construct; they
7568 are consumed by this function and become part of the constructed op tree.
7569 I<defsv_off> is the pad offset of the scalar lexical variable that will
7570 be affected. If it is 0, the global $_ will be used.
7576 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7578 PERL_ARGS_ASSERT_NEWGIVENOP;
7579 return newGIVWHENOP(
7580 ref_array_or_hash(cond),
7582 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7587 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7589 Constructs, checks, and returns an op tree expressing a C<when> block.
7590 I<cond> supplies the test expression, and I<block> supplies the block
7591 that will be executed if the test evaluates to true; they are consumed
7592 by this function and become part of the constructed op tree. I<cond>
7593 will be interpreted DWIMically, often as a comparison against C<$_>,
7594 and may be null to generate a C<default> block.
7600 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7602 const bool cond_llb = (!cond || looks_like_bool(cond));
7605 PERL_ARGS_ASSERT_NEWWHENOP;
7610 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7612 scalar(ref_array_or_hash(cond)));
7615 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7618 /* must not conflict with SVf_UTF8 */
7619 #define CV_CKPROTO_CURSTASH 0x1
7622 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7623 const STRLEN len, const U32 flags)
7625 SV *name = NULL, *msg;
7626 const char * cvp = SvROK(cv)
7627 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7628 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7631 STRLEN clen = CvPROTOLEN(cv), plen = len;
7633 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7635 if (p == NULL && cvp == NULL)
7638 if (!ckWARN_d(WARN_PROTOTYPE))
7642 p = S_strip_spaces(aTHX_ p, &plen);
7643 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7644 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7645 if (plen == clen && memEQ(cvp, p, plen))
7648 if (flags & SVf_UTF8) {
7649 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7653 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7659 msg = sv_newmortal();
7664 gv_efullname3(name = sv_newmortal(), gv, NULL);
7665 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7666 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7667 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7668 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7669 sv_catpvs(name, "::");
7671 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7672 assert (CvNAMED(SvRV_const(gv)));
7673 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7675 else sv_catsv(name, (SV *)gv);
7677 else name = (SV *)gv;
7679 sv_setpvs(msg, "Prototype mismatch:");
7681 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7683 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7684 UTF8fARG(SvUTF8(cv),clen,cvp)
7687 sv_catpvs(msg, ": none");
7688 sv_catpvs(msg, " vs ");
7690 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7692 sv_catpvs(msg, "none");
7693 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7696 static void const_sv_xsub(pTHX_ CV* cv);
7697 static void const_av_xsub(pTHX_ CV* cv);
7701 =head1 Optree Manipulation Functions
7703 =for apidoc cv_const_sv
7705 If C<cv> is a constant sub eligible for inlining, returns the constant
7706 value returned by the sub. Otherwise, returns NULL.
7708 Constant subs can be created with C<newCONSTSUB> or as described in
7709 L<perlsub/"Constant Functions">.
7714 Perl_cv_const_sv(const CV *const cv)
7719 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7721 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7722 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7727 Perl_cv_const_sv_or_av(const CV * const cv)
7731 if (SvROK(cv)) return SvRV((SV *)cv);
7732 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7733 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7736 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7737 * Can be called in 2 ways:
7740 * look for a single OP_CONST with attached value: return the value
7742 * allow_lex && !CvCONST(cv);
7744 * examine the clone prototype, and if contains only a single
7745 * OP_CONST, return the value; or if it contains a single PADSV ref-
7746 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7747 * a candidate for "constizing" at clone time, and return NULL.
7751 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7759 for (; o; o = o->op_next) {
7760 const OPCODE type = o->op_type;
7762 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7764 || type == OP_PUSHMARK)
7766 if (type == OP_DBSTATE)
7768 if (type == OP_LEAVESUB)
7772 if (type == OP_CONST && cSVOPo->op_sv)
7774 else if (type == OP_UNDEF && !o->op_private) {
7778 else if (allow_lex && type == OP_PADSV) {
7779 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
7781 sv = &PL_sv_undef; /* an arbitrary non-null value */
7799 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7800 PADNAME * const name, SV ** const const_svp)
7807 if (CvFLAGS(PL_compcv)) {
7808 /* might have had built-in attrs applied */
7809 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7810 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7811 && ckWARN(WARN_MISC))
7813 /* protect against fatal warnings leaking compcv */
7814 SAVEFREESV(PL_compcv);
7815 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7816 SvREFCNT_inc_simple_void_NN(PL_compcv);
7819 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7820 & ~(CVf_LVALUE * pureperl));
7825 /* redundant check for speed: */
7826 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7827 const line_t oldline = CopLINE(PL_curcop);
7830 : sv_2mortal(newSVpvn_utf8(
7831 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7833 if (PL_parser && PL_parser->copline != NOLINE)
7834 /* This ensures that warnings are reported at the first
7835 line of a redefinition, not the last. */
7836 CopLINE_set(PL_curcop, PL_parser->copline);
7837 /* protect against fatal warnings leaking compcv */
7838 SAVEFREESV(PL_compcv);
7839 report_redefined_cv(namesv, cv, const_svp);
7840 SvREFCNT_inc_simple_void_NN(PL_compcv);
7841 CopLINE_set(PL_curcop, oldline);
7848 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7853 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7856 CV *compcv = PL_compcv;
7859 PADOFFSET pax = o->op_targ;
7860 CV *outcv = CvOUTSIDE(PL_compcv);
7863 bool reusable = FALSE;
7865 #ifdef PERL_DEBUG_READONLY_OPS
7866 OPSLAB *slab = NULL;
7869 PERL_ARGS_ASSERT_NEWMYSUB;
7871 /* Find the pad slot for storing the new sub.
7872 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7873 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7874 ing sub. And then we need to dig deeper if this is a lexical from
7876 my sub foo; sub { sub foo { } }
7879 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7880 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7881 pax = PARENT_PAD_INDEX(name);
7882 outcv = CvOUTSIDE(outcv);
7887 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7888 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7889 spot = (CV **)svspot;
7891 if (!(PL_parser && PL_parser->error_count))
7892 move_proto_attr(&proto, &attrs, (GV *)name);
7895 assert(proto->op_type == OP_CONST);
7896 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7897 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7907 if (PL_parser && PL_parser->error_count) {
7909 SvREFCNT_dec(PL_compcv);
7914 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7916 svspot = (SV **)(spot = &clonee);
7918 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7922 SvUPGRADE(name, SVt_PVMG);
7923 mg = mg_find(name, PERL_MAGIC_proto);
7924 assert (SvTYPE(*spot) == SVt_PVCV);
7926 hek = CvNAME_HEK(*spot);
7930 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7931 CvNAME_HEK_set(*spot, hek =
7934 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
7938 CvLEXICAL_on(*spot);
7942 cv = (CV *)mg->mg_obj;
7945 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7946 mg = mg_find(name, PERL_MAGIC_proto);
7948 spot = (CV **)(svspot = &mg->mg_obj);
7952 /* This makes sub {}; work as expected. */
7953 if (block->op_type == OP_STUB) {
7954 const line_t l = PL_parser->copline;
7956 block = newSTATEOP(0, NULL, 0);
7957 PL_parser->copline = l;
7959 block = CvLVALUE(compcv)
7960 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
7961 ? newUNOP(OP_LEAVESUBLV, 0,
7962 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7963 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7964 start = LINKLIST(block);
7968 if (!block || !ps || *ps || attrs
7973 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
7976 const bool exists = CvROOT(cv) || CvXSUB(cv);
7978 /* if the subroutine doesn't exist and wasn't pre-declared
7979 * with a prototype, assume it will be AUTOLOADed,
7980 * skipping the prototype check
7982 if (exists || SvPOK(cv))
7983 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7984 /* already defined? */
7986 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7989 if (attrs) goto attrs;
7990 /* just a "sub foo;" when &foo is already defined */
7995 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8001 SvREFCNT_inc_simple_void_NN(const_sv);
8002 SvFLAGS(const_sv) |= SVs_PADTMP;
8004 assert(!CvROOT(cv) && !CvCONST(cv));
8008 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8009 CvFILE_set_from_cop(cv, PL_curcop);
8010 CvSTASH_set(cv, PL_curstash);
8013 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8014 CvXSUBANY(cv).any_ptr = const_sv;
8015 CvXSUB(cv) = const_sv_xsub;
8019 CvFLAGS(cv) |= CvMETHOD(compcv);
8021 SvREFCNT_dec(compcv);
8025 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8026 determine whether this sub definition is in the same scope as its
8027 declaration. If this sub definition is inside an inner named pack-
8028 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8029 the package sub. So check PadnameOUTER(name) too.
8031 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8032 assert(!CvWEAKOUTSIDE(compcv));
8033 SvREFCNT_dec(CvOUTSIDE(compcv));
8034 CvWEAKOUTSIDE_on(compcv);
8036 /* XXX else do we have a circular reference? */
8037 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8038 /* transfer PL_compcv to cv */
8041 cv_flags_t preserved_flags =
8042 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8043 PADLIST *const temp_padl = CvPADLIST(cv);
8044 CV *const temp_cv = CvOUTSIDE(cv);
8045 const cv_flags_t other_flags =
8046 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8047 OP * const cvstart = CvSTART(cv);
8051 CvFLAGS(compcv) | preserved_flags;
8052 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8053 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8054 CvPADLIST_set(cv, CvPADLIST(compcv));
8055 CvOUTSIDE(compcv) = temp_cv;
8056 CvPADLIST_set(compcv, temp_padl);
8057 CvSTART(cv) = CvSTART(compcv);
8058 CvSTART(compcv) = cvstart;
8059 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8060 CvFLAGS(compcv) |= other_flags;
8062 if (CvFILE(cv) && CvDYNFILE(cv)) {
8063 Safefree(CvFILE(cv));
8066 /* inner references to compcv must be fixed up ... */
8067 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8068 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8069 ++PL_sub_generation;
8072 /* Might have had built-in attributes applied -- propagate them. */
8073 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8075 /* ... before we throw it away */
8076 SvREFCNT_dec(compcv);
8077 PL_compcv = compcv = cv;
8085 if (!CvNAME_HEK(cv)) {
8086 if (hek) (void)share_hek_hek(hek);
8090 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8091 hek = share_hek(PadnamePV(name)+1,
8092 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8095 CvNAME_HEK_set(cv, hek);
8097 if (const_sv) goto clone;
8099 CvFILE_set_from_cop(cv, PL_curcop);
8100 CvSTASH_set(cv, PL_curstash);
8103 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8104 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8110 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8111 the debugger could be able to set a breakpoint in, so signal to
8112 pp_entereval that it should not throw away any saved lines at scope
8115 PL_breakable_sub_gen++;
8117 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8118 OpREFCNT_set(CvROOT(cv), 1);
8119 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8120 itself has a refcount. */
8122 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8123 #ifdef PERL_DEBUG_READONLY_OPS
8124 slab = (OPSLAB *)CvSTART(cv);
8126 CvSTART(cv) = start;
8128 finalize_optree(CvROOT(cv));
8129 S_prune_chain_head(&CvSTART(cv));
8131 /* now that optimizer has done its work, adjust pad values */
8133 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8137 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8138 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8142 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8143 SV * const tmpstr = sv_newmortal();
8144 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8145 GV_ADDMULTI, SVt_PVHV);
8147 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8150 (long)CopLINE(PL_curcop));
8151 if (HvNAME_HEK(PL_curstash)) {
8152 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8153 sv_catpvs(tmpstr, "::");
8155 else sv_setpvs(tmpstr, "__ANON__::");
8156 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8157 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8158 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8159 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8160 hv = GvHVn(db_postponed);
8161 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8162 CV * const pcv = GvCV(db_postponed);
8168 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8176 assert(CvDEPTH(outcv));
8178 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8179 if (reusable) cv_clone_into(clonee, *spot);
8180 else *spot = cv_clone(clonee);
8181 SvREFCNT_dec_NN(clonee);
8184 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8185 PADOFFSET depth = CvDEPTH(outcv);
8188 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8190 *svspot = SvREFCNT_inc_simple_NN(cv);
8191 SvREFCNT_dec(oldcv);
8197 PL_parser->copline = NOLINE;
8199 #ifdef PERL_DEBUG_READONLY_OPS
8209 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8210 OP *block, bool o_is_gv)
8214 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8218 const bool ec = PL_parser && PL_parser->error_count;
8219 /* If the subroutine has no body, no attributes, and no builtin attributes
8220 then it's just a sub declaration, and we may be able to get away with
8221 storing with a placeholder scalar in the symbol table, rather than a
8222 full CV. If anything is present then it will take a full CV to
8224 const I32 gv_fetch_flags
8225 = ec ? GV_NOADD_NOINIT :
8226 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8227 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8229 const char * const name =
8230 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8232 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8234 #ifdef PERL_DEBUG_READONLY_OPS
8235 OPSLAB *slab = NULL;
8236 bool special = FALSE;
8244 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8245 hek and CvSTASH pointer together can imply the GV. If the name
8246 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8247 CvSTASH, so forego the optimisation if we find any.
8248 Also, we may be called from load_module at run time, so
8249 PL_curstash (which sets CvSTASH) may not point to the stash the
8250 sub is stored in. */
8252 ec ? GV_NOADD_NOINIT
8253 : PL_curstash != CopSTASH(PL_curcop)
8254 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8256 : GV_ADDMULTI | GV_NOINIT;
8257 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8259 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8260 SV * const sv = sv_newmortal();
8261 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8262 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8263 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8264 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8266 } else if (PL_curstash) {
8267 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8270 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8274 move_proto_attr(&proto, &attrs,
8275 isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
8278 assert(proto->op_type == OP_CONST);
8279 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8280 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8294 if (name) SvREFCNT_dec(PL_compcv);
8295 else cv = PL_compcv;
8297 if (name && block) {
8298 const char *s = strrchr(name, ':');
8300 if (strEQ(s, "BEGIN")) {
8301 if (PL_in_eval & EVAL_KEEPERR)
8302 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8304 SV * const errsv = ERRSV;
8305 /* force display of errors found but not reported */
8306 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8307 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8314 if (!block && SvTYPE(gv) != SVt_PVGV) {
8315 /* If we are not defining a new sub and the existing one is not a
8317 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8318 /* We are applying attributes to an existing sub, so we need it
8319 upgraded if it is a constant. */
8320 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8321 gv_init_pvn(gv, PL_curstash, name, namlen,
8322 SVf_UTF8 * name_is_utf8);
8324 else { /* Maybe prototype now, and had at maximum
8325 a prototype or const/sub ref before. */
8326 if (SvTYPE(gv) > SVt_NULL) {
8327 cv_ckproto_len_flags((const CV *)gv,
8328 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8333 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8334 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8337 sv_setiv(MUTABLE_SV(gv), -1);
8340 SvREFCNT_dec(PL_compcv);
8341 cv = PL_compcv = NULL;
8346 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8350 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8355 /* This makes sub {}; work as expected. */
8356 if (block->op_type == OP_STUB) {
8357 const line_t l = PL_parser->copline;
8359 block = newSTATEOP(0, NULL, 0);
8360 PL_parser->copline = l;
8362 block = CvLVALUE(PL_compcv)
8363 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8364 && (!isGV(gv) || !GvASSUMECV(gv)))
8365 ? newUNOP(OP_LEAVESUBLV, 0,
8366 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8367 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8368 start = LINKLIST(block);
8372 if (!block || !ps || *ps || attrs
8373 || CvLVALUE(PL_compcv)
8378 S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
8380 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8382 cv_ckproto_len_flags((const CV *)gv,
8383 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8384 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8386 /* All the other code for sub redefinition warnings expects the
8387 clobbered sub to be a CV. Instead of making all those code
8388 paths more complex, just inline the RV version here. */
8389 const line_t oldline = CopLINE(PL_curcop);
8390 assert(IN_PERL_COMPILETIME);
8391 if (PL_parser && PL_parser->copline != NOLINE)
8392 /* This ensures that warnings are reported at the first
8393 line of a redefinition, not the last. */
8394 CopLINE_set(PL_curcop, PL_parser->copline);
8395 /* protect against fatal warnings leaking compcv */
8396 SAVEFREESV(PL_compcv);
8398 if (ckWARN(WARN_REDEFINE)
8399 || ( ckWARN_d(WARN_REDEFINE)
8400 && ( !const_sv || SvRV(gv) == const_sv
8401 || sv_cmp(SvRV(gv), const_sv) )))
8402 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8403 "Constant subroutine %"SVf" redefined",
8404 SVfARG(cSVOPo->op_sv));
8406 SvREFCNT_inc_simple_void_NN(PL_compcv);
8407 CopLINE_set(PL_curcop, oldline);
8408 SvREFCNT_dec(SvRV(gv));
8413 const bool exists = CvROOT(cv) || CvXSUB(cv);
8415 /* if the subroutine doesn't exist and wasn't pre-declared
8416 * with a prototype, assume it will be AUTOLOADed,
8417 * skipping the prototype check
8419 if (exists || SvPOK(cv))
8420 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8421 /* already defined (or promised)? */
8422 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8423 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8426 if (attrs) goto attrs;
8427 /* just a "sub foo;" when &foo is already defined */
8428 SAVEFREESV(PL_compcv);
8434 SvREFCNT_inc_simple_void_NN(const_sv);
8435 SvFLAGS(const_sv) |= SVs_PADTMP;
8437 assert(!CvROOT(cv) && !CvCONST(cv));
8439 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8440 CvXSUBANY(cv).any_ptr = const_sv;
8441 CvXSUB(cv) = const_sv_xsub;
8445 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8448 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8449 if (name && isGV(gv))
8451 cv = newCONSTSUB_flags(
8452 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8455 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8459 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8460 prepare_SV_for_RV((SV *)gv);
8464 SvRV_set(gv, const_sv);
8468 SvREFCNT_dec(PL_compcv);
8472 if (cv) { /* must reuse cv if autoloaded */
8473 /* transfer PL_compcv to cv */
8476 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8477 PADLIST *const temp_av = CvPADLIST(cv);
8478 CV *const temp_cv = CvOUTSIDE(cv);
8479 const cv_flags_t other_flags =
8480 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8481 OP * const cvstart = CvSTART(cv);
8485 assert(!CvCVGV_RC(cv));
8486 assert(CvGV(cv) == gv);
8491 PERL_HASH(hash, name, namlen);
8501 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8503 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8504 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8505 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8506 CvOUTSIDE(PL_compcv) = temp_cv;
8507 CvPADLIST_set(PL_compcv, temp_av);
8508 CvSTART(cv) = CvSTART(PL_compcv);
8509 CvSTART(PL_compcv) = cvstart;
8510 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8511 CvFLAGS(PL_compcv) |= other_flags;
8513 if (CvFILE(cv) && CvDYNFILE(cv)) {
8514 Safefree(CvFILE(cv));
8516 CvFILE_set_from_cop(cv, PL_curcop);
8517 CvSTASH_set(cv, PL_curstash);
8519 /* inner references to PL_compcv must be fixed up ... */
8520 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8521 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8522 ++PL_sub_generation;
8525 /* Might have had built-in attributes applied -- propagate them. */
8526 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8528 /* ... before we throw it away */
8529 SvREFCNT_dec(PL_compcv);
8534 if (name && isGV(gv)) {
8537 if (HvENAME_HEK(GvSTASH(gv)))
8538 /* sub Foo::bar { (shift)+1 } */
8539 gv_method_changed(gv);
8543 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8544 prepare_SV_for_RV((SV *)gv);
8548 SvRV_set(gv, (SV *)cv);
8552 if (isGV(gv)) CvGV_set(cv, gv);
8556 PERL_HASH(hash, name, namlen);
8557 CvNAME_HEK_set(cv, share_hek(name,
8563 CvFILE_set_from_cop(cv, PL_curcop);
8564 CvSTASH_set(cv, PL_curstash);
8568 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8569 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8575 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8576 the debugger could be able to set a breakpoint in, so signal to
8577 pp_entereval that it should not throw away any saved lines at scope
8580 PL_breakable_sub_gen++;
8582 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8583 OpREFCNT_set(CvROOT(cv), 1);
8584 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8585 itself has a refcount. */
8587 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8588 #ifdef PERL_DEBUG_READONLY_OPS
8589 slab = (OPSLAB *)CvSTART(cv);
8591 CvSTART(cv) = start;
8593 finalize_optree(CvROOT(cv));
8594 S_prune_chain_head(&CvSTART(cv));
8596 /* now that optimizer has done its work, adjust pad values */
8598 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8602 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8603 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8606 if (!name) SAVEFREESV(cv);
8607 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8608 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8611 if (block && has_name) {
8612 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8613 SV * const tmpstr = cv_name(cv,NULL,0);
8614 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8615 GV_ADDMULTI, SVt_PVHV);
8617 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8620 (long)CopLINE(PL_curcop));
8621 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8622 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8623 hv = GvHVn(db_postponed);
8624 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8625 CV * const pcv = GvCV(db_postponed);
8631 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8637 if (PL_parser && PL_parser->error_count)
8638 clear_special_blocks(name, gv, cv);
8640 #ifdef PERL_DEBUG_READONLY_OPS
8643 process_special_blocks(floor, name, gv, cv);
8649 PL_parser->copline = NOLINE;
8651 #ifdef PERL_DEBUG_READONLY_OPS
8652 /* Watch out for BEGIN blocks */
8653 if (!special && slab)
8660 S_clear_special_blocks(pTHX_ const char *const fullname,
8661 GV *const gv, CV *const cv) {
8665 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8667 colon = strrchr(fullname,':');
8668 name = colon ? colon + 1 : fullname;
8670 if ((*name == 'B' && strEQ(name, "BEGIN"))
8671 || (*name == 'E' && strEQ(name, "END"))
8672 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8673 || (*name == 'C' && strEQ(name, "CHECK"))
8674 || (*name == 'I' && strEQ(name, "INIT"))) {
8680 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8685 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8689 const char *const colon = strrchr(fullname,':');
8690 const char *const name = colon ? colon + 1 : fullname;
8692 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8695 if (strEQ(name, "BEGIN")) {
8696 const I32 oldscope = PL_scopestack_ix;
8699 if (floor) LEAVE_SCOPE(floor);
8701 PUSHSTACKi(PERLSI_REQUIRE);
8702 SAVECOPFILE(&PL_compiling);
8703 SAVECOPLINE(&PL_compiling);
8704 SAVEVPTR(PL_curcop);
8706 DEBUG_x( dump_sub(gv) );
8707 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8708 GvCV_set(gv,0); /* cv has been hijacked */
8709 call_list(oldscope, PL_beginav);
8719 if strEQ(name, "END") {
8720 DEBUG_x( dump_sub(gv) );
8721 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8724 } else if (*name == 'U') {
8725 if (strEQ(name, "UNITCHECK")) {
8726 /* It's never too late to run a unitcheck block */
8727 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8731 } else if (*name == 'C') {
8732 if (strEQ(name, "CHECK")) {
8734 /* diag_listed_as: Too late to run %s block */
8735 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8736 "Too late to run CHECK block");
8737 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8741 } else if (*name == 'I') {
8742 if (strEQ(name, "INIT")) {
8744 /* diag_listed_as: Too late to run %s block */
8745 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8746 "Too late to run INIT block");
8747 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8753 DEBUG_x( dump_sub(gv) );
8755 GvCV_set(gv,0); /* cv has been hijacked */
8761 =for apidoc newCONSTSUB
8763 See L</newCONSTSUB_flags>.
8769 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8771 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8775 =for apidoc newCONSTSUB_flags
8777 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8778 eligible for inlining at compile-time.
8780 Currently, the only useful value for C<flags> is SVf_UTF8.
8782 The newly created subroutine takes ownership of a reference to the passed in
8785 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8786 which won't be called if used as a destructor, but will suppress the overhead
8787 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8794 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8798 const char *const file = CopFILE(PL_curcop);
8802 if (IN_PERL_RUNTIME) {
8803 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8804 * an op shared between threads. Use a non-shared COP for our
8806 SAVEVPTR(PL_curcop);
8807 SAVECOMPILEWARNINGS();
8808 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8809 PL_curcop = &PL_compiling;
8811 SAVECOPLINE(PL_curcop);
8812 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8815 PL_hints &= ~HINT_BLOCK_SCOPE;
8818 SAVEGENERICSV(PL_curstash);
8819 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8822 /* Protect sv against leakage caused by fatal warnings. */
8823 if (sv) SAVEFREESV(sv);
8825 /* file becomes the CvFILE. For an XS, it's usually static storage,
8826 and so doesn't get free()d. (It's expected to be from the C pre-
8827 processor __FILE__ directive). But we need a dynamically allocated one,
8828 and we need it to get freed. */
8829 cv = newXS_len_flags(name, len,
8830 sv && SvTYPE(sv) == SVt_PVAV
8833 file ? file : "", "",
8834 &sv, XS_DYNAMIC_FILENAME | flags);
8835 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8844 =for apidoc U||newXS
8846 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
8847 static storage, as it is used directly as CvFILE(), without a copy being made.
8853 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8855 PERL_ARGS_ASSERT_NEWXS;
8856 return newXS_len_flags(
8857 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8862 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8863 const char *const filename, const char *const proto,
8866 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8867 return newXS_len_flags(
8868 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8873 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
8875 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
8876 return newXS_len_flags(
8877 name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
8882 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8883 XSUBADDR_t subaddr, const char *const filename,
8884 const char *const proto, SV **const_svp,
8888 bool interleave = FALSE;
8890 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8892 Perl_croak_nocontext("panic: no address for '%s' in '%s'",
8893 name, filename ? filename : PL_xsubfilename);
8895 GV * const gv = gv_fetchpvn(
8896 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8897 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8898 sizeof("__ANON__::__ANON__") - 1,
8899 GV_ADDMULTI | flags, SVt_PVCV);
8901 if ((cv = (name ? GvCV(gv) : NULL))) {
8903 /* just a cached method */
8907 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8908 /* already defined (or promised) */
8909 /* Redundant check that allows us to avoid creating an SV
8910 most of the time: */
8911 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8912 report_redefined_cv(newSVpvn_flags(
8913 name,len,(flags&SVf_UTF8)|SVs_TEMP
8924 if (cv) /* must reuse cv if autoloaded */
8927 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8931 if (HvENAME_HEK(GvSTASH(gv)))
8932 gv_method_changed(gv); /* newXS */
8938 (void)gv_fetchfile(filename);
8939 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8940 if (flags & XS_DYNAMIC_FILENAME) {
8942 CvFILE(cv) = savepv(filename);
8944 /* NOTE: not copied, as it is expected to be an external constant string */
8945 CvFILE(cv) = (char *)filename;
8948 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
8949 CvFILE(cv) = (char*)PL_xsubfilename;
8952 CvXSUB(cv) = subaddr;
8953 #ifndef PERL_IMPLICIT_CONTEXT
8954 CvHSCXT(cv) = &PL_stack_sp;
8960 process_special_blocks(0, name, gv, cv);
8963 } /* <- not a conditional branch */
8966 sv_setpv(MUTABLE_SV(cv), proto);
8967 if (interleave) LEAVE;
8972 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8974 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8976 PERL_ARGS_ASSERT_NEWSTUB;
8980 if (!fake && HvENAME_HEK(GvSTASH(gv)))
8981 gv_method_changed(gv);
8983 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8988 CvFILE_set_from_cop(cv, PL_curcop);
8989 CvSTASH_set(cv, PL_curstash);
8995 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9001 if (PL_parser && PL_parser->error_count) {
9007 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9008 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9011 if ((cv = GvFORM(gv))) {
9012 if (ckWARN(WARN_REDEFINE)) {
9013 const line_t oldline = CopLINE(PL_curcop);
9014 if (PL_parser && PL_parser->copline != NOLINE)
9015 CopLINE_set(PL_curcop, PL_parser->copline);
9017 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9018 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9020 /* diag_listed_as: Format %s redefined */
9021 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9022 "Format STDOUT redefined");
9024 CopLINE_set(PL_curcop, oldline);
9029 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9031 CvFILE_set_from_cop(cv, PL_curcop);
9034 pad_tidy(padtidy_FORMAT);
9035 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9036 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9037 OpREFCNT_set(CvROOT(cv), 1);
9038 CvSTART(cv) = LINKLIST(CvROOT(cv));
9039 CvROOT(cv)->op_next = 0;
9040 CALL_PEEP(CvSTART(cv));
9041 finalize_optree(CvROOT(cv));
9042 S_prune_chain_head(&CvSTART(cv));
9048 PL_parser->copline = NOLINE;
9053 Perl_newANONLIST(pTHX_ OP *o)
9055 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9059 Perl_newANONHASH(pTHX_ OP *o)
9061 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9065 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9067 return newANONATTRSUB(floor, proto, NULL, block);
9071 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9073 return newUNOP(OP_REFGEN, 0,
9074 newSVOP(OP_ANONCODE, 0,
9075 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
9079 Perl_oopsAV(pTHX_ OP *o)
9083 PERL_ARGS_ASSERT_OOPSAV;
9085 switch (o->op_type) {
9088 CHANGE_TYPE(o, OP_PADAV);
9089 return ref(o, OP_RV2AV);
9093 CHANGE_TYPE(o, OP_RV2AV);
9098 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9105 Perl_oopsHV(pTHX_ OP *o)
9109 PERL_ARGS_ASSERT_OOPSHV;
9111 switch (o->op_type) {
9114 CHANGE_TYPE(o, OP_PADHV);
9115 return ref(o, OP_RV2HV);
9119 CHANGE_TYPE(o, OP_RV2HV);
9124 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9131 Perl_newAVREF(pTHX_ OP *o)
9135 PERL_ARGS_ASSERT_NEWAVREF;
9137 if (o->op_type == OP_PADANY) {
9138 CHANGE_TYPE(o, OP_PADAV);
9141 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9142 Perl_croak(aTHX_ "Can't use an array as a reference");
9144 return newUNOP(OP_RV2AV, 0, scalar(o));
9148 Perl_newGVREF(pTHX_ I32 type, OP *o)
9150 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9151 return newUNOP(OP_NULL, 0, o);
9152 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9156 Perl_newHVREF(pTHX_ OP *o)
9160 PERL_ARGS_ASSERT_NEWHVREF;
9162 if (o->op_type == OP_PADANY) {
9163 CHANGE_TYPE(o, OP_PADHV);
9166 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9167 Perl_croak(aTHX_ "Can't use a hash as a reference");
9169 return newUNOP(OP_RV2HV, 0, scalar(o));
9173 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9175 if (o->op_type == OP_PADANY) {
9177 CHANGE_TYPE(o, OP_PADCV);
9179 return newUNOP(OP_RV2CV, flags, scalar(o));
9183 Perl_newSVREF(pTHX_ OP *o)
9187 PERL_ARGS_ASSERT_NEWSVREF;
9189 if (o->op_type == OP_PADANY) {
9190 CHANGE_TYPE(o, OP_PADSV);
9193 return newUNOP(OP_RV2SV, 0, scalar(o));
9196 /* Check routines. See the comments at the top of this file for details
9197 * on when these are called */
9200 Perl_ck_anoncode(pTHX_ OP *o)
9202 PERL_ARGS_ASSERT_CK_ANONCODE;
9204 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9205 cSVOPo->op_sv = NULL;
9210 S_io_hints(pTHX_ OP *o)
9212 #if O_BINARY != 0 || O_TEXT != 0
9214 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9216 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9219 const char *d = SvPV_const(*svp, len);
9220 const I32 mode = mode_from_discipline(d, len);
9221 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9223 if (mode & O_BINARY)
9224 o->op_private |= OPpOPEN_IN_RAW;
9228 o->op_private |= OPpOPEN_IN_CRLF;
9232 svp = hv_fetchs(table, "open_OUT", FALSE);
9235 const char *d = SvPV_const(*svp, len);
9236 const I32 mode = mode_from_discipline(d, len);
9237 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9239 if (mode & O_BINARY)
9240 o->op_private |= OPpOPEN_OUT_RAW;
9244 o->op_private |= OPpOPEN_OUT_CRLF;
9249 PERL_UNUSED_CONTEXT;
9255 Perl_ck_backtick(pTHX_ OP *o)
9260 PERL_ARGS_ASSERT_CK_BACKTICK;
9261 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9262 if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
9263 && (gv = gv_override("readpipe",8)))
9265 /* detach rest of siblings from o and its first child */
9266 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9267 newop = S_new_entersubop(aTHX_ gv, sibl);
9269 else if (!(o->op_flags & OPf_KIDS))
9270 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9275 S_io_hints(aTHX_ o);
9280 Perl_ck_bitop(pTHX_ OP *o)
9282 PERL_ARGS_ASSERT_CK_BITOP;
9284 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9285 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9286 && (o->op_type == OP_BIT_OR
9287 || o->op_type == OP_BIT_AND
9288 || o->op_type == OP_BIT_XOR))
9290 const OP * const left = cBINOPo->op_first;
9291 const OP * const right = OP_SIBLING(left);
9292 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9293 (left->op_flags & OPf_PARENS) == 0) ||
9294 (OP_IS_NUMCOMPARE(right->op_type) &&
9295 (right->op_flags & OPf_PARENS) == 0))
9296 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9297 "Possible precedence problem on bitwise %c operator",
9298 o->op_type == OP_BIT_OR ? '|'
9299 : o->op_type == OP_BIT_AND ? '&' : '^'
9305 PERL_STATIC_INLINE bool
9306 is_dollar_bracket(pTHX_ const OP * const o)
9309 PERL_UNUSED_CONTEXT;
9310 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9311 && (kid = cUNOPx(o)->op_first)
9312 && kid->op_type == OP_GV
9313 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9317 Perl_ck_cmp(pTHX_ OP *o)
9319 PERL_ARGS_ASSERT_CK_CMP;
9320 if (ckWARN(WARN_SYNTAX)) {
9321 const OP *kid = cUNOPo->op_first;
9324 ( is_dollar_bracket(aTHX_ kid)
9325 && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
9327 || ( kid->op_type == OP_CONST
9328 && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9332 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9333 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9339 Perl_ck_concat(pTHX_ OP *o)
9341 const OP * const kid = cUNOPo->op_first;
9343 PERL_ARGS_ASSERT_CK_CONCAT;
9344 PERL_UNUSED_CONTEXT;
9346 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9347 !(kUNOP->op_first->op_flags & OPf_MOD))
9348 o->op_flags |= OPf_STACKED;
9353 Perl_ck_spair(pTHX_ OP *o)
9357 PERL_ARGS_ASSERT_CK_SPAIR;
9359 if (o->op_flags & OPf_KIDS) {
9363 const OPCODE type = o->op_type;
9364 o = modkids(ck_fun(o), type);
9365 kid = cUNOPo->op_first;
9366 kidkid = kUNOP->op_first;
9367 newop = OP_SIBLING(kidkid);
9369 const OPCODE type = newop->op_type;
9370 if (OP_HAS_SIBLING(newop))
9372 if (o->op_type == OP_REFGEN
9373 && ( type == OP_RV2CV
9374 || ( !(newop->op_flags & OPf_PARENS)
9375 && ( type == OP_RV2AV || type == OP_PADAV
9376 || type == OP_RV2HV || type == OP_PADHV))))
9377 NOOP; /* OK (allow srefgen for \@a and \%h) */
9378 else if (!(PL_opargs[type] & OA_RETSCALAR))
9381 /* excise first sibling */
9382 op_sibling_splice(kid, NULL, 1, NULL);
9385 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9386 * and OP_CHOMP into OP_SCHOMP */
9387 o->op_ppaddr = PL_ppaddr[++o->op_type];
9392 Perl_ck_delete(pTHX_ OP *o)
9394 PERL_ARGS_ASSERT_CK_DELETE;
9398 if (o->op_flags & OPf_KIDS) {
9399 OP * const kid = cUNOPo->op_first;
9400 switch (kid->op_type) {
9402 o->op_flags |= OPf_SPECIAL;
9405 o->op_private |= OPpSLICE;
9408 o->op_flags |= OPf_SPECIAL;
9413 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9414 " use array slice");
9416 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9419 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9420 "element or slice");
9422 if (kid->op_private & OPpLVAL_INTRO)
9423 o->op_private |= OPpLVAL_INTRO;
9430 Perl_ck_eof(pTHX_ OP *o)
9432 PERL_ARGS_ASSERT_CK_EOF;
9434 if (o->op_flags & OPf_KIDS) {
9436 if (cLISTOPo->op_first->op_type == OP_STUB) {
9438 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9443 kid = cLISTOPo->op_first;
9444 if (kid->op_type == OP_RV2GV)
9445 kid->op_private |= OPpALLOW_FAKE;
9451 Perl_ck_eval(pTHX_ OP *o)
9455 PERL_ARGS_ASSERT_CK_EVAL;
9457 PL_hints |= HINT_BLOCK_SCOPE;
9458 if (o->op_flags & OPf_KIDS) {
9459 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9462 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
9465 /* cut whole sibling chain free from o */
9466 op_sibling_splice(o, NULL, -1, NULL);
9469 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9471 /* establish postfix order */
9472 enter->op_next = (OP*)enter;
9474 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9475 CHANGE_TYPE(o, OP_LEAVETRY);
9476 enter->op_other = o;
9481 S_set_haseval(aTHX);
9485 const U8 priv = o->op_private;
9487 /* the newUNOP will recursively call ck_eval(), which will handle
9488 * all the stuff at the end of this function, like adding
9491 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9493 o->op_targ = (PADOFFSET)PL_hints;
9494 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9495 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9496 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9497 /* Store a copy of %^H that pp_entereval can pick up. */
9498 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9499 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9500 /* append hhop to only child */
9501 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9503 o->op_private |= OPpEVAL_HAS_HH;
9505 if (!(o->op_private & OPpEVAL_BYTES)
9506 && FEATURE_UNIEVAL_IS_ENABLED)
9507 o->op_private |= OPpEVAL_UNICODE;
9512 Perl_ck_exec(pTHX_ OP *o)
9514 PERL_ARGS_ASSERT_CK_EXEC;
9516 if (o->op_flags & OPf_STACKED) {
9519 kid = OP_SIBLING(cUNOPo->op_first);
9520 if (kid->op_type == OP_RV2GV)
9529 Perl_ck_exists(pTHX_ OP *o)
9531 PERL_ARGS_ASSERT_CK_EXISTS;
9534 if (o->op_flags & OPf_KIDS) {
9535 OP * const kid = cUNOPo->op_first;
9536 if (kid->op_type == OP_ENTERSUB) {
9537 (void) ref(kid, o->op_type);
9538 if (kid->op_type != OP_RV2CV
9539 && !(PL_parser && PL_parser->error_count))
9541 "exists argument is not a subroutine name");
9542 o->op_private |= OPpEXISTS_SUB;
9544 else if (kid->op_type == OP_AELEM)
9545 o->op_flags |= OPf_SPECIAL;
9546 else if (kid->op_type != OP_HELEM)
9547 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9548 "element or a subroutine");
9555 Perl_ck_rvconst(pTHX_ OP *o)
9558 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9560 PERL_ARGS_ASSERT_CK_RVCONST;
9562 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9564 if (kid->op_type == OP_CONST) {
9567 SV * const kidsv = kid->op_sv;
9569 /* Is it a constant from cv_const_sv()? */
9570 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9573 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9574 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9575 const char *badthing;
9576 switch (o->op_type) {
9578 badthing = "a SCALAR";
9581 badthing = "an ARRAY";
9584 badthing = "a HASH";
9592 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9593 SVfARG(kidsv), badthing);
9596 * This is a little tricky. We only want to add the symbol if we
9597 * didn't add it in the lexer. Otherwise we get duplicate strict
9598 * warnings. But if we didn't add it in the lexer, we must at
9599 * least pretend like we wanted to add it even if it existed before,
9600 * or we get possible typo warnings. OPpCONST_ENTERED says
9601 * whether the lexer already added THIS instance of this symbol.
9603 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9604 gv = gv_fetchsv(kidsv,
9605 o->op_type == OP_RV2CV
9606 && o->op_private & OPpMAY_RETURN_CONSTANT
9608 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9611 : o->op_type == OP_RV2SV
9613 : o->op_type == OP_RV2AV
9615 : o->op_type == OP_RV2HV
9622 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9623 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9624 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9626 CHANGE_TYPE(kid, OP_GV);
9627 SvREFCNT_dec(kid->op_sv);
9629 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9630 assert (sizeof(PADOP) <= sizeof(SVOP));
9631 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9632 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9633 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9635 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9637 kid->op_private = 0;
9638 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9646 Perl_ck_ftst(pTHX_ OP *o)
9649 const I32 type = o->op_type;
9651 PERL_ARGS_ASSERT_CK_FTST;
9653 if (o->op_flags & OPf_REF) {
9656 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9657 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9658 const OPCODE kidtype = kid->op_type;
9660 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9661 && !kid->op_folded) {
9662 OP * const newop = newGVOP(type, OPf_REF,
9663 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9667 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9668 o->op_private |= OPpFT_ACCESS;
9669 if (PL_check[kidtype] == Perl_ck_ftst
9670 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9671 o->op_private |= OPpFT_STACKED;
9672 kid->op_private |= OPpFT_STACKING;
9673 if (kidtype == OP_FTTTY && (
9674 !(kid->op_private & OPpFT_STACKED)
9675 || kid->op_private & OPpFT_AFTER_t
9677 o->op_private |= OPpFT_AFTER_t;
9682 if (type == OP_FTTTY)
9683 o = newGVOP(type, OPf_REF, PL_stdingv);
9685 o = newUNOP(type, 0, newDEFSVOP());
9691 Perl_ck_fun(pTHX_ OP *o)
9693 const int type = o->op_type;
9694 I32 oa = PL_opargs[type] >> OASHIFT;
9696 PERL_ARGS_ASSERT_CK_FUN;
9698 if (o->op_flags & OPf_STACKED) {
9699 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9702 return no_fh_allowed(o);
9705 if (o->op_flags & OPf_KIDS) {
9706 OP *prev_kid = NULL;
9707 OP *kid = cLISTOPo->op_first;
9709 bool seen_optional = FALSE;
9711 if (kid->op_type == OP_PUSHMARK ||
9712 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9715 kid = OP_SIBLING(kid);
9717 if (kid && kid->op_type == OP_COREARGS) {
9718 bool optional = FALSE;
9721 if (oa & OA_OPTIONAL) optional = TRUE;
9724 if (optional) o->op_private |= numargs;
9729 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9730 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9732 /* append kid to chain */
9733 op_sibling_splice(o, prev_kid, 0, kid);
9735 seen_optional = TRUE;
9742 /* list seen where single (scalar) arg expected? */
9743 if (numargs == 1 && !(oa >> 4)
9744 && kid->op_type == OP_LIST && type != OP_SCALAR)
9746 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9748 if (type != OP_DELETE) scalar(kid);
9759 if ((type == OP_PUSH || type == OP_UNSHIFT)
9760 && !OP_HAS_SIBLING(kid))
9761 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9762 "Useless use of %s with no values",
9765 if (kid->op_type == OP_CONST
9766 && ( !SvROK(cSVOPx_sv(kid))
9767 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9769 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9770 /* Defer checks to run-time if we have a scalar arg */
9771 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9772 op_lvalue(kid, type);
9775 /* diag_listed_as: push on reference is experimental */
9776 Perl_ck_warner_d(aTHX_
9777 packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9778 "%s on reference is experimental",
9783 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9784 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9785 op_lvalue(kid, type);
9789 /* replace kid with newop in chain */
9791 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9792 newop->op_next = newop;
9797 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9798 if (kid->op_type == OP_CONST &&
9799 (kid->op_private & OPpCONST_BARE))
9801 OP * const newop = newGVOP(OP_GV, 0,
9802 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9803 /* replace kid with newop in chain */
9804 op_sibling_splice(o, prev_kid, 1, newop);
9808 else if (kid->op_type == OP_READLINE) {
9809 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9810 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9813 I32 flags = OPf_SPECIAL;
9817 /* is this op a FH constructor? */
9818 if (is_handle_constructor(o,numargs)) {
9819 const char *name = NULL;
9822 bool want_dollar = TRUE;
9825 /* Set a flag to tell rv2gv to vivify
9826 * need to "prove" flag does not mean something
9827 * else already - NI-S 1999/05/07
9830 if (kid->op_type == OP_PADSV) {
9832 = PAD_COMPNAME_SV(kid->op_targ);
9833 name = SvPV_const(namesv, len);
9834 name_utf8 = SvUTF8(namesv);
9836 else if (kid->op_type == OP_RV2SV
9837 && kUNOP->op_first->op_type == OP_GV)
9839 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9841 len = GvNAMELEN(gv);
9842 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9844 else if (kid->op_type == OP_AELEM
9845 || kid->op_type == OP_HELEM)
9848 OP *op = ((BINOP*)kid)->op_first;
9852 const char * const a =
9853 kid->op_type == OP_AELEM ?
9855 if (((op->op_type == OP_RV2AV) ||
9856 (op->op_type == OP_RV2HV)) &&
9857 (firstop = ((UNOP*)op)->op_first) &&
9858 (firstop->op_type == OP_GV)) {
9859 /* packagevar $a[] or $h{} */
9860 GV * const gv = cGVOPx_gv(firstop);
9868 else if (op->op_type == OP_PADAV
9869 || op->op_type == OP_PADHV) {
9870 /* lexicalvar $a[] or $h{} */
9871 const char * const padname =
9872 PAD_COMPNAME_PV(op->op_targ);
9881 name = SvPV_const(tmpstr, len);
9882 name_utf8 = SvUTF8(tmpstr);
9887 name = "__ANONIO__";
9889 want_dollar = FALSE;
9891 op_lvalue(kid, type);
9895 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9896 namesv = PAD_SVl(targ);
9897 if (want_dollar && *name != '$')
9898 sv_setpvs(namesv, "$");
9900 sv_setpvs(namesv, "");
9901 sv_catpvn(namesv, name, len);
9902 if ( name_utf8 ) SvUTF8_on(namesv);
9906 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9908 kid->op_targ = targ;
9909 kid->op_private |= priv;
9915 if ((type == OP_UNDEF || type == OP_POS)
9916 && numargs == 1 && !(oa >> 4)
9917 && kid->op_type == OP_LIST)
9918 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9919 op_lvalue(scalar(kid), type);
9924 kid = OP_SIBLING(kid);
9926 /* FIXME - should the numargs or-ing move after the too many
9927 * arguments check? */
9928 o->op_private |= numargs;
9930 return too_many_arguments_pv(o,OP_DESC(o), 0);
9933 else if (PL_opargs[type] & OA_DEFGV) {
9934 /* Ordering of these two is important to keep f_map.t passing. */
9936 return newUNOP(type, 0, newDEFSVOP());
9940 while (oa & OA_OPTIONAL)
9942 if (oa && oa != OA_LIST)
9943 return too_few_arguments_pv(o,OP_DESC(o), 0);
9949 Perl_ck_glob(pTHX_ OP *o)
9953 PERL_ARGS_ASSERT_CK_GLOB;
9956 if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
9957 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9959 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9963 * \ null - const(wildcard)
9968 * \ mark - glob - rv2cv
9969 * | \ gv(CORE::GLOBAL::glob)
9971 * \ null - const(wildcard)
9973 o->op_flags |= OPf_SPECIAL;
9974 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9975 o = S_new_entersubop(aTHX_ gv, o);
9976 o = newUNOP(OP_NULL, 0, o);
9977 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9980 else o->op_flags &= ~OPf_SPECIAL;
9981 #if !defined(PERL_EXTERNAL_GLOB)
9984 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9985 newSVpvs("File::Glob"), NULL, NULL, NULL);
9988 #endif /* !PERL_EXTERNAL_GLOB */
9989 gv = (GV *)newSV(0);
9990 gv_init(gv, 0, "", 0, 0);
9992 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9993 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9999 Perl_ck_grep(pTHX_ OP *o)
10004 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10007 PERL_ARGS_ASSERT_CK_GREP;
10009 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10011 if (o->op_flags & OPf_STACKED) {
10012 kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
10013 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10014 return no_fh_allowed(o);
10015 o->op_flags &= ~OPf_STACKED;
10017 kid = OP_SIBLING(cLISTOPo->op_first);
10018 if (type == OP_MAPWHILE)
10023 if (PL_parser && PL_parser->error_count)
10025 kid = OP_SIBLING(cLISTOPo->op_first);
10026 if (kid->op_type != OP_NULL)
10027 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10028 kid = kUNOP->op_first;
10030 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10031 kid->op_next = (OP*)gwop;
10032 offset = pad_findmy_pvs("$_", 0);
10033 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
10034 o->op_private = gwop->op_private = 0;
10035 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10038 o->op_private = gwop->op_private = OPpGREP_LEX;
10039 gwop->op_targ = o->op_targ = offset;
10042 kid = OP_SIBLING(cLISTOPo->op_first);
10043 for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
10044 op_lvalue(kid, OP_GREPSTART);
10050 Perl_ck_index(pTHX_ OP *o)
10052 PERL_ARGS_ASSERT_CK_INDEX;
10054 if (o->op_flags & OPf_KIDS) {
10055 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10057 kid = OP_SIBLING(kid); /* get past "big" */
10058 if (kid && kid->op_type == OP_CONST) {
10059 const bool save_taint = TAINT_get;
10060 SV *sv = kSVOP->op_sv;
10061 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10063 sv_copypv(sv, kSVOP->op_sv);
10064 SvREFCNT_dec_NN(kSVOP->op_sv);
10067 if (SvOK(sv)) fbm_compile(sv, 0);
10068 TAINT_set(save_taint);
10069 #ifdef NO_TAINT_SUPPORT
10070 PERL_UNUSED_VAR(save_taint);
10078 Perl_ck_lfun(pTHX_ OP *o)
10080 const OPCODE type = o->op_type;
10082 PERL_ARGS_ASSERT_CK_LFUN;
10084 return modkids(ck_fun(o), type);
10088 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10090 PERL_ARGS_ASSERT_CK_DEFINED;
10092 if ((o->op_flags & OPf_KIDS)) {
10093 switch (cUNOPo->op_first->op_type) {
10096 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10097 " (Maybe you should just omit the defined()?)");
10101 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10102 " (Maybe you should just omit the defined()?)");
10113 Perl_ck_readline(pTHX_ OP *o)
10115 PERL_ARGS_ASSERT_CK_READLINE;
10117 if (o->op_flags & OPf_KIDS) {
10118 OP *kid = cLISTOPo->op_first;
10119 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10123 = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
10131 Perl_ck_rfun(pTHX_ OP *o)
10133 const OPCODE type = o->op_type;
10135 PERL_ARGS_ASSERT_CK_RFUN;
10137 return refkids(ck_fun(o), type);
10141 Perl_ck_listiob(pTHX_ OP *o)
10145 PERL_ARGS_ASSERT_CK_LISTIOB;
10147 kid = cLISTOPo->op_first;
10149 o = force_list(o, 1);
10150 kid = cLISTOPo->op_first;
10152 if (kid->op_type == OP_PUSHMARK)
10153 kid = OP_SIBLING(kid);
10154 if (kid && o->op_flags & OPf_STACKED)
10155 kid = OP_SIBLING(kid);
10156 else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */
10157 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10158 && !kid->op_folded) {
10159 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10161 /* replace old const op with new OP_RV2GV parent */
10162 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10163 OP_RV2GV, OPf_REF);
10164 kid = OP_SIBLING(kid);
10169 op_append_elem(o->op_type, o, newDEFSVOP());
10171 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10172 return listkids(o);
10176 Perl_ck_smartmatch(pTHX_ OP *o)
10179 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10180 if (0 == (o->op_flags & OPf_SPECIAL)) {
10181 OP *first = cBINOPo->op_first;
10182 OP *second = OP_SIBLING(first);
10184 /* Implicitly take a reference to an array or hash */
10186 /* remove the original two siblings, then add back the
10187 * (possibly different) first and second sibs.
10189 op_sibling_splice(o, NULL, 1, NULL);
10190 op_sibling_splice(o, NULL, 1, NULL);
10191 first = ref_array_or_hash(first);
10192 second = ref_array_or_hash(second);
10193 op_sibling_splice(o, NULL, 0, second);
10194 op_sibling_splice(o, NULL, 0, first);
10196 /* Implicitly take a reference to a regular expression */
10197 if (first->op_type == OP_MATCH) {
10198 CHANGE_TYPE(first, OP_QR);
10200 if (second->op_type == OP_MATCH) {
10201 CHANGE_TYPE(second, OP_QR);
10210 S_maybe_targlex(pTHX_ OP *o)
10213 OP * const kid = cLISTOPo->op_first;
10214 /* has a disposable target? */
10215 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10216 && !(kid->op_flags & OPf_STACKED)
10217 /* Cannot steal the second time! */
10218 && !(kid->op_private & OPpTARGET_MY)
10221 OP * const kkid = OP_SIBLING(kid);
10223 /* Can just relocate the target. */
10224 if (kkid && kkid->op_type == OP_PADSV
10225 && (!(kkid->op_private & OPpLVAL_INTRO)
10226 || kkid->op_private & OPpPAD_STATE))
10228 kid->op_targ = kkid->op_targ;
10230 /* Now we do not need PADSV and SASSIGN.
10231 * Detach kid and free the rest. */
10232 op_sibling_splice(o, NULL, 1, NULL);
10234 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10242 Perl_ck_sassign(pTHX_ OP *o)
10245 OP * const kid = cLISTOPo->op_first;
10247 PERL_ARGS_ASSERT_CK_SASSIGN;
10249 if (OP_HAS_SIBLING(kid)) {
10250 OP *kkid = OP_SIBLING(kid);
10251 /* For state variable assignment with attributes, kkid is a list op
10252 whose op_last is a padsv. */
10253 if ((kkid->op_type == OP_PADSV ||
10254 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10255 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10258 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10259 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10260 const PADOFFSET target = kkid->op_targ;
10261 OP *const other = newOP(OP_PADSV,
10263 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10264 OP *const first = newOP(OP_NULL, 0);
10266 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10267 OP *const condop = first->op_next;
10269 CHANGE_TYPE(condop, OP_ONCE);
10270 other->op_targ = target;
10272 /* Store the initializedness of state vars in a separate
10275 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10276 /* hijacking PADSTALE for uninitialized state variables */
10277 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10282 return S_maybe_targlex(aTHX_ o);
10286 Perl_ck_match(pTHX_ OP *o)
10288 PERL_ARGS_ASSERT_CK_MATCH;
10290 if (o->op_type != OP_QR && PL_compcv) {
10291 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10292 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10293 o->op_targ = offset;
10294 o->op_private |= OPpTARGET_MY;
10297 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10298 o->op_private |= OPpRUNTIME;
10303 Perl_ck_method(pTHX_ OP *o)
10306 const char* method;
10309 STRLEN len, nsplit = 0, i;
10310 OP * const kid = cUNOPo->op_first;
10312 PERL_ARGS_ASSERT_CK_METHOD;
10313 if (kid->op_type != OP_CONST) return o;
10317 /* replace ' with :: */
10318 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10320 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10323 method = SvPVX_const(sv);
10325 utf8 = SvUTF8(sv) ? -1 : 1;
10327 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10332 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10334 if (!nsplit) { /* $proto->method() */
10336 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10339 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10341 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10348 Perl_ck_null(pTHX_ OP *o)
10350 PERL_ARGS_ASSERT_CK_NULL;
10351 PERL_UNUSED_CONTEXT;
10356 Perl_ck_open(pTHX_ OP *o)
10358 PERL_ARGS_ASSERT_CK_OPEN;
10360 S_io_hints(aTHX_ o);
10362 /* In case of three-arg dup open remove strictness
10363 * from the last arg if it is a bareword. */
10364 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10365 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10369 if ((last->op_type == OP_CONST) && /* The bareword. */
10370 (last->op_private & OPpCONST_BARE) &&
10371 (last->op_private & OPpCONST_STRICT) &&
10372 (oa = OP_SIBLING(first)) && /* The fh. */
10373 (oa = OP_SIBLING(oa)) && /* The mode. */
10374 (oa->op_type == OP_CONST) &&
10375 SvPOK(((SVOP*)oa)->op_sv) &&
10376 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10377 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10378 (last == OP_SIBLING(oa))) /* The bareword. */
10379 last->op_private &= ~OPpCONST_STRICT;
10385 Perl_ck_refassign(pTHX_ OP *o)
10387 OP * const right = cLISTOPo->op_first;
10388 OP * const left = OP_SIBLING(right);
10389 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10392 PERL_ARGS_ASSERT_CK_REFASSIGN;
10394 assert (left->op_type == OP_SREFGEN);
10396 o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10398 switch (varop->op_type) {
10400 o->op_private |= OPpLVREF_AV;
10403 o->op_private |= OPpLVREF_HV;
10406 o->op_targ = varop->op_targ;
10407 varop->op_targ = 0;
10408 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10411 o->op_private |= OPpLVREF_AV;
10414 o->op_private |= OPpLVREF_HV;
10417 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10419 /* Point varop to its GV kid, detached. */
10420 varop = op_sibling_splice(varop, NULL, -1, NULL);
10424 OP * const kidparent =
10425 cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
10426 OP * const kid = cUNOPx(kidparent)->op_first;
10427 o->op_private |= OPpLVREF_CV;
10428 if (kid->op_type == OP_GV) {
10430 goto detach_and_stack;
10432 if (kid->op_type != OP_PADCV) goto bad;
10433 o->op_targ = kid->op_targ;
10439 o->op_private |= OPpLVREF_ELEM;
10442 /* Detach varop. */
10443 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10447 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10448 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10453 if (!FEATURE_REFALIASING_IS_ENABLED)
10455 "Experimental aliasing via reference not enabled");
10456 Perl_ck_warner_d(aTHX_
10457 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10458 "Aliasing via reference is experimental");
10460 o->op_flags |= OPf_STACKED;
10461 op_sibling_splice(o, right, 1, varop);
10464 o->op_flags &=~ OPf_STACKED;
10465 op_sibling_splice(o, right, 1, NULL);
10472 Perl_ck_repeat(pTHX_ OP *o)
10474 PERL_ARGS_ASSERT_CK_REPEAT;
10476 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10478 o->op_private |= OPpREPEAT_DOLIST;
10479 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10480 kids = force_list(kids, 1); /* promote it to a list */
10481 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10489 Perl_ck_require(pTHX_ OP *o)
10493 PERL_ARGS_ASSERT_CK_REQUIRE;
10495 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10496 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10501 if (kid->op_type == OP_CONST) {
10502 SV * const sv = kid->op_sv;
10503 U32 const was_readonly = SvREADONLY(sv);
10504 if (kid->op_private & OPpCONST_BARE) {
10508 if (was_readonly) {
10509 SvREADONLY_off(sv);
10511 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10516 for (; s < end; s++) {
10517 if (*s == ':' && s[1] == ':') {
10519 Move(s+2, s+1, end - s - 1, char);
10523 SvEND_set(sv, end);
10524 sv_catpvs(sv, ".pm");
10525 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10526 hek = share_hek(SvPVX(sv),
10527 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10529 sv_sethek(sv, hek);
10531 SvFLAGS(sv) |= was_readonly;
10533 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
10535 if (SvREFCNT(sv) > 1) {
10536 kid->op_sv = newSVpvn_share(
10537 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10538 SvREFCNT_dec_NN(sv);
10542 if (was_readonly) SvREADONLY_off(sv);
10543 PERL_HASH(hash, s, len);
10545 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10547 sv_sethek(sv, hek);
10549 SvFLAGS(sv) |= was_readonly;
10555 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10556 /* handle override, if any */
10557 && (gv = gv_override("require", 7))) {
10559 if (o->op_flags & OPf_KIDS) {
10560 kid = cUNOPo->op_first;
10561 op_sibling_splice(o, NULL, -1, NULL);
10564 kid = newDEFSVOP();
10567 newop = S_new_entersubop(aTHX_ gv, kid);
10571 return scalar(ck_fun(o));
10575 Perl_ck_return(pTHX_ OP *o)
10579 PERL_ARGS_ASSERT_CK_RETURN;
10581 kid = OP_SIBLING(cLISTOPo->op_first);
10582 if (CvLVALUE(PL_compcv)) {
10583 for (; kid; kid = OP_SIBLING(kid))
10584 op_lvalue(kid, OP_LEAVESUBLV);
10591 Perl_ck_select(pTHX_ OP *o)
10596 PERL_ARGS_ASSERT_CK_SELECT;
10598 if (o->op_flags & OPf_KIDS) {
10599 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10600 if (kid && OP_HAS_SIBLING(kid)) {
10601 CHANGE_TYPE(o, OP_SSELECT);
10603 return fold_constants(op_integerize(op_std_init(o)));
10607 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10608 if (kid && kid->op_type == OP_RV2GV)
10609 kid->op_private &= ~HINT_STRICT_REFS;
10614 Perl_ck_shift(pTHX_ OP *o)
10616 const I32 type = o->op_type;
10618 PERL_ARGS_ASSERT_CK_SHIFT;
10620 if (!(o->op_flags & OPf_KIDS)) {
10623 if (!CvUNIQUE(PL_compcv)) {
10624 o->op_flags |= OPf_SPECIAL;
10628 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10630 return newUNOP(type, 0, scalar(argop));
10632 return scalar(ck_fun(o));
10636 Perl_ck_sort(pTHX_ OP *o)
10640 HV * const hinthv =
10641 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10644 PERL_ARGS_ASSERT_CK_SORT;
10647 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10649 const I32 sorthints = (I32)SvIV(*svp);
10650 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10651 o->op_private |= OPpSORT_QSORT;
10652 if ((sorthints & HINT_SORT_STABLE) != 0)
10653 o->op_private |= OPpSORT_STABLE;
10657 if (o->op_flags & OPf_STACKED)
10659 firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10661 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10662 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10664 /* if the first arg is a code block, process it and mark sort as
10666 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10668 if (kid->op_type == OP_LEAVE)
10669 op_null(kid); /* wipe out leave */
10670 /* Prevent execution from escaping out of the sort block. */
10673 /* provide scalar context for comparison function/block */
10674 kid = scalar(firstkid);
10675 kid->op_next = kid;
10676 o->op_flags |= OPf_SPECIAL;
10678 else if (kid->op_type == OP_CONST
10679 && kid->op_private & OPpCONST_BARE) {
10683 const char * const name = SvPV(kSVOP_sv, len);
10685 assert (len < 256);
10686 Copy(name, tmpbuf+1, len, char);
10687 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10688 if (off != NOT_IN_PAD) {
10689 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10691 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10692 sv_catpvs(fq, "::");
10693 sv_catsv(fq, kSVOP_sv);
10694 SvREFCNT_dec_NN(kSVOP_sv);
10698 OP * const padop = newOP(OP_PADCV, 0);
10699 padop->op_targ = off;
10700 cUNOPx(firstkid)->op_first = padop;
10701 #ifdef PERL_OP_PARENT
10702 padop->op_sibling = firstkid;
10709 firstkid = OP_SIBLING(firstkid);
10712 for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
10713 /* provide list context for arguments */
10716 op_lvalue(kid, OP_GREPSTART);
10722 /* for sort { X } ..., where X is one of
10723 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10724 * elide the second child of the sort (the one containing X),
10725 * and set these flags as appropriate
10729 * Also, check and warn on lexical $a, $b.
10733 S_simplify_sort(pTHX_ OP *o)
10735 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10739 const char *gvname;
10742 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10744 kid = kUNOP->op_first; /* get past null */
10745 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10746 && kid->op_type != OP_LEAVE)
10748 kid = kLISTOP->op_last; /* get past scope */
10749 switch(kid->op_type) {
10753 if (!have_scopeop) goto padkids;
10758 k = kid; /* remember this node*/
10759 if (kBINOP->op_first->op_type != OP_RV2SV
10760 || kBINOP->op_last ->op_type != OP_RV2SV)
10763 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10764 then used in a comparison. This catches most, but not
10765 all cases. For instance, it catches
10766 sort { my($a); $a <=> $b }
10768 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10769 (although why you'd do that is anyone's guess).
10773 if (!ckWARN(WARN_SYNTAX)) return;
10774 kid = kBINOP->op_first;
10776 if (kid->op_type == OP_PADSV) {
10777 SV * const name = PAD_COMPNAME_SV(kid->op_targ);
10778 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
10779 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
10780 /* diag_listed_as: "my %s" used in sort comparison */
10781 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10782 "\"%s %s\" used in sort comparison",
10783 SvPAD_STATE(name) ? "state" : "my",
10786 } while ((kid = OP_SIBLING(kid)));
10789 kid = kBINOP->op_first; /* get past cmp */
10790 if (kUNOP->op_first->op_type != OP_GV)
10792 kid = kUNOP->op_first; /* get past rv2sv */
10794 if (GvSTASH(gv) != PL_curstash)
10796 gvname = GvNAME(gv);
10797 if (*gvname == 'a' && gvname[1] == '\0')
10799 else if (*gvname == 'b' && gvname[1] == '\0')
10804 kid = k; /* back to cmp */
10805 /* already checked above that it is rv2sv */
10806 kid = kBINOP->op_last; /* down to 2nd arg */
10807 if (kUNOP->op_first->op_type != OP_GV)
10809 kid = kUNOP->op_first; /* get past rv2sv */
10811 if (GvSTASH(gv) != PL_curstash)
10813 gvname = GvNAME(gv);
10815 ? !(*gvname == 'a' && gvname[1] == '\0')
10816 : !(*gvname == 'b' && gvname[1] == '\0'))
10818 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10820 o->op_private |= OPpSORT_DESCEND;
10821 if (k->op_type == OP_NCMP)
10822 o->op_private |= OPpSORT_NUMERIC;
10823 if (k->op_type == OP_I_NCMP)
10824 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10825 kid = OP_SIBLING(cLISTOPo->op_first);
10826 /* cut out and delete old block (second sibling) */
10827 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10832 Perl_ck_split(pTHX_ OP *o)
10837 PERL_ARGS_ASSERT_CK_SPLIT;
10839 if (o->op_flags & OPf_STACKED)
10840 return no_fh_allowed(o);
10842 kid = cLISTOPo->op_first;
10843 if (kid->op_type != OP_NULL)
10844 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10845 /* delete leading NULL node, then add a CONST if no other nodes */
10846 op_sibling_splice(o, NULL, 1,
10847 OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10849 kid = cLISTOPo->op_first;
10851 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10852 /* remove kid, and replace with new optree */
10853 op_sibling_splice(o, NULL, 1, NULL);
10854 /* OPf_SPECIAL is used to trigger split " " behavior */
10855 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
10856 op_sibling_splice(o, NULL, 0, kid);
10858 CHANGE_TYPE(kid, OP_PUSHRE);
10860 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10861 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10862 "Use of /g modifier is meaningless in split");
10865 if (!OP_HAS_SIBLING(kid))
10866 op_append_elem(OP_SPLIT, o, newDEFSVOP());
10868 kid = OP_SIBLING(kid);
10872 if (!OP_HAS_SIBLING(kid))
10874 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10875 o->op_private |= OPpSPLIT_IMPLIM;
10877 assert(OP_HAS_SIBLING(kid));
10879 kid = OP_SIBLING(kid);
10882 if (OP_HAS_SIBLING(kid))
10883 return too_many_arguments_pv(o,OP_DESC(o), 0);
10889 Perl_ck_stringify(pTHX_ OP *o)
10891 OP * const kid = OP_SIBLING(cUNOPo->op_first);
10892 PERL_ARGS_ASSERT_CK_STRINGIFY;
10893 if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
10894 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
10895 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
10897 assert(!OP_HAS_SIBLING(kid));
10898 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10906 Perl_ck_join(pTHX_ OP *o)
10908 OP * const kid = OP_SIBLING(cLISTOPo->op_first);
10910 PERL_ARGS_ASSERT_CK_JOIN;
10912 if (kid && kid->op_type == OP_MATCH) {
10913 if (ckWARN(WARN_SYNTAX)) {
10914 const REGEXP *re = PM_GETRE(kPMOP);
10916 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10917 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10918 : newSVpvs_flags( "STRING", SVs_TEMP );
10919 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10920 "/%"SVf"/ should probably be written as \"%"SVf"\"",
10921 SVfARG(msg), SVfARG(msg));
10925 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
10926 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
10927 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
10928 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
10930 const OP * const bairn = OP_SIBLING(kid); /* the list */
10931 if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
10932 && PL_opargs[bairn->op_type] & OA_RETSCALAR)
10934 OP * const ret = op_convert_list(OP_STRINGIFY, 0,
10935 op_sibling_splice(o, kid, 1, NULL));
10937 ret->op_folded = 1;
10946 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10948 Examines an op, which is expected to identify a subroutine at runtime,
10949 and attempts to determine at compile time which subroutine it identifies.
10950 This is normally used during Perl compilation to determine whether
10951 a prototype can be applied to a function call. I<cvop> is the op
10952 being considered, normally an C<rv2cv> op. A pointer to the identified
10953 subroutine is returned, if it could be determined statically, and a null
10954 pointer is returned if it was not possible to determine statically.
10956 Currently, the subroutine can be identified statically if the RV that the
10957 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10958 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
10959 suitable if the constant value must be an RV pointing to a CV. Details of
10960 this process may change in future versions of Perl. If the C<rv2cv> op
10961 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10962 the subroutine statically: this flag is used to suppress compile-time
10963 magic on a subroutine call, forcing it to use default runtime behaviour.
10965 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10966 of a GV reference is modified. If a GV was examined and its CV slot was
10967 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10968 If the op is not optimised away, and the CV slot is later populated with
10969 a subroutine having a prototype, that flag eventually triggers the warning
10970 "called too early to check prototype".
10972 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10973 of returning a pointer to the subroutine it returns a pointer to the
10974 GV giving the most appropriate name for the subroutine in this context.
10975 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10976 (C<CvANON>) subroutine that is referenced through a GV it will be the
10977 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
10978 A null pointer is returned as usual if there is no statically-determinable
10984 /* shared by toke.c:yylex */
10986 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10988 PADNAME *name = PAD_COMPNAME(off);
10989 CV *compcv = PL_compcv;
10990 while (PadnameOUTER(name)) {
10991 assert(PARENT_PAD_INDEX(name));
10992 compcv = CvOUTSIDE(PL_compcv);
10993 name = PadlistNAMESARRAY(CvPADLIST(compcv))
10994 [off = PARENT_PAD_INDEX(name)];
10996 assert(!PadnameIsOUR(name));
10997 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10998 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
11000 assert(mg->mg_obj);
11001 return (CV *)mg->mg_obj;
11003 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11007 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11012 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11013 if (flags & ~RV2CVOPCV_FLAG_MASK)
11014 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11015 if (cvop->op_type != OP_RV2CV)
11017 if (cvop->op_private & OPpENTERSUB_AMPER)
11019 if (!(cvop->op_flags & OPf_KIDS))
11021 rvop = cUNOPx(cvop)->op_first;
11022 switch (rvop->op_type) {
11024 gv = cGVOPx_gv(rvop);
11026 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11027 cv = MUTABLE_CV(SvRV(gv));
11031 if (flags & RV2CVOPCV_RETURN_STUB)
11037 if (flags & RV2CVOPCV_MARK_EARLY)
11038 rvop->op_private |= OPpEARLY_CV;
11043 SV *rv = cSVOPx_sv(rvop);
11046 cv = (CV*)SvRV(rv);
11050 cv = find_lexical_cv(rvop->op_targ);
11055 } NOT_REACHED; /* NOTREACHED */
11057 if (SvTYPE((SV*)cv) != SVt_PVCV)
11059 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11060 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11061 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11070 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11072 Performs the default fixup of the arguments part of an C<entersub>
11073 op tree. This consists of applying list context to each of the
11074 argument ops. This is the standard treatment used on a call marked
11075 with C<&>, or a method call, or a call through a subroutine reference,
11076 or any other call where the callee can't be identified at compile time,
11077 or a call where the callee has no prototype.
11083 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11086 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11087 aop = cUNOPx(entersubop)->op_first;
11088 if (!OP_HAS_SIBLING(aop))
11089 aop = cUNOPx(aop)->op_first;
11090 for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
11092 op_lvalue(aop, OP_ENTERSUB);
11098 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11100 Performs the fixup of the arguments part of an C<entersub> op tree
11101 based on a subroutine prototype. This makes various modifications to
11102 the argument ops, from applying context up to inserting C<refgen> ops,
11103 and checking the number and syntactic types of arguments, as directed by
11104 the prototype. This is the standard treatment used on a subroutine call,
11105 not marked with C<&>, where the callee can be identified at compile time
11106 and has a prototype.
11108 I<protosv> supplies the subroutine prototype to be applied to the call.
11109 It may be a normal defined scalar, of which the string value will be used.
11110 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11111 that has been cast to C<SV*>) which has a prototype. The prototype
11112 supplied, in whichever form, does not need to match the actual callee
11113 referenced by the op tree.
11115 If the argument ops disagree with the prototype, for example by having
11116 an unacceptable number of arguments, a valid op tree is returned anyway.
11117 The error is reflected in the parser state, normally resulting in a single
11118 exception at the top level of parsing which covers all the compilation
11119 errors that occurred. In the error message, the callee is referred to
11120 by the name defined by the I<namegv> parameter.
11126 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11129 const char *proto, *proto_end;
11130 OP *aop, *prev, *cvop, *parent;
11133 I32 contextclass = 0;
11134 const char *e = NULL;
11135 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11136 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11137 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11138 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11139 if (SvTYPE(protosv) == SVt_PVCV)
11140 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11141 else proto = SvPV(protosv, proto_len);
11142 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11143 proto_end = proto + proto_len;
11144 parent = entersubop;
11145 aop = cUNOPx(entersubop)->op_first;
11146 if (!OP_HAS_SIBLING(aop)) {
11148 aop = cUNOPx(aop)->op_first;
11151 aop = OP_SIBLING(aop);
11152 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11153 while (aop != cvop) {
11156 if (proto >= proto_end)
11158 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11159 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11160 SVfARG(namesv)), SvUTF8(namesv));
11170 /* _ must be at the end */
11171 if (proto[1] && !strchr(";@%", proto[1]))
11187 if (o3->op_type != OP_SREFGEN
11188 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11190 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11193 arg == 1 ? "block or sub {}" : "sub {}",
11197 /* '*' allows any scalar type, including bareword */
11200 if (o3->op_type == OP_RV2GV)
11201 goto wrapref; /* autoconvert GLOB -> GLOBref */
11202 else if (o3->op_type == OP_CONST)
11203 o3->op_private &= ~OPpCONST_STRICT;
11209 if (o3->op_type == OP_RV2AV ||
11210 o3->op_type == OP_PADAV ||
11211 o3->op_type == OP_RV2HV ||
11212 o3->op_type == OP_PADHV
11218 case '[': case ']':
11225 switch (*proto++) {
11227 if (contextclass++ == 0) {
11228 e = strchr(proto, ']');
11229 if (!e || e == proto)
11237 if (contextclass) {
11238 const char *p = proto;
11239 const char *const end = proto;
11241 while (*--p != '[')
11242 /* \[$] accepts any scalar lvalue */
11244 && Perl_op_lvalue_flags(aTHX_
11246 OP_READ, /* not entersub */
11249 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
11250 (int)(end - p), p),
11256 if (o3->op_type == OP_RV2GV)
11259 bad_type_gv(arg, "symbol", namegv, 0, o3);
11262 if (o3->op_type == OP_ENTERSUB
11263 && !(o3->op_flags & OPf_STACKED))
11266 bad_type_gv(arg, "subroutine", namegv, 0,
11270 if (o3->op_type == OP_RV2SV ||
11271 o3->op_type == OP_PADSV ||
11272 o3->op_type == OP_HELEM ||
11273 o3->op_type == OP_AELEM)
11275 if (!contextclass) {
11276 /* \$ accepts any scalar lvalue */
11277 if (Perl_op_lvalue_flags(aTHX_
11279 OP_READ, /* not entersub */
11282 bad_type_gv(arg, "scalar", namegv, 0, o3);
11286 if (o3->op_type == OP_RV2AV ||
11287 o3->op_type == OP_PADAV)
11289 o3->op_flags &=~ OPf_PARENS;
11293 bad_type_gv(arg, "array", namegv, 0, o3);
11296 if (o3->op_type == OP_RV2HV ||
11297 o3->op_type == OP_PADHV)
11299 o3->op_flags &=~ OPf_PARENS;
11303 bad_type_gv(arg, "hash", namegv, 0, o3);
11306 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11308 if (contextclass && e) {
11313 default: goto oops;
11323 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11324 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11329 op_lvalue(aop, OP_ENTERSUB);
11331 aop = OP_SIBLING(aop);
11333 if (aop == cvop && *proto == '_') {
11334 /* generate an access to $_ */
11335 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11337 if (!optional && proto_end > proto &&
11338 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11340 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11341 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11342 SVfARG(namesv)), SvUTF8(namesv));
11348 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11350 Performs the fixup of the arguments part of an C<entersub> op tree either
11351 based on a subroutine prototype or using default list-context processing.
11352 This is the standard treatment used on a subroutine call, not marked
11353 with C<&>, where the callee can be identified at compile time.
11355 I<protosv> supplies the subroutine prototype to be applied to the call,
11356 or indicates that there is no prototype. It may be a normal scalar,
11357 in which case if it is defined then the string value will be used
11358 as a prototype, and if it is undefined then there is no prototype.
11359 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11360 that has been cast to C<SV*>), of which the prototype will be used if it
11361 has one. The prototype (or lack thereof) supplied, in whichever form,
11362 does not need to match the actual callee referenced by the op tree.
11364 If the argument ops disagree with the prototype, for example by having
11365 an unacceptable number of arguments, a valid op tree is returned anyway.
11366 The error is reflected in the parser state, normally resulting in a single
11367 exception at the top level of parsing which covers all the compilation
11368 errors that occurred. In the error message, the callee is referred to
11369 by the name defined by the I<namegv> parameter.
11375 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11376 GV *namegv, SV *protosv)
11378 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11379 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11380 return ck_entersub_args_proto(entersubop, namegv, protosv);
11382 return ck_entersub_args_list(entersubop);
11386 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11388 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11389 OP *aop = cUNOPx(entersubop)->op_first;
11391 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11395 if (!OP_HAS_SIBLING(aop))
11396 aop = cUNOPx(aop)->op_first;
11397 aop = OP_SIBLING(aop);
11398 for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11400 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11402 op_free(entersubop);
11403 switch(GvNAME(namegv)[2]) {
11404 case 'F': return newSVOP(OP_CONST, 0,
11405 newSVpv(CopFILE(PL_curcop),0));
11406 case 'L': return newSVOP(
11408 Perl_newSVpvf(aTHX_
11409 "%"IVdf, (IV)CopLINE(PL_curcop)
11412 case 'P': return newSVOP(OP_CONST, 0,
11414 ? newSVhek(HvNAME_HEK(PL_curstash))
11422 OP *prev, *cvop, *first, *parent;
11425 parent = entersubop;
11426 if (!OP_HAS_SIBLING(aop)) {
11428 aop = cUNOPx(aop)->op_first;
11431 first = prev = aop;
11432 aop = OP_SIBLING(aop);
11433 /* find last sibling */
11435 OP_HAS_SIBLING(cvop);
11436 prev = cvop, cvop = OP_SIBLING(cvop))
11438 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11439 /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
11440 * parens, but these have their own meaning for that flag: */
11441 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11442 && opnum != OP_DELETE && opnum != OP_EXISTS)
11443 flags |= OPf_SPECIAL;
11444 /* excise cvop from end of sibling chain */
11445 op_sibling_splice(parent, prev, 1, NULL);
11447 if (aop == cvop) aop = NULL;
11449 /* detach remaining siblings from the first sibling, then
11450 * dispose of original optree */
11453 op_sibling_splice(parent, first, -1, NULL);
11454 op_free(entersubop);
11456 if (opnum == OP_ENTEREVAL
11457 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11458 flags |= OPpEVAL_BYTES <<8;
11460 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11462 case OA_BASEOP_OR_UNOP:
11463 case OA_FILESTATOP:
11464 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11467 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11470 return opnum == OP_RUNCV
11471 ? newPVOP(OP_RUNCV,0,NULL)
11474 return op_convert_list(opnum,0,aop);
11482 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11484 Retrieves the function that will be used to fix up a call to I<cv>.
11485 Specifically, the function is applied to an C<entersub> op tree for a
11486 subroutine call, not marked with C<&>, where the callee can be identified
11487 at compile time as I<cv>.
11489 The C-level function pointer is returned in I<*ckfun_p>, and an SV
11490 argument for it is returned in I<*ckobj_p>. The function is intended
11491 to be called in this manner:
11493 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11495 In this call, I<entersubop> is a pointer to the C<entersub> op,
11496 which may be replaced by the check function, and I<namegv> is a GV
11497 supplying the name that should be used by the check function to refer
11498 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11499 It is permitted to apply the check function in non-standard situations,
11500 such as to a call to a different subroutine or to a method call.
11502 By default, the function is
11503 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11504 and the SV parameter is I<cv> itself. This implements standard
11505 prototype processing. It can be changed, for a particular subroutine,
11506 by L</cv_set_call_checker>.
11512 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11516 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11518 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11519 *ckobj_p = callmg->mg_obj;
11520 if (flagsp) *flagsp = callmg->mg_flags;
11522 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11523 *ckobj_p = (SV*)cv;
11524 if (flagsp) *flagsp = 0;
11529 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11531 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11532 PERL_UNUSED_CONTEXT;
11533 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11537 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11539 Sets the function that will be used to fix up a call to I<cv>.
11540 Specifically, the function is applied to an C<entersub> op tree for a
11541 subroutine call, not marked with C<&>, where the callee can be identified
11542 at compile time as I<cv>.
11544 The C-level function pointer is supplied in I<ckfun>, and an SV argument
11545 for it is supplied in I<ckobj>. The function should be defined like this:
11547 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11549 It is intended to be called in this manner:
11551 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11553 In this call, I<entersubop> is a pointer to the C<entersub> op,
11554 which may be replaced by the check function, and I<namegv> supplies
11555 the name that should be used by the check function to refer
11556 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11557 It is permitted to apply the check function in non-standard situations,
11558 such as to a call to a different subroutine or to a method call.
11560 I<namegv> may not actually be a GV. For efficiency, perl may pass a
11561 CV or other SV instead. Whatever is passed can be used as the first
11562 argument to L</cv_name>. You can force perl to pass a GV by including
11563 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
11565 The current setting for a particular CV can be retrieved by
11566 L</cv_get_call_checker>.
11568 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11570 The original form of L</cv_set_call_checker_flags>, which passes it the
11571 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11577 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11579 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11580 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11584 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11585 SV *ckobj, U32 flags)
11587 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11588 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11589 if (SvMAGICAL((SV*)cv))
11590 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11593 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11594 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11596 if (callmg->mg_flags & MGf_REFCOUNTED) {
11597 SvREFCNT_dec(callmg->mg_obj);
11598 callmg->mg_flags &= ~MGf_REFCOUNTED;
11600 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11601 callmg->mg_obj = ckobj;
11602 if (ckobj != (SV*)cv) {
11603 SvREFCNT_inc_simple_void_NN(ckobj);
11604 callmg->mg_flags |= MGf_REFCOUNTED;
11606 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11607 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11612 Perl_ck_subr(pTHX_ OP *o)
11617 SV **const_class = NULL;
11619 PERL_ARGS_ASSERT_CK_SUBR;
11621 aop = cUNOPx(o)->op_first;
11622 if (!OP_HAS_SIBLING(aop))
11623 aop = cUNOPx(aop)->op_first;
11624 aop = OP_SIBLING(aop);
11625 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11626 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11627 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11629 o->op_private &= ~1;
11630 o->op_private |= OPpENTERSUB_HASTARG;
11631 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11632 if (PERLDB_SUB && PL_curstash != PL_debstash)
11633 o->op_private |= OPpENTERSUB_DB;
11634 switch (cvop->op_type) {
11636 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11640 case OP_METHOD_NAMED:
11641 case OP_METHOD_SUPER:
11642 if (aop->op_type == OP_CONST) {
11643 aop->op_private &= ~OPpCONST_STRICT;
11644 const_class = &cSVOPx(aop)->op_sv;
11646 else if (aop->op_type == OP_LIST) {
11647 OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
11648 if (sib && sib->op_type == OP_CONST) {
11649 sib->op_private &= ~OPpCONST_STRICT;
11650 const_class = &cSVOPx(sib)->op_sv;
11653 /* make class name a shared cow string to speedup method calls */
11654 /* constant string might be replaced with object, f.e. bigint */
11655 if (const_class && !SvROK(*const_class)) {
11657 const char* str = SvPV(*const_class, len);
11659 SV* const shared = newSVpvn_share(
11660 str, SvUTF8(*const_class) ? -len : len, 0
11662 SvREFCNT_dec(*const_class);
11663 *const_class = shared;
11670 return ck_entersub_args_list(o);
11672 Perl_call_checker ckfun;
11675 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11677 /* The original call checker API guarantees that a GV will be
11678 be provided with the right name. So, if the old API was
11679 used (or the REQUIRE_GV flag was passed), we have to reify
11680 the CV’s GV, unless this is an anonymous sub. This is not
11681 ideal for lexical subs, as its stringification will include
11682 the package. But it is the best we can do. */
11683 if (flags & MGf_REQUIRE_GV) {
11684 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11687 else namegv = MUTABLE_GV(cv);
11688 /* After a syntax error in a lexical sub, the cv that
11689 rv2cv_op_cv returns may be a nameless stub. */
11690 if (!namegv) return ck_entersub_args_list(o);
11693 return ckfun(aTHX_ o, namegv, ckobj);
11698 Perl_ck_svconst(pTHX_ OP *o)
11700 SV * const sv = cSVOPo->op_sv;
11701 PERL_ARGS_ASSERT_CK_SVCONST;
11702 PERL_UNUSED_CONTEXT;
11703 #ifdef PERL_OLD_COPY_ON_WRITE
11704 if (SvIsCOW(sv)) sv_force_normal(sv);
11705 #elif defined(PERL_NEW_COPY_ON_WRITE)
11706 /* Since the read-only flag may be used to protect a string buffer, we
11707 cannot do copy-on-write with existing read-only scalars that are not
11708 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11709 that constant, mark the constant as COWable here, if it is not
11710 already read-only. */
11711 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11714 # ifdef PERL_DEBUG_READONLY_COW
11724 Perl_ck_trunc(pTHX_ OP *o)
11726 PERL_ARGS_ASSERT_CK_TRUNC;
11728 if (o->op_flags & OPf_KIDS) {
11729 SVOP *kid = (SVOP*)cUNOPo->op_first;
11731 if (kid->op_type == OP_NULL)
11732 kid = (SVOP*)OP_SIBLING(kid);
11733 if (kid && kid->op_type == OP_CONST &&
11734 (kid->op_private & OPpCONST_BARE) &&
11737 o->op_flags |= OPf_SPECIAL;
11738 kid->op_private &= ~OPpCONST_STRICT;
11745 Perl_ck_substr(pTHX_ OP *o)
11747 PERL_ARGS_ASSERT_CK_SUBSTR;
11750 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11751 OP *kid = cLISTOPo->op_first;
11753 if (kid->op_type == OP_NULL)
11754 kid = OP_SIBLING(kid);
11756 kid->op_flags |= OPf_MOD;
11763 Perl_ck_tell(pTHX_ OP *o)
11765 PERL_ARGS_ASSERT_CK_TELL;
11767 if (o->op_flags & OPf_KIDS) {
11768 OP *kid = cLISTOPo->op_first;
11769 if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
11770 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11776 Perl_ck_each(pTHX_ OP *o)
11779 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11780 const unsigned orig_type = o->op_type;
11781 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
11782 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
11783 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
11784 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
11786 PERL_ARGS_ASSERT_CK_EACH;
11789 switch (kid->op_type) {
11795 CHANGE_TYPE(o, array_type);
11798 if (kid->op_private == OPpCONST_BARE
11799 || !SvROK(cSVOPx_sv(kid))
11800 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11801 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
11803 /* we let ck_fun handle it */
11806 CHANGE_TYPE(o, ref_type);
11810 /* if treating as a reference, defer additional checks to runtime */
11811 if (o->op_type == ref_type) {
11812 /* diag_listed_as: keys on reference is experimental */
11813 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
11814 "%s is experimental", PL_op_desc[ref_type]);
11821 Perl_ck_length(pTHX_ OP *o)
11823 PERL_ARGS_ASSERT_CK_LENGTH;
11827 if (ckWARN(WARN_SYNTAX)) {
11828 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11832 const bool hash = kid->op_type == OP_PADHV
11833 || kid->op_type == OP_RV2HV;
11834 switch (kid->op_type) {
11839 name = S_op_varname(aTHX_ kid);
11845 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11846 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11848 SVfARG(name), hash ? "keys " : "", SVfARG(name)
11851 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11852 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11853 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11855 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11856 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11857 "length() used on @array (did you mean \"scalar(@array)\"?)");
11864 /* Check for in place reverse and sort assignments like "@a = reverse @a"
11865 and modify the optree to make them work inplace */
11868 S_inplace_aassign(pTHX_ OP *o) {
11870 OP *modop, *modop_pushmark;
11872 OP *oleft, *oleft_pushmark;
11874 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
11876 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
11878 assert(cUNOPo->op_first->op_type == OP_NULL);
11879 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
11880 assert(modop_pushmark->op_type == OP_PUSHMARK);
11881 modop = OP_SIBLING(modop_pushmark);
11883 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
11886 /* no other operation except sort/reverse */
11887 if (OP_HAS_SIBLING(modop))
11890 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
11891 if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
11893 if (modop->op_flags & OPf_STACKED) {
11894 /* skip sort subroutine/block */
11895 assert(oright->op_type == OP_NULL);
11896 oright = OP_SIBLING(oright);
11899 assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
11900 oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
11901 assert(oleft_pushmark->op_type == OP_PUSHMARK);
11902 oleft = OP_SIBLING(oleft_pushmark);
11904 /* Check the lhs is an array */
11906 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
11907 || OP_HAS_SIBLING(oleft)
11908 || (oleft->op_private & OPpLVAL_INTRO)
11912 /* Only one thing on the rhs */
11913 if (OP_HAS_SIBLING(oright))
11916 /* check the array is the same on both sides */
11917 if (oleft->op_type == OP_RV2AV) {
11918 if (oright->op_type != OP_RV2AV
11919 || !cUNOPx(oright)->op_first
11920 || cUNOPx(oright)->op_first->op_type != OP_GV
11921 || cUNOPx(oleft )->op_first->op_type != OP_GV
11922 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11923 cGVOPx_gv(cUNOPx(oright)->op_first)
11927 else if (oright->op_type != OP_PADAV
11928 || oright->op_targ != oleft->op_targ
11932 /* This actually is an inplace assignment */
11934 modop->op_private |= OPpSORT_INPLACE;
11936 /* transfer MODishness etc from LHS arg to RHS arg */
11937 oright->op_flags = oleft->op_flags;
11939 /* remove the aassign op and the lhs */
11941 op_null(oleft_pushmark);
11942 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11943 op_null(cUNOPx(oleft)->op_first);
11949 /* mechanism for deferring recursion in rpeep() */
11951 #define MAX_DEFERRED 4
11955 if (defer_ix == (MAX_DEFERRED-1)) { \
11956 OP **defer = defer_queue[defer_base]; \
11957 CALL_RPEEP(*defer); \
11958 S_prune_chain_head(defer); \
11959 defer_base = (defer_base + 1) % MAX_DEFERRED; \
11962 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
11965 #define IS_AND_OP(o) (o->op_type == OP_AND)
11966 #define IS_OR_OP(o) (o->op_type == OP_OR)
11969 /* A peephole optimizer. We visit the ops in the order they're to execute.
11970 * See the comments at the top of this file for more details about when
11971 * peep() is called */
11974 Perl_rpeep(pTHX_ OP *o)
11978 OP* oldoldop = NULL;
11979 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11980 int defer_base = 0;
11985 if (!o || o->op_opt)
11989 SAVEVPTR(PL_curcop);
11990 for (;; o = o->op_next) {
11991 if (o && o->op_opt)
11994 while (defer_ix >= 0) {
11996 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
11997 CALL_RPEEP(*defer);
11998 S_prune_chain_head(defer);
12004 /* By default, this op has now been optimised. A couple of cases below
12005 clear this again. */
12010 switch (o->op_type) {
12012 PL_curcop = ((COP*)o); /* for warnings */
12015 PL_curcop = ((COP*)o); /* for warnings */
12017 /* Optimise a "return ..." at the end of a sub to just be "...".
12018 * This saves 2 ops. Before:
12019 * 1 <;> nextstate(main 1 -e:1) v ->2
12020 * 4 <@> return K ->5
12021 * 2 <0> pushmark s ->3
12022 * - <1> ex-rv2sv sK/1 ->4
12023 * 3 <#> gvsv[*cat] s ->4
12026 * - <@> return K ->-
12027 * - <0> pushmark s ->2
12028 * - <1> ex-rv2sv sK/1 ->-
12029 * 2 <$> gvsv(*cat) s ->3
12032 OP *next = o->op_next;
12033 OP *sibling = OP_SIBLING(o);
12034 if ( OP_TYPE_IS(next, OP_PUSHMARK)
12035 && OP_TYPE_IS(sibling, OP_RETURN)
12036 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
12037 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
12038 ||OP_TYPE_IS(sibling->op_next->op_next,
12040 && cUNOPx(sibling)->op_first == next
12041 && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
12044 /* Look through the PUSHMARK's siblings for one that
12045 * points to the RETURN */
12046 OP *top = OP_SIBLING(next);
12047 while (top && top->op_next) {
12048 if (top->op_next == sibling) {
12049 top->op_next = sibling->op_next;
12050 o->op_next = next->op_next;
12053 top = OP_SIBLING(top);
12058 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
12060 * This latter form is then suitable for conversion into padrange
12061 * later on. Convert:
12063 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
12067 * nextstate1 -> listop -> nextstate3
12069 * pushmark -> padop1 -> padop2
12071 if (o->op_next && (
12072 o->op_next->op_type == OP_PADSV
12073 || o->op_next->op_type == OP_PADAV
12074 || o->op_next->op_type == OP_PADHV
12076 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
12077 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
12078 && o->op_next->op_next->op_next && (
12079 o->op_next->op_next->op_next->op_type == OP_PADSV
12080 || o->op_next->op_next->op_next->op_type == OP_PADAV
12081 || o->op_next->op_next->op_next->op_type == OP_PADHV
12083 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
12084 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
12085 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
12086 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
12088 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
12091 ns2 = pad1->op_next;
12092 pad2 = ns2->op_next;
12093 ns3 = pad2->op_next;
12095 /* we assume here that the op_next chain is the same as
12096 * the op_sibling chain */
12097 assert(OP_SIBLING(o) == pad1);
12098 assert(OP_SIBLING(pad1) == ns2);
12099 assert(OP_SIBLING(ns2) == pad2);
12100 assert(OP_SIBLING(pad2) == ns3);
12102 /* create new listop, with children consisting of:
12103 * a new pushmark, pad1, pad2. */
12104 OP_SIBLING_set(pad2, NULL);
12105 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
12106 newop->op_flags |= OPf_PARENS;
12107 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12108 newpm = cUNOPx(newop)->op_first; /* pushmark */
12110 /* Kill nextstate2 between padop1/padop2 */
12113 o ->op_next = newpm;
12114 newpm->op_next = pad1;
12115 pad1 ->op_next = pad2;
12116 pad2 ->op_next = newop; /* listop */
12117 newop->op_next = ns3;
12119 OP_SIBLING_set(o, newop);
12120 OP_SIBLING_set(newop, ns3);
12121 newop->op_lastsib = 0;
12123 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12125 /* Ensure pushmark has this flag if padops do */
12126 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
12127 o->op_next->op_flags |= OPf_MOD;
12133 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
12134 to carry two labels. For now, take the easier option, and skip
12135 this optimisation if the first NEXTSTATE has a label. */
12136 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
12137 OP *nextop = o->op_next;
12138 while (nextop && nextop->op_type == OP_NULL)
12139 nextop = nextop->op_next;
12141 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
12144 oldop->op_next = nextop;
12145 /* Skip (old)oldop assignment since the current oldop's
12146 op_next already points to the next op. */
12153 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
12154 if (o->op_next->op_private & OPpTARGET_MY) {
12155 if (o->op_flags & OPf_STACKED) /* chained concats */
12156 break; /* ignore_optimization */
12158 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
12159 o->op_targ = o->op_next->op_targ;
12160 o->op_next->op_targ = 0;
12161 o->op_private |= OPpTARGET_MY;
12164 op_null(o->op_next);
12168 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
12169 break; /* Scalar stub must produce undef. List stub is noop */
12173 if (o->op_targ == OP_NEXTSTATE
12174 || o->op_targ == OP_DBSTATE)
12176 PL_curcop = ((COP*)o);
12178 /* XXX: We avoid setting op_seq here to prevent later calls
12179 to rpeep() from mistakenly concluding that optimisation
12180 has already occurred. This doesn't fix the real problem,
12181 though (See 20010220.007). AMS 20010719 */
12182 /* op_seq functionality is now replaced by op_opt */
12190 oldop->op_next = o->op_next;
12204 convert repeat into a stub with no kids.
12206 if (o->op_next->op_type == OP_CONST
12207 || ( o->op_next->op_type == OP_PADSV
12208 && !(o->op_next->op_private & OPpLVAL_INTRO))
12209 || ( o->op_next->op_type == OP_GV
12210 && o->op_next->op_next->op_type == OP_RV2SV
12211 && !(o->op_next->op_next->op_private
12212 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
12214 const OP *kid = o->op_next->op_next;
12215 if (o->op_next->op_type == OP_GV)
12216 kid = kid->op_next;
12217 /* kid is now the ex-list. */
12218 if (kid->op_type == OP_NULL
12219 && (kid = kid->op_next)->op_type == OP_CONST
12220 /* kid is now the repeat count. */
12221 && kid->op_next->op_type == OP_REPEAT
12222 && kid->op_next->op_private & OPpREPEAT_DOLIST
12223 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
12224 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
12226 o = kid->op_next; /* repeat */
12228 oldop->op_next = o;
12229 op_free(cBINOPo->op_first);
12230 op_free(cBINOPo->op_last );
12231 o->op_flags &=~ OPf_KIDS;
12232 /* stub is a baseop; repeat is a binop */
12233 assert(sizeof(OP) <= sizeof(BINOP));
12234 CHANGE_TYPE(o, OP_STUB);
12240 /* Convert a series of PAD ops for my vars plus support into a
12241 * single padrange op. Basically
12243 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
12245 * becomes, depending on circumstances, one of
12247 * padrange ----------------------------------> (list) -> rest
12248 * padrange --------------------------------------------> rest
12250 * where all the pad indexes are sequential and of the same type
12252 * We convert the pushmark into a padrange op, then skip
12253 * any other pad ops, and possibly some trailing ops.
12254 * Note that we don't null() the skipped ops, to make it
12255 * easier for Deparse to undo this optimisation (and none of
12256 * the skipped ops are holding any resourses). It also makes
12257 * it easier for find_uninit_var(), as it can just ignore
12258 * padrange, and examine the original pad ops.
12262 OP *followop = NULL; /* the op that will follow the padrange op */
12265 PADOFFSET base = 0; /* init only to stop compiler whining */
12266 U8 gimme = 0; /* init only to stop compiler whining */
12267 bool defav = 0; /* seen (...) = @_ */
12268 bool reuse = 0; /* reuse an existing padrange op */
12270 /* look for a pushmark -> gv[_] -> rv2av */
12275 if ( p->op_type == OP_GV
12276 && cGVOPx_gv(p) == PL_defgv
12277 && (rv2av = p->op_next)
12278 && rv2av->op_type == OP_RV2AV
12279 && !(rv2av->op_flags & OPf_REF)
12280 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12281 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
12283 q = rv2av->op_next;
12284 if (q->op_type == OP_NULL)
12286 if (q->op_type == OP_PUSHMARK) {
12296 /* scan for PAD ops */
12298 for (p = p->op_next; p; p = p->op_next) {
12299 if (p->op_type == OP_NULL)
12302 if (( p->op_type != OP_PADSV
12303 && p->op_type != OP_PADAV
12304 && p->op_type != OP_PADHV
12306 /* any private flag other than INTRO? e.g. STATE */
12307 || (p->op_private & ~OPpLVAL_INTRO)
12311 /* let $a[N] potentially be optimised into AELEMFAST_LEX
12313 if ( p->op_type == OP_PADAV
12315 && p->op_next->op_type == OP_CONST
12316 && p->op_next->op_next
12317 && p->op_next->op_next->op_type == OP_AELEM
12321 /* for 1st padop, note what type it is and the range
12322 * start; for the others, check that it's the same type
12323 * and that the targs are contiguous */
12325 intro = (p->op_private & OPpLVAL_INTRO);
12327 gimme = (p->op_flags & OPf_WANT);
12330 if ((p->op_private & OPpLVAL_INTRO) != intro)
12332 /* Note that you'd normally expect targs to be
12333 * contiguous in my($a,$b,$c), but that's not the case
12334 * when external modules start doing things, e.g.
12335 i* Function::Parameters */
12336 if (p->op_targ != base + count)
12338 assert(p->op_targ == base + count);
12339 /* all the padops should be in the same context */
12340 if (gimme != (p->op_flags & OPf_WANT))
12344 /* for AV, HV, only when we're not flattening */
12345 if ( p->op_type != OP_PADSV
12346 && gimme != OPf_WANT_VOID
12347 && !(p->op_flags & OPf_REF)
12351 if (count >= OPpPADRANGE_COUNTMASK)
12354 /* there's a biggest base we can fit into a
12355 * SAVEt_CLEARPADRANGE in pp_padrange */
12356 if (intro && base >
12357 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
12360 /* Success! We've got another valid pad op to optimise away */
12362 followop = p->op_next;
12365 if (count < 1 || (count == 1 && !defav))
12368 /* pp_padrange in specifically compile-time void context
12369 * skips pushing a mark and lexicals; in all other contexts
12370 * (including unknown till runtime) it pushes a mark and the
12371 * lexicals. We must be very careful then, that the ops we
12372 * optimise away would have exactly the same effect as the
12374 * In particular in void context, we can only optimise to
12375 * a padrange if see see the complete sequence
12376 * pushmark, pad*v, ...., list
12377 * which has the net effect of of leaving the markstack as it
12378 * was. Not pushing on to the stack (whereas padsv does touch
12379 * the stack) makes no difference in void context.
12382 if (gimme == OPf_WANT_VOID) {
12383 if (followop->op_type == OP_LIST
12384 && gimme == (followop->op_flags & OPf_WANT)
12387 followop = followop->op_next; /* skip OP_LIST */
12389 /* consolidate two successive my(...);'s */
12392 && oldoldop->op_type == OP_PADRANGE
12393 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
12394 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
12395 && !(oldoldop->op_flags & OPf_SPECIAL)
12398 assert(oldoldop->op_next == oldop);
12399 assert( oldop->op_type == OP_NEXTSTATE
12400 || oldop->op_type == OP_DBSTATE);
12401 assert(oldop->op_next == o);
12404 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
12406 /* Do not assume pad offsets for $c and $d are con-
12411 if ( oldoldop->op_targ + old_count == base
12412 && old_count < OPpPADRANGE_COUNTMASK - count) {
12413 base = oldoldop->op_targ;
12414 count += old_count;
12419 /* if there's any immediately following singleton
12420 * my var's; then swallow them and the associated
12422 * my ($a,$b); my $c; my $d;
12424 * my ($a,$b,$c,$d);
12427 while ( ((p = followop->op_next))
12428 && ( p->op_type == OP_PADSV
12429 || p->op_type == OP_PADAV
12430 || p->op_type == OP_PADHV)
12431 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
12432 && (p->op_private & OPpLVAL_INTRO) == intro
12433 && !(p->op_private & ~OPpLVAL_INTRO)
12435 && ( p->op_next->op_type == OP_NEXTSTATE
12436 || p->op_next->op_type == OP_DBSTATE)
12437 && count < OPpPADRANGE_COUNTMASK
12438 && base + count == p->op_targ
12441 followop = p->op_next;
12449 assert(oldoldop->op_type == OP_PADRANGE);
12450 oldoldop->op_next = followop;
12451 oldoldop->op_private = (intro | count);
12457 /* Convert the pushmark into a padrange.
12458 * To make Deparse easier, we guarantee that a padrange was
12459 * *always* formerly a pushmark */
12460 assert(o->op_type == OP_PUSHMARK);
12461 o->op_next = followop;
12462 CHANGE_TYPE(o, OP_PADRANGE);
12464 /* bit 7: INTRO; bit 6..0: count */
12465 o->op_private = (intro | count);
12466 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
12467 | gimme | (defav ? OPf_SPECIAL : 0));
12475 /* Skip over state($x) in void context. */
12476 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
12477 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
12479 oldop->op_next = o->op_next;
12480 goto redo_nextstate;
12482 if (o->op_type != OP_PADAV)
12486 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
12487 OP* const pop = (o->op_type == OP_PADAV) ?
12488 o->op_next : o->op_next->op_next;
12490 if (pop && pop->op_type == OP_CONST &&
12491 ((PL_op = pop->op_next)) &&
12492 pop->op_next->op_type == OP_AELEM &&
12493 !(pop->op_next->op_private &
12494 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
12495 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
12498 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
12499 no_bareword_allowed(pop);
12500 if (o->op_type == OP_GV)
12501 op_null(o->op_next);
12502 op_null(pop->op_next);
12504 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
12505 o->op_next = pop->op_next->op_next;
12506 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
12507 o->op_private = (U8)i;
12508 if (o->op_type == OP_GV) {
12511 o->op_type = OP_AELEMFAST;
12514 o->op_type = OP_AELEMFAST_LEX;
12516 if (o->op_type != OP_GV)
12520 /* Remove $foo from the op_next chain in void context. */
12522 && ( o->op_next->op_type == OP_RV2SV
12523 || o->op_next->op_type == OP_RV2AV
12524 || o->op_next->op_type == OP_RV2HV )
12525 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
12526 && !(o->op_next->op_private & OPpLVAL_INTRO))
12528 oldop->op_next = o->op_next->op_next;
12529 /* Reprocess the previous op if it is a nextstate, to
12530 allow double-nextstate optimisation. */
12532 if (oldop->op_type == OP_NEXTSTATE) {
12541 else if (o->op_next->op_type == OP_RV2SV) {
12542 if (!(o->op_next->op_private & OPpDEREF)) {
12543 op_null(o->op_next);
12544 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
12546 o->op_next = o->op_next->op_next;
12547 CHANGE_TYPE(o, OP_GVSV);
12550 else if (o->op_next->op_type == OP_READLINE
12551 && o->op_next->op_next->op_type == OP_CONCAT
12552 && (o->op_next->op_next->op_flags & OPf_STACKED))
12554 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
12555 CHANGE_TYPE(o, OP_RCATLINE);
12556 o->op_flags |= OPf_STACKED;
12557 op_null(o->op_next->op_next);
12558 op_null(o->op_next);
12563 #define HV_OR_SCALARHV(op) \
12564 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
12566 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
12567 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
12568 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
12569 ? cUNOPx(op)->op_first \
12573 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
12574 fop->op_private |= OPpTRUEBOOL;
12580 fop = cLOGOP->op_first;
12581 sop = OP_SIBLING(fop);
12582 while (cLOGOP->op_other->op_type == OP_NULL)
12583 cLOGOP->op_other = cLOGOP->op_other->op_next;
12584 while (o->op_next && ( o->op_type == o->op_next->op_type
12585 || o->op_next->op_type == OP_NULL))
12586 o->op_next = o->op_next->op_next;
12588 /* if we're an OR and our next is a AND in void context, we'll
12589 follow it's op_other on short circuit, same for reverse.
12590 We can't do this with OP_DOR since if it's true, its return
12591 value is the underlying value which must be evaluated
12595 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
12596 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
12598 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
12600 o->op_next = ((LOGOP*)o->op_next)->op_other;
12602 DEFER(cLOGOP->op_other);
12605 fop = HV_OR_SCALARHV(fop);
12606 if (sop) sop = HV_OR_SCALARHV(sop);
12611 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
12612 while (nop && nop->op_next) {
12613 switch (nop->op_next->op_type) {
12618 lop = nop = nop->op_next;
12621 nop = nop->op_next;
12630 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
12631 || o->op_type == OP_AND )
12632 fop->op_private |= OPpTRUEBOOL;
12633 else if (!(lop->op_flags & OPf_WANT))
12634 fop->op_private |= OPpMAYBE_TRUEBOOL;
12636 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
12638 sop->op_private |= OPpTRUEBOOL;
12645 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
12646 fop->op_private |= OPpTRUEBOOL;
12647 #undef HV_OR_SCALARHV
12648 /* GERONIMO! */ /* FALLTHROUGH */
12657 while (cLOGOP->op_other->op_type == OP_NULL)
12658 cLOGOP->op_other = cLOGOP->op_other->op_next;
12659 DEFER(cLOGOP->op_other);
12664 while (cLOOP->op_redoop->op_type == OP_NULL)
12665 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
12666 while (cLOOP->op_nextop->op_type == OP_NULL)
12667 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
12668 while (cLOOP->op_lastop->op_type == OP_NULL)
12669 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
12670 /* a while(1) loop doesn't have an op_next that escapes the
12671 * loop, so we have to explicitly follow the op_lastop to
12672 * process the rest of the code */
12673 DEFER(cLOOP->op_lastop);
12677 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
12678 DEFER(cLOGOPo->op_other);
12682 assert(!(cPMOP->op_pmflags & PMf_ONCE));
12683 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
12684 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
12685 cPMOP->op_pmstashstartu.op_pmreplstart
12686 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
12687 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
12693 if (o->op_flags & OPf_SPECIAL) {
12694 /* first arg is a code block */
12695 OP * const nullop = OP_SIBLING(cLISTOP->op_first);
12696 OP * kid = cUNOPx(nullop)->op_first;
12698 assert(nullop->op_type == OP_NULL);
12699 assert(kid->op_type == OP_SCOPE
12700 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
12701 /* since OP_SORT doesn't have a handy op_other-style
12702 * field that can point directly to the start of the code
12703 * block, store it in the otherwise-unused op_next field
12704 * of the top-level OP_NULL. This will be quicker at
12705 * run-time, and it will also allow us to remove leading
12706 * OP_NULLs by just messing with op_nexts without
12707 * altering the basic op_first/op_sibling layout. */
12708 kid = kLISTOP->op_first;
12710 (kid->op_type == OP_NULL
12711 && ( kid->op_targ == OP_NEXTSTATE
12712 || kid->op_targ == OP_DBSTATE ))
12713 || kid->op_type == OP_STUB
12714 || kid->op_type == OP_ENTER);
12715 nullop->op_next = kLISTOP->op_next;
12716 DEFER(nullop->op_next);
12719 /* check that RHS of sort is a single plain array */
12720 oright = cUNOPo->op_first;
12721 if (!oright || oright->op_type != OP_PUSHMARK)
12724 if (o->op_private & OPpSORT_INPLACE)
12727 /* reverse sort ... can be optimised. */
12728 if (!OP_HAS_SIBLING(cUNOPo)) {
12729 /* Nothing follows us on the list. */
12730 OP * const reverse = o->op_next;
12732 if (reverse->op_type == OP_REVERSE &&
12733 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
12734 OP * const pushmark = cUNOPx(reverse)->op_first;
12735 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
12736 && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
12737 /* reverse -> pushmark -> sort */
12738 o->op_private |= OPpSORT_REVERSE;
12740 pushmark->op_next = oright->op_next;
12750 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
12752 LISTOP *enter, *exlist;
12754 if (o->op_private & OPpSORT_INPLACE)
12757 enter = (LISTOP *) o->op_next;
12760 if (enter->op_type == OP_NULL) {
12761 enter = (LISTOP *) enter->op_next;
12765 /* for $a (...) will have OP_GV then OP_RV2GV here.
12766 for (...) just has an OP_GV. */
12767 if (enter->op_type == OP_GV) {
12768 gvop = (OP *) enter;
12769 enter = (LISTOP *) enter->op_next;
12772 if (enter->op_type == OP_RV2GV) {
12773 enter = (LISTOP *) enter->op_next;
12779 if (enter->op_type != OP_ENTERITER)
12782 iter = enter->op_next;
12783 if (!iter || iter->op_type != OP_ITER)
12786 expushmark = enter->op_first;
12787 if (!expushmark || expushmark->op_type != OP_NULL
12788 || expushmark->op_targ != OP_PUSHMARK)
12791 exlist = (LISTOP *) OP_SIBLING(expushmark);
12792 if (!exlist || exlist->op_type != OP_NULL
12793 || exlist->op_targ != OP_LIST)
12796 if (exlist->op_last != o) {
12797 /* Mmm. Was expecting to point back to this op. */
12800 theirmark = exlist->op_first;
12801 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
12804 if (OP_SIBLING(theirmark) != o) {
12805 /* There's something between the mark and the reverse, eg
12806 for (1, reverse (...))
12811 ourmark = ((LISTOP *)o)->op_first;
12812 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
12815 ourlast = ((LISTOP *)o)->op_last;
12816 if (!ourlast || ourlast->op_next != o)
12819 rv2av = OP_SIBLING(ourmark);
12820 if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av)
12821 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
12822 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
12823 /* We're just reversing a single array. */
12824 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
12825 enter->op_flags |= OPf_STACKED;
12828 /* We don't have control over who points to theirmark, so sacrifice
12830 theirmark->op_next = ourmark->op_next;
12831 theirmark->op_flags = ourmark->op_flags;
12832 ourlast->op_next = gvop ? gvop : (OP *) enter;
12835 enter->op_private |= OPpITER_REVERSED;
12836 iter->op_private |= OPpITER_REVERSED;
12843 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
12844 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
12849 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
12850 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
12853 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
12855 sv = newRV((SV *)PL_compcv);
12859 CHANGE_TYPE(o, OP_CONST);
12860 o->op_flags |= OPf_SPECIAL;
12861 cSVOPo->op_sv = sv;
12866 if (OP_GIMME(o,0) == G_VOID
12867 || ( o->op_next->op_type == OP_LINESEQ
12868 && ( o->op_next->op_next->op_type == OP_LEAVESUB
12869 || ( o->op_next->op_next->op_type == OP_RETURN
12870 && !CvLVALUE(PL_compcv)))))
12872 OP *right = cBINOP->op_first;
12891 OP *left = OP_SIBLING(right);
12892 if (left->op_type == OP_SUBSTR
12893 && (left->op_private & 7) < 4) {
12895 /* cut out right */
12896 op_sibling_splice(o, NULL, 1, NULL);
12897 /* and insert it as second child of OP_SUBSTR */
12898 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
12900 left->op_private |= OPpSUBSTR_REPL_FIRST;
12902 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12909 /* We do the common-vars check here, rather than in newASSIGNOP
12910 (as formerly), so that all lexical vars that get aliased are
12911 marked as such before we do the check. */
12912 /* There can’t be common vars if the lhs is a stub. */
12913 if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
12914 == cLISTOPx(cBINOPo->op_last)->op_last
12915 && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
12917 o->op_private &=~ OPpASSIGN_COMMON;
12920 if (o->op_private & OPpASSIGN_COMMON) {
12921 /* See the comment before S_aassign_common_vars concerning
12922 PL_generation sorcery. */
12924 if (!aassign_common_vars(o))
12925 o->op_private &=~ OPpASSIGN_COMMON;
12927 else if (S_aassign_common_vars_aliases_only(aTHX_ o))
12928 o->op_private |= OPpASSIGN_COMMON;
12932 Perl_cpeep_t cpeep =
12933 XopENTRYCUSTOM(o, xop_peep);
12935 cpeep(aTHX_ o, oldop);
12940 /* did we just null the current op? If so, re-process it to handle
12941 * eliding "empty" ops from the chain */
12942 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
12955 Perl_peep(pTHX_ OP *o)
12961 =head1 Custom Operators
12963 =for apidoc Ao||custom_op_xop
12964 Return the XOP structure for a given custom op. This macro should be
12965 considered internal to OP_NAME and the other access macros: use them instead.
12966 This macro does call a function. Prior
12967 to 5.19.6, this was implemented as a
12974 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
12980 static const XOP xop_null = { 0, 0, 0, 0, 0 };
12982 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
12983 assert(o->op_type == OP_CUSTOM);
12985 /* This is wrong. It assumes a function pointer can be cast to IV,
12986 * which isn't guaranteed, but this is what the old custom OP code
12987 * did. In principle it should be safer to Copy the bytes of the
12988 * pointer into a PV: since the new interface is hidden behind
12989 * functions, this can be changed later if necessary. */
12990 /* Change custom_op_xop if this ever happens */
12991 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
12994 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12996 /* assume noone will have just registered a desc */
12997 if (!he && PL_custom_op_names &&
12998 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
13003 /* XXX does all this need to be shared mem? */
13004 Newxz(xop, 1, XOP);
13005 pv = SvPV(HeVAL(he), l);
13006 XopENTRY_set(xop, xop_name, savepvn(pv, l));
13007 if (PL_custom_op_descs &&
13008 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
13010 pv = SvPV(HeVAL(he), l);
13011 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
13013 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
13017 xop = (XOP *)&xop_null;
13019 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
13023 if(field == XOPe_xop_ptr) {
13026 const U32 flags = XopFLAGS(xop);
13027 if(flags & field) {
13029 case XOPe_xop_name:
13030 any.xop_name = xop->xop_name;
13032 case XOPe_xop_desc:
13033 any.xop_desc = xop->xop_desc;
13035 case XOPe_xop_class:
13036 any.xop_class = xop->xop_class;
13038 case XOPe_xop_peep:
13039 any.xop_peep = xop->xop_peep;
13047 case XOPe_xop_name:
13048 any.xop_name = XOPd_xop_name;
13050 case XOPe_xop_desc:
13051 any.xop_desc = XOPd_xop_desc;
13053 case XOPe_xop_class:
13054 any.xop_class = XOPd_xop_class;
13056 case XOPe_xop_peep:
13057 any.xop_peep = XOPd_xop_peep;
13065 /* Some gcc releases emit a warning for this function:
13066 * op.c: In function 'Perl_custom_op_get_field':
13067 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
13068 * Whether this is true, is currently unknown. */
13074 =for apidoc Ao||custom_op_register
13075 Register a custom op. See L<perlguts/"Custom Operators">.
13081 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
13085 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
13087 /* see the comment in custom_op_xop */
13088 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
13090 if (!PL_custom_ops)
13091 PL_custom_ops = newHV();
13093 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
13094 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
13099 =for apidoc core_prototype
13101 This function assigns the prototype of the named core function to C<sv>, or
13102 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
13103 NULL if the core function has no prototype. C<code> is a code as returned
13104 by C<keyword()>. It must not be equal to 0.
13110 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
13113 int i = 0, n = 0, seen_question = 0, defgv = 0;
13115 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
13116 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
13117 bool nullret = FALSE;
13119 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
13123 if (!sv) sv = sv_newmortal();
13125 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
13127 switch (code < 0 ? -code : code) {
13128 case KEY_and : case KEY_chop: case KEY_chomp:
13129 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
13130 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
13131 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
13132 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
13133 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
13134 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
13135 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
13136 case KEY_x : case KEY_xor :
13137 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
13138 case KEY_glob: retsetpvs("_;", OP_GLOB);
13139 case KEY_keys: retsetpvs("+", OP_KEYS);
13140 case KEY_values: retsetpvs("+", OP_VALUES);
13141 case KEY_each: retsetpvs("+", OP_EACH);
13142 case KEY_push: retsetpvs("+@", OP_PUSH);
13143 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
13144 case KEY_pop: retsetpvs(";+", OP_POP);
13145 case KEY_shift: retsetpvs(";+", OP_SHIFT);
13146 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
13148 retsetpvs("+;$$@", OP_SPLICE);
13149 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
13151 case KEY_evalbytes:
13152 name = "entereval"; break;
13160 while (i < MAXO) { /* The slow way. */
13161 if (strEQ(name, PL_op_name[i])
13162 || strEQ(name, PL_op_desc[i]))
13164 if (nullret) { assert(opnum); *opnum = i; return NULL; }
13171 defgv = PL_opargs[i] & OA_DEFGV;
13172 oa = PL_opargs[i] >> OASHIFT;
13174 if (oa & OA_OPTIONAL && !seen_question && (
13175 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
13180 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
13181 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
13182 /* But globs are already references (kinda) */
13183 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
13187 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
13188 && !scalar_mod_type(NULL, i)) {
13193 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
13197 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
13198 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
13199 str[n-1] = '_'; defgv = 0;
13203 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
13205 sv_setpvn(sv, str, n - 1);
13206 if (opnum) *opnum = i;
13211 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
13214 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
13217 PERL_ARGS_ASSERT_CORESUB_OP;
13221 return op_append_elem(OP_LINESEQ,
13224 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
13228 case OP_SELECT: /* which represents OP_SSELECT as well */
13233 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
13234 newSVOP(OP_CONST, 0, newSVuv(1))
13236 coresub_op(newSVuv((UV)OP_SSELECT), 0,
13238 coresub_op(coreargssv, 0, OP_SELECT)
13242 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13244 return op_append_elem(
13247 opnum == OP_WANTARRAY || opnum == OP_RUNCV
13248 ? OPpOFFBYONE << 8 : 0)
13250 case OA_BASEOP_OR_UNOP:
13251 if (opnum == OP_ENTEREVAL) {
13252 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
13253 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
13255 else o = newUNOP(opnum,0,argop);
13256 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
13259 if (is_handle_constructor(o, 1))
13260 argop->op_private |= OPpCOREARGS_DEREF1;
13261 if (scalar_mod_type(NULL, opnum))
13262 argop->op_private |= OPpCOREARGS_SCALARMOD;
13266 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
13267 if (is_handle_constructor(o, 2))
13268 argop->op_private |= OPpCOREARGS_DEREF2;
13269 if (opnum == OP_SUBSTR) {
13270 o->op_private |= OPpMAYBE_LVSUB;
13279 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
13280 SV * const *new_const_svp)
13282 const char *hvname;
13283 bool is_const = !!CvCONST(old_cv);
13284 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
13286 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
13288 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
13290 /* They are 2 constant subroutines generated from
13291 the same constant. This probably means that
13292 they are really the "same" proxy subroutine
13293 instantiated in 2 places. Most likely this is
13294 when a constant is exported twice. Don't warn.
13297 (ckWARN(WARN_REDEFINE)
13299 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
13300 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
13301 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
13302 strEQ(hvname, "autouse"))
13306 && ckWARN_d(WARN_REDEFINE)
13307 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
13310 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
13312 ? "Constant subroutine %"SVf" redefined"
13313 : "Subroutine %"SVf" redefined",
13318 =head1 Hook manipulation
13320 These functions provide convenient and thread-safe means of manipulating
13327 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
13329 Puts a C function into the chain of check functions for a specified op
13330 type. This is the preferred way to manipulate the L</PL_check> array.
13331 I<opcode> specifies which type of op is to be affected. I<new_checker>
13332 is a pointer to the C function that is to be added to that opcode's
13333 check chain, and I<old_checker_p> points to the storage location where a
13334 pointer to the next function in the chain will be stored. The value of
13335 I<new_pointer> is written into the L</PL_check> array, while the value
13336 previously stored there is written to I<*old_checker_p>.
13338 The function should be defined like this:
13340 static OP *new_checker(pTHX_ OP *op) { ... }
13342 It is intended to be called in this manner:
13344 new_checker(aTHX_ op)
13346 I<old_checker_p> should be defined like this:
13348 static Perl_check_t old_checker_p;
13350 L</PL_check> is global to an entire process, and a module wishing to
13351 hook op checking may find itself invoked more than once per process,
13352 typically in different threads. To handle that situation, this function
13353 is idempotent. The location I<*old_checker_p> must initially (once
13354 per process) contain a null pointer. A C variable of static duration
13355 (declared at file scope, typically also marked C<static> to give
13356 it internal linkage) will be implicitly initialised appropriately,
13357 if it does not have an explicit initialiser. This function will only
13358 actually modify the check chain if it finds I<*old_checker_p> to be null.
13359 This function is also thread safe on the small scale. It uses appropriate
13360 locking to avoid race conditions in accessing L</PL_check>.
13362 When this function is called, the function referenced by I<new_checker>
13363 must be ready to be called, except for I<*old_checker_p> being unfilled.
13364 In a threading situation, I<new_checker> may be called immediately,
13365 even before this function has returned. I<*old_checker_p> will always
13366 be appropriately set before I<new_checker> is called. If I<new_checker>
13367 decides not to do anything special with an op that it is given (which
13368 is the usual case for most uses of op check hooking), it must chain the
13369 check function referenced by I<*old_checker_p>.
13371 If you want to influence compilation of calls to a specific subroutine,
13372 then use L</cv_set_call_checker> rather than hooking checking of all
13379 Perl_wrap_op_checker(pTHX_ Optype opcode,
13380 Perl_check_t new_checker, Perl_check_t *old_checker_p)
13384 PERL_UNUSED_CONTEXT;
13385 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
13386 if (*old_checker_p) return;
13387 OP_CHECK_MUTEX_LOCK;
13388 if (!*old_checker_p) {
13389 *old_checker_p = PL_check[opcode];
13390 PL_check[opcode] = new_checker;
13392 OP_CHECK_MUTEX_UNLOCK;
13397 /* Efficient sub that returns a constant scalar value. */
13399 const_sv_xsub(pTHX_ CV* cv)
13402 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
13403 PERL_UNUSED_ARG(items);
13413 const_av_xsub(pTHX_ CV* cv)
13416 AV * const av = MUTABLE_AV(XSANY.any_ptr);
13424 if (SvRMAGICAL(av))
13425 Perl_croak(aTHX_ "Magical list constants are not supported");
13426 if (GIMME_V != G_ARRAY) {
13428 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
13431 EXTEND(SP, AvFILLp(av)+1);
13432 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
13433 XSRETURN(AvFILLp(av)+1);
13438 * c-indentation-style: bsd
13439 * c-basic-offset: 4
13440 * indent-tabs-mode: nil
13443 * ex: set ts=8 sts=4 sw=4 et: