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 /* remove any leading "empty" ops from the op_next chain whose first
113 * node's address is stored in op_p. Store the updated address of the
114 * first node in op_p.
118 S_prune_chain_head(OP** op_p)
121 && ( (*op_p)->op_type == OP_NULL
122 || (*op_p)->op_type == OP_SCOPE
123 || (*op_p)->op_type == OP_SCALAR
124 || (*op_p)->op_type == OP_LINESEQ)
126 *op_p = (*op_p)->op_next;
130 /* See the explanatory comments above struct opslab in op.h. */
132 #ifdef PERL_DEBUG_READONLY_OPS
133 # define PERL_SLAB_SIZE 128
134 # define PERL_MAX_SLAB_SIZE 4096
135 # include <sys/mman.h>
138 #ifndef PERL_SLAB_SIZE
139 # define PERL_SLAB_SIZE 64
141 #ifndef PERL_MAX_SLAB_SIZE
142 # define PERL_MAX_SLAB_SIZE 2048
145 /* rounds up to nearest pointer */
146 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
147 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
150 S_new_slab(pTHX_ size_t sz)
152 #ifdef PERL_DEBUG_READONLY_OPS
153 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
154 PROT_READ|PROT_WRITE,
155 MAP_ANON|MAP_PRIVATE, -1, 0);
156 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
157 (unsigned long) sz, slab));
158 if (slab == MAP_FAILED) {
159 perror("mmap failed");
162 slab->opslab_size = (U16)sz;
164 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
167 /* The context is unused in non-Windows */
170 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
174 /* requires double parens and aTHX_ */
175 #define DEBUG_S_warn(args) \
177 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
181 Perl_Slab_Alloc(pTHX_ size_t sz)
189 /* We only allocate ops from the slab during subroutine compilation.
190 We find the slab via PL_compcv, hence that must be non-NULL. It could
191 also be pointing to a subroutine which is now fully set up (CvROOT()
192 pointing to the top of the optree for that sub), or a subroutine
193 which isn't using the slab allocator. If our sanity checks aren't met,
194 don't use a slab, but allocate the OP directly from the heap. */
195 if (!PL_compcv || CvROOT(PL_compcv)
196 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
198 o = (OP*)PerlMemShared_calloc(1, sz);
202 /* While the subroutine is under construction, the slabs are accessed via
203 CvSTART(), to avoid needing to expand PVCV by one pointer for something
204 unneeded at runtime. Once a subroutine is constructed, the slabs are
205 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
206 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
208 if (!CvSTART(PL_compcv)) {
210 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
211 CvSLABBED_on(PL_compcv);
212 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
214 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
216 opsz = SIZE_TO_PSIZE(sz);
217 sz = opsz + OPSLOT_HEADER_P;
219 /* The slabs maintain a free list of OPs. In particular, constant folding
220 will free up OPs, so it makes sense to re-use them where possible. A
221 freed up slot is used in preference to a new allocation. */
222 if (slab->opslab_freed) {
223 OP **too = &slab->opslab_freed;
225 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
226 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
227 DEBUG_S_warn((aTHX_ "Alas! too small"));
228 o = *(too = &o->op_next);
229 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
233 Zero(o, opsz, I32 *);
239 #define INIT_OPSLOT \
240 slot->opslot_slab = slab; \
241 slot->opslot_next = slab2->opslab_first; \
242 slab2->opslab_first = slot; \
243 o = &slot->opslot_op; \
246 /* The partially-filled slab is next in the chain. */
247 slab2 = slab->opslab_next ? slab->opslab_next : slab;
248 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
249 /* Remaining space is too small. */
251 /* If we can fit a BASEOP, add it to the free chain, so as not
253 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
254 slot = &slab2->opslab_slots;
256 o->op_type = OP_FREED;
257 o->op_next = slab->opslab_freed;
258 slab->opslab_freed = o;
261 /* Create a new slab. Make this one twice as big. */
262 slot = slab2->opslab_first;
263 while (slot->opslot_next) slot = slot->opslot_next;
264 slab2 = S_new_slab(aTHX_
265 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
267 : (DIFF(slab2, slot)+1)*2);
268 slab2->opslab_next = slab->opslab_next;
269 slab->opslab_next = slab2;
271 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
273 /* Create a new op slot */
274 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
275 assert(slot >= &slab2->opslab_slots);
276 if (DIFF(&slab2->opslab_slots, slot)
277 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
278 slot = &slab2->opslab_slots;
280 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
283 /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
285 assert(!o->op_sibling);
292 #ifdef PERL_DEBUG_READONLY_OPS
294 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
296 PERL_ARGS_ASSERT_SLAB_TO_RO;
298 if (slab->opslab_readonly) return;
299 slab->opslab_readonly = 1;
300 for (; slab; slab = slab->opslab_next) {
301 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
302 (unsigned long) slab->opslab_size, slab));*/
303 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
304 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
305 (unsigned long)slab->opslab_size, errno);
310 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
314 PERL_ARGS_ASSERT_SLAB_TO_RW;
316 if (!slab->opslab_readonly) return;
318 for (; slab2; slab2 = slab2->opslab_next) {
319 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
320 (unsigned long) size, slab2));*/
321 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
322 PROT_READ|PROT_WRITE)) {
323 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
324 (unsigned long)slab2->opslab_size, errno);
327 slab->opslab_readonly = 0;
331 # define Slab_to_rw(op) NOOP
334 /* This cannot possibly be right, but it was copied from the old slab
335 allocator, to which it was originally added, without explanation, in
338 # define PerlMemShared PerlMem
342 Perl_Slab_Free(pTHX_ void *op)
344 OP * const o = (OP *)op;
347 PERL_ARGS_ASSERT_SLAB_FREE;
349 if (!o->op_slabbed) {
351 PerlMemShared_free(op);
356 /* If this op is already freed, our refcount will get screwy. */
357 assert(o->op_type != OP_FREED);
358 o->op_type = OP_FREED;
359 o->op_next = slab->opslab_freed;
360 slab->opslab_freed = o;
361 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
362 OpslabREFCNT_dec_padok(slab);
366 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
368 const bool havepad = !!PL_comppad;
369 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
372 PAD_SAVE_SETNULLPAD();
379 Perl_opslab_free(pTHX_ OPSLAB *slab)
382 PERL_ARGS_ASSERT_OPSLAB_FREE;
384 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
385 assert(slab->opslab_refcnt == 1);
386 for (; slab; slab = slab2) {
387 slab2 = slab->opslab_next;
389 slab->opslab_refcnt = ~(size_t)0;
391 #ifdef PERL_DEBUG_READONLY_OPS
392 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
394 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
395 perror("munmap failed");
399 PerlMemShared_free(slab);
405 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
410 size_t savestack_count = 0;
412 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
415 for (slot = slab2->opslab_first;
417 slot = slot->opslot_next) {
418 if (slot->opslot_op.op_type != OP_FREED
419 && !(slot->opslot_op.op_savefree
425 assert(slot->opslot_op.op_slabbed);
426 op_free(&slot->opslot_op);
427 if (slab->opslab_refcnt == 1) goto free;
430 } while ((slab2 = slab2->opslab_next));
431 /* > 1 because the CV still holds a reference count. */
432 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
434 assert(savestack_count == slab->opslab_refcnt-1);
436 /* Remove the CV’s reference count. */
437 slab->opslab_refcnt--;
444 #ifdef PERL_DEBUG_READONLY_OPS
446 Perl_op_refcnt_inc(pTHX_ OP *o)
449 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
450 if (slab && slab->opslab_readonly) {
463 Perl_op_refcnt_dec(pTHX_ OP *o)
466 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
468 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
470 if (slab && slab->opslab_readonly) {
472 result = --o->op_targ;
475 result = --o->op_targ;
481 * In the following definition, the ", (OP*)0" is just to make the compiler
482 * think the expression is of the right type: croak actually does a Siglongjmp.
484 #define CHECKOP(type,o) \
485 ((PL_op_mask && PL_op_mask[type]) \
486 ? ( op_free((OP*)o), \
487 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
489 : PL_check[type](aTHX_ (OP*)o))
491 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
493 #define CHANGE_TYPE(o,type) \
495 o->op_type = (OPCODE)type; \
496 o->op_ppaddr = PL_ppaddr[type]; \
500 S_no_fh_allowed(pTHX_ OP *o)
502 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
504 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
510 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
512 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
513 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
518 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
520 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
522 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
527 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
529 PERL_ARGS_ASSERT_BAD_TYPE_PV;
531 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
532 (int)n, name, t, OP_DESC(kid)), flags);
536 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
538 SV * const namesv = cv_name((CV *)gv, NULL, 0);
539 PERL_ARGS_ASSERT_BAD_TYPE_GV;
541 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
542 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
546 S_no_bareword_allowed(pTHX_ OP *o)
548 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
550 qerror(Perl_mess(aTHX_
551 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
553 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
556 /* "register" allocation */
559 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
562 const bool is_our = (PL_parser->in_my == KEY_our);
564 PERL_ARGS_ASSERT_ALLOCMY;
566 if (flags & ~SVf_UTF8)
567 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
570 /* complain about "my $<special_var>" etc etc */
574 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
575 (name[1] == '_' && (*name == '$' || len > 2))))
577 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
578 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
579 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
580 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
581 PL_parser->in_my == KEY_state ? "state" : "my"));
583 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
584 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
587 else if (len == 2 && name[1] == '_' && !is_our)
588 /* diag_listed_as: Use of my $_ is experimental */
589 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
590 "Use of %s $_ is experimental",
591 PL_parser->in_my == KEY_state
595 /* allocate a spare slot and store the name in that slot */
597 off = pad_add_name_pvn(name, len,
598 (is_our ? padadd_OUR :
599 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
600 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
601 PL_parser->in_my_stash,
603 /* $_ is always in main::, even with our */
604 ? (PL_curstash && !memEQs(name,len,"$_")
610 /* anon sub prototypes contains state vars should always be cloned,
611 * otherwise the state var would be shared between anon subs */
613 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
614 CvCLONE_on(PL_compcv);
620 =head1 Optree Manipulation Functions
622 =for apidoc alloccopstash
624 Available only under threaded builds, this function allocates an entry in
625 C<PL_stashpad> for the stash passed to it.
632 Perl_alloccopstash(pTHX_ HV *hv)
634 PADOFFSET off = 0, o = 1;
635 bool found_slot = FALSE;
637 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
639 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
641 for (; o < PL_stashpadmax; ++o) {
642 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
643 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
644 found_slot = TRUE, off = o;
647 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
648 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
649 off = PL_stashpadmax;
650 PL_stashpadmax += 10;
653 PL_stashpad[PL_stashpadix = off] = hv;
658 /* free the body of an op without examining its contents.
659 * Always use this rather than FreeOp directly */
662 S_op_destroy(pTHX_ OP *o)
670 =for apidoc Am|void|op_free|OP *o
672 Free an op. Only use this when an op is no longer linked to from any
679 Perl_op_free(pTHX_ OP *o)
686 /* Though ops may be freed twice, freeing the op after its slab is a
688 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
689 /* During the forced freeing of ops after compilation failure, kidops
690 may be freed before their parents. */
691 if (!o || o->op_type == OP_FREED)
696 /* an op should only ever acquire op_private flags that we know about.
697 * If this fails, you may need to fix something in regen/op_private */
698 assert(!(o->op_private & ~PL_op_private_valid[type]));
700 if (o->op_private & OPpREFCOUNTED) {
711 refcnt = OpREFCNT_dec(o);
714 /* Need to find and remove any pattern match ops from the list
715 we maintain for reset(). */
716 find_and_forget_pmops(o);
726 /* Call the op_free hook if it has been set. Do it now so that it's called
727 * at the right time for refcounted ops, but still before all of the kids
731 if (o->op_flags & OPf_KIDS) {
733 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
734 nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
739 type = (OPCODE)o->op_targ;
742 Slab_to_rw(OpSLAB(o));
744 /* COP* is not cleared by op_clear() so that we may track line
745 * numbers etc even after null() */
746 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
752 #ifdef DEBUG_LEAKING_SCALARS
759 Perl_op_clear(pTHX_ OP *o)
764 PERL_ARGS_ASSERT_OP_CLEAR;
766 switch (o->op_type) {
767 case OP_NULL: /* Was holding old type, if any. */
770 case OP_ENTEREVAL: /* Was holding hints. */
774 if (!(o->op_flags & OPf_REF)
775 || (PL_check[o->op_type] != Perl_ck_ftst))
782 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
787 /* It's possible during global destruction that the GV is freed
788 before the optree. Whilst the SvREFCNT_inc is happy to bump from
789 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
790 will trigger an assertion failure, because the entry to sv_clear
791 checks that the scalar is not already freed. A check of for
792 !SvIS_FREED(gv) turns out to be invalid, because during global
793 destruction the reference count can be forced down to zero
794 (with SVf_BREAK set). In which case raising to 1 and then
795 dropping to 0 triggers cleanup before it should happen. I
796 *think* that this might actually be a general, systematic,
797 weakness of the whole idea of SVf_BREAK, in that code *is*
798 allowed to raise and lower references during global destruction,
799 so any *valid* code that happens to do this during global
800 destruction might well trigger premature cleanup. */
801 bool still_valid = gv && SvREFCNT(gv);
804 SvREFCNT_inc_simple_void(gv);
806 if (cPADOPo->op_padix > 0) {
807 pad_swipe(cPADOPo->op_padix, TRUE);
808 cPADOPo->op_padix = 0;
811 SvREFCNT_dec(cSVOPo->op_sv);
812 cSVOPo->op_sv = NULL;
815 int try_downgrade = SvREFCNT(gv) == 2;
818 gv_try_downgrade(gv);
822 case OP_METHOD_NAMED:
823 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
824 cMETHOPx(o)->op_u.op_meth_sv = NULL;
827 pad_swipe(o->op_targ, 1);
834 SvREFCNT_dec(cSVOPo->op_sv);
835 cSVOPo->op_sv = NULL;
838 Even if op_clear does a pad_free for the target of the op,
839 pad_free doesn't actually remove the sv that exists in the pad;
840 instead it lives on. This results in that it could be reused as
841 a target later on when the pad was reallocated.
844 pad_swipe(o->op_targ,1);
854 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
859 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
860 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
862 if (cPADOPo->op_padix > 0) {
863 pad_swipe(cPADOPo->op_padix, TRUE);
864 cPADOPo->op_padix = 0;
867 SvREFCNT_dec(cSVOPo->op_sv);
868 cSVOPo->op_sv = NULL;
872 PerlMemShared_free(cPVOPo->op_pv);
873 cPVOPo->op_pv = NULL;
877 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
881 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
882 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
885 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
891 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
892 op_free(cPMOPo->op_code_list);
893 cPMOPo->op_code_list = NULL;
895 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
896 /* we use the same protection as the "SAFE" version of the PM_ macros
897 * here since sv_clean_all might release some PMOPs
898 * after PL_regex_padav has been cleared
899 * and the clearing of PL_regex_padav needs to
900 * happen before sv_clean_all
903 if(PL_regex_pad) { /* We could be in destruction */
904 const IV offset = (cPMOPo)->op_pmoffset;
905 ReREFCNT_dec(PM_GETRE(cPMOPo));
906 PL_regex_pad[offset] = &PL_sv_undef;
907 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
911 ReREFCNT_dec(PM_GETRE(cPMOPo));
912 PM_SETRE(cPMOPo, NULL);
918 if (o->op_targ > 0) {
919 pad_free(o->op_targ);
925 S_cop_free(pTHX_ COP* cop)
927 PERL_ARGS_ASSERT_COP_FREE;
930 if (! specialWARN(cop->cop_warnings))
931 PerlMemShared_free(cop->cop_warnings);
932 cophh_free(CopHINTHASH_get(cop));
933 if (PL_curcop == cop)
938 S_forget_pmop(pTHX_ PMOP *const o
941 HV * const pmstash = PmopSTASH(o);
943 PERL_ARGS_ASSERT_FORGET_PMOP;
945 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
946 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
948 PMOP **const array = (PMOP**) mg->mg_ptr;
949 U32 count = mg->mg_len / sizeof(PMOP**);
954 /* Found it. Move the entry at the end to overwrite it. */
955 array[i] = array[--count];
956 mg->mg_len = count * sizeof(PMOP**);
957 /* Could realloc smaller at this point always, but probably
958 not worth it. Probably worth free()ing if we're the
961 Safefree(mg->mg_ptr);
974 S_find_and_forget_pmops(pTHX_ OP *o)
976 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
978 if (o->op_flags & OPf_KIDS) {
979 OP *kid = cUNOPo->op_first;
981 switch (kid->op_type) {
986 forget_pmop((PMOP*)kid);
988 find_and_forget_pmops(kid);
989 kid = OP_SIBLING(kid);
995 =for apidoc Am|void|op_null|OP *o
997 Neutralizes an op when it is no longer needed, but is still linked to from
1004 Perl_op_null(pTHX_ OP *o)
1008 PERL_ARGS_ASSERT_OP_NULL;
1010 if (o->op_type == OP_NULL)
1013 o->op_targ = o->op_type;
1014 o->op_type = OP_NULL;
1015 o->op_ppaddr = PL_ppaddr[OP_NULL];
1019 Perl_op_refcnt_lock(pTHX)
1024 PERL_UNUSED_CONTEXT;
1029 Perl_op_refcnt_unlock(pTHX)
1034 PERL_UNUSED_CONTEXT;
1040 =for apidoc op_sibling_splice
1042 A general function for editing the structure of an existing chain of
1043 op_sibling nodes. By analogy with the perl-level splice() function, allows
1044 you to delete zero or more sequential nodes, replacing them with zero or
1045 more different nodes. Performs the necessary op_first/op_last
1046 housekeeping on the parent node and op_sibling manipulation on the
1047 children. The last deleted node will be marked as as the last node by
1048 updating the op_sibling or op_lastsib field as appropriate.
1050 Note that op_next is not manipulated, and nodes are not freed; that is the
1051 responsibility of the caller. It also won't create a new list op for an
1052 empty list etc; use higher-level functions like op_append_elem() for that.
1054 parent is the parent node of the sibling chain.
1056 start is the node preceding the first node to be spliced. Node(s)
1057 following it will be deleted, and ops will be inserted after it. If it is
1058 NULL, the first node onwards is deleted, and nodes are inserted at the
1061 del_count is the number of nodes to delete. If zero, no nodes are deleted.
1062 If -1 or greater than or equal to the number of remaining kids, all
1063 remaining kids are deleted.
1065 insert is the first of a chain of nodes to be inserted in place of the nodes.
1066 If NULL, no nodes are inserted.
1068 The head of the chain of deleted ops is returned, or NULL if no ops were
1073 action before after returns
1074 ------ ----- ----- -------
1077 splice(P, A, 2, X-Y-Z) | | B-C
1081 splice(P, NULL, 1, X-Y) | | A
1085 splice(P, NULL, 3, NULL) | | A-B-C
1089 splice(P, B, 0, X-Y) | | NULL
1096 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1098 OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1100 OP *last_del = NULL;
1101 OP *last_ins = NULL;
1103 PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1105 assert(del_count >= -1);
1107 if (del_count && first) {
1109 while (--del_count && OP_HAS_SIBLING(last_del))
1110 last_del = OP_SIBLING(last_del);
1111 rest = OP_SIBLING(last_del);
1112 OP_SIBLING_set(last_del, NULL);
1113 last_del->op_lastsib = 1;
1120 while (OP_HAS_SIBLING(last_ins))
1121 last_ins = OP_SIBLING(last_ins);
1122 OP_SIBLING_set(last_ins, rest);
1123 last_ins->op_lastsib = rest ? 0 : 1;
1129 OP_SIBLING_set(start, insert);
1130 start->op_lastsib = insert ? 0 : 1;
1133 cLISTOPx(parent)->op_first = insert;
1136 /* update op_last etc */
1137 U32 type = parent->op_type;
1140 if (type == OP_NULL)
1141 type = parent->op_targ;
1142 type = PL_opargs[type] & OA_CLASS_MASK;
1144 lastop = last_ins ? last_ins : start ? start : NULL;
1145 if ( type == OA_BINOP
1146 || type == OA_LISTOP
1150 cLISTOPx(parent)->op_last = lastop;
1153 lastop->op_lastsib = 1;
1154 #ifdef PERL_OP_PARENT
1155 lastop->op_sibling = parent;
1159 return last_del ? first : NULL;
1163 =for apidoc op_parent
1165 returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1166 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1173 Perl_op_parent(OP *o)
1175 PERL_ARGS_ASSERT_OP_PARENT;
1176 #ifdef PERL_OP_PARENT
1177 while (OP_HAS_SIBLING(o))
1179 return o->op_sibling;
1187 /* replace the sibling following start with a new UNOP, which becomes
1188 * the parent of the original sibling; e.g.
1190 * op_sibling_newUNOP(P, A, unop-args...)
1198 * where U is the new UNOP.
1200 * parent and start args are the same as for op_sibling_splice();
1201 * type and flags args are as newUNOP().
1203 * Returns the new UNOP.
1207 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1211 kid = op_sibling_splice(parent, start, 1, NULL);
1212 newop = newUNOP(type, flags, kid);
1213 op_sibling_splice(parent, start, 0, newop);
1218 /* lowest-level newLOGOP-style function - just allocates and populates
1219 * the struct. Higher-level stuff should be done by S_new_logop() /
1220 * newLOGOP(). This function exists mainly to avoid op_first assignment
1221 * being spread throughout this file.
1225 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1229 NewOp(1101, logop, 1, LOGOP);
1230 logop->op_type = (OPCODE)type;
1231 logop->op_first = first;
1232 logop->op_other = other;
1233 logop->op_flags = OPf_KIDS;
1234 while (kid && OP_HAS_SIBLING(kid))
1235 kid = OP_SIBLING(kid);
1237 kid->op_lastsib = 1;
1238 #ifdef PERL_OP_PARENT
1239 kid->op_sibling = (OP*)logop;
1246 /* Contextualizers */
1249 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1251 Applies a syntactic context to an op tree representing an expression.
1252 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1253 or C<G_VOID> to specify the context to apply. The modified op tree
1260 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1262 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1264 case G_SCALAR: return scalar(o);
1265 case G_ARRAY: return list(o);
1266 case G_VOID: return scalarvoid(o);
1268 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1275 =for apidoc Am|OP*|op_linklist|OP *o
1276 This function is the implementation of the L</LINKLIST> macro. It should
1277 not be called directly.
1283 Perl_op_linklist(pTHX_ OP *o)
1287 PERL_ARGS_ASSERT_OP_LINKLIST;
1292 /* establish postfix order */
1293 first = cUNOPo->op_first;
1296 o->op_next = LINKLIST(first);
1299 OP *sibl = OP_SIBLING(kid);
1301 kid->op_next = LINKLIST(sibl);
1316 S_scalarkids(pTHX_ OP *o)
1318 if (o && o->op_flags & OPf_KIDS) {
1320 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1327 S_scalarboolean(pTHX_ OP *o)
1329 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1331 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1332 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1333 if (ckWARN(WARN_SYNTAX)) {
1334 const line_t oldline = CopLINE(PL_curcop);
1336 if (PL_parser && PL_parser->copline != NOLINE) {
1337 /* This ensures that warnings are reported at the first line
1338 of the conditional, not the last. */
1339 CopLINE_set(PL_curcop, PL_parser->copline);
1341 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1342 CopLINE_set(PL_curcop, oldline);
1349 S_op_varname(pTHX_ const OP *o)
1352 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1353 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1355 const char funny = o->op_type == OP_PADAV
1356 || o->op_type == OP_RV2AV ? '@' : '%';
1357 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1359 if (cUNOPo->op_first->op_type != OP_GV
1360 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1362 return varname(gv, funny, 0, NULL, 0, 1);
1365 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1370 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1371 { /* or not so pretty :-) */
1372 if (o->op_type == OP_CONST) {
1374 if (SvPOK(*retsv)) {
1376 *retsv = sv_newmortal();
1377 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1378 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1380 else if (!SvOK(*retsv))
1383 else *retpv = "...";
1387 S_scalar_slice_warning(pTHX_ const OP *o)
1391 o->op_type == OP_HSLICE ? '{' : '[';
1393 o->op_type == OP_HSLICE ? '}' : ']';
1395 SV *keysv = NULL; /* just to silence compiler warnings */
1396 const char *key = NULL;
1398 if (!(o->op_private & OPpSLICEWARNING))
1400 if (PL_parser && PL_parser->error_count)
1401 /* This warning can be nonsensical when there is a syntax error. */
1404 kid = cLISTOPo->op_first;
1405 kid = OP_SIBLING(kid); /* get past pushmark */
1406 /* weed out false positives: any ops that can return lists */
1407 switch (kid->op_type) {
1436 /* Don't warn if we have a nulled list either. */
1437 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1440 assert(OP_SIBLING(kid));
1441 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1442 if (!name) /* XS module fiddling with the op tree */
1444 S_op_pretty(aTHX_ kid, &keysv, &key);
1445 assert(SvPOK(name));
1446 sv_chop(name,SvPVX(name)+1);
1448 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1449 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1450 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1452 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1453 lbrack, key, rbrack);
1455 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1456 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1457 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1459 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1460 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1464 Perl_scalar(pTHX_ OP *o)
1468 /* assumes no premature commitment */
1469 if (!o || (PL_parser && PL_parser->error_count)
1470 || (o->op_flags & OPf_WANT)
1471 || o->op_type == OP_RETURN)
1476 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1478 switch (o->op_type) {
1480 scalar(cBINOPo->op_first);
1485 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1495 if (o->op_flags & OPf_KIDS) {
1496 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1502 kid = cLISTOPo->op_first;
1504 kid = OP_SIBLING(kid);
1507 OP *sib = OP_SIBLING(kid);
1508 if (sib && kid->op_type != OP_LEAVEWHEN)
1514 PL_curcop = &PL_compiling;
1519 kid = cLISTOPo->op_first;
1522 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1527 /* Warn about scalar context */
1528 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1529 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1532 const char *key = NULL;
1534 /* This warning can be nonsensical when there is a syntax error. */
1535 if (PL_parser && PL_parser->error_count)
1538 if (!ckWARN(WARN_SYNTAX)) break;
1540 kid = cLISTOPo->op_first;
1541 kid = OP_SIBLING(kid); /* get past pushmark */
1542 assert(OP_SIBLING(kid));
1543 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1544 if (!name) /* XS module fiddling with the op tree */
1546 S_op_pretty(aTHX_ kid, &keysv, &key);
1547 assert(SvPOK(name));
1548 sv_chop(name,SvPVX(name)+1);
1550 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1551 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1552 "%%%"SVf"%c%s%c in scalar context better written "
1554 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1555 lbrack, key, rbrack);
1557 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1558 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1559 "%%%"SVf"%c%"SVf"%c in scalar context better "
1560 "written as $%"SVf"%c%"SVf"%c",
1561 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1562 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1569 Perl_scalarvoid(pTHX_ OP *o)
1573 SV *useless_sv = NULL;
1574 const char* useless = NULL;
1578 PERL_ARGS_ASSERT_SCALARVOID;
1580 if (o->op_type == OP_NEXTSTATE
1581 || o->op_type == OP_DBSTATE
1582 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1583 || o->op_targ == OP_DBSTATE)))
1584 PL_curcop = (COP*)o; /* for warning below */
1586 /* assumes no premature commitment */
1587 want = o->op_flags & OPf_WANT;
1588 if ((want && want != OPf_WANT_SCALAR)
1589 || (PL_parser && PL_parser->error_count)
1590 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1595 if ((o->op_private & OPpTARGET_MY)
1596 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1598 return scalar(o); /* As if inside SASSIGN */
1601 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1603 switch (o->op_type) {
1605 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1609 if (o->op_flags & OPf_STACKED)
1613 if (o->op_private == 4)
1638 case OP_AELEMFAST_LEX:
1659 case OP_GETSOCKNAME:
1660 case OP_GETPEERNAME:
1665 case OP_GETPRIORITY:
1690 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1691 /* Otherwise it's "Useless use of grep iterator" */
1692 useless = OP_DESC(o);
1696 kid = cLISTOPo->op_first;
1697 if (kid && kid->op_type == OP_PUSHRE
1699 && !(o->op_flags & OPf_STACKED)
1701 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1703 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1705 useless = OP_DESC(o);
1709 kid = cUNOPo->op_first;
1710 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1711 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1714 useless = "negative pattern binding (!~)";
1718 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1719 useless = "non-destructive substitution (s///r)";
1723 useless = "non-destructive transliteration (tr///r)";
1730 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1731 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1732 useless = "a variable";
1737 if (cSVOPo->op_private & OPpCONST_STRICT)
1738 no_bareword_allowed(o);
1740 if (ckWARN(WARN_VOID)) {
1742 /* don't warn on optimised away booleans, eg
1743 * use constant Foo, 5; Foo || print; */
1744 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1746 /* the constants 0 and 1 are permitted as they are
1747 conventionally used as dummies in constructs like
1748 1 while some_condition_with_side_effects; */
1749 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1751 else if (SvPOK(sv)) {
1752 SV * const dsv = newSVpvs("");
1754 = Perl_newSVpvf(aTHX_
1756 pv_pretty(dsv, SvPVX_const(sv),
1757 SvCUR(sv), 32, NULL, NULL,
1759 | PERL_PV_ESCAPE_NOCLEAR
1760 | PERL_PV_ESCAPE_UNI_DETECT));
1761 SvREFCNT_dec_NN(dsv);
1763 else if (SvOK(sv)) {
1764 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1767 useless = "a constant (undef)";
1770 op_null(o); /* don't execute or even remember it */
1774 o->op_type = OP_PREINC; /* pre-increment is faster */
1775 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1779 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1780 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1784 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1785 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1789 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1790 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1795 UNOP *refgen, *rv2cv;
1798 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1801 rv2gv = ((BINOP *)o)->op_last;
1802 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1805 refgen = (UNOP *)((BINOP *)o)->op_first;
1807 if (!refgen || (refgen->op_type != OP_REFGEN
1808 && refgen->op_type != OP_SREFGEN))
1811 exlist = (LISTOP *)refgen->op_first;
1812 if (!exlist || exlist->op_type != OP_NULL
1813 || exlist->op_targ != OP_LIST)
1816 if (exlist->op_first->op_type != OP_PUSHMARK
1817 && exlist->op_first != exlist->op_last)
1820 rv2cv = (UNOP*)exlist->op_last;
1822 if (rv2cv->op_type != OP_RV2CV)
1825 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1826 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1827 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1829 o->op_private |= OPpASSIGN_CV_TO_GV;
1830 rv2gv->op_private |= OPpDONT_INIT_GV;
1831 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1843 kid = cLOGOPo->op_first;
1844 if (kid->op_type == OP_NOT
1845 && (kid->op_flags & OPf_KIDS)) {
1846 if (o->op_type == OP_AND) {
1848 o->op_ppaddr = PL_ppaddr[OP_OR];
1850 o->op_type = OP_AND;
1851 o->op_ppaddr = PL_ppaddr[OP_AND];
1861 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1866 if (o->op_flags & OPf_STACKED)
1873 if (!(o->op_flags & OPf_KIDS))
1884 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1895 /* mortalise it, in case warnings are fatal. */
1896 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1897 "Useless use of %"SVf" in void context",
1898 SVfARG(sv_2mortal(useless_sv)));
1901 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1902 "Useless use of %s in void context",
1909 S_listkids(pTHX_ OP *o)
1911 if (o && o->op_flags & OPf_KIDS) {
1913 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1920 Perl_list(pTHX_ OP *o)
1924 /* assumes no premature commitment */
1925 if (!o || (o->op_flags & OPf_WANT)
1926 || (PL_parser && PL_parser->error_count)
1927 || o->op_type == OP_RETURN)
1932 if ((o->op_private & OPpTARGET_MY)
1933 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1935 return o; /* As if inside SASSIGN */
1938 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1940 switch (o->op_type) {
1943 list(cBINOPo->op_first);
1948 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1956 if (!(o->op_flags & OPf_KIDS))
1958 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1959 list(cBINOPo->op_first);
1960 return gen_constant_list(o);
1967 kid = cLISTOPo->op_first;
1969 kid = OP_SIBLING(kid);
1972 OP *sib = OP_SIBLING(kid);
1973 if (sib && kid->op_type != OP_LEAVEWHEN)
1979 PL_curcop = &PL_compiling;
1983 kid = cLISTOPo->op_first;
1990 S_scalarseq(pTHX_ OP *o)
1993 const OPCODE type = o->op_type;
1995 if (type == OP_LINESEQ || type == OP_SCOPE ||
1996 type == OP_LEAVE || type == OP_LEAVETRY)
1999 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2000 if (OP_HAS_SIBLING(kid)) {
2004 PL_curcop = &PL_compiling;
2006 o->op_flags &= ~OPf_PARENS;
2007 if (PL_hints & HINT_BLOCK_SCOPE)
2008 o->op_flags |= OPf_PARENS;
2011 o = newOP(OP_STUB, 0);
2016 S_modkids(pTHX_ OP *o, I32 type)
2018 if (o && o->op_flags & OPf_KIDS) {
2020 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2021 op_lvalue(kid, type);
2027 =for apidoc finalize_optree
2029 This function finalizes the optree. Should be called directly after
2030 the complete optree is built. It does some additional
2031 checking which can't be done in the normal ck_xxx functions and makes
2032 the tree thread-safe.
2037 Perl_finalize_optree(pTHX_ OP* o)
2039 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2042 SAVEVPTR(PL_curcop);
2050 /* Relocate sv to the pad for thread safety.
2051 * Despite being a "constant", the SV is written to,
2052 * for reference counts, sv_upgrade() etc. */
2053 PERL_STATIC_INLINE void
2054 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2057 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2059 ix = pad_alloc(OP_CONST, SVf_READONLY);
2060 SvREFCNT_dec(PAD_SVl(ix));
2061 PAD_SETSV(ix, *svp);
2062 /* XXX I don't know how this isn't readonly already. */
2063 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2071 S_finalize_op(pTHX_ OP* o)
2073 PERL_ARGS_ASSERT_FINALIZE_OP;
2076 switch (o->op_type) {
2079 PL_curcop = ((COP*)o); /* for warnings */
2082 if (OP_HAS_SIBLING(o)) {
2083 OP *sib = OP_SIBLING(o);
2084 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2085 && ckWARN(WARN_EXEC)
2086 && OP_HAS_SIBLING(sib))
2088 const OPCODE type = OP_SIBLING(sib)->op_type;
2089 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2090 const line_t oldline = CopLINE(PL_curcop);
2091 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2092 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2093 "Statement unlikely to be reached");
2094 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2095 "\t(Maybe you meant system() when you said exec()?)\n");
2096 CopLINE_set(PL_curcop, oldline);
2103 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2104 GV * const gv = cGVOPo_gv;
2105 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2106 /* XXX could check prototype here instead of just carping */
2107 SV * const sv = sv_newmortal();
2108 gv_efullname3(sv, gv, NULL);
2109 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2110 "%"SVf"() called too early to check prototype",
2117 if (cSVOPo->op_private & OPpCONST_STRICT)
2118 no_bareword_allowed(o);
2122 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2127 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2128 case OP_METHOD_NAMED:
2129 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2141 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2144 rop = (UNOP*)((BINOP*)o)->op_first;
2149 S_scalar_slice_warning(aTHX_ o);
2153 kid = OP_SIBLING(cLISTOPo->op_first);
2154 if (/* I bet there's always a pushmark... */
2155 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2156 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2161 key_op = (SVOP*)(kid->op_type == OP_CONST
2163 : OP_SIBLING(kLISTOP->op_first));
2165 rop = (UNOP*)((LISTOP*)o)->op_last;
2168 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2170 else if (rop->op_first->op_type == OP_PADSV)
2171 /* @$hash{qw(keys here)} */
2172 rop = (UNOP*)rop->op_first;
2174 /* @{$hash}{qw(keys here)} */
2175 if (rop->op_first->op_type == OP_SCOPE
2176 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2178 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2184 lexname = NULL; /* just to silence compiler warnings */
2185 fields = NULL; /* just to silence compiler warnings */
2189 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2190 SvPAD_TYPED(lexname))
2191 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2192 && isGV(*fields) && GvHV(*fields);
2194 key_op = (SVOP*)OP_SIBLING(key_op)) {
2196 if (key_op->op_type != OP_CONST)
2198 svp = cSVOPx_svp(key_op);
2200 /* Make the CONST have a shared SV */
2201 if ((!SvIsCOW_shared_hash(sv = *svp))
2202 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2204 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2205 SV *nsv = newSVpvn_share(key,
2206 SvUTF8(sv) ? -keylen : keylen, 0);
2207 SvREFCNT_dec_NN(sv);
2212 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2213 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2214 "in variable %"SVf" of type %"HEKf,
2215 SVfARG(*svp), SVfARG(lexname),
2216 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2222 S_scalar_slice_warning(aTHX_ o);
2226 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2227 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2234 if (o->op_flags & OPf_KIDS) {
2238 /* check that op_last points to the last sibling, and that
2239 * the last op_sibling field points back to the parent, and
2240 * that the only ops with KIDS are those which are entitled to
2242 U32 type = o->op_type;
2246 if (type == OP_NULL) {
2248 /* ck_glob creates a null UNOP with ex-type GLOB
2249 * (which is a list op. So pretend it wasn't a listop */
2250 if (type == OP_GLOB)
2253 family = PL_opargs[type] & OA_CLASS_MASK;
2255 has_last = ( family == OA_BINOP
2256 || family == OA_LISTOP
2257 || family == OA_PMOP
2258 || family == OA_LOOP
2260 assert( has_last /* has op_first and op_last, or ...
2261 ... has (or may have) op_first: */
2262 || family == OA_UNOP
2263 || family == OA_LOGOP
2264 || family == OA_BASEOP_OR_UNOP
2265 || family == OA_FILESTATOP
2266 || family == OA_LOOPEXOP
2267 || family == OA_METHOP
2268 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2269 || type == OP_SASSIGN
2270 || type == OP_CUSTOM
2271 || type == OP_NULL /* new_logop does this */
2273 /* XXX list form of 'x' is has a null op_last. This is wrong,
2274 * but requires too much hacking (e.g. in Deparse) to fix for
2276 if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2281 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2282 # ifdef PERL_OP_PARENT
2283 if (!OP_HAS_SIBLING(kid)) {
2285 assert(kid == cLISTOPo->op_last);
2286 assert(kid->op_sibling == o);
2289 if (OP_HAS_SIBLING(kid)) {
2290 assert(!kid->op_lastsib);
2293 assert(kid->op_lastsib);
2295 assert(kid == cLISTOPo->op_last);
2301 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2307 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2309 Propagate lvalue ("modifiable") context to an op and its children.
2310 I<type> represents the context type, roughly based on the type of op that
2311 would do the modifying, although C<local()> is represented by OP_NULL,
2312 because it has no op type of its own (it is signalled by a flag on
2315 This function detects things that can't be modified, such as C<$x+1>, and
2316 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2317 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2319 It also flags things that need to behave specially in an lvalue context,
2320 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2326 S_vivifies(const OPCODE type)
2329 case OP_RV2AV: case OP_ASLICE:
2330 case OP_RV2HV: case OP_KVASLICE:
2331 case OP_RV2SV: case OP_HSLICE:
2332 case OP_AELEMFAST: case OP_KVHSLICE:
2341 S_lvref(pTHX_ OP *o, I32 type)
2344 switch (o->op_type) {
2346 for (kid = OP_SIBLING(cUNOPo->op_first); kid;
2347 kid = OP_SIBLING(kid))
2348 S_lvref(aTHX_ kid, type);
2353 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2354 o->op_flags |= OPf_STACKED;
2355 if (o->op_flags & OPf_PARENS) {
2356 if (o->op_private & OPpLVAL_INTRO) {
2357 /* diag_listed_as: Can't modify %s in %s */
2358 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2359 "localized parenthesized array in list assignment"));
2363 o->op_type = OP_LVAVREF;
2364 o->op_ppaddr = PL_ppaddr[OP_LVAVREF];
2365 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2366 o->op_flags |= OPf_MOD|OPf_REF;
2369 o->op_private |= OPpLVREF_AV;
2372 kid = cUNOPo->op_first;
2373 if (kid->op_type == OP_NULL)
2374 kid = cUNOPx(kUNOP->op_first->op_sibling)
2376 o->op_private = OPpLVREF_CV;
2377 if (kid->op_type == OP_GV)
2378 o->op_flags |= OPf_STACKED;
2379 else if (kid->op_type == OP_PADCV) {
2380 o->op_targ = kid->op_targ;
2382 op_free(cUNOPo->op_first);
2383 cUNOPo->op_first = NULL;
2384 o->op_flags &=~ OPf_KIDS;
2389 if (o->op_flags & OPf_PARENS) {
2391 /* diag_listed_as: Can't modify %s in %s */
2392 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2393 "parenthesized hash in list assignment"));
2396 o->op_private |= OPpLVREF_HV;
2400 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2401 o->op_flags |= OPf_STACKED;
2404 if (o->op_flags & OPf_PARENS) goto parenhash;
2405 o->op_private |= OPpLVREF_HV;
2408 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2411 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2412 if (o->op_flags & OPf_PARENS) goto slurpy;
2413 o->op_private |= OPpLVREF_AV;
2417 o->op_private |= OPpLVREF_ELEM;
2418 o->op_flags |= OPf_STACKED;
2422 o->op_type = OP_LVREFSLICE;
2423 o->op_ppaddr = PL_ppaddr[OP_LVREFSLICE];
2424 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2427 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2429 else if (!(o->op_flags & OPf_KIDS))
2431 if (o->op_targ != OP_LIST) {
2432 S_lvref(aTHX_ cBINOPo->op_first, type);
2437 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2438 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2439 S_lvref(aTHX_ kid, type);
2443 if (o->op_flags & OPf_PARENS)
2448 /* diag_listed_as: Can't modify %s in %s */
2449 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2450 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2456 o->op_type = OP_LVREF;
2457 o->op_ppaddr = PL_ppaddr[OP_LVREF];
2459 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2460 if (type == OP_ENTERLOOP)
2461 o->op_private |= OPpLVREF_ITER;
2465 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2469 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2472 if (!o || (PL_parser && PL_parser->error_count))
2475 if ((o->op_private & OPpTARGET_MY)
2476 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2481 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2483 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2485 switch (o->op_type) {
2490 if ((o->op_flags & OPf_PARENS))
2494 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2495 !(o->op_flags & OPf_STACKED)) {
2496 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2497 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2498 assert(cUNOPo->op_first->op_type == OP_NULL);
2499 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2502 else { /* lvalue subroutine call */
2503 o->op_private |= OPpLVAL_INTRO;
2504 PL_modcount = RETURN_UNLIMITED_NUMBER;
2505 if (type == OP_GREPSTART || type == OP_ENTERSUB
2506 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
2507 /* Potential lvalue context: */
2508 o->op_private |= OPpENTERSUB_INARGS;
2511 else { /* Compile-time error message: */
2512 OP *kid = cUNOPo->op_first;
2516 if (kid->op_type != OP_PUSHMARK) {
2517 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2519 "panic: unexpected lvalue entersub "
2520 "args: type/targ %ld:%"UVuf,
2521 (long)kid->op_type, (UV)kid->op_targ);
2522 kid = kLISTOP->op_first;
2524 while (OP_HAS_SIBLING(kid))
2525 kid = OP_SIBLING(kid);
2526 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2527 break; /* Postpone until runtime */
2530 kid = kUNOP->op_first;
2531 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2532 kid = kUNOP->op_first;
2533 if (kid->op_type == OP_NULL)
2535 "Unexpected constant lvalue entersub "
2536 "entry via type/targ %ld:%"UVuf,
2537 (long)kid->op_type, (UV)kid->op_targ);
2538 if (kid->op_type != OP_GV) {
2545 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2546 ? MUTABLE_CV(SvRV(gv))
2557 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2558 /* grep, foreach, subcalls, refgen */
2559 if (type == OP_GREPSTART || type == OP_ENTERSUB
2560 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2562 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2563 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2565 : (o->op_type == OP_ENTERSUB
2566 ? "non-lvalue subroutine call"
2568 type ? PL_op_desc[type] : "local"));
2582 case OP_RIGHT_SHIFT:
2591 if (!(o->op_flags & OPf_STACKED))
2598 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2599 op_lvalue(kid, type);
2604 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2605 PL_modcount = RETURN_UNLIMITED_NUMBER;
2606 return o; /* Treat \(@foo) like ordinary list. */
2610 if (scalar_mod_type(o, type))
2612 ref(cUNOPo->op_first, o->op_type);
2619 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2620 if (type == OP_LEAVESUBLV && (
2621 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2622 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2624 o->op_private |= OPpMAYBE_LVSUB;
2628 PL_modcount = RETURN_UNLIMITED_NUMBER;
2632 if (type == OP_LEAVESUBLV)
2633 o->op_private |= OPpMAYBE_LVSUB;
2636 PL_hints |= HINT_BLOCK_SCOPE;
2637 if (type == OP_LEAVESUBLV)
2638 o->op_private |= OPpMAYBE_LVSUB;
2642 ref(cUNOPo->op_first, o->op_type);
2646 PL_hints |= HINT_BLOCK_SCOPE;
2656 case OP_AELEMFAST_LEX:
2663 PL_modcount = RETURN_UNLIMITED_NUMBER;
2664 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2665 return o; /* Treat \(@foo) like ordinary list. */
2666 if (scalar_mod_type(o, type))
2668 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2669 && type == OP_LEAVESUBLV)
2670 o->op_private |= OPpMAYBE_LVSUB;
2674 if (!type) /* local() */
2675 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2676 PAD_COMPNAME_SV(o->op_targ));
2685 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2689 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2695 if (type == OP_LEAVESUBLV)
2696 o->op_private |= OPpMAYBE_LVSUB;
2697 if (o->op_flags & OPf_KIDS)
2698 op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2703 ref(cBINOPo->op_first, o->op_type);
2704 if (type == OP_ENTERSUB &&
2705 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2706 o->op_private |= OPpLVAL_DEFER;
2707 if (type == OP_LEAVESUBLV)
2708 o->op_private |= OPpMAYBE_LVSUB;
2715 o->op_private |= OPpLVALUE;
2721 if (o->op_flags & OPf_KIDS)
2722 op_lvalue(cLISTOPo->op_last, type);
2727 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2729 else if (!(o->op_flags & OPf_KIDS))
2731 if (o->op_targ != OP_LIST) {
2732 op_lvalue(cBINOPo->op_first, type);
2738 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2739 /* elements might be in void context because the list is
2740 in scalar context or because they are attribute sub calls */
2741 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2742 op_lvalue(kid, type);
2750 if (type == OP_LEAVESUBLV
2751 || !S_vivifies(cLOGOPo->op_first->op_type))
2752 op_lvalue(cLOGOPo->op_first, type);
2753 if (type == OP_LEAVESUBLV
2754 || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2755 op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2759 if (type != OP_AASSIGN && type != OP_SASSIGN
2760 && type != OP_ENTERLOOP)
2762 /* Don’t bother applying lvalue context to the ex-list. */
2763 kid = cUNOPx(cUNOPo->op_first)->op_first;
2764 assert (!OP_HAS_SIBLING(kid));
2767 if (type != OP_AASSIGN) goto nomod;
2768 kid = cUNOPo->op_first;
2771 const U8 ec = PL_parser ? PL_parser->error_count : 0;
2772 S_lvref(aTHX_ kid, type);
2773 if (!PL_parser || PL_parser->error_count == ec) {
2774 if (!FEATURE_LVREF_IS_ENABLED)
2776 "Experimental lvalue references not enabled");
2777 Perl_ck_warner_d(aTHX_
2778 packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
2779 "Lvalue references are experimental");
2782 if (o->op_type == OP_REFGEN)
2783 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
2788 /* [20011101.069] File test operators interpret OPf_REF to mean that
2789 their argument is a filehandle; thus \stat(".") should not set
2791 if (type == OP_REFGEN &&
2792 PL_check[o->op_type] == Perl_ck_ftst)
2795 if (type != OP_LEAVESUBLV)
2796 o->op_flags |= OPf_MOD;
2798 if (type == OP_AASSIGN || type == OP_SASSIGN)
2799 o->op_flags |= OPf_SPECIAL|OPf_REF;
2800 else if (!type) { /* local() */
2803 o->op_private |= OPpLVAL_INTRO;
2804 o->op_flags &= ~OPf_SPECIAL;
2805 PL_hints |= HINT_BLOCK_SCOPE;
2810 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2811 "Useless localization of %s", OP_DESC(o));
2814 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2815 && type != OP_LEAVESUBLV)
2816 o->op_flags |= OPf_REF;
2821 S_scalar_mod_type(const OP *o, I32 type)
2826 if (o && o->op_type == OP_RV2GV)
2850 case OP_RIGHT_SHIFT:
2871 S_is_handle_constructor(const OP *o, I32 numargs)
2873 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2875 switch (o->op_type) {
2883 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2896 S_refkids(pTHX_ OP *o, I32 type)
2898 if (o && o->op_flags & OPf_KIDS) {
2900 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2907 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2912 PERL_ARGS_ASSERT_DOREF;
2914 if (!o || (PL_parser && PL_parser->error_count))
2917 switch (o->op_type) {
2919 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2920 !(o->op_flags & OPf_STACKED)) {
2921 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2922 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2923 assert(cUNOPo->op_first->op_type == OP_NULL);
2924 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2925 o->op_flags |= OPf_SPECIAL;
2927 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2928 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2929 : type == OP_RV2HV ? OPpDEREF_HV
2931 o->op_flags |= OPf_MOD;
2937 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2938 doref(kid, type, set_op_ref);
2941 if (type == OP_DEFINED)
2942 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2943 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2946 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2947 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2948 : type == OP_RV2HV ? OPpDEREF_HV
2950 o->op_flags |= OPf_MOD;
2957 o->op_flags |= OPf_REF;
2960 if (type == OP_DEFINED)
2961 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2962 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2968 o->op_flags |= OPf_REF;
2973 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2975 doref(cBINOPo->op_first, type, set_op_ref);
2979 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2980 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2981 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2982 : type == OP_RV2HV ? OPpDEREF_HV
2984 o->op_flags |= OPf_MOD;
2994 if (!(o->op_flags & OPf_KIDS))
2996 doref(cLISTOPo->op_last, type, set_op_ref);
3006 S_dup_attrlist(pTHX_ OP *o)
3010 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3012 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3013 * where the first kid is OP_PUSHMARK and the remaining ones
3014 * are OP_CONST. We need to push the OP_CONST values.
3016 if (o->op_type == OP_CONST)
3017 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3019 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3021 for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
3022 if (o->op_type == OP_CONST)
3023 rop = op_append_elem(OP_LIST, rop,
3024 newSVOP(OP_CONST, o->op_flags,
3025 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3032 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3034 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3036 PERL_ARGS_ASSERT_APPLY_ATTRS;
3038 /* fake up C<use attributes $pkg,$rv,@attrs> */
3040 #define ATTRSMODULE "attributes"
3041 #define ATTRSMODULE_PM "attributes.pm"
3043 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3044 newSVpvs(ATTRSMODULE),
3046 op_prepend_elem(OP_LIST,
3047 newSVOP(OP_CONST, 0, stashsv),
3048 op_prepend_elem(OP_LIST,
3049 newSVOP(OP_CONST, 0,
3051 dup_attrlist(attrs))));
3055 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3057 OP *pack, *imop, *arg;
3058 SV *meth, *stashsv, **svp;
3060 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3065 assert(target->op_type == OP_PADSV ||
3066 target->op_type == OP_PADHV ||
3067 target->op_type == OP_PADAV);
3069 /* Ensure that attributes.pm is loaded. */
3070 /* Don't force the C<use> if we don't need it. */
3071 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3072 if (svp && *svp != &PL_sv_undef)
3073 NOOP; /* already in %INC */
3075 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3076 newSVpvs(ATTRSMODULE), NULL);
3078 /* Need package name for method call. */
3079 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3081 /* Build up the real arg-list. */
3082 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3084 arg = newOP(OP_PADSV, 0);
3085 arg->op_targ = target->op_targ;
3086 arg = op_prepend_elem(OP_LIST,
3087 newSVOP(OP_CONST, 0, stashsv),
3088 op_prepend_elem(OP_LIST,
3089 newUNOP(OP_REFGEN, 0,
3090 op_lvalue(arg, OP_REFGEN)),
3091 dup_attrlist(attrs)));
3093 /* Fake up a method call to import */
3094 meth = newSVpvs_share("import");
3095 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3096 op_append_elem(OP_LIST,
3097 op_prepend_elem(OP_LIST, pack, list(arg)),
3098 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3100 /* Combine the ops. */
3101 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3105 =notfor apidoc apply_attrs_string
3107 Attempts to apply a list of attributes specified by the C<attrstr> and
3108 C<len> arguments to the subroutine identified by the C<cv> argument which
3109 is expected to be associated with the package identified by the C<stashpv>
3110 argument (see L<attributes>). It gets this wrong, though, in that it
3111 does not correctly identify the boundaries of the individual attribute
3112 specifications within C<attrstr>. This is not really intended for the
3113 public API, but has to be listed here for systems such as AIX which
3114 need an explicit export list for symbols. (It's called from XS code
3115 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3116 to respect attribute syntax properly would be welcome.
3122 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3123 const char *attrstr, STRLEN len)
3127 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3130 len = strlen(attrstr);
3134 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3136 const char * const sstr = attrstr;
3137 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3138 attrs = op_append_elem(OP_LIST, attrs,
3139 newSVOP(OP_CONST, 0,
3140 newSVpvn(sstr, attrstr-sstr)));
3144 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3145 newSVpvs(ATTRSMODULE),
3146 NULL, op_prepend_elem(OP_LIST,
3147 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3148 op_prepend_elem(OP_LIST,
3149 newSVOP(OP_CONST, 0,
3150 newRV(MUTABLE_SV(cv))),
3155 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3157 OP *new_proto = NULL;
3162 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3168 if (o->op_type == OP_CONST) {
3169 pv = SvPV(cSVOPo_sv, pvlen);
3170 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3171 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3172 SV ** const tmpo = cSVOPx_svp(o);
3173 SvREFCNT_dec(cSVOPo_sv);
3178 } else if (o->op_type == OP_LIST) {
3180 assert(o->op_flags & OPf_KIDS);
3181 lasto = cLISTOPo->op_first;
3182 assert(lasto->op_type == OP_PUSHMARK);
3183 for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3184 if (o->op_type == OP_CONST) {
3185 pv = SvPV(cSVOPo_sv, pvlen);
3186 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3187 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3188 SV ** const tmpo = cSVOPx_svp(o);
3189 SvREFCNT_dec(cSVOPo_sv);
3191 if (new_proto && ckWARN(WARN_MISC)) {
3193 const char * newp = SvPV(cSVOPo_sv, new_len);
3194 Perl_warner(aTHX_ packWARN(WARN_MISC),
3195 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3196 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3202 /* excise new_proto from the list */
3203 op_sibling_splice(*attrs, lasto, 1, NULL);
3210 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3211 would get pulled in with no real need */
3212 if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3221 svname = sv_newmortal();
3222 gv_efullname3(svname, name, NULL);
3224 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3225 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3227 svname = (SV *)name;
3228 if (ckWARN(WARN_ILLEGALPROTO))
3229 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3230 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3231 STRLEN old_len, new_len;
3232 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3233 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3235 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3236 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3238 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3239 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3249 S_cant_declare(pTHX_ OP *o)
3251 if (o->op_type == OP_NULL
3252 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3253 o = cUNOPo->op_first;
3254 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3255 o->op_type == OP_NULL
3256 && o->op_flags & OPf_SPECIAL
3259 PL_parser->in_my == KEY_our ? "our" :
3260 PL_parser->in_my == KEY_state ? "state" :
3265 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3268 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3270 PERL_ARGS_ASSERT_MY_KID;
3272 if (!o || (PL_parser && PL_parser->error_count))
3277 if (type == OP_LIST) {
3279 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3280 my_kid(kid, attrs, imopsp);
3282 } else if (type == OP_UNDEF || type == OP_STUB) {
3284 } else if (type == OP_RV2SV || /* "our" declaration */
3286 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3287 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3288 S_cant_declare(aTHX_ o);
3290 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3292 PL_parser->in_my = FALSE;
3293 PL_parser->in_my_stash = NULL;
3294 apply_attrs(GvSTASH(gv),
3295 (type == OP_RV2SV ? GvSV(gv) :
3296 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3297 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3300 o->op_private |= OPpOUR_INTRO;
3303 else if (type != OP_PADSV &&
3306 type != OP_PUSHMARK)
3308 S_cant_declare(aTHX_ o);
3311 else if (attrs && type != OP_PUSHMARK) {
3315 PL_parser->in_my = FALSE;
3316 PL_parser->in_my_stash = NULL;
3318 /* check for C<my Dog $spot> when deciding package */
3319 stash = PAD_COMPNAME_TYPE(o->op_targ);
3321 stash = PL_curstash;
3322 apply_attrs_my(stash, o, attrs, imopsp);
3324 o->op_flags |= OPf_MOD;
3325 o->op_private |= OPpLVAL_INTRO;
3327 o->op_private |= OPpPAD_STATE;
3332 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3335 int maybe_scalar = 0;
3337 PERL_ARGS_ASSERT_MY_ATTRS;
3339 /* [perl #17376]: this appears to be premature, and results in code such as
3340 C< our(%x); > executing in list mode rather than void mode */
3342 if (o->op_flags & OPf_PARENS)
3352 o = my_kid(o, attrs, &rops);
3354 if (maybe_scalar && o->op_type == OP_PADSV) {
3355 o = scalar(op_append_list(OP_LIST, rops, o));
3356 o->op_private |= OPpLVAL_INTRO;
3359 /* The listop in rops might have a pushmark at the beginning,
3360 which will mess up list assignment. */
3361 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3362 if (rops->op_type == OP_LIST &&
3363 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3365 OP * const pushmark = lrops->op_first;
3366 /* excise pushmark */
3367 op_sibling_splice(rops, NULL, 1, NULL);
3370 o = op_append_list(OP_LIST, o, rops);
3373 PL_parser->in_my = FALSE;
3374 PL_parser->in_my_stash = NULL;
3379 Perl_sawparens(pTHX_ OP *o)
3381 PERL_UNUSED_CONTEXT;
3383 o->op_flags |= OPf_PARENS;
3388 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3392 const OPCODE ltype = left->op_type;
3393 const OPCODE rtype = right->op_type;
3395 PERL_ARGS_ASSERT_BIND_MATCH;
3397 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3398 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3400 const char * const desc
3402 rtype == OP_SUBST || rtype == OP_TRANS
3403 || rtype == OP_TRANSR
3405 ? (int)rtype : OP_MATCH];
3406 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3408 S_op_varname(aTHX_ left);
3410 Perl_warner(aTHX_ packWARN(WARN_MISC),
3411 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3412 desc, SVfARG(name), SVfARG(name));
3414 const char * const sample = (isary
3415 ? "@array" : "%hash");
3416 Perl_warner(aTHX_ packWARN(WARN_MISC),
3417 "Applying %s to %s will act on scalar(%s)",
3418 desc, sample, sample);
3422 if (rtype == OP_CONST &&
3423 cSVOPx(right)->op_private & OPpCONST_BARE &&
3424 cSVOPx(right)->op_private & OPpCONST_STRICT)
3426 no_bareword_allowed(right);
3429 /* !~ doesn't make sense with /r, so error on it for now */
3430 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3432 /* diag_listed_as: Using !~ with %s doesn't make sense */
3433 yyerror("Using !~ with s///r doesn't make sense");
3434 if (rtype == OP_TRANSR && type == OP_NOT)
3435 /* diag_listed_as: Using !~ with %s doesn't make sense */
3436 yyerror("Using !~ with tr///r doesn't make sense");
3438 ismatchop = (rtype == OP_MATCH ||
3439 rtype == OP_SUBST ||
3440 rtype == OP_TRANS || rtype == OP_TRANSR)
3441 && !(right->op_flags & OPf_SPECIAL);
3442 if (ismatchop && right->op_private & OPpTARGET_MY) {
3444 right->op_private &= ~OPpTARGET_MY;
3446 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3449 right->op_flags |= OPf_STACKED;
3450 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3451 ! (rtype == OP_TRANS &&
3452 right->op_private & OPpTRANS_IDENTICAL) &&
3453 ! (rtype == OP_SUBST &&
3454 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3455 newleft = op_lvalue(left, rtype);
3458 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3459 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3461 o = op_prepend_elem(rtype, scalar(newleft), right);
3463 return newUNOP(OP_NOT, 0, scalar(o));
3467 return bind_match(type, left,
3468 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3472 Perl_invert(pTHX_ OP *o)
3476 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3480 =for apidoc Amx|OP *|op_scope|OP *o
3482 Wraps up an op tree with some additional ops so that at runtime a dynamic
3483 scope will be created. The original ops run in the new dynamic scope,
3484 and then, provided that they exit normally, the scope will be unwound.
3485 The additional ops used to create and unwind the dynamic scope will
3486 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3487 instead if the ops are simple enough to not need the full dynamic scope
3494 Perl_op_scope(pTHX_ OP *o)
3498 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3499 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3500 o->op_type = OP_LEAVE;
3501 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3503 else if (o->op_type == OP_LINESEQ) {
3505 o->op_type = OP_SCOPE;
3506 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3507 kid = ((LISTOP*)o)->op_first;
3508 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3511 /* The following deals with things like 'do {1 for 1}' */
3512 kid = OP_SIBLING(kid);
3514 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3519 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3525 Perl_op_unscope(pTHX_ OP *o)
3527 if (o && o->op_type == OP_LINESEQ) {
3528 OP *kid = cLISTOPo->op_first;
3529 for(; kid; kid = OP_SIBLING(kid))
3530 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3537 Perl_block_start(pTHX_ int full)
3539 const int retval = PL_savestack_ix;
3541 pad_block_start(full);
3543 PL_hints &= ~HINT_BLOCK_SCOPE;
3544 SAVECOMPILEWARNINGS();
3545 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3547 CALL_BLOCK_HOOKS(bhk_start, full);
3553 Perl_block_end(pTHX_ I32 floor, OP *seq)
3555 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3556 OP* retval = scalarseq(seq);
3559 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3563 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3567 /* pad_leavemy has created a sequence of introcv ops for all my
3568 subs declared in the block. We have to replicate that list with
3569 clonecv ops, to deal with this situation:
3574 sub s1 { state sub foo { \&s2 } }
3577 Originally, I was going to have introcv clone the CV and turn
3578 off the stale flag. Since &s1 is declared before &s2, the
3579 introcv op for &s1 is executed (on sub entry) before the one for
3580 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3581 cloned, since it is a state sub) closes over &s2 and expects
3582 to see it in its outer CV’s pad. If the introcv op clones &s1,
3583 then &s2 is still marked stale. Since &s1 is not active, and
3584 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3585 ble will not stay shared’ warning. Because it is the same stub
3586 that will be used when the introcv op for &s2 is executed, clos-
3587 ing over it is safe. Hence, we have to turn off the stale flag
3588 on all lexical subs in the block before we clone any of them.
3589 Hence, having introcv clone the sub cannot work. So we create a
3590 list of ops like this:
3614 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3615 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3616 for (;; kid = OP_SIBLING(kid)) {
3617 OP *newkid = newOP(OP_CLONECV, 0);
3618 newkid->op_targ = kid->op_targ;
3619 o = op_append_elem(OP_LINESEQ, o, newkid);
3620 if (kid == last) break;
3622 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3625 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3631 =head1 Compile-time scope hooks
3633 =for apidoc Aox||blockhook_register
3635 Register a set of hooks to be called when the Perl lexical scope changes
3636 at compile time. See L<perlguts/"Compile-time scope hooks">.
3642 Perl_blockhook_register(pTHX_ BHK *hk)
3644 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3646 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3652 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3653 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3654 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3657 OP * const o = newOP(OP_PADSV, 0);
3658 o->op_targ = offset;
3664 Perl_newPROG(pTHX_ OP *o)
3666 PERL_ARGS_ASSERT_NEWPROG;
3673 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3674 ((PL_in_eval & EVAL_KEEPERR)
3675 ? OPf_SPECIAL : 0), o);
3677 cx = &cxstack[cxstack_ix];
3678 assert(CxTYPE(cx) == CXt_EVAL);
3680 if ((cx->blk_gimme & G_WANT) == G_VOID)
3681 scalarvoid(PL_eval_root);
3682 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3685 scalar(PL_eval_root);
3687 PL_eval_start = op_linklist(PL_eval_root);
3688 PL_eval_root->op_private |= OPpREFCOUNTED;
3689 OpREFCNT_set(PL_eval_root, 1);
3690 PL_eval_root->op_next = 0;
3691 i = PL_savestack_ix;
3694 CALL_PEEP(PL_eval_start);
3695 finalize_optree(PL_eval_root);
3696 S_prune_chain_head(&PL_eval_start);
3698 PL_savestack_ix = i;
3701 if (o->op_type == OP_STUB) {
3702 /* This block is entered if nothing is compiled for the main
3703 program. This will be the case for an genuinely empty main
3704 program, or one which only has BEGIN blocks etc, so already
3707 Historically (5.000) the guard above was !o. However, commit
3708 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3709 c71fccf11fde0068, changed perly.y so that newPROG() is now
3710 called with the output of block_end(), which returns a new
3711 OP_STUB for the case of an empty optree. ByteLoader (and
3712 maybe other things) also take this path, because they set up
3713 PL_main_start and PL_main_root directly, without generating an
3716 If the parsing the main program aborts (due to parse errors,
3717 or due to BEGIN or similar calling exit), then newPROG()
3718 isn't even called, and hence this code path and its cleanups
3719 are skipped. This shouldn't make a make a difference:
3720 * a non-zero return from perl_parse is a failure, and
3721 perl_destruct() should be called immediately.
3722 * however, if exit(0) is called during the parse, then
3723 perl_parse() returns 0, and perl_run() is called. As
3724 PL_main_start will be NULL, perl_run() will return
3725 promptly, and the exit code will remain 0.
3728 PL_comppad_name = 0;
3730 S_op_destroy(aTHX_ o);
3733 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3734 PL_curcop = &PL_compiling;
3735 PL_main_start = LINKLIST(PL_main_root);
3736 PL_main_root->op_private |= OPpREFCOUNTED;
3737 OpREFCNT_set(PL_main_root, 1);
3738 PL_main_root->op_next = 0;
3739 CALL_PEEP(PL_main_start);
3740 finalize_optree(PL_main_root);
3741 S_prune_chain_head(&PL_main_start);
3742 cv_forget_slab(PL_compcv);
3745 /* Register with debugger */
3747 CV * const cv = get_cvs("DB::postponed", 0);
3751 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3753 call_sv(MUTABLE_SV(cv), G_DISCARD);
3760 Perl_localize(pTHX_ OP *o, I32 lex)
3762 PERL_ARGS_ASSERT_LOCALIZE;
3764 if (o->op_flags & OPf_PARENS)
3765 /* [perl #17376]: this appears to be premature, and results in code such as
3766 C< our(%x); > executing in list mode rather than void mode */
3773 if ( PL_parser->bufptr > PL_parser->oldbufptr
3774 && PL_parser->bufptr[-1] == ','
3775 && ckWARN(WARN_PARENTHESIS))
3777 char *s = PL_parser->bufptr;
3780 /* some heuristics to detect a potential error */
3781 while (*s && (strchr(", \t\n", *s)))
3785 if (*s && strchr("@$%*", *s) && *++s
3786 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3789 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3791 while (*s && (strchr(", \t\n", *s)))
3797 if (sigil && (*s == ';' || *s == '=')) {
3798 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3799 "Parentheses missing around \"%s\" list",
3801 ? (PL_parser->in_my == KEY_our
3803 : PL_parser->in_my == KEY_state
3813 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3814 PL_parser->in_my = FALSE;
3815 PL_parser->in_my_stash = NULL;
3820 Perl_jmaybe(pTHX_ OP *o)
3822 PERL_ARGS_ASSERT_JMAYBE;
3824 if (o->op_type == OP_LIST) {
3826 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3827 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3832 PERL_STATIC_INLINE OP *
3833 S_op_std_init(pTHX_ OP *o)
3835 I32 type = o->op_type;
3837 PERL_ARGS_ASSERT_OP_STD_INIT;
3839 if (PL_opargs[type] & OA_RETSCALAR)
3841 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3842 o->op_targ = pad_alloc(type, SVs_PADTMP);
3847 PERL_STATIC_INLINE OP *
3848 S_op_integerize(pTHX_ OP *o)
3850 I32 type = o->op_type;
3852 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3854 /* integerize op. */
3855 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3858 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3861 if (type == OP_NEGATE)
3862 /* XXX might want a ck_negate() for this */
3863 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3869 S_fold_constants(pTHX_ OP *o)
3874 VOL I32 type = o->op_type;
3880 SV * const oldwarnhook = PL_warnhook;
3881 SV * const olddiehook = PL_diehook;
3883 U8 oldwarn = PL_dowarn;
3886 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3888 if (!(PL_opargs[type] & OA_FOLDCONST))
3897 #ifdef USE_LOCALE_CTYPE
3898 if (IN_LC_COMPILETIME(LC_CTYPE))
3907 #ifdef USE_LOCALE_COLLATE
3908 if (IN_LC_COMPILETIME(LC_COLLATE))
3913 /* XXX what about the numeric ops? */
3914 #ifdef USE_LOCALE_NUMERIC
3915 if (IN_LC_COMPILETIME(LC_NUMERIC))
3920 if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3921 || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3924 SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3925 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3927 const char *s = SvPVX_const(sv);
3928 while (s < SvEND(sv)) {
3929 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
3936 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3939 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3940 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3944 if (PL_parser && PL_parser->error_count)
3945 goto nope; /* Don't try to run w/ errors */
3947 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3948 const OPCODE type = curop->op_type;
3949 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3951 type != OP_SCALAR &&
3953 type != OP_PUSHMARK)
3959 curop = LINKLIST(o);
3960 old_next = o->op_next;
3964 oldscope = PL_scopestack_ix;
3965 create_eval_scope(G_FAKINGEVAL);
3967 /* Verify that we don't need to save it: */
3968 assert(PL_curcop == &PL_compiling);
3969 StructCopy(&PL_compiling, ¬_compiling, COP);
3970 PL_curcop = ¬_compiling;
3971 /* The above ensures that we run with all the correct hints of the
3972 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3973 assert(IN_PERL_RUNTIME);
3974 PL_warnhook = PERL_WARNHOOK_FATAL;
3978 /* Effective $^W=1. */
3979 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
3980 PL_dowarn |= G_WARN_ON;
3985 sv = *(PL_stack_sp--);
3986 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3987 pad_swipe(o->op_targ, FALSE);
3989 else if (SvTEMP(sv)) { /* grab mortal temp? */
3990 SvREFCNT_inc_simple_void(sv);
3993 else { assert(SvIMMORTAL(sv)); }
3996 /* Something tried to die. Abandon constant folding. */
3997 /* Pretend the error never happened. */
3999 o->op_next = old_next;
4003 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4004 PL_warnhook = oldwarnhook;
4005 PL_diehook = olddiehook;
4006 /* XXX note that this croak may fail as we've already blown away
4007 * the stack - eg any nested evals */
4008 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4011 PL_dowarn = oldwarn;
4012 PL_warnhook = oldwarnhook;
4013 PL_diehook = olddiehook;
4014 PL_curcop = &PL_compiling;
4016 if (PL_scopestack_ix > oldscope)
4017 delete_eval_scope();
4022 folded = o->op_folded;
4025 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
4026 else if (!SvIMMORTAL(sv)) {
4030 if (type == OP_RV2GV)
4031 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
4034 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4035 /* OP_STRINGIFY and constant folding are used to implement qq.
4036 Here the constant folding is an implementation detail that we
4037 want to hide. If the stringify op is itself already marked
4038 folded, however, then it is actually a folded join. */
4039 if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
4048 S_gen_constant_list(pTHX_ OP *o)
4052 const SSize_t oldtmps_floor = PL_tmps_floor;
4057 if (PL_parser && PL_parser->error_count)
4058 return o; /* Don't attempt to run with errors */
4060 curop = LINKLIST(o);
4063 S_prune_chain_head(&curop);
4065 Perl_pp_pushmark(aTHX);
4068 assert (!(curop->op_flags & OPf_SPECIAL));
4069 assert(curop->op_type == OP_RANGE);
4070 Perl_pp_anonlist(aTHX);
4071 PL_tmps_floor = oldtmps_floor;
4073 o->op_type = OP_RV2AV;
4074 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4075 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4076 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4077 o->op_opt = 0; /* needs to be revisited in rpeep() */
4078 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4080 /* replace subtree with an OP_CONST */
4081 curop = ((UNOP*)o)->op_first;
4082 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4085 if (AvFILLp(av) != -1)
4086 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4089 SvREADONLY_on(*svp);
4095 /* convert o (and any siblings) into a list if not already, then
4096 * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
4100 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
4103 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4104 if (!o || o->op_type != OP_LIST)
4105 o = force_list(o, 0);
4107 o->op_flags &= ~OPf_WANT;
4109 if (!(PL_opargs[type] & OA_MARK))
4110 op_null(cLISTOPo->op_first);
4112 OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
4113 if (kid2 && kid2->op_type == OP_COREARGS) {
4114 op_null(cLISTOPo->op_first);
4115 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4119 o->op_type = (OPCODE)type;
4120 o->op_ppaddr = PL_ppaddr[type];
4121 o->op_flags |= flags;
4123 o = CHECKOP(type, o);
4124 if (o->op_type != (unsigned)type)
4127 return fold_constants(op_integerize(op_std_init(o)));
4131 =head1 Optree Manipulation Functions
4134 /* List constructors */
4137 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4139 Append an item to the list of ops contained directly within a list-type
4140 op, returning the lengthened list. I<first> is the list-type op,
4141 and I<last> is the op to append to the list. I<optype> specifies the
4142 intended opcode for the list. If I<first> is not already a list of the
4143 right type, it will be upgraded into one. If either I<first> or I<last>
4144 is null, the other is returned unchanged.
4150 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4158 if (first->op_type != (unsigned)type
4159 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4161 return newLISTOP(type, 0, first, last);
4164 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4165 first->op_flags |= OPf_KIDS;
4170 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4172 Concatenate the lists of ops contained directly within two list-type ops,
4173 returning the combined list. I<first> and I<last> are the list-type ops
4174 to concatenate. I<optype> specifies the intended opcode for the list.
4175 If either I<first> or I<last> is not already a list of the right type,
4176 it will be upgraded into one. If either I<first> or I<last> is null,
4177 the other is returned unchanged.
4183 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4191 if (first->op_type != (unsigned)type)
4192 return op_prepend_elem(type, first, last);
4194 if (last->op_type != (unsigned)type)
4195 return op_append_elem(type, first, last);
4197 ((LISTOP*)first)->op_last->op_lastsib = 0;
4198 OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4199 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4200 ((LISTOP*)first)->op_last->op_lastsib = 1;
4201 #ifdef PERL_OP_PARENT
4202 ((LISTOP*)first)->op_last->op_sibling = first;
4204 first->op_flags |= (last->op_flags & OPf_KIDS);
4207 S_op_destroy(aTHX_ last);
4213 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4215 Prepend an item to the list of ops contained directly within a list-type
4216 op, returning the lengthened list. I<first> is the op to prepend to the
4217 list, and I<last> is the list-type op. I<optype> specifies the intended
4218 opcode for the list. If I<last> is not already a list of the right type,
4219 it will be upgraded into one. If either I<first> or I<last> is null,
4220 the other is returned unchanged.
4226 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4234 if (last->op_type == (unsigned)type) {
4235 if (type == OP_LIST) { /* already a PUSHMARK there */
4236 /* insert 'first' after pushmark */
4237 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4238 if (!(first->op_flags & OPf_PARENS))
4239 last->op_flags &= ~OPf_PARENS;
4242 op_sibling_splice(last, NULL, 0, first);
4243 last->op_flags |= OPf_KIDS;
4247 return newLISTOP(type, 0, first, last);
4254 =head1 Optree construction
4256 =for apidoc Am|OP *|newNULLLIST
4258 Constructs, checks, and returns a new C<stub> op, which represents an
4259 empty list expression.
4265 Perl_newNULLLIST(pTHX)
4267 return newOP(OP_STUB, 0);
4270 /* promote o and any siblings to be a list if its not already; i.e.
4278 * pushmark - o - A - B
4280 * If nullit it true, the list op is nulled.
4284 S_force_list(pTHX_ OP *o, bool nullit)
4286 if (!o || o->op_type != OP_LIST) {
4289 /* manually detach any siblings then add them back later */
4290 rest = OP_SIBLING(o);
4291 OP_SIBLING_set(o, NULL);
4294 o = newLISTOP(OP_LIST, 0, o, NULL);
4296 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4304 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4306 Constructs, checks, and returns an op of any list type. I<type> is
4307 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4308 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4309 supply up to two ops to be direct children of the list op; they are
4310 consumed by this function and become part of the constructed op tree.
4316 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4321 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4323 NewOp(1101, listop, 1, LISTOP);
4325 listop->op_type = (OPCODE)type;
4326 listop->op_ppaddr = PL_ppaddr[type];
4329 listop->op_flags = (U8)flags;
4333 else if (!first && last)
4336 OP_SIBLING_set(first, last);
4337 listop->op_first = first;
4338 listop->op_last = last;
4339 if (type == OP_LIST) {
4340 OP* const pushop = newOP(OP_PUSHMARK, 0);
4341 pushop->op_lastsib = 0;
4342 OP_SIBLING_set(pushop, first);
4343 listop->op_first = pushop;
4344 listop->op_flags |= OPf_KIDS;
4346 listop->op_last = pushop;
4349 first->op_lastsib = 0;
4350 if (listop->op_last) {
4351 listop->op_last->op_lastsib = 1;
4352 #ifdef PERL_OP_PARENT
4353 listop->op_last->op_sibling = (OP*)listop;
4357 return CHECKOP(type, listop);
4361 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4363 Constructs, checks, and returns an op of any base type (any type that
4364 has no extra fields). I<type> is the opcode. I<flags> gives the
4365 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4372 Perl_newOP(pTHX_ I32 type, I32 flags)
4377 if (type == -OP_ENTEREVAL) {
4378 type = OP_ENTEREVAL;
4379 flags |= OPpEVAL_BYTES<<8;
4382 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4383 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4384 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4385 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4387 NewOp(1101, o, 1, OP);
4388 o->op_type = (OPCODE)type;
4389 o->op_ppaddr = PL_ppaddr[type];
4390 o->op_flags = (U8)flags;
4393 o->op_private = (U8)(0 | (flags >> 8));
4394 if (PL_opargs[type] & OA_RETSCALAR)
4396 if (PL_opargs[type] & OA_TARGET)
4397 o->op_targ = pad_alloc(type, SVs_PADTMP);
4398 return CHECKOP(type, o);
4402 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4404 Constructs, checks, and returns an op of any unary type. I<type> is
4405 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4406 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4407 bits, the eight bits of C<op_private>, except that the bit with value 1
4408 is automatically set. I<first> supplies an optional op to be the direct
4409 child of the unary op; it is consumed by this function and become part
4410 of the constructed op tree.
4416 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4421 if (type == -OP_ENTEREVAL) {
4422 type = OP_ENTEREVAL;
4423 flags |= OPpEVAL_BYTES<<8;
4426 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4427 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4428 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4429 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4430 || type == OP_SASSIGN
4431 || type == OP_ENTERTRY
4432 || type == OP_NULL );
4435 first = newOP(OP_STUB, 0);
4436 if (PL_opargs[type] & OA_MARK)
4437 first = force_list(first, 1);
4439 NewOp(1101, unop, 1, UNOP);
4440 unop->op_type = (OPCODE)type;
4441 unop->op_ppaddr = PL_ppaddr[type];
4442 unop->op_first = first;
4443 unop->op_flags = (U8)(flags | OPf_KIDS);
4444 unop->op_private = (U8)(1 | (flags >> 8));
4446 #ifdef PERL_OP_PARENT
4447 if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4448 first->op_sibling = (OP*)unop;
4451 unop = (UNOP*) CHECKOP(type, unop);
4455 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4459 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4461 Constructs, checks, and returns an op of method type with a method name
4462 evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
4463 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4464 and, shifted up eight bits, the eight bits of C<op_private>, except that
4465 the bit with value 1 is automatically set. I<dynamic_meth> supplies an
4466 op which evaluates method name; it is consumed by this function and
4467 become part of the constructed op tree.
4468 Supported optypes: OP_METHOD.
4474 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4478 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP);
4480 NewOp(1101, methop, 1, METHOP);
4482 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4483 methop->op_flags = (U8)(flags | OPf_KIDS);
4484 methop->op_u.op_first = dynamic_meth;
4485 methop->op_private = (U8)(1 | (flags >> 8));
4489 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4490 methop->op_u.op_meth_sv = const_meth;
4491 methop->op_private = (U8)(0 | (flags >> 8));
4492 methop->op_next = (OP*)methop;
4495 methop->op_type = (OPCODE)type;
4496 methop->op_ppaddr = PL_ppaddr[type];
4497 methop = (METHOP*) CHECKOP(type, methop);
4499 if (methop->op_next) return (OP*)methop;
4501 return fold_constants(op_integerize(op_std_init((OP *) methop)));
4505 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4506 PERL_ARGS_ASSERT_NEWMETHOP;
4507 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4511 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4513 Constructs, checks, and returns an op of method type with a constant
4514 method name. I<type> is the opcode. I<flags> gives the eight bits of
4515 C<op_flags>, and, shifted up eight bits, the eight bits of
4516 C<op_private>. I<const_meth> supplies a constant method name;
4517 it must be a shared COW string.
4518 Supported optypes: OP_METHOD_NAMED.
4524 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4525 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4526 return newMETHOP_internal(type, flags, NULL, const_meth);
4530 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4532 Constructs, checks, and returns an op of any binary type. I<type>
4533 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4534 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4535 the eight bits of C<op_private>, except that the bit with value 1 or
4536 2 is automatically set as required. I<first> and I<last> supply up to
4537 two ops to be the direct children of the binary op; they are consumed
4538 by this function and become part of the constructed op tree.
4544 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4549 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4550 || type == OP_SASSIGN || type == OP_NULL );
4552 NewOp(1101, binop, 1, BINOP);
4555 first = newOP(OP_NULL, 0);
4557 binop->op_type = (OPCODE)type;
4558 binop->op_ppaddr = PL_ppaddr[type];
4559 binop->op_first = first;
4560 binop->op_flags = (U8)(flags | OPf_KIDS);
4563 binop->op_private = (U8)(1 | (flags >> 8));
4566 binop->op_private = (U8)(2 | (flags >> 8));
4567 OP_SIBLING_set(first, last);
4568 first->op_lastsib = 0;
4571 #ifdef PERL_OP_PARENT
4572 if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4573 last->op_sibling = (OP*)binop;
4576 binop->op_last = OP_SIBLING(binop->op_first);
4577 #ifdef PERL_OP_PARENT
4579 binop->op_last->op_sibling = (OP*)binop;
4582 binop = (BINOP*)CHECKOP(type, binop);
4583 if (binop->op_next || binop->op_type != (OPCODE)type)
4586 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4589 static int uvcompare(const void *a, const void *b)
4590 __attribute__nonnull__(1)
4591 __attribute__nonnull__(2)
4592 __attribute__pure__;
4593 static int uvcompare(const void *a, const void *b)
4595 if (*((const UV *)a) < (*(const UV *)b))
4597 if (*((const UV *)a) > (*(const UV *)b))
4599 if (*((const UV *)a+1) < (*(const UV *)b+1))
4601 if (*((const UV *)a+1) > (*(const UV *)b+1))
4607 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4609 SV * const tstr = ((SVOP*)expr)->op_sv;
4611 ((SVOP*)repl)->op_sv;
4614 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4615 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4621 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4622 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4623 I32 del = o->op_private & OPpTRANS_DELETE;
4626 PERL_ARGS_ASSERT_PMTRANS;
4628 PL_hints |= HINT_BLOCK_SCOPE;
4631 o->op_private |= OPpTRANS_FROM_UTF;
4634 o->op_private |= OPpTRANS_TO_UTF;
4636 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4637 SV* const listsv = newSVpvs("# comment\n");
4639 const U8* tend = t + tlen;
4640 const U8* rend = r + rlen;
4654 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4655 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4658 const U32 flags = UTF8_ALLOW_DEFAULT;
4662 t = tsave = bytes_to_utf8(t, &len);
4665 if (!to_utf && rlen) {
4667 r = rsave = bytes_to_utf8(r, &len);
4671 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4672 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4676 U8 tmpbuf[UTF8_MAXBYTES+1];
4679 Newx(cp, 2*tlen, UV);
4681 transv = newSVpvs("");
4683 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4685 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4687 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4691 cp[2*i+1] = cp[2*i];
4695 qsort(cp, i, 2*sizeof(UV), uvcompare);
4696 for (j = 0; j < i; j++) {
4698 diff = val - nextmin;
4700 t = uvchr_to_utf8(tmpbuf,nextmin);
4701 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4703 U8 range_mark = ILLEGAL_UTF8_BYTE;
4704 t = uvchr_to_utf8(tmpbuf, val - 1);
4705 sv_catpvn(transv, (char *)&range_mark, 1);
4706 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4713 t = uvchr_to_utf8(tmpbuf,nextmin);
4714 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4716 U8 range_mark = ILLEGAL_UTF8_BYTE;
4717 sv_catpvn(transv, (char *)&range_mark, 1);
4719 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4720 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4721 t = (const U8*)SvPVX_const(transv);
4722 tlen = SvCUR(transv);
4726 else if (!rlen && !del) {
4727 r = t; rlen = tlen; rend = tend;
4730 if ((!rlen && !del) || t == r ||
4731 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4733 o->op_private |= OPpTRANS_IDENTICAL;
4737 while (t < tend || tfirst <= tlast) {
4738 /* see if we need more "t" chars */
4739 if (tfirst > tlast) {
4740 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4742 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4744 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4751 /* now see if we need more "r" chars */
4752 if (rfirst > rlast) {
4754 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4756 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4758 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4767 rfirst = rlast = 0xffffffff;
4771 /* now see which range will peter our first, if either. */
4772 tdiff = tlast - tfirst;
4773 rdiff = rlast - rfirst;
4780 if (rfirst == 0xffffffff) {
4781 diff = tdiff; /* oops, pretend rdiff is infinite */
4783 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4784 (long)tfirst, (long)tlast);
4786 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4790 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4791 (long)tfirst, (long)(tfirst + diff),
4794 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4795 (long)tfirst, (long)rfirst);
4797 if (rfirst + diff > max)
4798 max = rfirst + diff;
4800 grows = (tfirst < rfirst &&
4801 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4813 else if (max > 0xff)
4818 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4820 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4821 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4822 PAD_SETSV(cPADOPo->op_padix, swash);
4824 SvREADONLY_on(swash);
4826 cSVOPo->op_sv = swash;
4828 SvREFCNT_dec(listsv);
4829 SvREFCNT_dec(transv);
4831 if (!del && havefinal && rlen)
4832 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4833 newSVuv((UV)final), 0);
4836 o->op_private |= OPpTRANS_GROWS;
4846 tbl = (short*)PerlMemShared_calloc(
4847 (o->op_private & OPpTRANS_COMPLEMENT) &&
4848 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4850 cPVOPo->op_pv = (char*)tbl;
4852 for (i = 0; i < (I32)tlen; i++)
4854 for (i = 0, j = 0; i < 256; i++) {
4856 if (j >= (I32)rlen) {
4865 if (i < 128 && r[j] >= 128)
4875 o->op_private |= OPpTRANS_IDENTICAL;
4877 else if (j >= (I32)rlen)
4882 PerlMemShared_realloc(tbl,
4883 (0x101+rlen-j) * sizeof(short));
4884 cPVOPo->op_pv = (char*)tbl;
4886 tbl[0x100] = (short)(rlen - j);
4887 for (i=0; i < (I32)rlen - j; i++)
4888 tbl[0x101+i] = r[j+i];
4892 if (!rlen && !del) {
4895 o->op_private |= OPpTRANS_IDENTICAL;
4897 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4898 o->op_private |= OPpTRANS_IDENTICAL;
4900 for (i = 0; i < 256; i++)
4902 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4903 if (j >= (I32)rlen) {
4905 if (tbl[t[i]] == -1)
4911 if (tbl[t[i]] == -1) {
4912 if (t[i] < 128 && r[j] >= 128)
4919 if(del && rlen == tlen) {
4920 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4921 } else if(rlen > tlen && !complement) {
4922 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4926 o->op_private |= OPpTRANS_GROWS;
4934 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4936 Constructs, checks, and returns an op of any pattern matching type.
4937 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4938 and, shifted up eight bits, the eight bits of C<op_private>.
4944 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4949 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4951 NewOp(1101, pmop, 1, PMOP);
4952 pmop->op_type = (OPCODE)type;
4953 pmop->op_ppaddr = PL_ppaddr[type];
4954 pmop->op_flags = (U8)flags;
4955 pmop->op_private = (U8)(0 | (flags >> 8));
4957 if (PL_hints & HINT_RE_TAINT)
4958 pmop->op_pmflags |= PMf_RETAINT;
4959 #ifdef USE_LOCALE_CTYPE
4960 if (IN_LC_COMPILETIME(LC_CTYPE)) {
4961 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4966 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4968 if (PL_hints & HINT_RE_FLAGS) {
4969 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4970 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4972 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4973 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4974 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4976 if (reflags && SvOK(reflags)) {
4977 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4983 assert(SvPOK(PL_regex_pad[0]));
4984 if (SvCUR(PL_regex_pad[0])) {
4985 /* Pop off the "packed" IV from the end. */
4986 SV *const repointer_list = PL_regex_pad[0];
4987 const char *p = SvEND(repointer_list) - sizeof(IV);
4988 const IV offset = *((IV*)p);
4990 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4992 SvEND_set(repointer_list, p);
4994 pmop->op_pmoffset = offset;
4995 /* This slot should be free, so assert this: */
4996 assert(PL_regex_pad[offset] == &PL_sv_undef);
4998 SV * const repointer = &PL_sv_undef;
4999 av_push(PL_regex_padav, repointer);
5000 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5001 PL_regex_pad = AvARRAY(PL_regex_padav);
5005 return CHECKOP(type, pmop);
5008 /* Given some sort of match op o, and an expression expr containing a
5009 * pattern, either compile expr into a regex and attach it to o (if it's
5010 * constant), or convert expr into a runtime regcomp op sequence (if it's
5013 * isreg indicates that the pattern is part of a regex construct, eg
5014 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5015 * split "pattern", which aren't. In the former case, expr will be a list
5016 * if the pattern contains more than one term (eg /a$b/) or if it contains
5017 * a replacement, ie s/// or tr///.
5019 * When the pattern has been compiled within a new anon CV (for
5020 * qr/(?{...})/ ), then floor indicates the savestack level just before
5021 * the new sub was created
5025 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
5030 I32 repl_has_vars = 0;
5032 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5033 bool is_compiletime;
5036 PERL_ARGS_ASSERT_PMRUNTIME;
5038 /* for s/// and tr///, last element in list is the replacement; pop it */
5040 if (is_trans || o->op_type == OP_SUBST) {
5042 repl = cLISTOPx(expr)->op_last;
5043 kid = cLISTOPx(expr)->op_first;
5044 while (OP_SIBLING(kid) != repl)
5045 kid = OP_SIBLING(kid);
5046 op_sibling_splice(expr, kid, 1, NULL);
5049 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
5054 assert(expr->op_type == OP_LIST);
5055 first = cLISTOPx(expr)->op_first;
5056 last = cLISTOPx(expr)->op_last;
5057 assert(first->op_type == OP_PUSHMARK);
5058 assert(OP_SIBLING(first) == last);
5060 /* cut 'last' from sibling chain, then free everything else */
5061 op_sibling_splice(expr, first, 1, NULL);
5064 return pmtrans(o, last, repl);
5067 /* find whether we have any runtime or code elements;
5068 * at the same time, temporarily set the op_next of each DO block;
5069 * then when we LINKLIST, this will cause the DO blocks to be excluded
5070 * from the op_next chain (and from having LINKLIST recursively
5071 * applied to them). We fix up the DOs specially later */
5075 if (expr->op_type == OP_LIST) {
5077 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5078 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5080 assert(!o->op_next);
5081 if (UNLIKELY(!OP_HAS_SIBLING(o))) {
5082 assert(PL_parser && PL_parser->error_count);
5083 /* This can happen with qr/ (?{(^{})/. Just fake up
5084 the op we were expecting to see, to avoid crashing
5086 op_sibling_splice(expr, o, 0,
5087 newSVOP(OP_CONST, 0, &PL_sv_no));
5089 o->op_next = OP_SIBLING(o);
5091 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5095 else if (expr->op_type != OP_CONST)
5100 /* fix up DO blocks; treat each one as a separate little sub;
5101 * also, mark any arrays as LIST/REF */
5103 if (expr->op_type == OP_LIST) {
5105 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5107 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5108 assert( !(o->op_flags & OPf_WANT));
5109 /* push the array rather than its contents. The regex
5110 * engine will retrieve and join the elements later */
5111 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5115 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5117 o->op_next = NULL; /* undo temporary hack from above */
5120 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5121 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5123 assert(leaveop->op_first->op_type == OP_ENTER);
5124 assert(OP_HAS_SIBLING(leaveop->op_first));
5125 o->op_next = OP_SIBLING(leaveop->op_first);
5127 assert(leaveop->op_flags & OPf_KIDS);
5128 assert(leaveop->op_last->op_next == (OP*)leaveop);
5129 leaveop->op_next = NULL; /* stop on last op */
5130 op_null((OP*)leaveop);
5134 OP *scope = cLISTOPo->op_first;
5135 assert(scope->op_type == OP_SCOPE);
5136 assert(scope->op_flags & OPf_KIDS);
5137 scope->op_next = NULL; /* stop on last op */
5140 /* have to peep the DOs individually as we've removed it from
5141 * the op_next chain */
5143 S_prune_chain_head(&(o->op_next));
5145 /* runtime finalizes as part of finalizing whole tree */
5149 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5150 assert( !(expr->op_flags & OPf_WANT));
5151 /* push the array rather than its contents. The regex
5152 * engine will retrieve and join the elements later */
5153 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5156 PL_hints |= HINT_BLOCK_SCOPE;
5158 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5160 if (is_compiletime) {
5161 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5162 regexp_engine const *eng = current_re_engine();
5164 if (o->op_flags & OPf_SPECIAL)
5165 rx_flags |= RXf_SPLIT;
5167 if (!has_code || !eng->op_comp) {
5168 /* compile-time simple constant pattern */
5170 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5171 /* whoops! we guessed that a qr// had a code block, but we
5172 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5173 * that isn't required now. Note that we have to be pretty
5174 * confident that nothing used that CV's pad while the
5175 * regex was parsed */
5176 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
5177 /* But we know that one op is using this CV's slab. */
5178 cv_forget_slab(PL_compcv);
5180 pm->op_pmflags &= ~PMf_HAS_CV;
5185 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5186 rx_flags, pm->op_pmflags)
5187 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5188 rx_flags, pm->op_pmflags)
5193 /* compile-time pattern that includes literal code blocks */
5194 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5197 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5200 if (pm->op_pmflags & PMf_HAS_CV) {
5202 /* this QR op (and the anon sub we embed it in) is never
5203 * actually executed. It's just a placeholder where we can
5204 * squirrel away expr in op_code_list without the peephole
5205 * optimiser etc processing it for a second time */
5206 OP *qr = newPMOP(OP_QR, 0);
5207 ((PMOP*)qr)->op_code_list = expr;
5209 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5210 SvREFCNT_inc_simple_void(PL_compcv);
5211 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5212 ReANY(re)->qr_anoncv = cv;
5214 /* attach the anon CV to the pad so that
5215 * pad_fixup_inner_anons() can find it */
5216 (void)pad_add_anon(cv, o->op_type);
5217 SvREFCNT_inc_simple_void(cv);
5220 pm->op_code_list = expr;
5225 /* runtime pattern: build chain of regcomp etc ops */
5227 PADOFFSET cv_targ = 0;
5229 reglist = isreg && expr->op_type == OP_LIST;
5234 pm->op_code_list = expr;
5235 /* don't free op_code_list; its ops are embedded elsewhere too */
5236 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5239 if (o->op_flags & OPf_SPECIAL)
5240 pm->op_pmflags |= PMf_SPLIT;
5242 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5243 * to allow its op_next to be pointed past the regcomp and
5244 * preceding stacking ops;
5245 * OP_REGCRESET is there to reset taint before executing the
5247 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5248 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5250 if (pm->op_pmflags & PMf_HAS_CV) {
5251 /* we have a runtime qr with literal code. This means
5252 * that the qr// has been wrapped in a new CV, which
5253 * means that runtime consts, vars etc will have been compiled
5254 * against a new pad. So... we need to execute those ops
5255 * within the environment of the new CV. So wrap them in a call
5256 * to a new anon sub. i.e. for
5260 * we build an anon sub that looks like
5262 * sub { "a", $b, '(?{...})' }
5264 * and call it, passing the returned list to regcomp.
5265 * Or to put it another way, the list of ops that get executed
5269 * ------ -------------------
5270 * pushmark (for regcomp)
5271 * pushmark (for entersub)
5272 * pushmark (for refgen)
5276 * regcreset regcreset
5278 * const("a") const("a")
5280 * const("(?{...})") const("(?{...})")
5285 SvREFCNT_inc_simple_void(PL_compcv);
5286 /* these lines are just an unrolled newANONATTRSUB */
5287 expr = newSVOP(OP_ANONCODE, 0,
5288 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5289 cv_targ = expr->op_targ;
5290 expr = newUNOP(OP_REFGEN, 0, expr);
5292 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5295 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5296 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
5297 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5298 | (reglist ? OPf_STACKED : 0);
5299 rcop->op_targ = cv_targ;
5301 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5302 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
5304 /* establish postfix order */
5305 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5307 rcop->op_next = expr;
5308 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5311 rcop->op_next = LINKLIST(expr);
5312 expr->op_next = (OP*)rcop;
5315 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5321 /* If we are looking at s//.../e with a single statement, get past
5322 the implicit do{}. */
5323 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5324 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5325 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5328 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5329 if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
5330 && !OP_HAS_SIBLING(sib))
5333 if (curop->op_type == OP_CONST)
5335 else if (( (curop->op_type == OP_RV2SV ||
5336 curop->op_type == OP_RV2AV ||
5337 curop->op_type == OP_RV2HV ||
5338 curop->op_type == OP_RV2GV)
5339 && cUNOPx(curop)->op_first
5340 && cUNOPx(curop)->op_first->op_type == OP_GV )
5341 || curop->op_type == OP_PADSV
5342 || curop->op_type == OP_PADAV
5343 || curop->op_type == OP_PADHV
5344 || curop->op_type == OP_PADANY) {
5352 || !RX_PRELEN(PM_GETRE(pm))
5353 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5355 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5356 op_prepend_elem(o->op_type, scalar(repl), o);
5359 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5360 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
5361 rcop->op_private = 1;
5363 /* establish postfix order */
5364 rcop->op_next = LINKLIST(repl);
5365 repl->op_next = (OP*)rcop;
5367 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5368 assert(!(pm->op_pmflags & PMf_ONCE));
5369 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5378 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5380 Constructs, checks, and returns an op of any type that involves an
5381 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
5382 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
5383 takes ownership of one reference to it.
5389 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5394 PERL_ARGS_ASSERT_NEWSVOP;
5396 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5397 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5398 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5400 NewOp(1101, svop, 1, SVOP);
5401 svop->op_type = (OPCODE)type;
5402 svop->op_ppaddr = PL_ppaddr[type];
5404 svop->op_next = (OP*)svop;
5405 svop->op_flags = (U8)flags;
5406 svop->op_private = (U8)(0 | (flags >> 8));
5407 if (PL_opargs[type] & OA_RETSCALAR)
5409 if (PL_opargs[type] & OA_TARGET)
5410 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5411 return CHECKOP(type, svop);
5417 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5419 Constructs, checks, and returns an op of any type that involves a
5420 reference to a pad element. I<type> is the opcode. I<flags> gives the
5421 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5422 is populated with I<sv>; this function takes ownership of one reference
5425 This function only exists if Perl has been compiled to use ithreads.
5431 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5436 PERL_ARGS_ASSERT_NEWPADOP;
5438 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5439 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5440 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5442 NewOp(1101, padop, 1, PADOP);
5443 padop->op_type = (OPCODE)type;
5444 padop->op_ppaddr = PL_ppaddr[type];
5446 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5447 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5448 PAD_SETSV(padop->op_padix, sv);
5450 padop->op_next = (OP*)padop;
5451 padop->op_flags = (U8)flags;
5452 if (PL_opargs[type] & OA_RETSCALAR)
5454 if (PL_opargs[type] & OA_TARGET)
5455 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5456 return CHECKOP(type, padop);
5459 #endif /* USE_ITHREADS */
5462 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5464 Constructs, checks, and returns an op of any type that involves an
5465 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5466 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5467 reference; calling this function does not transfer ownership of any
5474 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5476 PERL_ARGS_ASSERT_NEWGVOP;
5479 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5481 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5486 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5488 Constructs, checks, and returns an op of any type that involves an
5489 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5490 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
5491 must have been allocated using C<PerlMemShared_malloc>; the memory will
5492 be freed when the op is destroyed.
5498 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5501 const bool utf8 = cBOOL(flags & SVf_UTF8);
5506 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5508 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5510 NewOp(1101, pvop, 1, PVOP);
5511 pvop->op_type = (OPCODE)type;
5512 pvop->op_ppaddr = PL_ppaddr[type];
5514 pvop->op_next = (OP*)pvop;
5515 pvop->op_flags = (U8)flags;
5516 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5517 if (PL_opargs[type] & OA_RETSCALAR)
5519 if (PL_opargs[type] & OA_TARGET)
5520 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5521 return CHECKOP(type, pvop);
5525 Perl_package(pTHX_ OP *o)
5527 SV *const sv = cSVOPo->op_sv;
5529 PERL_ARGS_ASSERT_PACKAGE;
5531 SAVEGENERICSV(PL_curstash);
5532 save_item(PL_curstname);
5534 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5536 sv_setsv(PL_curstname, sv);
5538 PL_hints |= HINT_BLOCK_SCOPE;
5539 PL_parser->copline = NOLINE;
5545 Perl_package_version( pTHX_ OP *v )
5547 U32 savehints = PL_hints;
5548 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5549 PL_hints &= ~HINT_STRICT_VARS;
5550 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5551 PL_hints = savehints;
5556 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5561 SV *use_version = NULL;
5563 PERL_ARGS_ASSERT_UTILIZE;
5565 if (idop->op_type != OP_CONST)
5566 Perl_croak(aTHX_ "Module name must be constant");
5571 SV * const vesv = ((SVOP*)version)->op_sv;
5573 if (!arg && !SvNIOKp(vesv)) {
5580 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5581 Perl_croak(aTHX_ "Version number must be a constant number");
5583 /* Make copy of idop so we don't free it twice */
5584 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5586 /* Fake up a method call to VERSION */
5587 meth = newSVpvs_share("VERSION");
5588 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5589 op_append_elem(OP_LIST,
5590 op_prepend_elem(OP_LIST, pack, list(version)),
5591 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5595 /* Fake up an import/unimport */
5596 if (arg && arg->op_type == OP_STUB) {
5597 imop = arg; /* no import on explicit () */
5599 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5600 imop = NULL; /* use 5.0; */
5602 use_version = ((SVOP*)idop)->op_sv;
5604 idop->op_private |= OPpCONST_NOVER;
5609 /* Make copy of idop so we don't free it twice */
5610 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5612 /* Fake up a method call to import/unimport */
5614 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5615 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5616 op_append_elem(OP_LIST,
5617 op_prepend_elem(OP_LIST, pack, list(arg)),
5618 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5621 /* Fake up the BEGIN {}, which does its thing immediately. */
5623 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5626 op_append_elem(OP_LINESEQ,
5627 op_append_elem(OP_LINESEQ,
5628 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5629 newSTATEOP(0, NULL, veop)),
5630 newSTATEOP(0, NULL, imop) ));
5634 * feature bundle that corresponds to the required version. */
5635 use_version = sv_2mortal(new_version(use_version));
5636 S_enable_feature_bundle(aTHX_ use_version);
5638 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5639 if (vcmp(use_version,
5640 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5641 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5642 PL_hints |= HINT_STRICT_REFS;
5643 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5644 PL_hints |= HINT_STRICT_SUBS;
5645 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5646 PL_hints |= HINT_STRICT_VARS;
5648 /* otherwise they are off */
5650 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5651 PL_hints &= ~HINT_STRICT_REFS;
5652 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5653 PL_hints &= ~HINT_STRICT_SUBS;
5654 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5655 PL_hints &= ~HINT_STRICT_VARS;
5659 /* The "did you use incorrect case?" warning used to be here.
5660 * The problem is that on case-insensitive filesystems one
5661 * might get false positives for "use" (and "require"):
5662 * "use Strict" or "require CARP" will work. This causes
5663 * portability problems for the script: in case-strict
5664 * filesystems the script will stop working.
5666 * The "incorrect case" warning checked whether "use Foo"
5667 * imported "Foo" to your namespace, but that is wrong, too:
5668 * there is no requirement nor promise in the language that
5669 * a Foo.pm should or would contain anything in package "Foo".
5671 * There is very little Configure-wise that can be done, either:
5672 * the case-sensitivity of the build filesystem of Perl does not
5673 * help in guessing the case-sensitivity of the runtime environment.
5676 PL_hints |= HINT_BLOCK_SCOPE;
5677 PL_parser->copline = NOLINE;
5678 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5679 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5685 =head1 Embedding Functions
5687 =for apidoc load_module
5689 Loads the module whose name is pointed to by the string part of name.
5690 Note that the actual module name, not its filename, should be given.
5691 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5692 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5693 (or 0 for no flags). ver, if specified
5694 and not NULL, provides version semantics
5695 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5696 arguments can be used to specify arguments to the module's import()
5697 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5698 terminated with a final NULL pointer. Note that this list can only
5699 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5700 Otherwise at least a single NULL pointer to designate the default
5701 import list is required.
5703 The reference count for each specified C<SV*> parameter is decremented.
5708 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5712 PERL_ARGS_ASSERT_LOAD_MODULE;
5714 va_start(args, ver);
5715 vload_module(flags, name, ver, &args);
5719 #ifdef PERL_IMPLICIT_CONTEXT
5721 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5725 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5726 va_start(args, ver);
5727 vload_module(flags, name, ver, &args);
5733 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5736 OP * const modname = newSVOP(OP_CONST, 0, name);
5738 PERL_ARGS_ASSERT_VLOAD_MODULE;
5740 modname->op_private |= OPpCONST_BARE;
5742 veop = newSVOP(OP_CONST, 0, ver);
5746 if (flags & PERL_LOADMOD_NOIMPORT) {
5747 imop = sawparens(newNULLLIST());
5749 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5750 imop = va_arg(*args, OP*);
5755 sv = va_arg(*args, SV*);
5757 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5758 sv = va_arg(*args, SV*);
5762 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5763 * that it has a PL_parser to play with while doing that, and also
5764 * that it doesn't mess with any existing parser, by creating a tmp
5765 * new parser with lex_start(). This won't actually be used for much,
5766 * since pp_require() will create another parser for the real work.
5767 * The ENTER/LEAVE pair protect callers from any side effects of use. */
5770 SAVEVPTR(PL_curcop);
5771 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5772 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5773 veop, modname, imop);
5777 PERL_STATIC_INLINE OP *
5778 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5780 return newUNOP(OP_ENTERSUB, OPf_STACKED,
5781 newLISTOP(OP_LIST, 0, arg,
5782 newUNOP(OP_RV2CV, 0,
5783 newGVOP(OP_GV, 0, gv))));
5787 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5792 PERL_ARGS_ASSERT_DOFILE;
5794 if (!force_builtin && (gv = gv_override("do", 2))) {
5795 doop = S_new_entersubop(aTHX_ gv, term);
5798 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5804 =head1 Optree construction
5806 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5808 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5809 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5810 be set automatically, and, shifted up eight bits, the eight bits of
5811 C<op_private>, except that the bit with value 1 or 2 is automatically
5812 set as required. I<listval> and I<subscript> supply the parameters of
5813 the slice; they are consumed by this function and become part of the
5814 constructed op tree.
5820 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5822 return newBINOP(OP_LSLICE, flags,
5823 list(force_list(subscript, 1)),
5824 list(force_list(listval, 1)) );
5827 #define ASSIGN_LIST 1
5828 #define ASSIGN_REF 2
5831 S_assignment_type(pTHX_ const OP *o)
5840 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5841 o = cUNOPo->op_first;
5843 flags = o->op_flags;
5845 if (type == OP_COND_EXPR) {
5846 OP * const sib = OP_SIBLING(cLOGOPo->op_first);
5847 const I32 t = assignment_type(sib);
5848 const I32 f = assignment_type(OP_SIBLING(sib));
5850 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
5852 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
5853 yyerror("Assignment to both a list and a scalar");
5857 if (type == OP_SREFGEN)
5859 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
5860 type = kid->op_type;
5861 flags |= kid->op_flags;
5862 if (!(flags & OPf_PARENS)
5863 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
5864 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
5870 if (type == OP_LIST &&
5871 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5872 o->op_private & OPpLVAL_INTRO)
5875 if (type == OP_LIST || flags & OPf_PARENS ||
5876 type == OP_RV2AV || type == OP_RV2HV ||
5877 type == OP_ASLICE || type == OP_HSLICE ||
5878 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
5881 if (type == OP_PADAV || type == OP_PADHV)
5884 if (type == OP_RV2SV)
5891 Helper function for newASSIGNOP to detection commonality between the
5892 lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
5893 flags the op and the peephole optimizer calls this helper function
5894 if the flag is set.) Marks all variables with PL_generation. If it
5895 returns TRUE the assignment must be able to handle common variables.
5897 PL_generation sorcery:
5898 An assignment like ($a,$b) = ($c,$d) is easier than
5899 ($a,$b) = ($c,$a), since there is no need for temporary vars.
5900 To detect whether there are common vars, the global var
5901 PL_generation is incremented for each assign op we compile.
5902 Then, while compiling the assign op, we run through all the
5903 variables on both sides of the assignment, setting a spare slot
5904 in each of them to PL_generation. If any of them already have
5905 that value, we know we've got commonality. Also, if the
5906 generation number is already set to PERL_INT_MAX, then
5907 the variable is involved in aliasing, so we also have
5908 potential commonality in that case. We could use a
5909 single bit marker, but then we'd have to make 2 passes, first
5910 to clear the flag, then to test and set it. And that
5911 wouldn't help with aliasing, either. To find somewhere
5912 to store these values, evil chicanery is done with SvUVX().
5914 PERL_STATIC_INLINE bool
5915 S_aassign_common_vars(pTHX_ OP* o)
5918 for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
5919 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5920 if (curop->op_type == OP_GV || curop->op_type == OP_GVSV) {
5921 GV *gv = cGVOPx_gv(curop);
5923 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5925 GvASSIGN_GENERATION_set(gv, PL_generation);
5927 else if (curop->op_type == OP_PADSV ||
5928 curop->op_type == OP_PADAV ||
5929 curop->op_type == OP_PADHV ||
5930 curop->op_type == OP_PADANY)
5933 if (PAD_COMPNAME_GEN(curop->op_targ)
5934 == (STRLEN)PL_generation
5935 || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
5937 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5940 else if (curop->op_type == OP_RV2CV)
5942 else if (curop->op_type == OP_RV2SV ||
5943 curop->op_type == OP_RV2AV ||
5944 curop->op_type == OP_RV2HV ||
5945 curop->op_type == OP_RV2GV) {
5946 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5949 else if (curop->op_type == OP_PUSHRE) {
5952 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5953 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5956 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5960 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5962 GvASSIGN_GENERATION_set(gv, PL_generation);
5964 else if (curop->op_targ)
5967 else if (curop->op_type == OP_PADRANGE)
5968 /* Ignore padrange; checking its siblings is sufficient. */
5974 if (curop->op_flags & OPf_KIDS) {
5975 if (aassign_common_vars(curop))
5982 /* This variant only handles lexical aliases. It is called when
5983 newASSIGNOP decides that we don’t have any common vars, as lexical ali-
5984 ases trump that decision. */
5985 PERL_STATIC_INLINE bool
5986 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
5989 for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
5990 if ((curop->op_type == OP_PADSV ||
5991 curop->op_type == OP_PADAV ||
5992 curop->op_type == OP_PADHV ||
5993 curop->op_type == OP_PADANY)
5994 && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
5997 if (curop->op_type == OP_PUSHRE && curop->op_targ
5998 && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6001 if (curop->op_flags & OPf_KIDS) {
6002 if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6010 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6012 Constructs, checks, and returns an assignment op. I<left> and I<right>
6013 supply the parameters of the assignment; they are consumed by this
6014 function and become part of the constructed op tree.
6016 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6017 a suitable conditional optree is constructed. If I<optype> is the opcode
6018 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6019 performs the binary operation and assigns the result to the left argument.
6020 Either way, if I<optype> is non-zero then I<flags> has no effect.
6022 If I<optype> is zero, then a plain scalar or list assignment is
6023 constructed. Which type of assignment it is is automatically determined.
6024 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6025 will be set automatically, and, shifted up eight bits, the eight bits
6026 of C<op_private>, except that the bit with value 1 or 2 is automatically
6033 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6039 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6040 return newLOGOP(optype, 0,
6041 op_lvalue(scalar(left), optype),
6042 newUNOP(OP_SASSIGN, 0, scalar(right)));
6045 return newBINOP(optype, OPf_STACKED,
6046 op_lvalue(scalar(left), optype), scalar(right));
6050 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6051 static const char no_list_state[] = "Initialization of state variables"
6052 " in list context currently forbidden";
6054 bool maybe_common_vars = TRUE;
6056 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6057 left->op_private &= ~ OPpSLICEWARNING;
6060 left = op_lvalue(left, OP_AASSIGN);
6061 curop = list(force_list(left, 1));
6062 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6063 o->op_private = (U8)(0 | (flags >> 8));
6065 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6067 OP* lop = ((LISTOP*)left)->op_first;
6068 maybe_common_vars = FALSE;
6070 if (lop->op_type == OP_PADSV ||
6071 lop->op_type == OP_PADAV ||
6072 lop->op_type == OP_PADHV ||
6073 lop->op_type == OP_PADANY) {
6074 if (!(lop->op_private & OPpLVAL_INTRO))
6076 maybe_common_vars = TRUE;
6080 if (lop->op_private & OPpPAD_STATE) {
6081 if (left->op_private & OPpLVAL_INTRO) {
6082 /* Each variable in state($a, $b, $c) = ... */
6085 /* Each state variable in
6086 (state $a, my $b, our $c, $d, undef) = ... */
6088 yyerror(no_list_state);
6090 /* Each my variable in
6091 (state $a, my $b, our $c, $d, undef) = ... */
6093 } else if (lop->op_type == OP_UNDEF ||
6094 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6095 /* undef may be interesting in
6096 (state $a, undef, state $c) */
6098 /* Other ops in the list. */
6099 maybe_common_vars = TRUE;
6102 lop = OP_SIBLING(lop);
6105 else if ((left->op_private & OPpLVAL_INTRO)
6106 && ( left->op_type == OP_PADSV
6107 || left->op_type == OP_PADAV
6108 || left->op_type == OP_PADHV
6109 || left->op_type == OP_PADANY))
6111 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6112 if (left->op_private & OPpPAD_STATE) {
6113 /* All single variable list context state assignments, hence
6123 yyerror(no_list_state);
6127 if (maybe_common_vars) {
6128 /* The peephole optimizer will do the full check and pos-
6129 sibly turn this off. */
6130 o->op_private |= OPpASSIGN_COMMON;
6133 if (right && right->op_type == OP_SPLIT
6134 && !(right->op_flags & OPf_STACKED)) {
6135 OP* tmpop = ((LISTOP*)right)->op_first;
6136 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
6137 PMOP * const pm = (PMOP*)tmpop;
6140 !pm->op_pmreplrootu.op_pmtargetoff
6142 !pm->op_pmreplrootu.op_pmtargetgv
6146 if (!(left->op_private & OPpLVAL_INTRO) &&
6147 ( (left->op_type == OP_RV2AV &&
6148 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6149 || left->op_type == OP_PADAV )
6151 if (tmpop != (OP *)pm) {
6153 pm->op_pmreplrootu.op_pmtargetoff
6154 = cPADOPx(tmpop)->op_padix;
6155 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6157 pm->op_pmreplrootu.op_pmtargetgv
6158 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6159 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6161 right->op_private |=
6162 left->op_private & OPpOUR_INTRO;
6165 pm->op_targ = left->op_targ;
6166 left->op_targ = 0; /* filch it */
6169 tmpop = cUNOPo->op_first; /* to list (nulled) */
6170 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6171 /* detach rest of siblings from o subtree,
6172 * and free subtree */
6173 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6174 op_free(o); /* blow off assign */
6175 right->op_flags &= ~OPf_WANT;
6176 /* "I don't know and I don't care." */
6179 else if (left->op_type == OP_RV2AV
6180 || left->op_type == OP_PADAV)
6182 /* Detach the array. */
6186 op_sibling_splice(cBINOPo->op_last,
6187 cUNOPx(cBINOPo->op_last)
6188 ->op_first, 1, NULL);
6189 assert(ary == left);
6190 /* Attach it to the split. */
6191 op_sibling_splice(right, cLISTOPx(right)->op_last,
6193 right->op_flags |= OPf_STACKED;
6194 /* Detach split and expunge aassign as above. */
6197 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6198 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6201 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6202 SV * const sv = *svp;
6203 if (SvIOK(sv) && SvIVX(sv) == 0)
6205 if (right->op_private & OPpSPLIT_IMPLIM) {
6206 /* our own SV, created in ck_split */
6208 sv_setiv(sv, PL_modcount+1);
6211 /* SV may belong to someone else */
6213 *svp = newSViv(PL_modcount+1);
6222 if (assign_type == ASSIGN_REF)
6223 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6225 right = newOP(OP_UNDEF, 0);
6226 if (right->op_type == OP_READLINE) {
6227 right->op_flags |= OPf_STACKED;
6228 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6232 o = newBINOP(OP_SASSIGN, flags,
6233 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6239 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6241 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6242 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6243 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6244 If I<label> is non-null, it supplies the name of a label to attach to
6245 the state op; this function takes ownership of the memory pointed at by
6246 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
6249 If I<o> is null, the state op is returned. Otherwise the state op is
6250 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
6251 is consumed by this function and becomes part of the returned op tree.
6257 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6260 const U32 seq = intro_my();
6261 const U32 utf8 = flags & SVf_UTF8;
6266 NewOp(1101, cop, 1, COP);
6267 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6268 cop->op_type = OP_DBSTATE;
6269 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
6272 cop->op_type = OP_NEXTSTATE;
6273 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
6275 cop->op_flags = (U8)flags;
6276 CopHINTS_set(cop, PL_hints);
6278 cop->op_private |= NATIVE_HINTS;
6281 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6283 cop->op_next = (OP*)cop;
6286 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6287 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6289 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6291 PL_hints |= HINT_BLOCK_SCOPE;
6292 /* It seems that we need to defer freeing this pointer, as other parts
6293 of the grammar end up wanting to copy it after this op has been
6298 if (PL_parser->preambling != NOLINE) {
6299 CopLINE_set(cop, PL_parser->preambling);
6300 PL_parser->copline = NOLINE;
6302 else if (PL_parser->copline == NOLINE)
6303 CopLINE_set(cop, CopLINE(PL_curcop));
6305 CopLINE_set(cop, PL_parser->copline);
6306 PL_parser->copline = NOLINE;
6309 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6311 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6313 CopSTASH_set(cop, PL_curstash);
6315 if (cop->op_type == OP_DBSTATE) {
6316 /* this line can have a breakpoint - store the cop in IV */
6317 AV *av = CopFILEAVx(PL_curcop);
6319 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6320 if (svp && *svp != &PL_sv_undef ) {
6321 (void)SvIOK_on(*svp);
6322 SvIV_set(*svp, PTR2IV(cop));
6327 if (flags & OPf_SPECIAL)
6329 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6333 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6335 Constructs, checks, and returns a logical (flow control) op. I<type>
6336 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
6337 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6338 the eight bits of C<op_private>, except that the bit with value 1 is
6339 automatically set. I<first> supplies the expression controlling the
6340 flow, and I<other> supplies the side (alternate) chain of ops; they are
6341 consumed by this function and become part of the constructed op tree.
6347 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6349 PERL_ARGS_ASSERT_NEWLOGOP;
6351 return new_logop(type, flags, &first, &other);
6355 S_search_const(pTHX_ OP *o)
6357 PERL_ARGS_ASSERT_SEARCH_CONST;
6359 switch (o->op_type) {
6363 if (o->op_flags & OPf_KIDS)
6364 return search_const(cUNOPo->op_first);
6371 if (!(o->op_flags & OPf_KIDS))
6373 kid = cLISTOPo->op_first;
6375 switch (kid->op_type) {
6379 kid = OP_SIBLING(kid);
6382 if (kid != cLISTOPo->op_last)
6388 kid = cLISTOPo->op_last;
6390 return search_const(kid);
6398 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6406 int prepend_not = 0;
6408 PERL_ARGS_ASSERT_NEW_LOGOP;
6413 /* [perl #59802]: Warn about things like "return $a or $b", which
6414 is parsed as "(return $a) or $b" rather than "return ($a or
6415 $b)". NB: This also applies to xor, which is why we do it
6418 switch (first->op_type) {
6422 /* XXX: Perhaps we should emit a stronger warning for these.
6423 Even with the high-precedence operator they don't seem to do
6426 But until we do, fall through here.
6432 /* XXX: Currently we allow people to "shoot themselves in the
6433 foot" by explicitly writing "(return $a) or $b".
6435 Warn unless we are looking at the result from folding or if
6436 the programmer explicitly grouped the operators like this.
6437 The former can occur with e.g.
6439 use constant FEATURE => ( $] >= ... );
6440 sub { not FEATURE and return or do_stuff(); }
6442 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6443 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6444 "Possible precedence issue with control flow operator");
6445 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6451 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6452 return newBINOP(type, flags, scalar(first), scalar(other));
6454 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6456 scalarboolean(first);
6457 /* optimize AND and OR ops that have NOTs as children */
6458 if (first->op_type == OP_NOT
6459 && (first->op_flags & OPf_KIDS)
6460 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6461 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6463 if (type == OP_AND || type == OP_OR) {
6469 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6471 prepend_not = 1; /* prepend a NOT op later */
6475 /* search for a constant op that could let us fold the test */
6476 if ((cstop = search_const(first))) {
6477 if (cstop->op_private & OPpCONST_STRICT)
6478 no_bareword_allowed(cstop);
6479 else if ((cstop->op_private & OPpCONST_BARE))
6480 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6481 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6482 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6483 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6485 if (other->op_type == OP_CONST)
6486 other->op_private |= OPpCONST_SHORTCIRCUIT;
6488 if (other->op_type == OP_LEAVE)
6489 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6490 else if (other->op_type == OP_MATCH
6491 || other->op_type == OP_SUBST
6492 || other->op_type == OP_TRANSR
6493 || other->op_type == OP_TRANS)
6494 /* Mark the op as being unbindable with =~ */
6495 other->op_flags |= OPf_SPECIAL;
6497 other->op_folded = 1;
6501 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6502 const OP *o2 = other;
6503 if ( ! (o2->op_type == OP_LIST
6504 && (( o2 = cUNOPx(o2)->op_first))
6505 && o2->op_type == OP_PUSHMARK
6506 && (( o2 = OP_SIBLING(o2))) )
6509 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6510 || o2->op_type == OP_PADHV)
6511 && o2->op_private & OPpLVAL_INTRO
6512 && !(o2->op_private & OPpPAD_STATE))
6514 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6515 "Deprecated use of my() in false conditional");
6519 if (cstop->op_type == OP_CONST)
6520 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6525 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6526 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6528 const OP * const k1 = ((UNOP*)first)->op_first;
6529 const OP * const k2 = OP_SIBLING(k1);
6531 switch (first->op_type)
6534 if (k2 && k2->op_type == OP_READLINE
6535 && (k2->op_flags & OPf_STACKED)
6536 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6538 warnop = k2->op_type;
6543 if (k1->op_type == OP_READDIR
6544 || k1->op_type == OP_GLOB
6545 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6546 || k1->op_type == OP_EACH
6547 || k1->op_type == OP_AEACH)
6549 warnop = ((k1->op_type == OP_NULL)
6550 ? (OPCODE)k1->op_targ : k1->op_type);
6555 const line_t oldline = CopLINE(PL_curcop);
6556 /* This ensures that warnings are reported at the first line
6557 of the construction, not the last. */
6558 CopLINE_set(PL_curcop, PL_parser->copline);
6559 Perl_warner(aTHX_ packWARN(WARN_MISC),
6560 "Value of %s%s can be \"0\"; test with defined()",
6562 ((warnop == OP_READLINE || warnop == OP_GLOB)
6563 ? " construct" : "() operator"));
6564 CopLINE_set(PL_curcop, oldline);
6571 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6572 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6574 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6575 logop->op_ppaddr = PL_ppaddr[type];
6576 logop->op_flags |= (U8)flags;
6577 logop->op_private = (U8)(1 | (flags >> 8));
6579 /* establish postfix order */
6580 logop->op_next = LINKLIST(first);
6581 first->op_next = (OP*)logop;
6582 assert(!OP_HAS_SIBLING(first));
6583 op_sibling_splice((OP*)logop, first, 0, other);
6585 CHECKOP(type,logop);
6587 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6594 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6596 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6597 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6598 will be set automatically, and, shifted up eight bits, the eight bits of
6599 C<op_private>, except that the bit with value 1 is automatically set.
6600 I<first> supplies the expression selecting between the two branches,
6601 and I<trueop> and I<falseop> supply the branches; they are consumed by
6602 this function and become part of the constructed op tree.
6608 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6616 PERL_ARGS_ASSERT_NEWCONDOP;
6619 return newLOGOP(OP_AND, 0, first, trueop);
6621 return newLOGOP(OP_OR, 0, first, falseop);
6623 scalarboolean(first);
6624 if ((cstop = search_const(first))) {
6625 /* Left or right arm of the conditional? */
6626 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6627 OP *live = left ? trueop : falseop;
6628 OP *const dead = left ? falseop : trueop;
6629 if (cstop->op_private & OPpCONST_BARE &&
6630 cstop->op_private & OPpCONST_STRICT) {
6631 no_bareword_allowed(cstop);
6635 if (live->op_type == OP_LEAVE)
6636 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6637 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6638 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6639 /* Mark the op as being unbindable with =~ */
6640 live->op_flags |= OPf_SPECIAL;
6641 live->op_folded = 1;
6644 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6645 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6646 logop->op_flags |= (U8)flags;
6647 logop->op_private = (U8)(1 | (flags >> 8));
6648 logop->op_next = LINKLIST(falseop);
6650 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6653 /* establish postfix order */
6654 start = LINKLIST(first);
6655 first->op_next = (OP*)logop;
6657 /* make first, trueop, falseop siblings */
6658 op_sibling_splice((OP*)logop, first, 0, trueop);
6659 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6661 o = newUNOP(OP_NULL, 0, (OP*)logop);
6663 trueop->op_next = falseop->op_next = o;
6670 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6672 Constructs and returns a C<range> op, with subordinate C<flip> and
6673 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6674 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6675 for both the C<flip> and C<range> ops, except that the bit with value
6676 1 is automatically set. I<left> and I<right> supply the expressions
6677 controlling the endpoints of the range; they are consumed by this function
6678 and become part of the constructed op tree.
6684 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6693 PERL_ARGS_ASSERT_NEWRANGE;
6695 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6696 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6697 range->op_flags = OPf_KIDS;
6698 leftstart = LINKLIST(left);
6699 range->op_private = (U8)(1 | (flags >> 8));
6701 /* make left and right siblings */
6702 op_sibling_splice((OP*)range, left, 0, right);
6704 range->op_next = (OP*)range;
6705 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6706 flop = newUNOP(OP_FLOP, 0, flip);
6707 o = newUNOP(OP_NULL, 0, flop);
6709 range->op_next = leftstart;
6711 left->op_next = flip;
6712 right->op_next = flop;
6714 range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);
6715 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6716 flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);;
6717 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6718 SvPADTMP_on(PAD_SV(flip->op_targ));
6720 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6721 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6723 /* check barewords before they might be optimized aways */
6724 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6725 no_bareword_allowed(left);
6726 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6727 no_bareword_allowed(right);
6730 if (!flip->op_private || !flop->op_private)
6731 LINKLIST(o); /* blow off optimizer unless constant */
6737 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6739 Constructs, checks, and returns an op tree expressing a loop. This is
6740 only a loop in the control flow through the op tree; it does not have
6741 the heavyweight loop structure that allows exiting the loop by C<last>
6742 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6743 top-level op, except that some bits will be set automatically as required.
6744 I<expr> supplies the expression controlling loop iteration, and I<block>
6745 supplies the body of the loop; they are consumed by this function and
6746 become part of the constructed op tree. I<debuggable> is currently
6747 unused and should always be 1.
6753 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6757 const bool once = block && block->op_flags & OPf_SPECIAL &&
6758 block->op_type == OP_NULL;
6760 PERL_UNUSED_ARG(debuggable);
6764 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6765 || ( expr->op_type == OP_NOT
6766 && cUNOPx(expr)->op_first->op_type == OP_CONST
6767 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6770 /* Return the block now, so that S_new_logop does not try to
6772 return block; /* do {} while 0 does once */
6773 if (expr->op_type == OP_READLINE
6774 || expr->op_type == OP_READDIR
6775 || expr->op_type == OP_GLOB
6776 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6777 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6778 expr = newUNOP(OP_DEFINED, 0,
6779 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6780 } else if (expr->op_flags & OPf_KIDS) {
6781 const OP * const k1 = ((UNOP*)expr)->op_first;
6782 const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL;
6783 switch (expr->op_type) {
6785 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6786 && (k2->op_flags & OPf_STACKED)
6787 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6788 expr = newUNOP(OP_DEFINED, 0, expr);
6792 if (k1 && (k1->op_type == OP_READDIR
6793 || k1->op_type == OP_GLOB
6794 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6795 || k1->op_type == OP_EACH
6796 || k1->op_type == OP_AEACH))
6797 expr = newUNOP(OP_DEFINED, 0, expr);
6803 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6804 * op, in listop. This is wrong. [perl #27024] */
6806 block = newOP(OP_NULL, 0);
6807 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6808 o = new_logop(OP_AND, 0, &expr, &listop);
6815 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6817 if (once && o != listop)
6819 assert(cUNOPo->op_first->op_type == OP_AND
6820 || cUNOPo->op_first->op_type == OP_OR);
6821 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6825 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6827 o->op_flags |= flags;
6829 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6834 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6836 Constructs, checks, and returns an op tree expressing a C<while> loop.
6837 This is a heavyweight loop, with structure that allows exiting the loop
6838 by C<last> and suchlike.
6840 I<loop> is an optional preconstructed C<enterloop> op to use in the
6841 loop; if it is null then a suitable op will be constructed automatically.
6842 I<expr> supplies the loop's controlling expression. I<block> supplies the
6843 main body of the loop, and I<cont> optionally supplies a C<continue> block
6844 that operates as a second half of the body. All of these optree inputs
6845 are consumed by this function and become part of the constructed op tree.
6847 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6848 op and, shifted up eight bits, the eight bits of C<op_private> for
6849 the C<leaveloop> op, except that (in both cases) some bits will be set
6850 automatically. I<debuggable> is currently unused and should always be 1.
6851 I<has_my> can be supplied as true to force the
6852 loop body to be enclosed in its own scope.
6858 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6859 OP *expr, OP *block, OP *cont, I32 has_my)
6868 PERL_UNUSED_ARG(debuggable);
6871 if (expr->op_type == OP_READLINE
6872 || expr->op_type == OP_READDIR
6873 || expr->op_type == OP_GLOB
6874 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6875 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6876 expr = newUNOP(OP_DEFINED, 0,
6877 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6878 } else if (expr->op_flags & OPf_KIDS) {
6879 const OP * const k1 = ((UNOP*)expr)->op_first;
6880 const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL;
6881 switch (expr->op_type) {
6883 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6884 && (k2->op_flags & OPf_STACKED)
6885 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6886 expr = newUNOP(OP_DEFINED, 0, expr);
6890 if (k1 && (k1->op_type == OP_READDIR
6891 || k1->op_type == OP_GLOB
6892 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6893 || k1->op_type == OP_EACH
6894 || k1->op_type == OP_AEACH))
6895 expr = newUNOP(OP_DEFINED, 0, expr);
6902 block = newOP(OP_NULL, 0);
6903 else if (cont || has_my) {
6904 block = op_scope(block);
6908 next = LINKLIST(cont);
6911 OP * const unstack = newOP(OP_UNSTACK, 0);
6914 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6918 listop = op_append_list(OP_LINESEQ, block, cont);
6920 redo = LINKLIST(listop);
6924 o = new_logop(OP_AND, 0, &expr, &listop);
6925 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6927 return expr; /* listop already freed by new_logop */
6930 ((LISTOP*)listop)->op_last->op_next =
6931 (o == listop ? redo : LINKLIST(o));
6937 NewOp(1101,loop,1,LOOP);
6938 loop->op_type = OP_ENTERLOOP;
6939 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6940 loop->op_private = 0;
6941 loop->op_next = (OP*)loop;
6944 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6946 loop->op_redoop = redo;
6947 loop->op_lastop = o;
6948 o->op_private |= loopflags;
6951 loop->op_nextop = next;
6953 loop->op_nextop = o;
6955 o->op_flags |= flags;
6956 o->op_private |= (flags >> 8);
6961 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6963 Constructs, checks, and returns an op tree expressing a C<foreach>
6964 loop (iteration through a list of values). This is a heavyweight loop,
6965 with structure that allows exiting the loop by C<last> and suchlike.
6967 I<sv> optionally supplies the variable that will be aliased to each
6968 item in turn; if null, it defaults to C<$_> (either lexical or global).
6969 I<expr> supplies the list of values to iterate over. I<block> supplies
6970 the main body of the loop, and I<cont> optionally supplies a C<continue>
6971 block that operates as a second half of the body. All of these optree
6972 inputs are consumed by this function and become part of the constructed
6975 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6976 op and, shifted up eight bits, the eight bits of C<op_private> for
6977 the C<leaveloop> op, except that (in both cases) some bits will be set
6984 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6989 PADOFFSET padoff = 0;
6993 PERL_ARGS_ASSERT_NEWFOROP;
6996 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6997 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6998 sv->op_type = OP_RV2GV;
6999 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
7001 /* The op_type check is needed to prevent a possible segfault
7002 * if the loop variable is undeclared and 'strict vars' is in
7003 * effect. This is illegal but is nonetheless parsed, so we
7004 * may reach this point with an OP_CONST where we're expecting
7007 if (cUNOPx(sv)->op_first->op_type == OP_GV
7008 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7009 iterpflags |= OPpITER_DEF;
7011 else if (sv->op_type == OP_PADSV) { /* private variable */
7012 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7013 padoff = sv->op_targ;
7017 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7019 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7022 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7024 SV *const namesv = PAD_COMPNAME_SV(padoff);
7026 const char *const name = SvPV_const(namesv, len);
7028 if (len == 2 && name[0] == '$' && name[1] == '_')
7029 iterpflags |= OPpITER_DEF;
7033 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7034 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7035 sv = newGVOP(OP_GV, 0, PL_defgv);
7040 iterpflags |= OPpITER_DEF;
7043 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7044 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7045 iterflags |= OPf_STACKED;
7047 else if (expr->op_type == OP_NULL &&
7048 (expr->op_flags & OPf_KIDS) &&
7049 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7051 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7052 * set the STACKED flag to indicate that these values are to be
7053 * treated as min/max values by 'pp_enteriter'.
7055 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7056 LOGOP* const range = (LOGOP*) flip->op_first;
7057 OP* const left = range->op_first;
7058 OP* const right = OP_SIBLING(left);
7061 range->op_flags &= ~OPf_KIDS;
7062 /* detach range's children */
7063 op_sibling_splice((OP*)range, NULL, -1, NULL);
7065 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7066 listop->op_first->op_next = range->op_next;
7067 left->op_next = range->op_other;
7068 right->op_next = (OP*)listop;
7069 listop->op_next = listop->op_first;
7072 expr = (OP*)(listop);
7074 iterflags |= OPf_STACKED;
7077 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7080 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
7081 op_append_elem(OP_LIST, expr, scalar(sv))));
7082 assert(!loop->op_next);
7083 /* for my $x () sets OPpLVAL_INTRO;
7084 * for our $x () sets OPpOUR_INTRO */
7085 loop->op_private = (U8)iterpflags;
7086 if (loop->op_slabbed
7087 && DIFF(loop, OpSLOT(loop)->opslot_next)
7088 < SIZE_TO_PSIZE(sizeof(LOOP)))
7091 NewOp(1234,tmp,1,LOOP);
7092 Copy(loop,tmp,1,LISTOP);
7093 #ifdef PERL_OP_PARENT
7094 assert(loop->op_last->op_sibling == (OP*)loop);
7095 loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
7097 S_op_destroy(aTHX_ (OP*)loop);
7100 else if (!loop->op_slabbed)
7101 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7102 loop->op_targ = padoff;
7103 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7108 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7110 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7111 or C<last>). I<type> is the opcode. I<label> supplies the parameter
7112 determining the target of the op; it is consumed by this function and
7113 becomes part of the constructed op tree.
7119 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7123 PERL_ARGS_ASSERT_NEWLOOPEX;
7125 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7127 if (type != OP_GOTO) {
7128 /* "last()" means "last" */
7129 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7130 o = newOP(type, OPf_SPECIAL);
7134 /* Check whether it's going to be a goto &function */
7135 if (label->op_type == OP_ENTERSUB
7136 && !(label->op_flags & OPf_STACKED))
7137 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7140 /* Check for a constant argument */
7141 if (label->op_type == OP_CONST) {
7142 SV * const sv = ((SVOP *)label)->op_sv;
7144 const char *s = SvPV_const(sv,l);
7145 if (l == strlen(s)) {
7147 SvUTF8(((SVOP*)label)->op_sv),
7149 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7153 /* If we have already created an op, we do not need the label. */
7156 else o = newUNOP(type, OPf_STACKED, label);
7158 PL_hints |= HINT_BLOCK_SCOPE;
7162 /* if the condition is a literal array or hash
7163 (or @{ ... } etc), make a reference to it.
7166 S_ref_array_or_hash(pTHX_ OP *cond)
7169 && (cond->op_type == OP_RV2AV
7170 || cond->op_type == OP_PADAV
7171 || cond->op_type == OP_RV2HV
7172 || cond->op_type == OP_PADHV))
7174 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7177 && (cond->op_type == OP_ASLICE
7178 || cond->op_type == OP_KVASLICE
7179 || cond->op_type == OP_HSLICE
7180 || cond->op_type == OP_KVHSLICE)) {
7182 /* anonlist now needs a list from this op, was previously used in
7184 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
7185 cond->op_flags |= OPf_WANT_LIST;
7187 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7194 /* These construct the optree fragments representing given()
7197 entergiven and enterwhen are LOGOPs; the op_other pointer
7198 points up to the associated leave op. We need this so we
7199 can put it in the context and make break/continue work.
7200 (Also, of course, pp_enterwhen will jump straight to
7201 op_other if the match fails.)
7205 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7206 I32 enter_opcode, I32 leave_opcode,
7207 PADOFFSET entertarg)
7213 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7215 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7216 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
7217 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7218 enterop->op_private = 0;
7220 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7223 /* prepend cond if we have one */
7224 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7226 o->op_next = LINKLIST(cond);
7227 cond->op_next = (OP *) enterop;
7230 /* This is a default {} block */
7231 enterop->op_flags |= OPf_SPECIAL;
7232 o ->op_flags |= OPf_SPECIAL;
7234 o->op_next = (OP *) enterop;
7237 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7238 entergiven and enterwhen both
7241 enterop->op_next = LINKLIST(block);
7242 block->op_next = enterop->op_other = o;
7247 /* Does this look like a boolean operation? For these purposes
7248 a boolean operation is:
7249 - a subroutine call [*]
7250 - a logical connective
7251 - a comparison operator
7252 - a filetest operator, with the exception of -s -M -A -C
7253 - defined(), exists() or eof()
7254 - /$re/ or $foo =~ /$re/
7256 [*] possibly surprising
7259 S_looks_like_bool(pTHX_ const OP *o)
7261 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7263 switch(o->op_type) {
7266 return looks_like_bool(cLOGOPo->op_first);
7270 OP* sibl = OP_SIBLING(cLOGOPo->op_first);
7273 looks_like_bool(cLOGOPo->op_first)
7274 && looks_like_bool(sibl));
7280 o->op_flags & OPf_KIDS
7281 && looks_like_bool(cUNOPo->op_first));
7285 case OP_NOT: case OP_XOR:
7287 case OP_EQ: case OP_NE: case OP_LT:
7288 case OP_GT: case OP_LE: case OP_GE:
7290 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7291 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7293 case OP_SEQ: case OP_SNE: case OP_SLT:
7294 case OP_SGT: case OP_SLE: case OP_SGE:
7298 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7299 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7300 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7301 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7302 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7303 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7304 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7305 case OP_FTTEXT: case OP_FTBINARY:
7307 case OP_DEFINED: case OP_EXISTS:
7308 case OP_MATCH: case OP_EOF:
7315 /* Detect comparisons that have been optimized away */
7316 if (cSVOPo->op_sv == &PL_sv_yes
7317 || cSVOPo->op_sv == &PL_sv_no)
7330 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7332 Constructs, checks, and returns an op tree expressing a C<given> block.
7333 I<cond> supplies the expression that will be locally assigned to a lexical
7334 variable, and I<block> supplies the body of the C<given> construct; they
7335 are consumed by this function and become part of the constructed op tree.
7336 I<defsv_off> is the pad offset of the scalar lexical variable that will
7337 be affected. If it is 0, the global $_ will be used.
7343 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7345 PERL_ARGS_ASSERT_NEWGIVENOP;
7346 return newGIVWHENOP(
7347 ref_array_or_hash(cond),
7349 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7354 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7356 Constructs, checks, and returns an op tree expressing a C<when> block.
7357 I<cond> supplies the test expression, and I<block> supplies the block
7358 that will be executed if the test evaluates to true; they are consumed
7359 by this function and become part of the constructed op tree. I<cond>
7360 will be interpreted DWIMically, often as a comparison against C<$_>,
7361 and may be null to generate a C<default> block.
7367 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7369 const bool cond_llb = (!cond || looks_like_bool(cond));
7372 PERL_ARGS_ASSERT_NEWWHENOP;
7377 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7379 scalar(ref_array_or_hash(cond)));
7382 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7385 /* must not conflict with SVf_UTF8 */
7386 #define CV_CKPROTO_CURSTASH 0x1
7389 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7390 const STRLEN len, const U32 flags)
7392 SV *name = NULL, *msg;
7393 const char * cvp = SvROK(cv)
7394 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7395 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7398 STRLEN clen = CvPROTOLEN(cv), plen = len;
7400 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7402 if (p == NULL && cvp == NULL)
7405 if (!ckWARN_d(WARN_PROTOTYPE))
7409 p = S_strip_spaces(aTHX_ p, &plen);
7410 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7411 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7412 if (plen == clen && memEQ(cvp, p, plen))
7415 if (flags & SVf_UTF8) {
7416 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7420 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7426 msg = sv_newmortal();
7431 gv_efullname3(name = sv_newmortal(), gv, NULL);
7432 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7433 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7434 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7435 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7436 sv_catpvs(name, "::");
7438 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7439 assert (CvNAMED(SvRV_const(gv)));
7440 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7442 else sv_catsv(name, (SV *)gv);
7444 else name = (SV *)gv;
7446 sv_setpvs(msg, "Prototype mismatch:");
7448 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7450 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7451 UTF8fARG(SvUTF8(cv),clen,cvp)
7454 sv_catpvs(msg, ": none");
7455 sv_catpvs(msg, " vs ");
7457 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7459 sv_catpvs(msg, "none");
7460 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7463 static void const_sv_xsub(pTHX_ CV* cv);
7464 static void const_av_xsub(pTHX_ CV* cv);
7468 =head1 Optree Manipulation Functions
7470 =for apidoc cv_const_sv
7472 If C<cv> is a constant sub eligible for inlining, returns the constant
7473 value returned by the sub. Otherwise, returns NULL.
7475 Constant subs can be created with C<newCONSTSUB> or as described in
7476 L<perlsub/"Constant Functions">.
7481 Perl_cv_const_sv(const CV *const cv)
7486 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7488 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7489 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7494 Perl_cv_const_sv_or_av(const CV * const cv)
7498 if (SvROK(cv)) return SvRV((SV *)cv);
7499 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7500 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7503 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7504 * Can be called in 3 ways:
7507 * look for a single OP_CONST with attached value: return the value
7509 * cv && CvCLONE(cv) && !CvCONST(cv)
7511 * examine the clone prototype, and if contains only a single
7512 * OP_CONST referencing a pad const, or a single PADSV referencing
7513 * an outer lexical, return a non-zero value to indicate the CV is
7514 * a candidate for "constizing" at clone time
7518 * We have just cloned an anon prototype that was marked as a const
7519 * candidate. Try to grab the current value, and in the case of
7520 * PADSV, ignore it if it has multiple references. In this case we
7521 * return a newly created *copy* of the value.
7525 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
7532 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
7533 o = OP_SIBLING(cLISTOPo->op_first);
7535 for (; o; o = o->op_next) {
7536 const OPCODE type = o->op_type;
7538 if (sv && o->op_next == o)
7540 if (o->op_next != o) {
7541 if (type == OP_NEXTSTATE
7542 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7543 || type == OP_PUSHMARK)
7545 if (type == OP_DBSTATE)
7548 if (type == OP_LEAVESUB || type == OP_RETURN)
7552 if (type == OP_CONST && cSVOPo->op_sv)
7554 else if (type == OP_UNDEF && !o->op_private) {
7558 else if (cv && type == OP_CONST) {
7559 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7563 else if (cv && type == OP_PADSV) {
7564 if (CvCONST(cv)) { /* newly cloned anon */
7565 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7566 /* the candidate should have 1 ref from this pad and 1 ref
7567 * from the parent */
7568 if (!sv || SvREFCNT(sv) != 2)
7575 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
7576 sv = &PL_sv_undef; /* an arbitrary non-null value */
7587 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7588 PADNAME * const name, SV ** const const_svp)
7595 if (CvFLAGS(PL_compcv)) {
7596 /* might have had built-in attrs applied */
7597 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7598 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7599 && ckWARN(WARN_MISC))
7601 /* protect against fatal warnings leaking compcv */
7602 SAVEFREESV(PL_compcv);
7603 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7604 SvREFCNT_inc_simple_void_NN(PL_compcv);
7607 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7608 & ~(CVf_LVALUE * pureperl));
7613 /* redundant check for speed: */
7614 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7615 const line_t oldline = CopLINE(PL_curcop);
7618 : sv_2mortal(newSVpvn_utf8(
7619 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7621 if (PL_parser && PL_parser->copline != NOLINE)
7622 /* This ensures that warnings are reported at the first
7623 line of a redefinition, not the last. */
7624 CopLINE_set(PL_curcop, PL_parser->copline);
7625 /* protect against fatal warnings leaking compcv */
7626 SAVEFREESV(PL_compcv);
7627 report_redefined_cv(namesv, cv, const_svp);
7628 SvREFCNT_inc_simple_void_NN(PL_compcv);
7629 CopLINE_set(PL_curcop, oldline);
7636 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7641 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7644 CV *compcv = PL_compcv;
7647 PADOFFSET pax = o->op_targ;
7648 CV *outcv = CvOUTSIDE(PL_compcv);
7651 bool reusable = FALSE;
7653 PERL_ARGS_ASSERT_NEWMYSUB;
7655 /* Find the pad slot for storing the new sub.
7656 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7657 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7658 ing sub. And then we need to dig deeper if this is a lexical from
7660 my sub foo; sub { sub foo { } }
7663 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7664 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7665 pax = PARENT_PAD_INDEX(name);
7666 outcv = CvOUTSIDE(outcv);
7671 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7672 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7673 spot = (CV **)svspot;
7675 if (!(PL_parser && PL_parser->error_count))
7676 move_proto_attr(&proto, &attrs, (GV *)name);
7679 assert(proto->op_type == OP_CONST);
7680 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7681 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7691 if (PL_parser && PL_parser->error_count) {
7693 SvREFCNT_dec(PL_compcv);
7698 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7700 svspot = (SV **)(spot = &clonee);
7702 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7706 SvUPGRADE(name, SVt_PVMG);
7707 mg = mg_find(name, PERL_MAGIC_proto);
7708 assert (SvTYPE(*spot) == SVt_PVCV);
7710 hek = CvNAME_HEK(*spot);
7714 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7715 CvNAME_HEK_set(*spot, hek =
7718 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
7721 CvLEXICAL_on(*spot);
7725 cv = (CV *)mg->mg_obj;
7728 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7729 mg = mg_find(name, PERL_MAGIC_proto);
7731 spot = (CV **)(svspot = &mg->mg_obj);
7734 if (!block || !ps || *ps || attrs
7735 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7739 const_sv = op_const_sv(block, NULL);
7742 const bool exists = CvROOT(cv) || CvXSUB(cv);
7744 /* if the subroutine doesn't exist and wasn't pre-declared
7745 * with a prototype, assume it will be AUTOLOADed,
7746 * skipping the prototype check
7748 if (exists || SvPOK(cv))
7749 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7750 /* already defined? */
7752 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7755 if (attrs) goto attrs;
7756 /* just a "sub foo;" when &foo is already defined */
7761 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7767 SvREFCNT_inc_simple_void_NN(const_sv);
7768 SvFLAGS(const_sv) |= SVs_PADTMP;
7770 assert(!CvROOT(cv) && !CvCONST(cv));
7774 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7775 CvFILE_set_from_cop(cv, PL_curcop);
7776 CvSTASH_set(cv, PL_curstash);
7779 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7780 CvXSUBANY(cv).any_ptr = const_sv;
7781 CvXSUB(cv) = const_sv_xsub;
7785 SvREFCNT_dec(compcv);
7789 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7790 determine whether this sub definition is in the same scope as its
7791 declaration. If this sub definition is inside an inner named pack-
7792 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7793 the package sub. So check PadnameOUTER(name) too.
7795 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7796 assert(!CvWEAKOUTSIDE(compcv));
7797 SvREFCNT_dec(CvOUTSIDE(compcv));
7798 CvWEAKOUTSIDE_on(compcv);
7800 /* XXX else do we have a circular reference? */
7801 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7802 /* transfer PL_compcv to cv */
7805 cv_flags_t preserved_flags =
7806 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7807 PADLIST *const temp_padl = CvPADLIST(cv);
7808 CV *const temp_cv = CvOUTSIDE(cv);
7809 const cv_flags_t other_flags =
7810 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7811 OP * const cvstart = CvSTART(cv);
7815 CvFLAGS(compcv) | preserved_flags;
7816 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7817 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7818 CvPADLIST(cv) = CvPADLIST(compcv);
7819 CvOUTSIDE(compcv) = temp_cv;
7820 CvPADLIST(compcv) = temp_padl;
7821 CvSTART(cv) = CvSTART(compcv);
7822 CvSTART(compcv) = cvstart;
7823 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7824 CvFLAGS(compcv) |= other_flags;
7826 if (CvFILE(cv) && CvDYNFILE(cv)) {
7827 Safefree(CvFILE(cv));
7830 /* inner references to compcv must be fixed up ... */
7831 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7832 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7833 ++PL_sub_generation;
7836 /* Might have had built-in attributes applied -- propagate them. */
7837 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7839 /* ... before we throw it away */
7840 SvREFCNT_dec(compcv);
7841 PL_compcv = compcv = cv;
7849 if (!CvNAME_HEK(cv)) {
7850 if (hek) (void)share_hek_hek(hek);
7854 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7855 hek = share_hek(PadnamePV(name)+1,
7856 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7859 CvNAME_HEK_set(cv, hek);
7861 if (const_sv) goto clone;
7863 CvFILE_set_from_cop(cv, PL_curcop);
7864 CvSTASH_set(cv, PL_curstash);
7867 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7868 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7874 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7875 the debugger could be able to set a breakpoint in, so signal to
7876 pp_entereval that it should not throw away any saved lines at scope
7879 PL_breakable_sub_gen++;
7880 /* This makes sub {}; work as expected. */
7881 if (block->op_type == OP_STUB) {
7882 OP* const newblock = newSTATEOP(0, NULL, 0);
7886 CvROOT(cv) = CvLVALUE(cv)
7887 ? newUNOP(OP_LEAVESUBLV, 0,
7888 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7889 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7890 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7891 OpREFCNT_set(CvROOT(cv), 1);
7892 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7893 itself has a refcount. */
7895 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7896 CvSTART(cv) = LINKLIST(CvROOT(cv));
7897 CvROOT(cv)->op_next = 0;
7898 CALL_PEEP(CvSTART(cv));
7899 finalize_optree(CvROOT(cv));
7900 S_prune_chain_head(&CvSTART(cv));
7902 /* now that optimizer has done its work, adjust pad values */
7904 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7907 assert(!CvCONST(cv));
7908 if (ps && !*ps && op_const_sv(block, cv))
7914 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7915 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7919 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7920 SV * const tmpstr = sv_newmortal();
7921 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7922 GV_ADDMULTI, SVt_PVHV);
7924 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7927 (long)CopLINE(PL_curcop));
7928 if (HvNAME_HEK(PL_curstash)) {
7929 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7930 sv_catpvs(tmpstr, "::");
7932 else sv_setpvs(tmpstr, "__ANON__::");
7933 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7934 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7935 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7936 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7937 hv = GvHVn(db_postponed);
7938 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7939 CV * const pcv = GvCV(db_postponed);
7945 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7953 assert(CvDEPTH(outcv));
7955 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7956 if (reusable) cv_clone_into(clonee, *spot);
7957 else *spot = cv_clone(clonee);
7958 SvREFCNT_dec_NN(clonee);
7961 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7962 PADOFFSET depth = CvDEPTH(outcv);
7965 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7967 *svspot = SvREFCNT_inc_simple_NN(cv);
7968 SvREFCNT_dec(oldcv);
7974 PL_parser->copline = NOLINE;
7982 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7983 OP *block, bool o_is_gv)
7987 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7991 const bool ec = PL_parser && PL_parser->error_count;
7992 /* If the subroutine has no body, no attributes, and no builtin attributes
7993 then it's just a sub declaration, and we may be able to get away with
7994 storing with a placeholder scalar in the symbol table, rather than a
7995 full CV. If anything is present then it will take a full CV to
7997 const I32 gv_fetch_flags
7998 = ec ? GV_NOADD_NOINIT :
7999 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8000 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8002 const char * const name =
8003 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8005 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8006 #ifdef PERL_DEBUG_READONLY_OPS
8007 OPSLAB *slab = NULL;
8008 bool special = FALSE;
8016 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8017 hek and CvSTASH pointer together can imply the GV. If the name
8018 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8019 CvSTASH, so forego the optimisation if we find any.
8020 Also, we may be called from load_module at run time, so
8021 PL_curstash (which sets CvSTASH) may not point to the stash the
8022 sub is stored in. */
8024 ec ? GV_NOADD_NOINIT
8025 : PL_curstash != CopSTASH(PL_curcop)
8026 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8028 : GV_ADDMULTI | GV_NOINIT;
8029 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8031 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8032 SV * const sv = sv_newmortal();
8033 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8034 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8035 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8036 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8038 } else if (PL_curstash) {
8039 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8042 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8046 move_proto_attr(&proto, &attrs,
8047 isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
8050 assert(proto->op_type == OP_CONST);
8051 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8052 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8066 if (name) SvREFCNT_dec(PL_compcv);
8067 else cv = PL_compcv;
8069 if (name && block) {
8070 const char *s = strrchr(name, ':');
8072 if (strEQ(s, "BEGIN")) {
8073 if (PL_in_eval & EVAL_KEEPERR)
8074 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8076 SV * const errsv = ERRSV;
8077 /* force display of errors found but not reported */
8078 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8079 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8086 if (!block && SvTYPE(gv) != SVt_PVGV) {
8087 /* If we are not defining a new sub and the existing one is not a
8089 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8090 /* We are applying attributes to an existing sub, so we need it
8091 upgraded if it is a constant. */
8092 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8093 gv_init_pvn(gv, PL_curstash, name, namlen,
8094 SVf_UTF8 * name_is_utf8);
8096 else { /* Maybe prototype now, and had at maximum
8097 a prototype or const/sub ref before. */
8098 if (SvTYPE(gv) > SVt_NULL) {
8099 cv_ckproto_len_flags((const CV *)gv,
8100 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8105 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8106 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8109 sv_setiv(MUTABLE_SV(gv), -1);
8112 SvREFCNT_dec(PL_compcv);
8113 cv = PL_compcv = NULL;
8118 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8122 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8127 if (!block || !ps || *ps || attrs
8128 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
8132 const_sv = op_const_sv(block, NULL);
8134 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8136 cv_ckproto_len_flags((const CV *)gv,
8137 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8138 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8140 /* All the other code for sub redefinition warnings expects the
8141 clobbered sub to be a CV. Instead of making all those code
8142 paths more complex, just inline the RV version here. */
8143 const line_t oldline = CopLINE(PL_curcop);
8144 assert(IN_PERL_COMPILETIME);
8145 if (PL_parser && PL_parser->copline != NOLINE)
8146 /* This ensures that warnings are reported at the first
8147 line of a redefinition, not the last. */
8148 CopLINE_set(PL_curcop, PL_parser->copline);
8149 /* protect against fatal warnings leaking compcv */
8150 SAVEFREESV(PL_compcv);
8152 if (ckWARN(WARN_REDEFINE)
8153 || ( ckWARN_d(WARN_REDEFINE)
8154 && ( !const_sv || SvRV(gv) == const_sv
8155 || sv_cmp(SvRV(gv), const_sv) )))
8156 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8157 "Constant subroutine %"SVf" redefined",
8158 SVfARG(cSVOPo->op_sv));
8160 SvREFCNT_inc_simple_void_NN(PL_compcv);
8161 CopLINE_set(PL_curcop, oldline);
8162 SvREFCNT_dec(SvRV(gv));
8167 const bool exists = CvROOT(cv) || CvXSUB(cv);
8169 /* if the subroutine doesn't exist and wasn't pre-declared
8170 * with a prototype, assume it will be AUTOLOADed,
8171 * skipping the prototype check
8173 if (exists || SvPOK(cv))
8174 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8175 /* already defined (or promised)? */
8176 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8177 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8180 if (attrs) goto attrs;
8181 /* just a "sub foo;" when &foo is already defined */
8182 SAVEFREESV(PL_compcv);
8188 SvREFCNT_inc_simple_void_NN(const_sv);
8189 SvFLAGS(const_sv) |= SVs_PADTMP;
8191 assert(!CvROOT(cv) && !CvCONST(cv));
8193 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8194 CvXSUBANY(cv).any_ptr = const_sv;
8195 CvXSUB(cv) = const_sv_xsub;
8201 if (name) GvCV_set(gv, NULL);
8202 cv = newCONSTSUB_flags(
8203 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8209 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8210 prepare_SV_for_RV((SV *)gv);
8214 SvRV_set(gv, const_sv);
8218 SvREFCNT_dec(PL_compcv);
8222 if (cv) { /* must reuse cv if autoloaded */
8223 /* transfer PL_compcv to cv */
8226 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8227 PADLIST *const temp_av = CvPADLIST(cv);
8228 CV *const temp_cv = CvOUTSIDE(cv);
8229 const cv_flags_t other_flags =
8230 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8231 OP * const cvstart = CvSTART(cv);
8235 assert(!CvCVGV_RC(cv));
8236 assert(CvGV(cv) == gv);
8241 PERL_HASH(hash, name, namlen);
8251 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8253 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8254 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8255 CvPADLIST(cv) = CvPADLIST(PL_compcv);
8256 CvOUTSIDE(PL_compcv) = temp_cv;
8257 CvPADLIST(PL_compcv) = temp_av;
8258 CvSTART(cv) = CvSTART(PL_compcv);
8259 CvSTART(PL_compcv) = cvstart;
8260 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8261 CvFLAGS(PL_compcv) |= other_flags;
8263 if (CvFILE(cv) && CvDYNFILE(cv)) {
8264 Safefree(CvFILE(cv));
8266 CvFILE_set_from_cop(cv, PL_curcop);
8267 CvSTASH_set(cv, PL_curstash);
8269 /* inner references to PL_compcv must be fixed up ... */
8270 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8271 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8272 ++PL_sub_generation;
8275 /* Might have had built-in attributes applied -- propagate them. */
8276 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8278 /* ... before we throw it away */
8279 SvREFCNT_dec(PL_compcv);
8284 if (name && isGV(gv)) {
8287 if (HvENAME_HEK(GvSTASH(gv)))
8288 /* sub Foo::bar { (shift)+1 } */
8289 gv_method_changed(gv);
8293 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8294 prepare_SV_for_RV((SV *)gv);
8298 SvRV_set(gv, (SV *)cv);
8302 if (isGV(gv)) CvGV_set(cv, gv);
8306 PERL_HASH(hash, name, namlen);
8307 CvNAME_HEK_set(cv, share_hek(name,
8313 CvFILE_set_from_cop(cv, PL_curcop);
8314 CvSTASH_set(cv, PL_curstash);
8318 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8319 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8325 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8326 the debugger could be able to set a breakpoint in, so signal to
8327 pp_entereval that it should not throw away any saved lines at scope
8330 PL_breakable_sub_gen++;
8331 /* This makes sub {}; work as expected. */
8332 if (block->op_type == OP_STUB) {
8333 OP* const newblock = newSTATEOP(0, NULL, 0);
8337 CvROOT(cv) = CvLVALUE(cv)
8338 ? newUNOP(OP_LEAVESUBLV, 0,
8339 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8340 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8341 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8342 OpREFCNT_set(CvROOT(cv), 1);
8343 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8344 itself has a refcount. */
8346 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8347 #ifdef PERL_DEBUG_READONLY_OPS
8348 slab = (OPSLAB *)CvSTART(cv);
8350 CvSTART(cv) = LINKLIST(CvROOT(cv));
8351 CvROOT(cv)->op_next = 0;
8352 CALL_PEEP(CvSTART(cv));
8353 finalize_optree(CvROOT(cv));
8354 S_prune_chain_head(&CvSTART(cv));
8356 /* now that optimizer has done its work, adjust pad values */
8358 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8361 assert(!CvCONST(cv));
8362 if (ps && !*ps && op_const_sv(block, cv))
8368 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8369 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8372 if (!name) SAVEFREESV(cv);
8373 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8374 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8377 if (block && has_name) {
8378 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8379 SV * const tmpstr = cv_name(cv,NULL,0);
8380 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8381 GV_ADDMULTI, SVt_PVHV);
8383 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8386 (long)CopLINE(PL_curcop));
8387 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8388 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8389 hv = GvHVn(db_postponed);
8390 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8391 CV * const pcv = GvCV(db_postponed);
8397 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8403 if (PL_parser && PL_parser->error_count)
8404 clear_special_blocks(name, gv, cv);
8406 #ifdef PERL_DEBUG_READONLY_OPS
8409 process_special_blocks(floor, name, gv, cv);
8415 PL_parser->copline = NOLINE;
8417 #ifdef PERL_DEBUG_READONLY_OPS
8418 /* Watch out for BEGIN blocks */
8419 if (!special) Slab_to_ro(slab);
8425 S_clear_special_blocks(pTHX_ const char *const fullname,
8426 GV *const gv, CV *const cv) {
8430 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8432 colon = strrchr(fullname,':');
8433 name = colon ? colon + 1 : fullname;
8435 if ((*name == 'B' && strEQ(name, "BEGIN"))
8436 || (*name == 'E' && strEQ(name, "END"))
8437 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8438 || (*name == 'C' && strEQ(name, "CHECK"))
8439 || (*name == 'I' && strEQ(name, "INIT"))) {
8445 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8450 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8454 const char *const colon = strrchr(fullname,':');
8455 const char *const name = colon ? colon + 1 : fullname;
8457 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8460 if (strEQ(name, "BEGIN")) {
8461 const I32 oldscope = PL_scopestack_ix;
8464 if (floor) LEAVE_SCOPE(floor);
8466 PUSHSTACKi(PERLSI_REQUIRE);
8467 SAVECOPFILE(&PL_compiling);
8468 SAVECOPLINE(&PL_compiling);
8469 SAVEVPTR(PL_curcop);
8471 DEBUG_x( dump_sub(gv) );
8472 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8473 GvCV_set(gv,0); /* cv has been hijacked */
8474 call_list(oldscope, PL_beginav);
8484 if strEQ(name, "END") {
8485 DEBUG_x( dump_sub(gv) );
8486 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8489 } else if (*name == 'U') {
8490 if (strEQ(name, "UNITCHECK")) {
8491 /* It's never too late to run a unitcheck block */
8492 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8496 } else if (*name == 'C') {
8497 if (strEQ(name, "CHECK")) {
8499 /* diag_listed_as: Too late to run %s block */
8500 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8501 "Too late to run CHECK block");
8502 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8506 } else if (*name == 'I') {
8507 if (strEQ(name, "INIT")) {
8509 /* diag_listed_as: Too late to run %s block */
8510 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8511 "Too late to run INIT block");
8512 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8518 DEBUG_x( dump_sub(gv) );
8520 GvCV_set(gv,0); /* cv has been hijacked */
8526 =for apidoc newCONSTSUB
8528 See L</newCONSTSUB_flags>.
8534 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8536 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8540 =for apidoc newCONSTSUB_flags
8542 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8543 eligible for inlining at compile-time.
8545 Currently, the only useful value for C<flags> is SVf_UTF8.
8547 The newly created subroutine takes ownership of a reference to the passed in
8550 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8551 which won't be called if used as a destructor, but will suppress the overhead
8552 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8559 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8563 const char *const file = CopFILE(PL_curcop);
8567 if (IN_PERL_RUNTIME) {
8568 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8569 * an op shared between threads. Use a non-shared COP for our
8571 SAVEVPTR(PL_curcop);
8572 SAVECOMPILEWARNINGS();
8573 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8574 PL_curcop = &PL_compiling;
8576 SAVECOPLINE(PL_curcop);
8577 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8580 PL_hints &= ~HINT_BLOCK_SCOPE;
8583 SAVEGENERICSV(PL_curstash);
8584 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8587 /* Protect sv against leakage caused by fatal warnings. */
8588 if (sv) SAVEFREESV(sv);
8590 /* file becomes the CvFILE. For an XS, it's usually static storage,
8591 and so doesn't get free()d. (It's expected to be from the C pre-
8592 processor __FILE__ directive). But we need a dynamically allocated one,
8593 and we need it to get freed. */
8594 cv = newXS_len_flags(name, len,
8595 sv && SvTYPE(sv) == SVt_PVAV
8598 file ? file : "", "",
8599 &sv, XS_DYNAMIC_FILENAME | flags);
8600 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8609 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8610 const char *const filename, const char *const proto,
8613 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8614 return newXS_len_flags(
8615 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8620 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8621 XSUBADDR_t subaddr, const char *const filename,
8622 const char *const proto, SV **const_svp,
8626 bool interleave = FALSE;
8628 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8631 GV * const gv = gv_fetchpvn(
8632 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8633 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8634 sizeof("__ANON__::__ANON__") - 1,
8635 GV_ADDMULTI | flags, SVt_PVCV);
8638 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8640 if ((cv = (name ? GvCV(gv) : NULL))) {
8642 /* just a cached method */
8646 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8647 /* already defined (or promised) */
8648 /* Redundant check that allows us to avoid creating an SV
8649 most of the time: */
8650 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8651 report_redefined_cv(newSVpvn_flags(
8652 name,len,(flags&SVf_UTF8)|SVs_TEMP
8663 if (cv) /* must reuse cv if autoloaded */
8666 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8670 if (HvENAME_HEK(GvSTASH(gv)))
8671 gv_method_changed(gv); /* newXS */
8677 (void)gv_fetchfile(filename);
8678 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8679 an external constant string */
8680 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8682 CvXSUB(cv) = subaddr;
8685 process_special_blocks(0, name, gv, cv);
8688 if (flags & XS_DYNAMIC_FILENAME) {
8689 CvFILE(cv) = savepv(filename);
8692 sv_setpv(MUTABLE_SV(cv), proto);
8693 if (interleave) LEAVE;
8698 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8700 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8702 PERL_ARGS_ASSERT_NEWSTUB;
8706 if (!fake && HvENAME_HEK(GvSTASH(gv)))
8707 gv_method_changed(gv);
8709 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8714 CvFILE_set_from_cop(cv, PL_curcop);
8715 CvSTASH_set(cv, PL_curstash);
8721 =for apidoc U||newXS
8723 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
8724 static storage, as it is used directly as CvFILE(), without a copy being made.
8730 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8732 PERL_ARGS_ASSERT_NEWXS;
8733 return newXS_len_flags(
8734 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8739 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8745 if (PL_parser && PL_parser->error_count) {
8751 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8752 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8755 if ((cv = GvFORM(gv))) {
8756 if (ckWARN(WARN_REDEFINE)) {
8757 const line_t oldline = CopLINE(PL_curcop);
8758 if (PL_parser && PL_parser->copline != NOLINE)
8759 CopLINE_set(PL_curcop, PL_parser->copline);
8761 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8762 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8764 /* diag_listed_as: Format %s redefined */
8765 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8766 "Format STDOUT redefined");
8768 CopLINE_set(PL_curcop, oldline);
8773 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8775 CvFILE_set_from_cop(cv, PL_curcop);
8778 pad_tidy(padtidy_FORMAT);
8779 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8780 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8781 OpREFCNT_set(CvROOT(cv), 1);
8782 CvSTART(cv) = LINKLIST(CvROOT(cv));
8783 CvROOT(cv)->op_next = 0;
8784 CALL_PEEP(CvSTART(cv));
8785 finalize_optree(CvROOT(cv));
8786 S_prune_chain_head(&CvSTART(cv));
8792 PL_parser->copline = NOLINE;
8797 Perl_newANONLIST(pTHX_ OP *o)
8799 return convert(OP_ANONLIST, OPf_SPECIAL, o);
8803 Perl_newANONHASH(pTHX_ OP *o)
8805 return convert(OP_ANONHASH, OPf_SPECIAL, o);
8809 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8811 return newANONATTRSUB(floor, proto, NULL, block);
8815 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8817 return newUNOP(OP_REFGEN, 0,
8818 newSVOP(OP_ANONCODE, 0,
8819 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8823 Perl_oopsAV(pTHX_ OP *o)
8827 PERL_ARGS_ASSERT_OOPSAV;
8829 switch (o->op_type) {
8832 o->op_type = OP_PADAV;
8833 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8834 return ref(o, OP_RV2AV);
8838 o->op_type = OP_RV2AV;
8839 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8844 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8851 Perl_oopsHV(pTHX_ OP *o)
8855 PERL_ARGS_ASSERT_OOPSHV;
8857 switch (o->op_type) {
8860 o->op_type = OP_PADHV;
8861 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8862 return ref(o, OP_RV2HV);
8866 o->op_type = OP_RV2HV;
8867 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8872 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8879 Perl_newAVREF(pTHX_ OP *o)
8883 PERL_ARGS_ASSERT_NEWAVREF;
8885 if (o->op_type == OP_PADANY) {
8886 o->op_type = OP_PADAV;
8887 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8890 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8891 Perl_croak(aTHX_ "Can't use an array as a reference");
8893 return newUNOP(OP_RV2AV, 0, scalar(o));
8897 Perl_newGVREF(pTHX_ I32 type, OP *o)
8899 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8900 return newUNOP(OP_NULL, 0, o);
8901 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8905 Perl_newHVREF(pTHX_ OP *o)
8909 PERL_ARGS_ASSERT_NEWHVREF;
8911 if (o->op_type == OP_PADANY) {
8912 o->op_type = OP_PADHV;
8913 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8916 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8917 Perl_croak(aTHX_ "Can't use a hash as a reference");
8919 return newUNOP(OP_RV2HV, 0, scalar(o));
8923 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8925 if (o->op_type == OP_PADANY) {
8927 o->op_type = OP_PADCV;
8928 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8930 return newUNOP(OP_RV2CV, flags, scalar(o));
8934 Perl_newSVREF(pTHX_ OP *o)
8938 PERL_ARGS_ASSERT_NEWSVREF;
8940 if (o->op_type == OP_PADANY) {
8941 o->op_type = OP_PADSV;
8942 o->op_ppaddr = PL_ppaddr[OP_PADSV];
8945 return newUNOP(OP_RV2SV, 0, scalar(o));
8948 /* Check routines. See the comments at the top of this file for details
8949 * on when these are called */
8952 Perl_ck_anoncode(pTHX_ OP *o)
8954 PERL_ARGS_ASSERT_CK_ANONCODE;
8956 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8957 cSVOPo->op_sv = NULL;
8962 S_io_hints(pTHX_ OP *o)
8964 #if O_BINARY != 0 || O_TEXT != 0
8966 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8968 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8971 const char *d = SvPV_const(*svp, len);
8972 const I32 mode = mode_from_discipline(d, len);
8973 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8975 if (mode & O_BINARY)
8976 o->op_private |= OPpOPEN_IN_RAW;
8980 o->op_private |= OPpOPEN_IN_CRLF;
8984 svp = hv_fetchs(table, "open_OUT", FALSE);
8987 const char *d = SvPV_const(*svp, len);
8988 const I32 mode = mode_from_discipline(d, len);
8989 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8991 if (mode & O_BINARY)
8992 o->op_private |= OPpOPEN_OUT_RAW;
8996 o->op_private |= OPpOPEN_OUT_CRLF;
9001 PERL_UNUSED_CONTEXT;
9007 Perl_ck_backtick(pTHX_ OP *o)
9012 PERL_ARGS_ASSERT_CK_BACKTICK;
9013 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9014 if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
9015 && (gv = gv_override("readpipe",8)))
9017 /* detach rest of siblings from o and its first child */
9018 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9019 newop = S_new_entersubop(aTHX_ gv, sibl);
9021 else if (!(o->op_flags & OPf_KIDS))
9022 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9027 S_io_hints(aTHX_ o);
9032 Perl_ck_bitop(pTHX_ OP *o)
9034 PERL_ARGS_ASSERT_CK_BITOP;
9036 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9037 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9038 && (o->op_type == OP_BIT_OR
9039 || o->op_type == OP_BIT_AND
9040 || o->op_type == OP_BIT_XOR))
9042 const OP * const left = cBINOPo->op_first;
9043 const OP * const right = OP_SIBLING(left);
9044 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9045 (left->op_flags & OPf_PARENS) == 0) ||
9046 (OP_IS_NUMCOMPARE(right->op_type) &&
9047 (right->op_flags & OPf_PARENS) == 0))
9048 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9049 "Possible precedence problem on bitwise %c operator",
9050 o->op_type == OP_BIT_OR ? '|'
9051 : o->op_type == OP_BIT_AND ? '&' : '^'
9057 PERL_STATIC_INLINE bool
9058 is_dollar_bracket(pTHX_ const OP * const o)
9061 PERL_UNUSED_CONTEXT;
9062 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9063 && (kid = cUNOPx(o)->op_first)
9064 && kid->op_type == OP_GV
9065 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9069 Perl_ck_cmp(pTHX_ OP *o)
9071 PERL_ARGS_ASSERT_CK_CMP;
9072 if (ckWARN(WARN_SYNTAX)) {
9073 const OP *kid = cUNOPo->op_first;
9076 ( is_dollar_bracket(aTHX_ kid)
9077 && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
9079 || ( kid->op_type == OP_CONST
9080 && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9084 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9085 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9091 Perl_ck_concat(pTHX_ OP *o)
9093 const OP * const kid = cUNOPo->op_first;
9095 PERL_ARGS_ASSERT_CK_CONCAT;
9096 PERL_UNUSED_CONTEXT;
9098 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9099 !(kUNOP->op_first->op_flags & OPf_MOD))
9100 o->op_flags |= OPf_STACKED;
9105 Perl_ck_spair(pTHX_ OP *o)
9109 PERL_ARGS_ASSERT_CK_SPAIR;
9111 if (o->op_flags & OPf_KIDS) {
9115 const OPCODE type = o->op_type;
9116 o = modkids(ck_fun(o), type);
9117 kid = cUNOPo->op_first;
9118 kidkid = kUNOP->op_first;
9119 newop = OP_SIBLING(kidkid);
9121 const OPCODE type = newop->op_type;
9122 if (OP_HAS_SIBLING(newop))
9124 if (o->op_type == OP_REFGEN && !(newop->op_flags & OPf_PARENS)
9125 && (type == OP_RV2AV || type == OP_PADAV
9126 || type == OP_RV2HV || type == OP_PADHV
9127 || type == OP_RV2CV))
9128 NOOP; /* OK (allow srefgen for \@a and \%h) */
9129 else if (!(PL_opargs[type] & OA_RETSCALAR))
9132 /* excise first sibling */
9133 op_sibling_splice(kid, NULL, 1, NULL);
9136 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9137 * and OP_CHOMP into OP_SCHOMP */
9138 o->op_ppaddr = PL_ppaddr[++o->op_type];
9143 Perl_ck_delete(pTHX_ OP *o)
9145 PERL_ARGS_ASSERT_CK_DELETE;
9149 if (o->op_flags & OPf_KIDS) {
9150 OP * const kid = cUNOPo->op_first;
9151 switch (kid->op_type) {
9153 o->op_flags |= OPf_SPECIAL;
9156 o->op_private |= OPpSLICE;
9159 o->op_flags |= OPf_SPECIAL;
9164 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9165 " use array slice");
9167 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9170 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9171 "element or slice");
9173 if (kid->op_private & OPpLVAL_INTRO)
9174 o->op_private |= OPpLVAL_INTRO;
9181 Perl_ck_eof(pTHX_ OP *o)
9183 PERL_ARGS_ASSERT_CK_EOF;
9185 if (o->op_flags & OPf_KIDS) {
9187 if (cLISTOPo->op_first->op_type == OP_STUB) {
9189 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9194 kid = cLISTOPo->op_first;
9195 if (kid->op_type == OP_RV2GV)
9196 kid->op_private |= OPpALLOW_FAKE;
9202 Perl_ck_eval(pTHX_ OP *o)
9206 PERL_ARGS_ASSERT_CK_EVAL;
9208 PL_hints |= HINT_BLOCK_SCOPE;
9209 if (o->op_flags & OPf_KIDS) {
9210 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9213 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
9216 /* cut whole sibling chain free from o */
9217 op_sibling_splice(o, NULL, -1, NULL);
9220 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9221 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
9223 /* establish postfix order */
9224 enter->op_next = (OP*)enter;
9226 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9227 o->op_type = OP_LEAVETRY;
9228 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
9229 enter->op_other = o;
9238 const U8 priv = o->op_private;
9240 /* the newUNOP will recursively call ck_eval(), which will handle
9241 * all the stuff at the end of this function, like adding
9244 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9246 o->op_targ = (PADOFFSET)PL_hints;
9247 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9248 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9249 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9250 /* Store a copy of %^H that pp_entereval can pick up. */
9251 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9252 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9253 /* append hhop to only child */
9254 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9256 o->op_private |= OPpEVAL_HAS_HH;
9258 if (!(o->op_private & OPpEVAL_BYTES)
9259 && FEATURE_UNIEVAL_IS_ENABLED)
9260 o->op_private |= OPpEVAL_UNICODE;
9265 Perl_ck_exec(pTHX_ OP *o)
9267 PERL_ARGS_ASSERT_CK_EXEC;
9269 if (o->op_flags & OPf_STACKED) {
9272 kid = OP_SIBLING(cUNOPo->op_first);
9273 if (kid->op_type == OP_RV2GV)
9282 Perl_ck_exists(pTHX_ OP *o)
9284 PERL_ARGS_ASSERT_CK_EXISTS;
9287 if (o->op_flags & OPf_KIDS) {
9288 OP * const kid = cUNOPo->op_first;
9289 if (kid->op_type == OP_ENTERSUB) {
9290 (void) ref(kid, o->op_type);
9291 if (kid->op_type != OP_RV2CV
9292 && !(PL_parser && PL_parser->error_count))
9294 "exists argument is not a subroutine name");
9295 o->op_private |= OPpEXISTS_SUB;
9297 else if (kid->op_type == OP_AELEM)
9298 o->op_flags |= OPf_SPECIAL;
9299 else if (kid->op_type != OP_HELEM)
9300 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9301 "element or a subroutine");
9308 Perl_ck_rvconst(pTHX_ OP *o)
9311 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9313 PERL_ARGS_ASSERT_CK_RVCONST;
9315 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9317 if (kid->op_type == OP_CONST) {
9320 SV * const kidsv = kid->op_sv;
9322 /* Is it a constant from cv_const_sv()? */
9323 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9326 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9327 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9328 const char *badthing;
9329 switch (o->op_type) {
9331 badthing = "a SCALAR";
9334 badthing = "an ARRAY";
9337 badthing = "a HASH";
9345 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9346 SVfARG(kidsv), badthing);
9349 * This is a little tricky. We only want to add the symbol if we
9350 * didn't add it in the lexer. Otherwise we get duplicate strict
9351 * warnings. But if we didn't add it in the lexer, we must at
9352 * least pretend like we wanted to add it even if it existed before,
9353 * or we get possible typo warnings. OPpCONST_ENTERED says
9354 * whether the lexer already added THIS instance of this symbol.
9356 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9357 gv = gv_fetchsv(kidsv,
9358 o->op_type == OP_RV2CV
9359 && o->op_private & OPpMAY_RETURN_CONSTANT
9361 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9364 : o->op_type == OP_RV2SV
9366 : o->op_type == OP_RV2AV
9368 : o->op_type == OP_RV2HV
9375 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9376 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9377 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9379 kid->op_type = OP_GV;
9380 SvREFCNT_dec(kid->op_sv);
9382 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9383 assert (sizeof(PADOP) <= sizeof(SVOP));
9384 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9385 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9386 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9388 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9390 kid->op_private = 0;
9391 kid->op_ppaddr = PL_ppaddr[OP_GV];
9392 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9400 Perl_ck_ftst(pTHX_ OP *o)
9403 const I32 type = o->op_type;
9405 PERL_ARGS_ASSERT_CK_FTST;
9407 if (o->op_flags & OPf_REF) {
9410 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9411 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9412 const OPCODE kidtype = kid->op_type;
9414 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9415 && !kid->op_folded) {
9416 OP * const newop = newGVOP(type, OPf_REF,
9417 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9421 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9422 o->op_private |= OPpFT_ACCESS;
9423 if (PL_check[kidtype] == Perl_ck_ftst
9424 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9425 o->op_private |= OPpFT_STACKED;
9426 kid->op_private |= OPpFT_STACKING;
9427 if (kidtype == OP_FTTTY && (
9428 !(kid->op_private & OPpFT_STACKED)
9429 || kid->op_private & OPpFT_AFTER_t
9431 o->op_private |= OPpFT_AFTER_t;
9436 if (type == OP_FTTTY)
9437 o = newGVOP(type, OPf_REF, PL_stdingv);
9439 o = newUNOP(type, 0, newDEFSVOP());
9445 Perl_ck_fun(pTHX_ OP *o)
9447 const int type = o->op_type;
9448 I32 oa = PL_opargs[type] >> OASHIFT;
9450 PERL_ARGS_ASSERT_CK_FUN;
9452 if (o->op_flags & OPf_STACKED) {
9453 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9456 return no_fh_allowed(o);
9459 if (o->op_flags & OPf_KIDS) {
9460 OP *prev_kid = NULL;
9461 OP *kid = cLISTOPo->op_first;
9463 bool seen_optional = FALSE;
9465 if (kid->op_type == OP_PUSHMARK ||
9466 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9469 kid = OP_SIBLING(kid);
9471 if (kid && kid->op_type == OP_COREARGS) {
9472 bool optional = FALSE;
9475 if (oa & OA_OPTIONAL) optional = TRUE;
9478 if (optional) o->op_private |= numargs;
9483 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9484 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9486 /* append kid to chain */
9487 op_sibling_splice(o, prev_kid, 0, kid);
9489 seen_optional = TRUE;
9496 /* list seen where single (scalar) arg expected? */
9497 if (numargs == 1 && !(oa >> 4)
9498 && kid->op_type == OP_LIST && type != OP_SCALAR)
9500 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9502 if (type != OP_DELETE) scalar(kid);
9513 if ((type == OP_PUSH || type == OP_UNSHIFT)
9514 && !OP_HAS_SIBLING(kid))
9515 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9516 "Useless use of %s with no values",
9519 if (kid->op_type == OP_CONST
9520 && ( !SvROK(cSVOPx_sv(kid))
9521 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9523 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9524 /* Defer checks to run-time if we have a scalar arg */
9525 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9526 op_lvalue(kid, type);
9529 /* diag_listed_as: push on reference is experimental */
9530 Perl_ck_warner_d(aTHX_
9531 packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9532 "%s on reference is experimental",
9537 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9538 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9539 op_lvalue(kid, type);
9543 /* replace kid with newop in chain */
9545 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9546 newop->op_next = newop;
9551 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9552 if (kid->op_type == OP_CONST &&
9553 (kid->op_private & OPpCONST_BARE))
9555 OP * const newop = newGVOP(OP_GV, 0,
9556 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9557 /* replace kid with newop in chain */
9558 op_sibling_splice(o, prev_kid, 1, newop);
9562 else if (kid->op_type == OP_READLINE) {
9563 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9564 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9567 I32 flags = OPf_SPECIAL;
9571 /* is this op a FH constructor? */
9572 if (is_handle_constructor(o,numargs)) {
9573 const char *name = NULL;
9576 bool want_dollar = TRUE;
9579 /* Set a flag to tell rv2gv to vivify
9580 * need to "prove" flag does not mean something
9581 * else already - NI-S 1999/05/07
9584 if (kid->op_type == OP_PADSV) {
9586 = PAD_COMPNAME_SV(kid->op_targ);
9587 name = SvPV_const(namesv, len);
9588 name_utf8 = SvUTF8(namesv);
9590 else if (kid->op_type == OP_RV2SV
9591 && kUNOP->op_first->op_type == OP_GV)
9593 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9595 len = GvNAMELEN(gv);
9596 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9598 else if (kid->op_type == OP_AELEM
9599 || kid->op_type == OP_HELEM)
9602 OP *op = ((BINOP*)kid)->op_first;
9606 const char * const a =
9607 kid->op_type == OP_AELEM ?
9609 if (((op->op_type == OP_RV2AV) ||
9610 (op->op_type == OP_RV2HV)) &&
9611 (firstop = ((UNOP*)op)->op_first) &&
9612 (firstop->op_type == OP_GV)) {
9613 /* packagevar $a[] or $h{} */
9614 GV * const gv = cGVOPx_gv(firstop);
9622 else if (op->op_type == OP_PADAV
9623 || op->op_type == OP_PADHV) {
9624 /* lexicalvar $a[] or $h{} */
9625 const char * const padname =
9626 PAD_COMPNAME_PV(op->op_targ);
9635 name = SvPV_const(tmpstr, len);
9636 name_utf8 = SvUTF8(tmpstr);
9641 name = "__ANONIO__";
9643 want_dollar = FALSE;
9645 op_lvalue(kid, type);
9649 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9650 namesv = PAD_SVl(targ);
9651 if (want_dollar && *name != '$')
9652 sv_setpvs(namesv, "$");
9654 sv_setpvs(namesv, "");
9655 sv_catpvn(namesv, name, len);
9656 if ( name_utf8 ) SvUTF8_on(namesv);
9660 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9662 kid->op_targ = targ;
9663 kid->op_private |= priv;
9669 if ((type == OP_UNDEF || type == OP_POS)
9670 && numargs == 1 && !(oa >> 4)
9671 && kid->op_type == OP_LIST)
9672 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9673 op_lvalue(scalar(kid), type);
9678 kid = OP_SIBLING(kid);
9680 /* FIXME - should the numargs or-ing move after the too many
9681 * arguments check? */
9682 o->op_private |= numargs;
9684 return too_many_arguments_pv(o,OP_DESC(o), 0);
9687 else if (PL_opargs[type] & OA_DEFGV) {
9688 /* Ordering of these two is important to keep f_map.t passing. */
9690 return newUNOP(type, 0, newDEFSVOP());
9694 while (oa & OA_OPTIONAL)
9696 if (oa && oa != OA_LIST)
9697 return too_few_arguments_pv(o,OP_DESC(o), 0);
9703 Perl_ck_glob(pTHX_ OP *o)
9707 PERL_ARGS_ASSERT_CK_GLOB;
9710 if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
9711 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9713 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9717 * \ null - const(wildcard)
9722 * \ mark - glob - rv2cv
9723 * | \ gv(CORE::GLOBAL::glob)
9725 * \ null - const(wildcard)
9727 o->op_flags |= OPf_SPECIAL;
9728 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9729 o = S_new_entersubop(aTHX_ gv, o);
9730 o = newUNOP(OP_NULL, 0, o);
9731 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9734 else o->op_flags &= ~OPf_SPECIAL;
9735 #if !defined(PERL_EXTERNAL_GLOB)
9738 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9739 newSVpvs("File::Glob"), NULL, NULL, NULL);
9742 #endif /* !PERL_EXTERNAL_GLOB */
9743 gv = (GV *)newSV(0);
9744 gv_init(gv, 0, "", 0, 0);
9746 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9747 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9753 Perl_ck_grep(pTHX_ OP *o)
9758 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9761 PERL_ARGS_ASSERT_CK_GREP;
9763 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9764 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9766 if (o->op_flags & OPf_STACKED) {
9767 kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
9768 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9769 return no_fh_allowed(o);
9770 o->op_flags &= ~OPf_STACKED;
9772 kid = OP_SIBLING(cLISTOPo->op_first);
9773 if (type == OP_MAPWHILE)
9778 if (PL_parser && PL_parser->error_count)
9780 kid = OP_SIBLING(cLISTOPo->op_first);
9781 if (kid->op_type != OP_NULL)
9782 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9783 kid = kUNOP->op_first;
9785 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
9786 gwop->op_ppaddr = PL_ppaddr[type];
9787 kid->op_next = (OP*)gwop;
9788 offset = pad_findmy_pvs("$_", 0);
9789 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9790 o->op_private = gwop->op_private = 0;
9791 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9794 o->op_private = gwop->op_private = OPpGREP_LEX;
9795 gwop->op_targ = o->op_targ = offset;
9798 kid = OP_SIBLING(cLISTOPo->op_first);
9799 for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
9800 op_lvalue(kid, OP_GREPSTART);
9806 Perl_ck_index(pTHX_ OP *o)
9808 PERL_ARGS_ASSERT_CK_INDEX;
9810 if (o->op_flags & OPf_KIDS) {
9811 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9813 kid = OP_SIBLING(kid); /* get past "big" */
9814 if (kid && kid->op_type == OP_CONST) {
9815 const bool save_taint = TAINT_get;
9816 SV *sv = kSVOP->op_sv;
9817 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9819 sv_copypv(sv, kSVOP->op_sv);
9820 SvREFCNT_dec_NN(kSVOP->op_sv);
9823 if (SvOK(sv)) fbm_compile(sv, 0);
9824 TAINT_set(save_taint);
9825 #ifdef NO_TAINT_SUPPORT
9826 PERL_UNUSED_VAR(save_taint);
9834 Perl_ck_lfun(pTHX_ OP *o)
9836 const OPCODE type = o->op_type;
9838 PERL_ARGS_ASSERT_CK_LFUN;
9840 return modkids(ck_fun(o), type);
9844 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
9846 PERL_ARGS_ASSERT_CK_DEFINED;
9848 if ((o->op_flags & OPf_KIDS)) {
9849 switch (cUNOPo->op_first->op_type) {
9852 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
9853 " (Maybe you should just omit the defined()?)");
9857 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
9858 " (Maybe you should just omit the defined()?)");
9869 Perl_ck_readline(pTHX_ OP *o)
9871 PERL_ARGS_ASSERT_CK_READLINE;
9873 if (o->op_flags & OPf_KIDS) {
9874 OP *kid = cLISTOPo->op_first;
9875 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9879 = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9887 Perl_ck_rfun(pTHX_ OP *o)
9889 const OPCODE type = o->op_type;
9891 PERL_ARGS_ASSERT_CK_RFUN;
9893 return refkids(ck_fun(o), type);
9897 Perl_ck_listiob(pTHX_ OP *o)
9901 PERL_ARGS_ASSERT_CK_LISTIOB;
9903 kid = cLISTOPo->op_first;
9905 o = force_list(o, 1);
9906 kid = cLISTOPo->op_first;
9908 if (kid->op_type == OP_PUSHMARK)
9909 kid = OP_SIBLING(kid);
9910 if (kid && o->op_flags & OPf_STACKED)
9911 kid = OP_SIBLING(kid);
9912 else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */
9913 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9914 && !kid->op_folded) {
9915 o->op_flags |= OPf_STACKED; /* make it a filehandle */
9917 /* replace old const op with new OP_RV2GV parent */
9918 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
9920 kid = OP_SIBLING(kid);
9925 op_append_elem(o->op_type, o, newDEFSVOP());
9927 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9932 Perl_ck_smartmatch(pTHX_ OP *o)
9935 PERL_ARGS_ASSERT_CK_SMARTMATCH;
9936 if (0 == (o->op_flags & OPf_SPECIAL)) {
9937 OP *first = cBINOPo->op_first;
9938 OP *second = OP_SIBLING(first);
9940 /* Implicitly take a reference to an array or hash */
9942 /* remove the original two siblings, then add back the
9943 * (possibly different) first and second sibs.
9945 op_sibling_splice(o, NULL, 1, NULL);
9946 op_sibling_splice(o, NULL, 1, NULL);
9947 first = ref_array_or_hash(first);
9948 second = ref_array_or_hash(second);
9949 op_sibling_splice(o, NULL, 0, second);
9950 op_sibling_splice(o, NULL, 0, first);
9952 /* Implicitly take a reference to a regular expression */
9953 if (first->op_type == OP_MATCH) {
9954 first->op_type = OP_QR;
9955 first->op_ppaddr = PL_ppaddr[OP_QR];
9957 if (second->op_type == OP_MATCH) {
9958 second->op_type = OP_QR;
9959 second->op_ppaddr = PL_ppaddr[OP_QR];
9968 Perl_ck_sassign(pTHX_ OP *o)
9971 OP * const kid = cLISTOPo->op_first;
9973 PERL_ARGS_ASSERT_CK_SASSIGN;
9975 /* has a disposable target? */
9976 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9977 && !(kid->op_flags & OPf_STACKED)
9978 /* Cannot steal the second time! */
9979 && !(kid->op_private & OPpTARGET_MY)
9982 OP * const kkid = OP_SIBLING(kid);
9984 /* Can just relocate the target. */
9985 if (kkid && kkid->op_type == OP_PADSV
9986 && !(kkid->op_private & OPpLVAL_INTRO))
9988 kid->op_targ = kkid->op_targ;
9990 /* Now we do not need PADSV and SASSIGN.
9991 * first replace the PADSV with OP_SIBLING(o), then
9992 * detach kid and OP_SIBLING(o) from o */
9993 op_sibling_splice(o, kid, 1, OP_SIBLING(o));
9994 op_sibling_splice(o, NULL, -1, NULL);
9997 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10001 if (OP_HAS_SIBLING(kid)) {
10002 OP *kkid = OP_SIBLING(kid);
10003 /* For state variable assignment, kkid is a list op whose op_last
10005 if ((kkid->op_type == OP_PADSV ||
10006 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10007 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10010 && (kkid->op_private & OPpLVAL_INTRO)
10011 && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
10012 const PADOFFSET target = kkid->op_targ;
10013 OP *const other = newOP(OP_PADSV,
10015 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10016 OP *const first = newOP(OP_NULL, 0);
10017 OP *const nullop = newCONDOP(0, first, o, other);
10018 OP *const condop = first->op_next;
10020 condop->op_type = OP_ONCE;
10021 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
10022 other->op_targ = target;
10024 /* Store the initializedness of state vars in a separate
10027 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10028 /* hijacking PADSTALE for uninitialized state variables */
10029 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10038 Perl_ck_match(pTHX_ OP *o)
10040 PERL_ARGS_ASSERT_CK_MATCH;
10042 if (o->op_type != OP_QR && PL_compcv) {
10043 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10044 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10045 o->op_targ = offset;
10046 o->op_private |= OPpTARGET_MY;
10049 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10050 o->op_private |= OPpRUNTIME;
10055 Perl_ck_method(pTHX_ OP *o)
10058 const char* method;
10059 OP * const kid = cUNOPo->op_first;
10061 PERL_ARGS_ASSERT_CK_METHOD;
10062 if (kid->op_type != OP_CONST) return o;
10065 method = SvPVX_const(sv);
10066 if (!(strchr(method, ':') || strchr(method, '\''))) {
10068 if (!SvIsCOW_shared_hash(sv)) {
10069 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
10072 kSVOP->op_sv = NULL;
10074 cmop = newMETHOP_named(OP_METHOD_NAMED, 0, sv);
10082 Perl_ck_null(pTHX_ OP *o)
10084 PERL_ARGS_ASSERT_CK_NULL;
10085 PERL_UNUSED_CONTEXT;
10090 Perl_ck_open(pTHX_ OP *o)
10092 PERL_ARGS_ASSERT_CK_OPEN;
10094 S_io_hints(aTHX_ o);
10096 /* In case of three-arg dup open remove strictness
10097 * from the last arg if it is a bareword. */
10098 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10099 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10103 if ((last->op_type == OP_CONST) && /* The bareword. */
10104 (last->op_private & OPpCONST_BARE) &&
10105 (last->op_private & OPpCONST_STRICT) &&
10106 (oa = OP_SIBLING(first)) && /* The fh. */
10107 (oa = OP_SIBLING(oa)) && /* The mode. */
10108 (oa->op_type == OP_CONST) &&
10109 SvPOK(((SVOP*)oa)->op_sv) &&
10110 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10111 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10112 (last == OP_SIBLING(oa))) /* The bareword. */
10113 last->op_private &= ~OPpCONST_STRICT;
10119 Perl_ck_refassign(pTHX_ OP *o)
10121 OP * const right = cLISTOPo->op_first;
10122 OP * const left = OP_SIBLING(right);
10123 OP * const varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10126 PERL_ARGS_ASSERT_CK_REFASSIGN;
10128 assert (left->op_type == OP_SREFGEN);
10130 switch (varop->op_type) {
10132 o->op_private = OPpLVREF_AV;
10135 o->op_private = OPpLVREF_HV;
10138 o->op_targ = varop->op_targ;
10139 varop->op_targ = 0;
10140 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10143 o->op_private = OPpLVREF_AV;
10146 o->op_private = OPpLVREF_HV;
10149 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10150 goto null_and_stack;
10153 cUNOPx(cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling)
10155 o->op_private = OPpLVREF_CV;
10156 if (kid->op_type == OP_GV) goto null_and_stack;
10157 if (kid->op_type != OP_PADCV) goto bad;
10158 o->op_targ = kid->op_targ;
10164 o->op_private = OPpLVREF_ELEM;
10172 /* diag_listed_as: Can't modify %s in %s */
10173 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10178 if (!FEATURE_LVREF_IS_ENABLED)
10180 "Experimental lvalue references not enabled");
10181 Perl_ck_warner_d(aTHX_
10182 packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
10183 "Lvalue references are experimental");
10184 o->op_private |= varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10185 if (stacked) o->op_flags |= OPf_STACKED;
10187 o->op_flags &=~ OPf_STACKED;
10188 op_sibling_splice(o, right, 1, NULL);
10195 Perl_ck_repeat(pTHX_ OP *o)
10197 PERL_ARGS_ASSERT_CK_REPEAT;
10199 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10201 o->op_private |= OPpREPEAT_DOLIST;
10202 kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
10203 kids = force_list(kids, 1); /* promote them to a list */
10204 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10205 if (cBINOPo->op_last == kids) cBINOPo->op_last = NULL;
10213 Perl_ck_require(pTHX_ OP *o)
10217 PERL_ARGS_ASSERT_CK_REQUIRE;
10219 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10220 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10225 if (kid->op_type == OP_CONST) {
10226 SV * const sv = kid->op_sv;
10227 U32 const was_readonly = SvREADONLY(sv);
10228 if (kid->op_private & OPpCONST_BARE) {
10232 if (was_readonly) {
10233 SvREADONLY_off(sv);
10235 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10240 for (; s < end; s++) {
10241 if (*s == ':' && s[1] == ':') {
10243 Move(s+2, s+1, end - s - 1, char);
10247 SvEND_set(sv, end);
10248 sv_catpvs(sv, ".pm");
10249 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10250 hek = share_hek(SvPVX(sv),
10251 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10253 sv_sethek(sv, hek);
10255 SvFLAGS(sv) |= was_readonly;
10257 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
10259 if (SvREFCNT(sv) > 1) {
10260 kid->op_sv = newSVpvn_share(
10261 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10262 SvREFCNT_dec_NN(sv);
10266 if (was_readonly) SvREADONLY_off(sv);
10267 PERL_HASH(hash, s, len);
10269 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10271 sv_sethek(sv, hek);
10273 SvFLAGS(sv) |= was_readonly;
10279 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10280 /* handle override, if any */
10281 && (gv = gv_override("require", 7))) {
10283 if (o->op_flags & OPf_KIDS) {
10284 kid = cUNOPo->op_first;
10285 op_sibling_splice(o, NULL, -1, NULL);
10288 kid = newDEFSVOP();
10291 newop = S_new_entersubop(aTHX_ gv, kid);
10295 return scalar(ck_fun(o));
10299 Perl_ck_return(pTHX_ OP *o)
10303 PERL_ARGS_ASSERT_CK_RETURN;
10305 kid = OP_SIBLING(cLISTOPo->op_first);
10306 if (CvLVALUE(PL_compcv)) {
10307 for (; kid; kid = OP_SIBLING(kid))
10308 op_lvalue(kid, OP_LEAVESUBLV);
10315 Perl_ck_select(pTHX_ OP *o)
10320 PERL_ARGS_ASSERT_CK_SELECT;
10322 if (o->op_flags & OPf_KIDS) {
10323 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10324 if (kid && OP_HAS_SIBLING(kid)) {
10325 o->op_type = OP_SSELECT;
10326 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
10328 return fold_constants(op_integerize(op_std_init(o)));
10332 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10333 if (kid && kid->op_type == OP_RV2GV)
10334 kid->op_private &= ~HINT_STRICT_REFS;
10339 Perl_ck_shift(pTHX_ OP *o)
10341 const I32 type = o->op_type;
10343 PERL_ARGS_ASSERT_CK_SHIFT;
10345 if (!(o->op_flags & OPf_KIDS)) {
10348 if (!CvUNIQUE(PL_compcv)) {
10349 o->op_flags |= OPf_SPECIAL;
10353 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10355 return newUNOP(type, 0, scalar(argop));
10357 return scalar(ck_fun(o));
10361 Perl_ck_sort(pTHX_ OP *o)
10365 HV * const hinthv =
10366 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10369 PERL_ARGS_ASSERT_CK_SORT;
10372 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10374 const I32 sorthints = (I32)SvIV(*svp);
10375 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10376 o->op_private |= OPpSORT_QSORT;
10377 if ((sorthints & HINT_SORT_STABLE) != 0)
10378 o->op_private |= OPpSORT_STABLE;
10382 if (o->op_flags & OPf_STACKED)
10384 firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10386 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10387 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10389 /* if the first arg is a code block, process it and mark sort as
10391 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10393 if (kid->op_type == OP_LEAVE)
10394 op_null(kid); /* wipe out leave */
10395 /* Prevent execution from escaping out of the sort block. */
10398 /* provide scalar context for comparison function/block */
10399 kid = scalar(firstkid);
10400 kid->op_next = kid;
10401 o->op_flags |= OPf_SPECIAL;
10403 else if (kid->op_type == OP_CONST
10404 && kid->op_private & OPpCONST_BARE) {
10408 const char * const name = SvPV(kSVOP_sv, len);
10410 assert (len < 256);
10411 Copy(name, tmpbuf+1, len, char);
10412 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10413 if (off != NOT_IN_PAD) {
10414 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10416 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10417 sv_catpvs(fq, "::");
10418 sv_catsv(fq, kSVOP_sv);
10419 SvREFCNT_dec_NN(kSVOP_sv);
10423 OP * const padop = newOP(OP_PADCV, 0);
10424 padop->op_targ = off;
10425 cUNOPx(firstkid)->op_first = padop;
10431 firstkid = OP_SIBLING(firstkid);
10434 for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
10435 /* provide list context for arguments */
10438 op_lvalue(kid, OP_GREPSTART);
10444 /* for sort { X } ..., where X is one of
10445 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10446 * elide the second child of the sort (the one containing X),
10447 * and set these flags as appropriate
10451 * Also, check and warn on lexical $a, $b.
10455 S_simplify_sort(pTHX_ OP *o)
10457 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10461 const char *gvname;
10464 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10466 kid = kUNOP->op_first; /* get past null */
10467 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10468 && kid->op_type != OP_LEAVE)
10470 kid = kLISTOP->op_last; /* get past scope */
10471 switch(kid->op_type) {
10475 if (!have_scopeop) goto padkids;
10480 k = kid; /* remember this node*/
10481 if (kBINOP->op_first->op_type != OP_RV2SV
10482 || kBINOP->op_last ->op_type != OP_RV2SV)
10485 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10486 then used in a comparison. This catches most, but not
10487 all cases. For instance, it catches
10488 sort { my($a); $a <=> $b }
10490 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10491 (although why you'd do that is anyone's guess).
10495 if (!ckWARN(WARN_SYNTAX)) return;
10496 kid = kBINOP->op_first;
10498 if (kid->op_type == OP_PADSV) {
10499 SV * const name = PAD_COMPNAME_SV(kid->op_targ);
10500 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
10501 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
10502 /* diag_listed_as: "my %s" used in sort comparison */
10503 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10504 "\"%s %s\" used in sort comparison",
10505 SvPAD_STATE(name) ? "state" : "my",
10508 } while ((kid = OP_SIBLING(kid)));
10511 kid = kBINOP->op_first; /* get past cmp */
10512 if (kUNOP->op_first->op_type != OP_GV)
10514 kid = kUNOP->op_first; /* get past rv2sv */
10516 if (GvSTASH(gv) != PL_curstash)
10518 gvname = GvNAME(gv);
10519 if (*gvname == 'a' && gvname[1] == '\0')
10521 else if (*gvname == 'b' && gvname[1] == '\0')
10526 kid = k; /* back to cmp */
10527 /* already checked above that it is rv2sv */
10528 kid = kBINOP->op_last; /* down to 2nd arg */
10529 if (kUNOP->op_first->op_type != OP_GV)
10531 kid = kUNOP->op_first; /* get past rv2sv */
10533 if (GvSTASH(gv) != PL_curstash)
10535 gvname = GvNAME(gv);
10537 ? !(*gvname == 'a' && gvname[1] == '\0')
10538 : !(*gvname == 'b' && gvname[1] == '\0'))
10540 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10542 o->op_private |= OPpSORT_DESCEND;
10543 if (k->op_type == OP_NCMP)
10544 o->op_private |= OPpSORT_NUMERIC;
10545 if (k->op_type == OP_I_NCMP)
10546 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10547 kid = OP_SIBLING(cLISTOPo->op_first);
10548 /* cut out and delete old block (second sibling) */
10549 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10554 Perl_ck_split(pTHX_ OP *o)
10559 PERL_ARGS_ASSERT_CK_SPLIT;
10561 if (o->op_flags & OPf_STACKED)
10562 return no_fh_allowed(o);
10564 kid = cLISTOPo->op_first;
10565 if (kid->op_type != OP_NULL)
10566 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10567 /* delete leading NULL node, then add a CONST if no other nodes */
10568 op_sibling_splice(o, NULL, 1,
10569 OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10571 kid = cLISTOPo->op_first;
10573 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10574 /* remove kid, and replace with new optree */
10575 op_sibling_splice(o, NULL, 1, NULL);
10576 /* OPf_SPECIAL is used to trigger split " " behavior */
10577 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
10578 op_sibling_splice(o, NULL, 0, kid);
10581 kid->op_type = OP_PUSHRE;
10582 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
10584 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10585 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10586 "Use of /g modifier is meaningless in split");
10589 if (!OP_HAS_SIBLING(kid))
10590 op_append_elem(OP_SPLIT, o, newDEFSVOP());
10592 kid = OP_SIBLING(kid);
10596 if (!OP_HAS_SIBLING(kid))
10598 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10599 o->op_private |= OPpSPLIT_IMPLIM;
10601 assert(OP_HAS_SIBLING(kid));
10603 kid = OP_SIBLING(kid);
10606 if (OP_HAS_SIBLING(kid))
10607 return too_many_arguments_pv(o,OP_DESC(o), 0);
10613 Perl_ck_stringify(pTHX_ OP *o)
10615 OP * const kid = OP_SIBLING(cUNOPo->op_first);
10616 PERL_ARGS_ASSERT_CK_STRINGIFY;
10617 if (kid->op_type == OP_JOIN) {
10618 assert(!OP_HAS_SIBLING(kid));
10619 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
10627 Perl_ck_join(pTHX_ OP *o)
10629 OP * const kid = OP_SIBLING(cLISTOPo->op_first);
10631 PERL_ARGS_ASSERT_CK_JOIN;
10633 if (kid && kid->op_type == OP_MATCH) {
10634 if (ckWARN(WARN_SYNTAX)) {
10635 const REGEXP *re = PM_GETRE(kPMOP);
10637 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10638 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10639 : newSVpvs_flags( "STRING", SVs_TEMP );
10640 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10641 "/%"SVf"/ should probably be written as \"%"SVf"\"",
10642 SVfARG(msg), SVfARG(msg));
10645 if (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
10646 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
10647 || (kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
10648 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))))
10650 const OP * const bairn = OP_SIBLING(kid); /* the list */
10651 if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
10652 && PL_opargs[bairn->op_type] & OA_RETSCALAR)
10654 OP * const ret = convert(OP_STRINGIFY, 0,
10655 op_sibling_splice(o, kid, 1, NULL));
10657 ret->op_folded = 1;
10666 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10668 Examines an op, which is expected to identify a subroutine at runtime,
10669 and attempts to determine at compile time which subroutine it identifies.
10670 This is normally used during Perl compilation to determine whether
10671 a prototype can be applied to a function call. I<cvop> is the op
10672 being considered, normally an C<rv2cv> op. A pointer to the identified
10673 subroutine is returned, if it could be determined statically, and a null
10674 pointer is returned if it was not possible to determine statically.
10676 Currently, the subroutine can be identified statically if the RV that the
10677 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10678 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
10679 suitable if the constant value must be an RV pointing to a CV. Details of
10680 this process may change in future versions of Perl. If the C<rv2cv> op
10681 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10682 the subroutine statically: this flag is used to suppress compile-time
10683 magic on a subroutine call, forcing it to use default runtime behaviour.
10685 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10686 of a GV reference is modified. If a GV was examined and its CV slot was
10687 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10688 If the op is not optimised away, and the CV slot is later populated with
10689 a subroutine having a prototype, that flag eventually triggers the warning
10690 "called too early to check prototype".
10692 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10693 of returning a pointer to the subroutine it returns a pointer to the
10694 GV giving the most appropriate name for the subroutine in this context.
10695 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10696 (C<CvANON>) subroutine that is referenced through a GV it will be the
10697 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
10698 A null pointer is returned as usual if there is no statically-determinable
10704 /* shared by toke.c:yylex */
10706 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10708 PADNAME *name = PAD_COMPNAME(off);
10709 CV *compcv = PL_compcv;
10710 while (PadnameOUTER(name)) {
10711 assert(PARENT_PAD_INDEX(name));
10712 compcv = CvOUTSIDE(PL_compcv);
10713 name = PadlistNAMESARRAY(CvPADLIST(compcv))
10714 [off = PARENT_PAD_INDEX(name)];
10716 assert(!PadnameIsOUR(name));
10717 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10718 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10720 assert(mg->mg_obj);
10721 return (CV *)mg->mg_obj;
10723 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10727 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10732 PERL_ARGS_ASSERT_RV2CV_OP_CV;
10733 if (flags & ~RV2CVOPCV_FLAG_MASK)
10734 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10735 if (cvop->op_type != OP_RV2CV)
10737 if (cvop->op_private & OPpENTERSUB_AMPER)
10739 if (!(cvop->op_flags & OPf_KIDS))
10741 rvop = cUNOPx(cvop)->op_first;
10742 switch (rvop->op_type) {
10744 gv = cGVOPx_gv(rvop);
10746 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
10747 cv = MUTABLE_CV(SvRV(gv));
10751 if (flags & RV2CVOPCV_RETURN_STUB)
10757 if (flags & RV2CVOPCV_MARK_EARLY)
10758 rvop->op_private |= OPpEARLY_CV;
10763 SV *rv = cSVOPx_sv(rvop);
10766 cv = (CV*)SvRV(rv);
10770 cv = find_lexical_cv(rvop->op_targ);
10775 } NOT_REACHED; /* NOTREACHED */
10777 if (SvTYPE((SV*)cv) != SVt_PVCV)
10779 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
10780 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
10781 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
10790 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10792 Performs the default fixup of the arguments part of an C<entersub>
10793 op tree. This consists of applying list context to each of the
10794 argument ops. This is the standard treatment used on a call marked
10795 with C<&>, or a method call, or a call through a subroutine reference,
10796 or any other call where the callee can't be identified at compile time,
10797 or a call where the callee has no prototype.
10803 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10806 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10807 aop = cUNOPx(entersubop)->op_first;
10808 if (!OP_HAS_SIBLING(aop))
10809 aop = cUNOPx(aop)->op_first;
10810 for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
10812 op_lvalue(aop, OP_ENTERSUB);
10818 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10820 Performs the fixup of the arguments part of an C<entersub> op tree
10821 based on a subroutine prototype. This makes various modifications to
10822 the argument ops, from applying context up to inserting C<refgen> ops,
10823 and checking the number and syntactic types of arguments, as directed by
10824 the prototype. This is the standard treatment used on a subroutine call,
10825 not marked with C<&>, where the callee can be identified at compile time
10826 and has a prototype.
10828 I<protosv> supplies the subroutine prototype to be applied to the call.
10829 It may be a normal defined scalar, of which the string value will be used.
10830 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10831 that has been cast to C<SV*>) which has a prototype. The prototype
10832 supplied, in whichever form, does not need to match the actual callee
10833 referenced by the op tree.
10835 If the argument ops disagree with the prototype, for example by having
10836 an unacceptable number of arguments, a valid op tree is returned anyway.
10837 The error is reflected in the parser state, normally resulting in a single
10838 exception at the top level of parsing which covers all the compilation
10839 errors that occurred. In the error message, the callee is referred to
10840 by the name defined by the I<namegv> parameter.
10846 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10849 const char *proto, *proto_end;
10850 OP *aop, *prev, *cvop, *parent;
10853 I32 contextclass = 0;
10854 const char *e = NULL;
10855 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10856 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10857 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10858 "flags=%lx", (unsigned long) SvFLAGS(protosv));
10859 if (SvTYPE(protosv) == SVt_PVCV)
10860 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10861 else proto = SvPV(protosv, proto_len);
10862 proto = S_strip_spaces(aTHX_ proto, &proto_len);
10863 proto_end = proto + proto_len;
10864 parent = entersubop;
10865 aop = cUNOPx(entersubop)->op_first;
10866 if (!OP_HAS_SIBLING(aop)) {
10868 aop = cUNOPx(aop)->op_first;
10871 aop = OP_SIBLING(aop);
10872 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10873 while (aop != cvop) {
10876 if (proto >= proto_end)
10878 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
10879 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
10880 SVfARG(namesv)), SvUTF8(namesv));
10890 /* _ must be at the end */
10891 if (proto[1] && !strchr(";@%", proto[1]))
10907 if (o3->op_type != OP_REFGEN && o3->op_type != OP_SREFGEN
10908 && o3->op_type != OP_UNDEF)
10910 arg == 1 ? "block or sub {}" : "sub {}",
10914 /* '*' allows any scalar type, including bareword */
10917 if (o3->op_type == OP_RV2GV)
10918 goto wrapref; /* autoconvert GLOB -> GLOBref */
10919 else if (o3->op_type == OP_CONST)
10920 o3->op_private &= ~OPpCONST_STRICT;
10926 if (o3->op_type == OP_RV2AV ||
10927 o3->op_type == OP_PADAV ||
10928 o3->op_type == OP_RV2HV ||
10929 o3->op_type == OP_PADHV
10935 case '[': case ']':
10942 switch (*proto++) {
10944 if (contextclass++ == 0) {
10945 e = strchr(proto, ']');
10946 if (!e || e == proto)
10954 if (contextclass) {
10955 const char *p = proto;
10956 const char *const end = proto;
10958 while (*--p != '[')
10959 /* \[$] accepts any scalar lvalue */
10961 && Perl_op_lvalue_flags(aTHX_
10963 OP_READ, /* not entersub */
10966 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10967 (int)(end - p), p),
10973 if (o3->op_type == OP_RV2GV)
10976 bad_type_gv(arg, "symbol", namegv, 0, o3);
10979 if (o3->op_type == OP_ENTERSUB)
10982 bad_type_gv(arg, "subroutine entry", namegv, 0,
10986 if (o3->op_type == OP_RV2SV ||
10987 o3->op_type == OP_PADSV ||
10988 o3->op_type == OP_HELEM ||
10989 o3->op_type == OP_AELEM)
10991 if (!contextclass) {
10992 /* \$ accepts any scalar lvalue */
10993 if (Perl_op_lvalue_flags(aTHX_
10995 OP_READ, /* not entersub */
10998 bad_type_gv(arg, "scalar", namegv, 0, o3);
11002 if (o3->op_type == OP_RV2AV ||
11003 o3->op_type == OP_PADAV)
11006 bad_type_gv(arg, "array", namegv, 0, o3);
11009 if (o3->op_type == OP_RV2HV ||
11010 o3->op_type == OP_PADHV)
11013 bad_type_gv(arg, "hash", namegv, 0, o3);
11016 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11018 if (contextclass && e) {
11023 default: goto oops;
11033 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11034 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11039 op_lvalue(aop, OP_ENTERSUB);
11041 aop = OP_SIBLING(aop);
11043 if (aop == cvop && *proto == '_') {
11044 /* generate an access to $_ */
11045 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11047 if (!optional && proto_end > proto &&
11048 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11050 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11051 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11052 SVfARG(namesv)), SvUTF8(namesv));
11058 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11060 Performs the fixup of the arguments part of an C<entersub> op tree either
11061 based on a subroutine prototype or using default list-context processing.
11062 This is the standard treatment used on a subroutine call, not marked
11063 with C<&>, where the callee can be identified at compile time.
11065 I<protosv> supplies the subroutine prototype to be applied to the call,
11066 or indicates that there is no prototype. It may be a normal scalar,
11067 in which case if it is defined then the string value will be used
11068 as a prototype, and if it is undefined then there is no prototype.
11069 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11070 that has been cast to C<SV*>), of which the prototype will be used if it
11071 has one. The prototype (or lack thereof) supplied, in whichever form,
11072 does not need to match the actual callee referenced by the op tree.
11074 If the argument ops disagree with the prototype, for example by having
11075 an unacceptable number of arguments, a valid op tree is returned anyway.
11076 The error is reflected in the parser state, normally resulting in a single
11077 exception at the top level of parsing which covers all the compilation
11078 errors that occurred. In the error message, the callee is referred to
11079 by the name defined by the I<namegv> parameter.
11085 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11086 GV *namegv, SV *protosv)
11088 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11089 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11090 return ck_entersub_args_proto(entersubop, namegv, protosv);
11092 return ck_entersub_args_list(entersubop);
11096 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11098 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11099 OP *aop = cUNOPx(entersubop)->op_first;
11101 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11105 if (!OP_HAS_SIBLING(aop))
11106 aop = cUNOPx(aop)->op_first;
11107 aop = OP_SIBLING(aop);
11108 for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11110 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11112 op_free(entersubop);
11113 switch(GvNAME(namegv)[2]) {
11114 case 'F': return newSVOP(OP_CONST, 0,
11115 newSVpv(CopFILE(PL_curcop),0));
11116 case 'L': return newSVOP(
11118 Perl_newSVpvf(aTHX_
11119 "%"IVdf, (IV)CopLINE(PL_curcop)
11122 case 'P': return newSVOP(OP_CONST, 0,
11124 ? newSVhek(HvNAME_HEK(PL_curstash))
11132 OP *prev, *cvop, *first, *parent;
11135 parent = entersubop;
11136 if (!OP_HAS_SIBLING(aop)) {
11138 aop = cUNOPx(aop)->op_first;
11141 first = prev = aop;
11142 aop = OP_SIBLING(aop);
11143 /* find last sibling */
11145 OP_HAS_SIBLING(cvop);
11146 prev = cvop, cvop = OP_SIBLING(cvop))
11148 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11149 /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
11150 * parens, but these have their own meaning for that flag: */
11151 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11152 && opnum != OP_DELETE && opnum != OP_EXISTS)
11153 flags |= OPf_SPECIAL;
11154 /* excise cvop from end of sibling chain */
11155 op_sibling_splice(parent, prev, 1, NULL);
11157 if (aop == cvop) aop = NULL;
11159 /* detach remaining siblings from the first sibling, then
11160 * dispose of original optree */
11163 op_sibling_splice(parent, first, -1, NULL);
11164 op_free(entersubop);
11166 if (opnum == OP_ENTEREVAL
11167 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11168 flags |= OPpEVAL_BYTES <<8;
11170 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11172 case OA_BASEOP_OR_UNOP:
11173 case OA_FILESTATOP:
11174 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11177 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11180 return opnum == OP_RUNCV
11181 ? newPVOP(OP_RUNCV,0,NULL)
11184 return convert(opnum,0,aop);
11192 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11194 Retrieves the function that will be used to fix up a call to I<cv>.
11195 Specifically, the function is applied to an C<entersub> op tree for a
11196 subroutine call, not marked with C<&>, where the callee can be identified
11197 at compile time as I<cv>.
11199 The C-level function pointer is returned in I<*ckfun_p>, and an SV
11200 argument for it is returned in I<*ckobj_p>. The function is intended
11201 to be called in this manner:
11203 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11205 In this call, I<entersubop> is a pointer to the C<entersub> op,
11206 which may be replaced by the check function, and I<namegv> is a GV
11207 supplying the name that should be used by the check function to refer
11208 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11209 It is permitted to apply the check function in non-standard situations,
11210 such as to a call to a different subroutine or to a method call.
11212 By default, the function is
11213 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11214 and the SV parameter is I<cv> itself. This implements standard
11215 prototype processing. It can be changed, for a particular subroutine,
11216 by L</cv_set_call_checker>.
11222 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11226 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11228 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11229 *ckobj_p = callmg->mg_obj;
11230 if (flagsp) *flagsp = callmg->mg_flags;
11232 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11233 *ckobj_p = (SV*)cv;
11234 if (flagsp) *flagsp = 0;
11239 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11241 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11242 PERL_UNUSED_CONTEXT;
11243 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11247 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11249 Sets the function that will be used to fix up a call to I<cv>.
11250 Specifically, the function is applied to an C<entersub> op tree for a
11251 subroutine call, not marked with C<&>, where the callee can be identified
11252 at compile time as I<cv>.
11254 The C-level function pointer is supplied in I<ckfun>, and an SV argument
11255 for it is supplied in I<ckobj>. The function should be defined like this:
11257 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11259 It is intended to be called in this manner:
11261 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11263 In this call, I<entersubop> is a pointer to the C<entersub> op,
11264 which may be replaced by the check function, and I<namegv> supplies
11265 the name that should be used by the check function to refer
11266 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11267 It is permitted to apply the check function in non-standard situations,
11268 such as to a call to a different subroutine or to a method call.
11270 I<namegv> may not actually be a GV. For efficiency, perl may pass a
11271 CV or other SV instead. Whatever is passed can be used as the first
11272 argument to L</cv_name>. You can force perl to pass a GV by including
11273 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
11275 The current setting for a particular CV can be retrieved by
11276 L</cv_get_call_checker>.
11278 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11280 The original form of L</cv_set_call_checker_flags>, which passes it the
11281 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11287 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11289 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11290 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11294 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11295 SV *ckobj, U32 flags)
11297 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11298 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11299 if (SvMAGICAL((SV*)cv))
11300 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11303 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11304 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11306 if (callmg->mg_flags & MGf_REFCOUNTED) {
11307 SvREFCNT_dec(callmg->mg_obj);
11308 callmg->mg_flags &= ~MGf_REFCOUNTED;
11310 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11311 callmg->mg_obj = ckobj;
11312 if (ckobj != (SV*)cv) {
11313 SvREFCNT_inc_simple_void_NN(ckobj);
11314 callmg->mg_flags |= MGf_REFCOUNTED;
11316 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11317 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11322 Perl_ck_subr(pTHX_ OP *o)
11328 PERL_ARGS_ASSERT_CK_SUBR;
11330 aop = cUNOPx(o)->op_first;
11331 if (!OP_HAS_SIBLING(aop))
11332 aop = cUNOPx(aop)->op_first;
11333 aop = OP_SIBLING(aop);
11334 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
11335 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11336 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11338 o->op_private &= ~1;
11339 o->op_private |= OPpENTERSUB_HASTARG;
11340 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11341 if (PERLDB_SUB && PL_curstash != PL_debstash)
11342 o->op_private |= OPpENTERSUB_DB;
11343 if (cvop->op_type == OP_RV2CV) {
11344 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11346 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
11347 if (aop->op_type == OP_CONST)
11348 aop->op_private &= ~OPpCONST_STRICT;
11349 else if (aop->op_type == OP_LIST) {
11350 OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
11351 if (sib && sib->op_type == OP_CONST)
11352 sib->op_private &= ~OPpCONST_STRICT;
11357 return ck_entersub_args_list(o);
11359 Perl_call_checker ckfun;
11362 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11364 /* The original call checker API guarantees that a GV will be
11365 be provided with the right name. So, if the old API was
11366 used (or the REQUIRE_GV flag was passed), we have to reify
11367 the CV’s GV, unless this is an anonymous sub. This is not
11368 ideal for lexical subs, as its stringification will include
11369 the package. But it is the best we can do. */
11370 if (flags & MGf_REQUIRE_GV) {
11371 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11374 else namegv = MUTABLE_GV(cv);
11375 /* After a syntax error in a lexical sub, the cv that
11376 rv2cv_op_cv returns may be a nameless stub. */
11377 if (!namegv) return ck_entersub_args_list(o);
11380 return ckfun(aTHX_ o, namegv, ckobj);
11385 Perl_ck_svconst(pTHX_ OP *o)
11387 SV * const sv = cSVOPo->op_sv;
11388 PERL_ARGS_ASSERT_CK_SVCONST;
11389 PERL_UNUSED_CONTEXT;
11390 #ifdef PERL_OLD_COPY_ON_WRITE
11391 if (SvIsCOW(sv)) sv_force_normal(sv);
11392 #elif defined(PERL_NEW_COPY_ON_WRITE)
11393 /* Since the read-only flag may be used to protect a string buffer, we
11394 cannot do copy-on-write with existing read-only scalars that are not
11395 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11396 that constant, mark the constant as COWable here, if it is not
11397 already read-only. */
11398 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11401 # ifdef PERL_DEBUG_READONLY_COW
11411 Perl_ck_trunc(pTHX_ OP *o)
11413 PERL_ARGS_ASSERT_CK_TRUNC;
11415 if (o->op_flags & OPf_KIDS) {
11416 SVOP *kid = (SVOP*)cUNOPo->op_first;
11418 if (kid->op_type == OP_NULL)
11419 kid = (SVOP*)OP_SIBLING(kid);
11420 if (kid && kid->op_type == OP_CONST &&
11421 (kid->op_private & OPpCONST_BARE) &&
11424 o->op_flags |= OPf_SPECIAL;
11425 kid->op_private &= ~OPpCONST_STRICT;
11432 Perl_ck_substr(pTHX_ OP *o)
11434 PERL_ARGS_ASSERT_CK_SUBSTR;
11437 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11438 OP *kid = cLISTOPo->op_first;
11440 if (kid->op_type == OP_NULL)
11441 kid = OP_SIBLING(kid);
11443 kid->op_flags |= OPf_MOD;
11450 Perl_ck_tell(pTHX_ OP *o)
11452 PERL_ARGS_ASSERT_CK_TELL;
11454 if (o->op_flags & OPf_KIDS) {
11455 OP *kid = cLISTOPo->op_first;
11456 if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
11457 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11463 Perl_ck_each(pTHX_ OP *o)
11466 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11467 const unsigned orig_type = o->op_type;
11468 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
11469 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
11470 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
11471 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
11473 PERL_ARGS_ASSERT_CK_EACH;
11476 switch (kid->op_type) {
11482 CHANGE_TYPE(o, array_type);
11485 if (kid->op_private == OPpCONST_BARE
11486 || !SvROK(cSVOPx_sv(kid))
11487 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11488 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
11490 /* we let ck_fun handle it */
11493 CHANGE_TYPE(o, ref_type);
11497 /* if treating as a reference, defer additional checks to runtime */
11498 if (o->op_type == ref_type) {
11499 /* diag_listed_as: keys on reference is experimental */
11500 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
11501 "%s is experimental", PL_op_desc[ref_type]);
11508 Perl_ck_length(pTHX_ OP *o)
11510 PERL_ARGS_ASSERT_CK_LENGTH;
11514 if (ckWARN(WARN_SYNTAX)) {
11515 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11519 const bool hash = kid->op_type == OP_PADHV
11520 || kid->op_type == OP_RV2HV;
11521 switch (kid->op_type) {
11526 name = S_op_varname(aTHX_ kid);
11532 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11533 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11535 SVfARG(name), hash ? "keys " : "", SVfARG(name)
11538 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11540 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11542 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11543 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11544 "length() used on @array (did you mean \"scalar(@array)\"?)");
11551 /* Check for in place reverse and sort assignments like "@a = reverse @a"
11552 and modify the optree to make them work inplace */
11555 S_inplace_aassign(pTHX_ OP *o) {
11557 OP *modop, *modop_pushmark;
11559 OP *oleft, *oleft_pushmark;
11561 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
11563 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
11565 assert(cUNOPo->op_first->op_type == OP_NULL);
11566 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
11567 assert(modop_pushmark->op_type == OP_PUSHMARK);
11568 modop = OP_SIBLING(modop_pushmark);
11570 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
11573 /* no other operation except sort/reverse */
11574 if (OP_HAS_SIBLING(modop))
11577 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
11578 if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
11580 if (modop->op_flags & OPf_STACKED) {
11581 /* skip sort subroutine/block */
11582 assert(oright->op_type == OP_NULL);
11583 oright = OP_SIBLING(oright);
11586 assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
11587 oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
11588 assert(oleft_pushmark->op_type == OP_PUSHMARK);
11589 oleft = OP_SIBLING(oleft_pushmark);
11591 /* Check the lhs is an array */
11593 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
11594 || OP_HAS_SIBLING(oleft)
11595 || (oleft->op_private & OPpLVAL_INTRO)
11599 /* Only one thing on the rhs */
11600 if (OP_HAS_SIBLING(oright))
11603 /* check the array is the same on both sides */
11604 if (oleft->op_type == OP_RV2AV) {
11605 if (oright->op_type != OP_RV2AV
11606 || !cUNOPx(oright)->op_first
11607 || cUNOPx(oright)->op_first->op_type != OP_GV
11608 || cUNOPx(oleft )->op_first->op_type != OP_GV
11609 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11610 cGVOPx_gv(cUNOPx(oright)->op_first)
11614 else if (oright->op_type != OP_PADAV
11615 || oright->op_targ != oleft->op_targ
11619 /* This actually is an inplace assignment */
11621 modop->op_private |= OPpSORT_INPLACE;
11623 /* transfer MODishness etc from LHS arg to RHS arg */
11624 oright->op_flags = oleft->op_flags;
11626 /* remove the aassign op and the lhs */
11628 op_null(oleft_pushmark);
11629 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11630 op_null(cUNOPx(oleft)->op_first);
11636 /* mechanism for deferring recursion in rpeep() */
11638 #define MAX_DEFERRED 4
11642 if (defer_ix == (MAX_DEFERRED-1)) { \
11643 OP **defer = defer_queue[defer_base]; \
11644 CALL_RPEEP(*defer); \
11645 S_prune_chain_head(defer); \
11646 defer_base = (defer_base + 1) % MAX_DEFERRED; \
11649 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
11652 #define IS_AND_OP(o) (o->op_type == OP_AND)
11653 #define IS_OR_OP(o) (o->op_type == OP_OR)
11657 S_null_listop_in_list_context(pTHX_ OP *o)
11661 PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
11663 /* This is an OP_LIST in list context. That means we
11664 * can ditch the OP_LIST and the OP_PUSHMARK within. */
11666 kid = cLISTOPo->op_first;
11667 /* Find the end of the chain of OPs executed within the OP_LIST. */
11668 while (kid->op_next != o)
11669 kid = kid->op_next;
11671 kid->op_next = o->op_next; /* patch list out of exec chain */
11672 op_null(cUNOPo->op_first); /* NULL the pushmark */
11673 op_null(o); /* NULL the list */
11676 /* A peephole optimizer. We visit the ops in the order they're to execute.
11677 * See the comments at the top of this file for more details about when
11678 * peep() is called */
11681 Perl_rpeep(pTHX_ OP *o)
11685 OP* oldoldop = NULL;
11686 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11687 int defer_base = 0;
11692 if (!o || o->op_opt)
11696 SAVEVPTR(PL_curcop);
11697 for (;; o = o->op_next) {
11698 if (o && o->op_opt)
11701 while (defer_ix >= 0) {
11703 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
11704 CALL_RPEEP(*defer);
11705 S_prune_chain_head(defer);
11710 /* By default, this op has now been optimised. A couple of cases below
11711 clear this again. */
11716 /* The following will have the OP_LIST and OP_PUSHMARK
11717 * patched out later IF the OP_LIST is in list context.
11718 * So in that case, we can set the this OP's op_next
11719 * to skip to after the OP_PUSHMARK:
11725 * will eventually become:
11728 * - ex-pushmark -> -
11734 OP *other_pushmark;
11735 if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
11736 && (sibling = OP_SIBLING(o))
11737 && sibling->op_type == OP_LIST
11738 /* This KIDS check is likely superfluous since OP_LIST
11739 * would otherwise be an OP_STUB. */
11740 && sibling->op_flags & OPf_KIDS
11741 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
11742 && (other_pushmark = cLISTOPx(sibling)->op_first)
11743 /* Pointer equality also effectively checks that it's a
11745 && other_pushmark == o->op_next)
11747 o->op_next = other_pushmark->op_next;
11748 null_listop_in_list_context(sibling);
11752 switch (o->op_type) {
11754 PL_curcop = ((COP*)o); /* for warnings */
11757 PL_curcop = ((COP*)o); /* for warnings */
11759 /* Optimise a "return ..." at the end of a sub to just be "...".
11760 * This saves 2 ops. Before:
11761 * 1 <;> nextstate(main 1 -e:1) v ->2
11762 * 4 <@> return K ->5
11763 * 2 <0> pushmark s ->3
11764 * - <1> ex-rv2sv sK/1 ->4
11765 * 3 <#> gvsv[*cat] s ->4
11768 * - <@> return K ->-
11769 * - <0> pushmark s ->2
11770 * - <1> ex-rv2sv sK/1 ->-
11771 * 2 <$> gvsv(*cat) s ->3
11774 OP *next = o->op_next;
11775 OP *sibling = OP_SIBLING(o);
11776 if ( OP_TYPE_IS(next, OP_PUSHMARK)
11777 && OP_TYPE_IS(sibling, OP_RETURN)
11778 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
11779 && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
11780 && cUNOPx(sibling)->op_first == next
11781 && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
11784 /* Look through the PUSHMARK's siblings for one that
11785 * points to the RETURN */
11786 OP *top = OP_SIBLING(next);
11787 while (top && top->op_next) {
11788 if (top->op_next == sibling) {
11789 top->op_next = sibling->op_next;
11790 o->op_next = next->op_next;
11793 top = OP_SIBLING(top);
11798 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
11800 * This latter form is then suitable for conversion into padrange
11801 * later on. Convert:
11803 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
11807 * nextstate1 -> listop -> nextstate3
11809 * pushmark -> padop1 -> padop2
11811 if (o->op_next && (
11812 o->op_next->op_type == OP_PADSV
11813 || o->op_next->op_type == OP_PADAV
11814 || o->op_next->op_type == OP_PADHV
11816 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
11817 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
11818 && o->op_next->op_next->op_next && (
11819 o->op_next->op_next->op_next->op_type == OP_PADSV
11820 || o->op_next->op_next->op_next->op_type == OP_PADAV
11821 || o->op_next->op_next->op_next->op_type == OP_PADHV
11823 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
11824 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
11825 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
11826 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
11828 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
11831 ns2 = pad1->op_next;
11832 pad2 = ns2->op_next;
11833 ns3 = pad2->op_next;
11835 /* we assume here that the op_next chain is the same as
11836 * the op_sibling chain */
11837 assert(OP_SIBLING(o) == pad1);
11838 assert(OP_SIBLING(pad1) == ns2);
11839 assert(OP_SIBLING(ns2) == pad2);
11840 assert(OP_SIBLING(pad2) == ns3);
11842 /* create new listop, with children consisting of:
11843 * a new pushmark, pad1, pad2. */
11844 OP_SIBLING_set(pad2, NULL);
11845 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
11846 newop->op_flags |= OPf_PARENS;
11847 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11848 newpm = cUNOPx(newop)->op_first; /* pushmark */
11850 /* Kill nextstate2 between padop1/padop2 */
11853 o ->op_next = newpm;
11854 newpm->op_next = pad1;
11855 pad1 ->op_next = pad2;
11856 pad2 ->op_next = newop; /* listop */
11857 newop->op_next = ns3;
11859 OP_SIBLING_set(o, newop);
11860 OP_SIBLING_set(newop, ns3);
11861 newop->op_lastsib = 0;
11863 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11865 /* Ensure pushmark has this flag if padops do */
11866 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
11867 o->op_next->op_flags |= OPf_MOD;
11873 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11874 to carry two labels. For now, take the easier option, and skip
11875 this optimisation if the first NEXTSTATE has a label. */
11876 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
11877 OP *nextop = o->op_next;
11878 while (nextop && nextop->op_type == OP_NULL)
11879 nextop = nextop->op_next;
11881 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11882 COP *firstcop = (COP *)o;
11883 COP *secondcop = (COP *)nextop;
11884 /* We want the COP pointed to by o (and anything else) to
11885 become the next COP down the line. */
11886 cop_free(firstcop);
11888 firstcop->op_next = secondcop->op_next;
11890 /* Now steal all its pointers, and duplicate the other
11892 firstcop->cop_line = secondcop->cop_line;
11893 #ifdef USE_ITHREADS
11894 firstcop->cop_stashoff = secondcop->cop_stashoff;
11895 firstcop->cop_file = secondcop->cop_file;
11897 firstcop->cop_stash = secondcop->cop_stash;
11898 firstcop->cop_filegv = secondcop->cop_filegv;
11900 firstcop->cop_hints = secondcop->cop_hints;
11901 firstcop->cop_seq = secondcop->cop_seq;
11902 firstcop->cop_warnings = secondcop->cop_warnings;
11903 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11905 #ifdef USE_ITHREADS
11906 secondcop->cop_stashoff = 0;
11907 secondcop->cop_file = NULL;
11909 secondcop->cop_stash = NULL;
11910 secondcop->cop_filegv = NULL;
11912 secondcop->cop_warnings = NULL;
11913 secondcop->cop_hints_hash = NULL;
11915 /* If we use op_null(), and hence leave an ex-COP, some
11916 warnings are misreported. For example, the compile-time
11917 error in 'use strict; no strict refs;' */
11918 secondcop->op_type = OP_NULL;
11919 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11925 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11926 if (o->op_next->op_private & OPpTARGET_MY) {
11927 if (o->op_flags & OPf_STACKED) /* chained concats */
11928 break; /* ignore_optimization */
11930 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11931 o->op_targ = o->op_next->op_targ;
11932 o->op_next->op_targ = 0;
11933 o->op_private |= OPpTARGET_MY;
11936 op_null(o->op_next);
11940 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11941 break; /* Scalar stub must produce undef. List stub is noop */
11945 if (o->op_targ == OP_NEXTSTATE
11946 || o->op_targ == OP_DBSTATE)
11948 PL_curcop = ((COP*)o);
11950 /* XXX: We avoid setting op_seq here to prevent later calls
11951 to rpeep() from mistakenly concluding that optimisation
11952 has already occurred. This doesn't fix the real problem,
11953 though (See 20010220.007). AMS 20010719 */
11954 /* op_seq functionality is now replaced by op_opt */
11962 oldop->op_next = o->op_next;
11970 /* Convert a series of PAD ops for my vars plus support into a
11971 * single padrange op. Basically
11973 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11975 * becomes, depending on circumstances, one of
11977 * padrange ----------------------------------> (list) -> rest
11978 * padrange --------------------------------------------> rest
11980 * where all the pad indexes are sequential and of the same type
11982 * We convert the pushmark into a padrange op, then skip
11983 * any other pad ops, and possibly some trailing ops.
11984 * Note that we don't null() the skipped ops, to make it
11985 * easier for Deparse to undo this optimisation (and none of
11986 * the skipped ops are holding any resourses). It also makes
11987 * it easier for find_uninit_var(), as it can just ignore
11988 * padrange, and examine the original pad ops.
11992 OP *followop = NULL; /* the op that will follow the padrange op */
11995 PADOFFSET base = 0; /* init only to stop compiler whining */
11996 U8 gimme = 0; /* init only to stop compiler whining */
11997 bool defav = 0; /* seen (...) = @_ */
11998 bool reuse = 0; /* reuse an existing padrange op */
12000 /* look for a pushmark -> gv[_] -> rv2av */
12006 if ( p->op_type == OP_GV
12007 && (gv = cGVOPx_gv(p)) && isGV(gv)
12008 && GvNAMELEN_get(gv) == 1
12009 && *GvNAME_get(gv) == '_'
12010 && GvSTASH(gv) == PL_defstash
12011 && (rv2av = p->op_next)
12012 && rv2av->op_type == OP_RV2AV
12013 && !(rv2av->op_flags & OPf_REF)
12014 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12015 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
12016 && OP_SIBLING(o) == rv2av /* these two for Deparse */
12017 && cUNOPx(rv2av)->op_first == p
12019 q = rv2av->op_next;
12020 if (q->op_type == OP_NULL)
12022 if (q->op_type == OP_PUSHMARK) {
12029 /* To allow Deparse to pessimise this, it needs to be able
12030 * to restore the pushmark's original op_next, which it
12031 * will assume to be the same as OP_SIBLING. */
12032 if (o->op_next != OP_SIBLING(o))
12037 /* scan for PAD ops */
12039 for (p = p->op_next; p; p = p->op_next) {
12040 if (p->op_type == OP_NULL)
12043 if (( p->op_type != OP_PADSV
12044 && p->op_type != OP_PADAV
12045 && p->op_type != OP_PADHV
12047 /* any private flag other than INTRO? e.g. STATE */
12048 || (p->op_private & ~OPpLVAL_INTRO)
12052 /* let $a[N] potentially be optimised into AELEMFAST_LEX
12054 if ( p->op_type == OP_PADAV
12056 && p->op_next->op_type == OP_CONST
12057 && p->op_next->op_next
12058 && p->op_next->op_next->op_type == OP_AELEM
12062 /* for 1st padop, note what type it is and the range
12063 * start; for the others, check that it's the same type
12064 * and that the targs are contiguous */
12066 intro = (p->op_private & OPpLVAL_INTRO);
12068 gimme = (p->op_flags & OPf_WANT);
12071 if ((p->op_private & OPpLVAL_INTRO) != intro)
12073 /* Note that you'd normally expect targs to be
12074 * contiguous in my($a,$b,$c), but that's not the case
12075 * when external modules start doing things, e.g.
12076 i* Function::Parameters */
12077 if (p->op_targ != base + count)
12079 assert(p->op_targ == base + count);
12080 /* all the padops should be in the same context */
12081 if (gimme != (p->op_flags & OPf_WANT))
12085 /* for AV, HV, only when we're not flattening */
12086 if ( p->op_type != OP_PADSV
12087 && gimme != OPf_WANT_VOID
12088 && !(p->op_flags & OPf_REF)
12092 if (count >= OPpPADRANGE_COUNTMASK)
12095 /* there's a biggest base we can fit into a
12096 * SAVEt_CLEARPADRANGE in pp_padrange */
12097 if (intro && base >
12098 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
12101 /* Success! We've got another valid pad op to optimise away */
12103 followop = p->op_next;
12109 /* pp_padrange in specifically compile-time void context
12110 * skips pushing a mark and lexicals; in all other contexts
12111 * (including unknown till runtime) it pushes a mark and the
12112 * lexicals. We must be very careful then, that the ops we
12113 * optimise away would have exactly the same effect as the
12115 * In particular in void context, we can only optimise to
12116 * a padrange if see see the complete sequence
12117 * pushmark, pad*v, ...., list, nextstate
12118 * which has the net effect of of leaving the stack empty
12119 * (for now we leave the nextstate in the execution chain, for
12120 * its other side-effects).
12123 if (gimme == OPf_WANT_VOID) {
12124 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
12125 && gimme == (followop->op_flags & OPf_WANT)
12126 && ( followop->op_next->op_type == OP_NEXTSTATE
12127 || followop->op_next->op_type == OP_DBSTATE))
12129 followop = followop->op_next; /* skip OP_LIST */
12131 /* consolidate two successive my(...);'s */
12134 && oldoldop->op_type == OP_PADRANGE
12135 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
12136 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
12137 && !(oldoldop->op_flags & OPf_SPECIAL)
12140 assert(oldoldop->op_next == oldop);
12141 assert( oldop->op_type == OP_NEXTSTATE
12142 || oldop->op_type == OP_DBSTATE);
12143 assert(oldop->op_next == o);
12146 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
12148 /* Do not assume pad offsets for $c and $d are con-
12153 if ( oldoldop->op_targ + old_count == base
12154 && old_count < OPpPADRANGE_COUNTMASK - count) {
12155 base = oldoldop->op_targ;
12156 count += old_count;
12161 /* if there's any immediately following singleton
12162 * my var's; then swallow them and the associated
12164 * my ($a,$b); my $c; my $d;
12166 * my ($a,$b,$c,$d);
12169 while ( ((p = followop->op_next))
12170 && ( p->op_type == OP_PADSV
12171 || p->op_type == OP_PADAV
12172 || p->op_type == OP_PADHV)
12173 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
12174 && (p->op_private & OPpLVAL_INTRO) == intro
12175 && !(p->op_private & ~OPpLVAL_INTRO)
12177 && ( p->op_next->op_type == OP_NEXTSTATE
12178 || p->op_next->op_type == OP_DBSTATE)
12179 && count < OPpPADRANGE_COUNTMASK
12180 && base + count == p->op_targ
12183 followop = p->op_next;
12191 assert(oldoldop->op_type == OP_PADRANGE);
12192 oldoldop->op_next = followop;
12193 oldoldop->op_private = (intro | count);
12199 /* Convert the pushmark into a padrange.
12200 * To make Deparse easier, we guarantee that a padrange was
12201 * *always* formerly a pushmark */
12202 assert(o->op_type == OP_PUSHMARK);
12203 o->op_next = followop;
12204 o->op_type = OP_PADRANGE;
12205 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
12207 /* bit 7: INTRO; bit 6..0: count */
12208 o->op_private = (intro | count);
12209 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
12210 | gimme | (defav ? OPf_SPECIAL : 0));
12217 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
12218 OP* const pop = (o->op_type == OP_PADAV) ?
12219 o->op_next : o->op_next->op_next;
12221 if (pop && pop->op_type == OP_CONST &&
12222 ((PL_op = pop->op_next)) &&
12223 pop->op_next->op_type == OP_AELEM &&
12224 !(pop->op_next->op_private &
12225 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
12226 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
12229 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
12230 no_bareword_allowed(pop);
12231 if (o->op_type == OP_GV)
12232 op_null(o->op_next);
12233 op_null(pop->op_next);
12235 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
12236 o->op_next = pop->op_next->op_next;
12237 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
12238 o->op_private = (U8)i;
12239 if (o->op_type == OP_GV) {
12242 o->op_type = OP_AELEMFAST;
12245 o->op_type = OP_AELEMFAST_LEX;
12250 if (o->op_next->op_type == OP_RV2SV) {
12251 if (!(o->op_next->op_private & OPpDEREF)) {
12252 op_null(o->op_next);
12253 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
12255 o->op_next = o->op_next->op_next;
12256 o->op_type = OP_GVSV;
12257 o->op_ppaddr = PL_ppaddr[OP_GVSV];
12260 else if (o->op_next->op_type == OP_READLINE
12261 && o->op_next->op_next->op_type == OP_CONCAT
12262 && (o->op_next->op_next->op_flags & OPf_STACKED))
12264 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
12265 o->op_type = OP_RCATLINE;
12266 o->op_flags |= OPf_STACKED;
12267 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
12268 op_null(o->op_next->op_next);
12269 op_null(o->op_next);
12274 #define HV_OR_SCALARHV(op) \
12275 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
12277 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
12278 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
12279 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
12280 ? cUNOPx(op)->op_first \
12284 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
12285 fop->op_private |= OPpTRUEBOOL;
12291 fop = cLOGOP->op_first;
12292 sop = OP_SIBLING(fop);
12293 while (cLOGOP->op_other->op_type == OP_NULL)
12294 cLOGOP->op_other = cLOGOP->op_other->op_next;
12295 while (o->op_next && ( o->op_type == o->op_next->op_type
12296 || o->op_next->op_type == OP_NULL))
12297 o->op_next = o->op_next->op_next;
12299 /* if we're an OR and our next is a AND in void context, we'll
12300 follow it's op_other on short circuit, same for reverse.
12301 We can't do this with OP_DOR since if it's true, its return
12302 value is the underlying value which must be evaluated
12306 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
12307 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
12309 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
12311 o->op_next = ((LOGOP*)o->op_next)->op_other;
12313 DEFER(cLOGOP->op_other);
12316 fop = HV_OR_SCALARHV(fop);
12317 if (sop) sop = HV_OR_SCALARHV(sop);
12322 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
12323 while (nop && nop->op_next) {
12324 switch (nop->op_next->op_type) {
12329 lop = nop = nop->op_next;
12332 nop = nop->op_next;
12341 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
12342 || o->op_type == OP_AND )
12343 fop->op_private |= OPpTRUEBOOL;
12344 else if (!(lop->op_flags & OPf_WANT))
12345 fop->op_private |= OPpMAYBE_TRUEBOOL;
12347 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
12349 sop->op_private |= OPpTRUEBOOL;
12356 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
12357 fop->op_private |= OPpTRUEBOOL;
12358 #undef HV_OR_SCALARHV
12359 /* GERONIMO! */ /* FALLTHROUGH */
12368 while (cLOGOP->op_other->op_type == OP_NULL)
12369 cLOGOP->op_other = cLOGOP->op_other->op_next;
12370 DEFER(cLOGOP->op_other);
12375 while (cLOOP->op_redoop->op_type == OP_NULL)
12376 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
12377 while (cLOOP->op_nextop->op_type == OP_NULL)
12378 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
12379 while (cLOOP->op_lastop->op_type == OP_NULL)
12380 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
12381 /* a while(1) loop doesn't have an op_next that escapes the
12382 * loop, so we have to explicitly follow the op_lastop to
12383 * process the rest of the code */
12384 DEFER(cLOOP->op_lastop);
12388 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
12389 DEFER(cLOGOPo->op_other);
12393 assert(!(cPMOP->op_pmflags & PMf_ONCE));
12394 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
12395 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
12396 cPMOP->op_pmstashstartu.op_pmreplstart
12397 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
12398 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
12404 if (o->op_flags & OPf_SPECIAL) {
12405 /* first arg is a code block */
12406 OP * const nullop = OP_SIBLING(cLISTOP->op_first);
12407 OP * kid = cUNOPx(nullop)->op_first;
12409 assert(nullop->op_type == OP_NULL);
12410 assert(kid->op_type == OP_SCOPE
12411 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
12412 /* since OP_SORT doesn't have a handy op_other-style
12413 * field that can point directly to the start of the code
12414 * block, store it in the otherwise-unused op_next field
12415 * of the top-level OP_NULL. This will be quicker at
12416 * run-time, and it will also allow us to remove leading
12417 * OP_NULLs by just messing with op_nexts without
12418 * altering the basic op_first/op_sibling layout. */
12419 kid = kLISTOP->op_first;
12421 (kid->op_type == OP_NULL
12422 && ( kid->op_targ == OP_NEXTSTATE
12423 || kid->op_targ == OP_DBSTATE ))
12424 || kid->op_type == OP_STUB
12425 || kid->op_type == OP_ENTER);
12426 nullop->op_next = kLISTOP->op_next;
12427 DEFER(nullop->op_next);
12430 /* check that RHS of sort is a single plain array */
12431 oright = cUNOPo->op_first;
12432 if (!oright || oright->op_type != OP_PUSHMARK)
12435 if (o->op_private & OPpSORT_INPLACE)
12438 /* reverse sort ... can be optimised. */
12439 if (!OP_HAS_SIBLING(cUNOPo)) {
12440 /* Nothing follows us on the list. */
12441 OP * const reverse = o->op_next;
12443 if (reverse->op_type == OP_REVERSE &&
12444 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
12445 OP * const pushmark = cUNOPx(reverse)->op_first;
12446 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
12447 && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
12448 /* reverse -> pushmark -> sort */
12449 o->op_private |= OPpSORT_REVERSE;
12451 pushmark->op_next = oright->op_next;
12461 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
12463 LISTOP *enter, *exlist;
12465 if (o->op_private & OPpSORT_INPLACE)
12468 enter = (LISTOP *) o->op_next;
12471 if (enter->op_type == OP_NULL) {
12472 enter = (LISTOP *) enter->op_next;
12476 /* for $a (...) will have OP_GV then OP_RV2GV here.
12477 for (...) just has an OP_GV. */
12478 if (enter->op_type == OP_GV) {
12479 gvop = (OP *) enter;
12480 enter = (LISTOP *) enter->op_next;
12483 if (enter->op_type == OP_RV2GV) {
12484 enter = (LISTOP *) enter->op_next;
12490 if (enter->op_type != OP_ENTERITER)
12493 iter = enter->op_next;
12494 if (!iter || iter->op_type != OP_ITER)
12497 expushmark = enter->op_first;
12498 if (!expushmark || expushmark->op_type != OP_NULL
12499 || expushmark->op_targ != OP_PUSHMARK)
12502 exlist = (LISTOP *) OP_SIBLING(expushmark);
12503 if (!exlist || exlist->op_type != OP_NULL
12504 || exlist->op_targ != OP_LIST)
12507 if (exlist->op_last != o) {
12508 /* Mmm. Was expecting to point back to this op. */
12511 theirmark = exlist->op_first;
12512 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
12515 if (OP_SIBLING(theirmark) != o) {
12516 /* There's something between the mark and the reverse, eg
12517 for (1, reverse (...))
12522 ourmark = ((LISTOP *)o)->op_first;
12523 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
12526 ourlast = ((LISTOP *)o)->op_last;
12527 if (!ourlast || ourlast->op_next != o)
12530 rv2av = OP_SIBLING(ourmark);
12531 if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av)
12532 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
12533 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
12534 /* We're just reversing a single array. */
12535 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
12536 enter->op_flags |= OPf_STACKED;
12539 /* We don't have control over who points to theirmark, so sacrifice
12541 theirmark->op_next = ourmark->op_next;
12542 theirmark->op_flags = ourmark->op_flags;
12543 ourlast->op_next = gvop ? gvop : (OP *) enter;
12546 enter->op_private |= OPpITER_REVERSED;
12547 iter->op_private |= OPpITER_REVERSED;
12554 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
12555 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
12560 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
12562 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
12564 sv = newRV((SV *)PL_compcv);
12568 o->op_type = OP_CONST;
12569 o->op_ppaddr = PL_ppaddr[OP_CONST];
12570 o->op_flags |= OPf_SPECIAL;
12571 cSVOPo->op_sv = sv;
12576 if (OP_GIMME(o,0) == G_VOID) {
12577 OP *right = cBINOP->op_first;
12596 OP *left = OP_SIBLING(right);
12597 if (left->op_type == OP_SUBSTR
12598 && (left->op_private & 7) < 4) {
12600 /* cut out right */
12601 op_sibling_splice(o, NULL, 1, NULL);
12602 /* and insert it as second child of OP_SUBSTR */
12603 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
12605 left->op_private |= OPpSUBSTR_REPL_FIRST;
12607 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12614 /* We do the common-vars check here, rather than in newASSIGNOP
12615 (as formerly), so that all lexical vars that get aliased are
12616 marked as such before we do the check. */
12617 if (o->op_private & OPpASSIGN_COMMON) {
12618 /* See the comment before S_aassign_common_vars concerning
12619 PL_generation sorcery. */
12621 if (!aassign_common_vars(o))
12622 o->op_private &=~ OPpASSIGN_COMMON;
12624 else if (S_aassign_common_vars_aliases_only(aTHX_ o))
12625 o->op_private |= OPpASSIGN_COMMON;
12629 Perl_cpeep_t cpeep =
12630 XopENTRYCUSTOM(o, xop_peep);
12632 cpeep(aTHX_ o, oldop);
12637 /* did we just null the current op? If so, re-process it to handle
12638 * eliding "empty" ops from the chain */
12639 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
12652 Perl_peep(pTHX_ OP *o)
12658 =head1 Custom Operators
12660 =for apidoc Ao||custom_op_xop
12661 Return the XOP structure for a given custom op. This macro should be
12662 considered internal to OP_NAME and the other access macros: use them instead.
12663 This macro does call a function. Prior
12664 to 5.19.6, this was implemented as a
12671 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
12677 static const XOP xop_null = { 0, 0, 0, 0, 0 };
12679 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
12680 assert(o->op_type == OP_CUSTOM);
12682 /* This is wrong. It assumes a function pointer can be cast to IV,
12683 * which isn't guaranteed, but this is what the old custom OP code
12684 * did. In principle it should be safer to Copy the bytes of the
12685 * pointer into a PV: since the new interface is hidden behind
12686 * functions, this can be changed later if necessary. */
12687 /* Change custom_op_xop if this ever happens */
12688 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
12691 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12693 /* assume noone will have just registered a desc */
12694 if (!he && PL_custom_op_names &&
12695 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
12700 /* XXX does all this need to be shared mem? */
12701 Newxz(xop, 1, XOP);
12702 pv = SvPV(HeVAL(he), l);
12703 XopENTRY_set(xop, xop_name, savepvn(pv, l));
12704 if (PL_custom_op_descs &&
12705 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
12707 pv = SvPV(HeVAL(he), l);
12708 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
12710 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
12714 xop = (XOP *)&xop_null;
12716 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
12720 if(field == XOPe_xop_ptr) {
12723 const U32 flags = XopFLAGS(xop);
12724 if(flags & field) {
12726 case XOPe_xop_name:
12727 any.xop_name = xop->xop_name;
12729 case XOPe_xop_desc:
12730 any.xop_desc = xop->xop_desc;
12732 case XOPe_xop_class:
12733 any.xop_class = xop->xop_class;
12735 case XOPe_xop_peep:
12736 any.xop_peep = xop->xop_peep;
12744 case XOPe_xop_name:
12745 any.xop_name = XOPd_xop_name;
12747 case XOPe_xop_desc:
12748 any.xop_desc = XOPd_xop_desc;
12750 case XOPe_xop_class:
12751 any.xop_class = XOPd_xop_class;
12753 case XOPe_xop_peep:
12754 any.xop_peep = XOPd_xop_peep;
12762 /* Some gcc releases emit a warning for this function:
12763 * op.c: In function 'Perl_custom_op_get_field':
12764 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
12765 * Whether this is true, is currently unknown. */
12771 =for apidoc Ao||custom_op_register
12772 Register a custom op. See L<perlguts/"Custom Operators">.
12778 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
12782 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
12784 /* see the comment in custom_op_xop */
12785 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
12787 if (!PL_custom_ops)
12788 PL_custom_ops = newHV();
12790 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
12791 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
12796 =for apidoc core_prototype
12798 This function assigns the prototype of the named core function to C<sv>, or
12799 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
12800 NULL if the core function has no prototype. C<code> is a code as returned
12801 by C<keyword()>. It must not be equal to 0.
12807 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
12810 int i = 0, n = 0, seen_question = 0, defgv = 0;
12812 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
12813 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
12814 bool nullret = FALSE;
12816 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
12820 if (!sv) sv = sv_newmortal();
12822 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
12824 switch (code < 0 ? -code : code) {
12825 case KEY_and : case KEY_chop: case KEY_chomp:
12826 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
12827 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
12828 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
12829 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
12830 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
12831 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
12832 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
12833 case KEY_x : case KEY_xor :
12834 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
12835 case KEY_glob: retsetpvs("_;", OP_GLOB);
12836 case KEY_keys: retsetpvs("+", OP_KEYS);
12837 case KEY_values: retsetpvs("+", OP_VALUES);
12838 case KEY_each: retsetpvs("+", OP_EACH);
12839 case KEY_push: retsetpvs("+@", OP_PUSH);
12840 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
12841 case KEY_pop: retsetpvs(";+", OP_POP);
12842 case KEY_shift: retsetpvs(";+", OP_SHIFT);
12843 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
12845 retsetpvs("+;$$@", OP_SPLICE);
12846 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
12848 case KEY_evalbytes:
12849 name = "entereval"; break;
12857 while (i < MAXO) { /* The slow way. */
12858 if (strEQ(name, PL_op_name[i])
12859 || strEQ(name, PL_op_desc[i]))
12861 if (nullret) { assert(opnum); *opnum = i; return NULL; }
12868 defgv = PL_opargs[i] & OA_DEFGV;
12869 oa = PL_opargs[i] >> OASHIFT;
12871 if (oa & OA_OPTIONAL && !seen_question && (
12872 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
12877 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
12878 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
12879 /* But globs are already references (kinda) */
12880 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
12884 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
12885 && !scalar_mod_type(NULL, i)) {
12890 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
12894 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
12895 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
12896 str[n-1] = '_'; defgv = 0;
12900 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
12902 sv_setpvn(sv, str, n - 1);
12903 if (opnum) *opnum = i;
12908 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
12911 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
12914 PERL_ARGS_ASSERT_CORESUB_OP;
12918 return op_append_elem(OP_LINESEQ,
12921 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
12925 case OP_SELECT: /* which represents OP_SSELECT as well */
12930 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12931 newSVOP(OP_CONST, 0, newSVuv(1))
12933 coresub_op(newSVuv((UV)OP_SSELECT), 0,
12935 coresub_op(coreargssv, 0, OP_SELECT)
12939 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12941 return op_append_elem(
12944 opnum == OP_WANTARRAY || opnum == OP_RUNCV
12945 ? OPpOFFBYONE << 8 : 0)
12947 case OA_BASEOP_OR_UNOP:
12948 if (opnum == OP_ENTEREVAL) {
12949 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12950 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12952 else o = newUNOP(opnum,0,argop);
12953 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12956 if (is_handle_constructor(o, 1))
12957 argop->op_private |= OPpCOREARGS_DEREF1;
12958 if (scalar_mod_type(NULL, opnum))
12959 argop->op_private |= OPpCOREARGS_SCALARMOD;
12963 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
12964 if (is_handle_constructor(o, 2))
12965 argop->op_private |= OPpCOREARGS_DEREF2;
12966 if (opnum == OP_SUBSTR) {
12967 o->op_private |= OPpMAYBE_LVSUB;
12976 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12977 SV * const *new_const_svp)
12979 const char *hvname;
12980 bool is_const = !!CvCONST(old_cv);
12981 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12983 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12985 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12987 /* They are 2 constant subroutines generated from
12988 the same constant. This probably means that
12989 they are really the "same" proxy subroutine
12990 instantiated in 2 places. Most likely this is
12991 when a constant is exported twice. Don't warn.
12994 (ckWARN(WARN_REDEFINE)
12996 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12997 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12998 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12999 strEQ(hvname, "autouse"))
13003 && ckWARN_d(WARN_REDEFINE)
13004 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
13007 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
13009 ? "Constant subroutine %"SVf" redefined"
13010 : "Subroutine %"SVf" redefined",
13015 =head1 Hook manipulation
13017 These functions provide convenient and thread-safe means of manipulating
13024 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
13026 Puts a C function into the chain of check functions for a specified op
13027 type. This is the preferred way to manipulate the L</PL_check> array.
13028 I<opcode> specifies which type of op is to be affected. I<new_checker>
13029 is a pointer to the C function that is to be added to that opcode's
13030 check chain, and I<old_checker_p> points to the storage location where a
13031 pointer to the next function in the chain will be stored. The value of
13032 I<new_pointer> is written into the L</PL_check> array, while the value
13033 previously stored there is written to I<*old_checker_p>.
13035 The function should be defined like this:
13037 static OP *new_checker(pTHX_ OP *op) { ... }
13039 It is intended to be called in this manner:
13041 new_checker(aTHX_ op)
13043 I<old_checker_p> should be defined like this:
13045 static Perl_check_t old_checker_p;
13047 L</PL_check> is global to an entire process, and a module wishing to
13048 hook op checking may find itself invoked more than once per process,
13049 typically in different threads. To handle that situation, this function
13050 is idempotent. The location I<*old_checker_p> must initially (once
13051 per process) contain a null pointer. A C variable of static duration
13052 (declared at file scope, typically also marked C<static> to give
13053 it internal linkage) will be implicitly initialised appropriately,
13054 if it does not have an explicit initialiser. This function will only
13055 actually modify the check chain if it finds I<*old_checker_p> to be null.
13056 This function is also thread safe on the small scale. It uses appropriate
13057 locking to avoid race conditions in accessing L</PL_check>.
13059 When this function is called, the function referenced by I<new_checker>
13060 must be ready to be called, except for I<*old_checker_p> being unfilled.
13061 In a threading situation, I<new_checker> may be called immediately,
13062 even before this function has returned. I<*old_checker_p> will always
13063 be appropriately set before I<new_checker> is called. If I<new_checker>
13064 decides not to do anything special with an op that it is given (which
13065 is the usual case for most uses of op check hooking), it must chain the
13066 check function referenced by I<*old_checker_p>.
13068 If you want to influence compilation of calls to a specific subroutine,
13069 then use L</cv_set_call_checker> rather than hooking checking of all
13076 Perl_wrap_op_checker(pTHX_ Optype opcode,
13077 Perl_check_t new_checker, Perl_check_t *old_checker_p)
13081 PERL_UNUSED_CONTEXT;
13082 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
13083 if (*old_checker_p) return;
13084 OP_CHECK_MUTEX_LOCK;
13085 if (!*old_checker_p) {
13086 *old_checker_p = PL_check[opcode];
13087 PL_check[opcode] = new_checker;
13089 OP_CHECK_MUTEX_UNLOCK;
13094 /* Efficient sub that returns a constant scalar value. */
13096 const_sv_xsub(pTHX_ CV* cv)
13099 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
13100 PERL_UNUSED_ARG(items);
13110 const_av_xsub(pTHX_ CV* cv)
13113 AV * const av = MUTABLE_AV(XSANY.any_ptr);
13121 if (SvRMAGICAL(av))
13122 Perl_croak(aTHX_ "Magical list constants are not supported");
13123 if (GIMME_V != G_ARRAY) {
13125 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
13128 EXTEND(SP, AvFILLp(av)+1);
13129 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
13130 XSRETURN(AvFILLp(av)+1);
13135 * c-indentation-style: bsd
13136 * c-basic-offset: 4
13137 * indent-tabs-mode: nil
13140 * ex: set ts=8 sts=4 sw=4 et: