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)
190 /* We only allocate ops from the slab during subroutine compilation.
191 We find the slab via PL_compcv, hence that must be non-NULL. It could
192 also be pointing to a subroutine which is now fully set up (CvROOT()
193 pointing to the top of the optree for that sub), or a subroutine
194 which isn't using the slab allocator. If our sanity checks aren't met,
195 don't use a slab, but allocate the OP directly from the heap. */
196 if (!PL_compcv || CvROOT(PL_compcv)
197 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
198 return PerlMemShared_calloc(1, sz);
200 /* While the subroutine is under construction, the slabs are accessed via
201 CvSTART(), to avoid needing to expand PVCV by one pointer for something
202 unneeded at runtime. Once a subroutine is constructed, the slabs are
203 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
204 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
206 if (!CvSTART(PL_compcv)) {
208 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
209 CvSLABBED_on(PL_compcv);
210 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
212 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
214 opsz = SIZE_TO_PSIZE(sz);
215 sz = opsz + OPSLOT_HEADER_P;
217 /* The slabs maintain a free list of OPs. In particular, constant folding
218 will free up OPs, so it makes sense to re-use them where possible. A
219 freed up slot is used in preference to a new allocation. */
220 if (slab->opslab_freed) {
221 OP **too = &slab->opslab_freed;
223 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
224 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
225 DEBUG_S_warn((aTHX_ "Alas! too small"));
226 o = *(too = &o->op_next);
227 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
231 Zero(o, opsz, I32 *);
237 #define INIT_OPSLOT \
238 slot->opslot_slab = slab; \
239 slot->opslot_next = slab2->opslab_first; \
240 slab2->opslab_first = slot; \
241 o = &slot->opslot_op; \
244 /* The partially-filled slab is next in the chain. */
245 slab2 = slab->opslab_next ? slab->opslab_next : slab;
246 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
247 /* Remaining space is too small. */
249 /* If we can fit a BASEOP, add it to the free chain, so as not
251 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
252 slot = &slab2->opslab_slots;
254 o->op_type = OP_FREED;
255 o->op_next = slab->opslab_freed;
256 slab->opslab_freed = o;
259 /* Create a new slab. Make this one twice as big. */
260 slot = slab2->opslab_first;
261 while (slot->opslot_next) slot = slot->opslot_next;
262 slab2 = S_new_slab(aTHX_
263 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
265 : (DIFF(slab2, slot)+1)*2);
266 slab2->opslab_next = slab->opslab_next;
267 slab->opslab_next = slab2;
269 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
271 /* Create a new op slot */
272 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
273 assert(slot >= &slab2->opslab_slots);
274 if (DIFF(&slab2->opslab_slots, slot)
275 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
276 slot = &slab2->opslab_slots;
278 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
284 #ifdef PERL_DEBUG_READONLY_OPS
286 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
288 PERL_ARGS_ASSERT_SLAB_TO_RO;
290 if (slab->opslab_readonly) return;
291 slab->opslab_readonly = 1;
292 for (; slab; slab = slab->opslab_next) {
293 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
294 (unsigned long) slab->opslab_size, slab));*/
295 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
296 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
297 (unsigned long)slab->opslab_size, errno);
302 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
306 PERL_ARGS_ASSERT_SLAB_TO_RW;
308 if (!slab->opslab_readonly) return;
310 for (; slab2; slab2 = slab2->opslab_next) {
311 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
312 (unsigned long) size, slab2));*/
313 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
314 PROT_READ|PROT_WRITE)) {
315 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
316 (unsigned long)slab2->opslab_size, errno);
319 slab->opslab_readonly = 0;
323 # define Slab_to_rw(op) NOOP
326 /* This cannot possibly be right, but it was copied from the old slab
327 allocator, to which it was originally added, without explanation, in
330 # define PerlMemShared PerlMem
334 Perl_Slab_Free(pTHX_ void *op)
337 OP * const o = (OP *)op;
340 PERL_ARGS_ASSERT_SLAB_FREE;
342 if (!o->op_slabbed) {
344 PerlMemShared_free(op);
349 /* If this op is already freed, our refcount will get screwy. */
350 assert(o->op_type != OP_FREED);
351 o->op_type = OP_FREED;
352 o->op_next = slab->opslab_freed;
353 slab->opslab_freed = o;
354 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
355 OpslabREFCNT_dec_padok(slab);
359 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
362 const bool havepad = !!PL_comppad;
363 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
366 PAD_SAVE_SETNULLPAD();
373 Perl_opslab_free(pTHX_ OPSLAB *slab)
377 PERL_ARGS_ASSERT_OPSLAB_FREE;
379 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
380 assert(slab->opslab_refcnt == 1);
381 for (; slab; slab = slab2) {
382 slab2 = slab->opslab_next;
384 slab->opslab_refcnt = ~(size_t)0;
386 #ifdef PERL_DEBUG_READONLY_OPS
387 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
389 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
390 perror("munmap failed");
394 PerlMemShared_free(slab);
400 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
405 size_t savestack_count = 0;
407 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
410 for (slot = slab2->opslab_first;
412 slot = slot->opslot_next) {
413 if (slot->opslot_op.op_type != OP_FREED
414 && !(slot->opslot_op.op_savefree
420 assert(slot->opslot_op.op_slabbed);
421 op_free(&slot->opslot_op);
422 if (slab->opslab_refcnt == 1) goto free;
425 } while ((slab2 = slab2->opslab_next));
426 /* > 1 because the CV still holds a reference count. */
427 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
429 assert(savestack_count == slab->opslab_refcnt-1);
431 /* Remove the CV’s reference count. */
432 slab->opslab_refcnt--;
439 #ifdef PERL_DEBUG_READONLY_OPS
441 Perl_op_refcnt_inc(pTHX_ OP *o)
444 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
445 if (slab && slab->opslab_readonly) {
458 Perl_op_refcnt_dec(pTHX_ OP *o)
461 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
463 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
465 if (slab && slab->opslab_readonly) {
467 result = --o->op_targ;
470 result = --o->op_targ;
476 * In the following definition, the ", (OP*)0" is just to make the compiler
477 * think the expression is of the right type: croak actually does a Siglongjmp.
479 #define CHECKOP(type,o) \
480 ((PL_op_mask && PL_op_mask[type]) \
481 ? ( op_free((OP*)o), \
482 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
484 : PL_check[type](aTHX_ (OP*)o))
486 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
488 #define CHANGE_TYPE(o,type) \
490 o->op_type = (OPCODE)type; \
491 o->op_ppaddr = PL_ppaddr[type]; \
495 S_gv_ename(pTHX_ GV *gv)
497 SV* const tmpsv = sv_newmortal();
499 PERL_ARGS_ASSERT_GV_ENAME;
501 gv_efullname3(tmpsv, gv, NULL);
506 S_no_fh_allowed(pTHX_ OP *o)
508 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
510 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
516 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
518 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
519 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)),
520 SvUTF8(namesv) | flags);
525 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
527 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
528 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
533 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
535 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
537 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
542 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
544 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
546 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
547 SvUTF8(namesv) | flags);
552 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
554 PERL_ARGS_ASSERT_BAD_TYPE_PV;
556 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
557 (int)n, name, t, OP_DESC(kid)), flags);
561 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
563 SV * const namesv = gv_ename(gv);
564 PERL_ARGS_ASSERT_BAD_TYPE_GV;
566 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
567 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
571 S_no_bareword_allowed(pTHX_ OP *o)
573 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
575 qerror(Perl_mess(aTHX_
576 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
578 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
581 /* "register" allocation */
584 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
588 const bool is_our = (PL_parser->in_my == KEY_our);
590 PERL_ARGS_ASSERT_ALLOCMY;
592 if (flags & ~SVf_UTF8)
593 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
596 /* Until we're using the length for real, cross check that we're being
598 assert(strlen(name) == len);
600 /* complain about "my $<special_var>" etc etc */
604 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
605 (name[1] == '_' && (*name == '$' || len > 2))))
607 /* name[2] is true if strlen(name) > 2 */
608 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
609 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
610 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
611 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
612 PL_parser->in_my == KEY_state ? "state" : "my"));
614 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
615 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
618 else if (len == 2 && name[1] == '_' && !is_our)
619 /* diag_listed_as: Use of my $_ is experimental */
620 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
621 "Use of %s $_ is experimental",
622 PL_parser->in_my == KEY_state
626 /* allocate a spare slot and store the name in that slot */
628 off = pad_add_name_pvn(name, len,
629 (is_our ? padadd_OUR :
630 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
631 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
632 PL_parser->in_my_stash,
634 /* $_ is always in main::, even with our */
635 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
639 /* anon sub prototypes contains state vars should always be cloned,
640 * otherwise the state var would be shared between anon subs */
642 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
643 CvCLONE_on(PL_compcv);
649 =head1 Optree Manipulation Functions
651 =for apidoc alloccopstash
653 Available only under threaded builds, this function allocates an entry in
654 C<PL_stashpad> for the stash passed to it.
661 Perl_alloccopstash(pTHX_ HV *hv)
663 PADOFFSET off = 0, o = 1;
664 bool found_slot = FALSE;
666 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
668 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
670 for (; o < PL_stashpadmax; ++o) {
671 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
672 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
673 found_slot = TRUE, off = o;
676 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
677 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
678 off = PL_stashpadmax;
679 PL_stashpadmax += 10;
682 PL_stashpad[PL_stashpadix = off] = hv;
687 /* free the body of an op without examining its contents.
688 * Always use this rather than FreeOp directly */
691 S_op_destroy(pTHX_ OP *o)
699 =for apidoc Am|void|op_free|OP *o
701 Free an op. Only use this when an op is no longer linked to from any
708 Perl_op_free(pTHX_ OP *o)
713 /* Though ops may be freed twice, freeing the op after its slab is a
715 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
716 /* During the forced freeing of ops after compilation failure, kidops
717 may be freed before their parents. */
718 if (!o || o->op_type == OP_FREED)
722 if (o->op_private & OPpREFCOUNTED) {
733 refcnt = OpREFCNT_dec(o);
736 /* Need to find and remove any pattern match ops from the list
737 we maintain for reset(). */
738 find_and_forget_pmops(o);
748 /* Call the op_free hook if it has been set. Do it now so that it's called
749 * at the right time for refcounted ops, but still before all of the kids
753 if (o->op_flags & OPf_KIDS) {
755 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
756 nextkid = kid->op_sibling; /* Get before next freeing kid */
761 type = (OPCODE)o->op_targ;
764 Slab_to_rw(OpSLAB(o));
766 /* COP* is not cleared by op_clear() so that we may track line
767 * numbers etc even after null() */
768 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
774 #ifdef DEBUG_LEAKING_SCALARS
781 Perl_op_clear(pTHX_ OP *o)
786 PERL_ARGS_ASSERT_OP_CLEAR;
788 switch (o->op_type) {
789 case OP_NULL: /* Was holding old type, if any. */
792 case OP_ENTEREVAL: /* Was holding hints. */
796 if (!(o->op_flags & OPf_REF)
797 || (PL_check[o->op_type] != Perl_ck_ftst))
804 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
809 /* It's possible during global destruction that the GV is freed
810 before the optree. Whilst the SvREFCNT_inc is happy to bump from
811 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
812 will trigger an assertion failure, because the entry to sv_clear
813 checks that the scalar is not already freed. A check of for
814 !SvIS_FREED(gv) turns out to be invalid, because during global
815 destruction the reference count can be forced down to zero
816 (with SVf_BREAK set). In which case raising to 1 and then
817 dropping to 0 triggers cleanup before it should happen. I
818 *think* that this might actually be a general, systematic,
819 weakness of the whole idea of SVf_BREAK, in that code *is*
820 allowed to raise and lower references during global destruction,
821 so any *valid* code that happens to do this during global
822 destruction might well trigger premature cleanup. */
823 bool still_valid = gv && SvREFCNT(gv);
826 SvREFCNT_inc_simple_void(gv);
828 if (cPADOPo->op_padix > 0) {
829 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
830 * may still exist on the pad */
831 pad_swipe(cPADOPo->op_padix, TRUE);
832 cPADOPo->op_padix = 0;
835 SvREFCNT_dec(cSVOPo->op_sv);
836 cSVOPo->op_sv = NULL;
839 int try_downgrade = SvREFCNT(gv) == 2;
842 gv_try_downgrade(gv);
846 case OP_METHOD_NAMED:
849 SvREFCNT_dec(cSVOPo->op_sv);
850 cSVOPo->op_sv = NULL;
853 Even if op_clear does a pad_free for the target of the op,
854 pad_free doesn't actually remove the sv that exists in the pad;
855 instead it lives on. This results in that it could be reused as
856 a target later on when the pad was reallocated.
859 pad_swipe(o->op_targ,1);
869 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
874 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
875 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
877 if (cPADOPo->op_padix > 0) {
878 pad_swipe(cPADOPo->op_padix, TRUE);
879 cPADOPo->op_padix = 0;
882 SvREFCNT_dec(cSVOPo->op_sv);
883 cSVOPo->op_sv = NULL;
887 PerlMemShared_free(cPVOPo->op_pv);
888 cPVOPo->op_pv = NULL;
892 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
896 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
897 /* No GvIN_PAD_off here, because other references may still
898 * exist on the pad */
899 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
902 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
908 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
909 op_free(cPMOPo->op_code_list);
910 cPMOPo->op_code_list = NULL;
912 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
913 /* we use the same protection as the "SAFE" version of the PM_ macros
914 * here since sv_clean_all might release some PMOPs
915 * after PL_regex_padav has been cleared
916 * and the clearing of PL_regex_padav needs to
917 * happen before sv_clean_all
920 if(PL_regex_pad) { /* We could be in destruction */
921 const IV offset = (cPMOPo)->op_pmoffset;
922 ReREFCNT_dec(PM_GETRE(cPMOPo));
923 PL_regex_pad[offset] = &PL_sv_undef;
924 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
928 ReREFCNT_dec(PM_GETRE(cPMOPo));
929 PM_SETRE(cPMOPo, NULL);
935 if (o->op_targ > 0) {
936 pad_free(o->op_targ);
942 S_cop_free(pTHX_ COP* cop)
944 PERL_ARGS_ASSERT_COP_FREE;
947 if (! specialWARN(cop->cop_warnings))
948 PerlMemShared_free(cop->cop_warnings);
949 cophh_free(CopHINTHASH_get(cop));
950 if (PL_curcop == cop)
955 S_forget_pmop(pTHX_ PMOP *const o
958 HV * const pmstash = PmopSTASH(o);
960 PERL_ARGS_ASSERT_FORGET_PMOP;
962 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
963 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
965 PMOP **const array = (PMOP**) mg->mg_ptr;
966 U32 count = mg->mg_len / sizeof(PMOP**);
971 /* Found it. Move the entry at the end to overwrite it. */
972 array[i] = array[--count];
973 mg->mg_len = count * sizeof(PMOP**);
974 /* Could realloc smaller at this point always, but probably
975 not worth it. Probably worth free()ing if we're the
978 Safefree(mg->mg_ptr);
991 S_find_and_forget_pmops(pTHX_ OP *o)
993 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
995 if (o->op_flags & OPf_KIDS) {
996 OP *kid = cUNOPo->op_first;
998 switch (kid->op_type) {
1003 forget_pmop((PMOP*)kid);
1005 find_and_forget_pmops(kid);
1006 kid = kid->op_sibling;
1012 =for apidoc Am|void|op_null|OP *o
1014 Neutralizes an op when it is no longer needed, but is still linked to from
1021 Perl_op_null(pTHX_ OP *o)
1025 PERL_ARGS_ASSERT_OP_NULL;
1027 if (o->op_type == OP_NULL)
1030 o->op_targ = o->op_type;
1031 o->op_type = OP_NULL;
1032 o->op_ppaddr = PL_ppaddr[OP_NULL];
1036 Perl_op_refcnt_lock(pTHX)
1039 PERL_UNUSED_CONTEXT;
1044 Perl_op_refcnt_unlock(pTHX)
1047 PERL_UNUSED_CONTEXT;
1051 /* Contextualizers */
1054 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1056 Applies a syntactic context to an op tree representing an expression.
1057 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1058 or C<G_VOID> to specify the context to apply. The modified op tree
1065 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1067 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1069 case G_SCALAR: return scalar(o);
1070 case G_ARRAY: return list(o);
1071 case G_VOID: return scalarvoid(o);
1073 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1080 =for apidoc Am|OP*|op_linklist|OP *o
1081 This function is the implementation of the L</LINKLIST> macro. It should
1082 not be called directly.
1088 Perl_op_linklist(pTHX_ OP *o)
1092 PERL_ARGS_ASSERT_OP_LINKLIST;
1097 /* establish postfix order */
1098 first = cUNOPo->op_first;
1101 o->op_next = LINKLIST(first);
1104 if (kid->op_sibling) {
1105 kid->op_next = LINKLIST(kid->op_sibling);
1106 kid = kid->op_sibling;
1120 S_scalarkids(pTHX_ OP *o)
1122 if (o && o->op_flags & OPf_KIDS) {
1124 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1131 S_scalarboolean(pTHX_ OP *o)
1135 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1137 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1138 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1139 if (ckWARN(WARN_SYNTAX)) {
1140 const line_t oldline = CopLINE(PL_curcop);
1142 if (PL_parser && PL_parser->copline != NOLINE) {
1143 /* This ensures that warnings are reported at the first line
1144 of the conditional, not the last. */
1145 CopLINE_set(PL_curcop, PL_parser->copline);
1147 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1148 CopLINE_set(PL_curcop, oldline);
1155 S_op_varname(pTHX_ const OP *o)
1158 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1159 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1161 const char funny = o->op_type == OP_PADAV
1162 || o->op_type == OP_RV2AV ? '@' : '%';
1163 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1165 if (cUNOPo->op_first->op_type != OP_GV
1166 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1168 return varname(gv, funny, 0, NULL, 0, 1);
1171 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1176 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1177 { /* or not so pretty :-) */
1178 if (o->op_type == OP_CONST) {
1180 if (SvPOK(*retsv)) {
1182 *retsv = sv_newmortal();
1183 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1184 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1186 else if (!SvOK(*retsv))
1189 else *retpv = "...";
1193 S_scalar_slice_warning(pTHX_ const OP *o)
1197 o->op_type == OP_HSLICE ? '{' : '[';
1199 o->op_type == OP_HSLICE ? '}' : ']';
1201 SV *keysv = NULL; /* just to silence compiler warnings */
1202 const char *key = NULL;
1204 if (!(o->op_private & OPpSLICEWARNING))
1206 if (PL_parser && PL_parser->error_count)
1207 /* This warning can be nonsensical when there is a syntax error. */
1210 kid = cLISTOPo->op_first;
1211 kid = kid->op_sibling; /* get past pushmark */
1212 /* weed out false positives: any ops that can return lists */
1213 switch (kid->op_type) {
1242 /* Don't warn if we have a nulled list either. */
1243 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1246 assert(kid->op_sibling);
1247 name = S_op_varname(aTHX_ kid->op_sibling);
1248 if (!name) /* XS module fiddling with the op tree */
1250 S_op_pretty(aTHX_ kid, &keysv, &key);
1251 assert(SvPOK(name));
1252 sv_chop(name,SvPVX(name)+1);
1254 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1255 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1256 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1258 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1259 lbrack, key, rbrack);
1261 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1262 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1263 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1265 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1266 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1270 Perl_scalar(pTHX_ OP *o)
1275 /* assumes no premature commitment */
1276 if (!o || (PL_parser && PL_parser->error_count)
1277 || (o->op_flags & OPf_WANT)
1278 || o->op_type == OP_RETURN)
1283 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1285 switch (o->op_type) {
1287 scalar(cBINOPo->op_first);
1292 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1302 if (o->op_flags & OPf_KIDS) {
1303 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1309 kid = cLISTOPo->op_first;
1311 kid = kid->op_sibling;
1314 OP *sib = kid->op_sibling;
1315 if (sib && kid->op_type != OP_LEAVEWHEN)
1321 PL_curcop = &PL_compiling;
1326 kid = cLISTOPo->op_first;
1329 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1334 /* Warn about scalar context */
1335 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1336 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1339 const char *key = NULL;
1341 /* This warning can be nonsensical when there is a syntax error. */
1342 if (PL_parser && PL_parser->error_count)
1345 if (!ckWARN(WARN_SYNTAX)) break;
1347 kid = cLISTOPo->op_first;
1348 kid = kid->op_sibling; /* get past pushmark */
1349 assert(kid->op_sibling);
1350 name = S_op_varname(aTHX_ kid->op_sibling);
1351 if (!name) /* XS module fiddling with the op tree */
1353 S_op_pretty(aTHX_ kid, &keysv, &key);
1354 assert(SvPOK(name));
1355 sv_chop(name,SvPVX(name)+1);
1357 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1358 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1359 "%%%"SVf"%c%s%c in scalar context better written "
1361 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1362 lbrack, key, rbrack);
1364 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1365 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1366 "%%%"SVf"%c%"SVf"%c in scalar context better "
1367 "written as $%"SVf"%c%"SVf"%c",
1368 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1369 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1376 Perl_scalarvoid(pTHX_ OP *o)
1380 SV *useless_sv = NULL;
1381 const char* useless = NULL;
1385 PERL_ARGS_ASSERT_SCALARVOID;
1387 if (o->op_type == OP_NEXTSTATE
1388 || o->op_type == OP_DBSTATE
1389 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1390 || o->op_targ == OP_DBSTATE)))
1391 PL_curcop = (COP*)o; /* for warning below */
1393 /* assumes no premature commitment */
1394 want = o->op_flags & OPf_WANT;
1395 if ((want && want != OPf_WANT_SCALAR)
1396 || (PL_parser && PL_parser->error_count)
1397 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1402 if ((o->op_private & OPpTARGET_MY)
1403 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1405 return scalar(o); /* As if inside SASSIGN */
1408 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1410 switch (o->op_type) {
1412 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1416 if (o->op_flags & OPf_STACKED)
1420 if (o->op_private == 4)
1445 case OP_AELEMFAST_LEX:
1466 case OP_GETSOCKNAME:
1467 case OP_GETPEERNAME:
1472 case OP_GETPRIORITY:
1497 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1498 /* Otherwise it's "Useless use of grep iterator" */
1499 useless = OP_DESC(o);
1503 kid = cLISTOPo->op_first;
1504 if (kid && kid->op_type == OP_PUSHRE
1506 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1508 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1510 useless = OP_DESC(o);
1514 kid = cUNOPo->op_first;
1515 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1516 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1519 useless = "negative pattern binding (!~)";
1523 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1524 useless = "non-destructive substitution (s///r)";
1528 useless = "non-destructive transliteration (tr///r)";
1535 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1536 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1537 useless = "a variable";
1542 if (cSVOPo->op_private & OPpCONST_STRICT)
1543 no_bareword_allowed(o);
1545 if (ckWARN(WARN_VOID)) {
1546 /* don't warn on optimised away booleans, eg
1547 * use constant Foo, 5; Foo || print; */
1548 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1550 /* the constants 0 and 1 are permitted as they are
1551 conventionally used as dummies in constructs like
1552 1 while some_condition_with_side_effects; */
1553 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1555 else if (SvPOK(sv)) {
1556 SV * const dsv = newSVpvs("");
1558 = Perl_newSVpvf(aTHX_
1560 pv_pretty(dsv, SvPVX_const(sv),
1561 SvCUR(sv), 32, NULL, NULL,
1563 | PERL_PV_ESCAPE_NOCLEAR
1564 | PERL_PV_ESCAPE_UNI_DETECT));
1565 SvREFCNT_dec_NN(dsv);
1567 else if (SvOK(sv)) {
1568 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1571 useless = "a constant (undef)";
1574 op_null(o); /* don't execute or even remember it */
1578 o->op_type = OP_PREINC; /* pre-increment is faster */
1579 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1583 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1584 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1588 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1589 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1593 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1594 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1599 UNOP *refgen, *rv2cv;
1602 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1605 rv2gv = ((BINOP *)o)->op_last;
1606 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1609 refgen = (UNOP *)((BINOP *)o)->op_first;
1611 if (!refgen || refgen->op_type != OP_REFGEN)
1614 exlist = (LISTOP *)refgen->op_first;
1615 if (!exlist || exlist->op_type != OP_NULL
1616 || exlist->op_targ != OP_LIST)
1619 if (exlist->op_first->op_type != OP_PUSHMARK)
1622 rv2cv = (UNOP*)exlist->op_last;
1624 if (rv2cv->op_type != OP_RV2CV)
1627 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1628 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1629 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1631 o->op_private |= OPpASSIGN_CV_TO_GV;
1632 rv2gv->op_private |= OPpDONT_INIT_GV;
1633 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1645 kid = cLOGOPo->op_first;
1646 if (kid->op_type == OP_NOT
1647 && (kid->op_flags & OPf_KIDS)) {
1648 if (o->op_type == OP_AND) {
1650 o->op_ppaddr = PL_ppaddr[OP_OR];
1652 o->op_type = OP_AND;
1653 o->op_ppaddr = PL_ppaddr[OP_AND];
1663 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1668 if (o->op_flags & OPf_STACKED)
1675 if (!(o->op_flags & OPf_KIDS))
1686 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1697 /* mortalise it, in case warnings are fatal. */
1698 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1699 "Useless use of %"SVf" in void context",
1700 SVfARG(sv_2mortal(useless_sv)));
1703 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1704 "Useless use of %s in void context",
1711 S_listkids(pTHX_ OP *o)
1713 if (o && o->op_flags & OPf_KIDS) {
1715 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1722 Perl_list(pTHX_ OP *o)
1727 /* assumes no premature commitment */
1728 if (!o || (o->op_flags & OPf_WANT)
1729 || (PL_parser && PL_parser->error_count)
1730 || o->op_type == OP_RETURN)
1735 if ((o->op_private & OPpTARGET_MY)
1736 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1738 return o; /* As if inside SASSIGN */
1741 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1743 switch (o->op_type) {
1746 list(cBINOPo->op_first);
1751 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1759 if (!(o->op_flags & OPf_KIDS))
1761 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1762 list(cBINOPo->op_first);
1763 return gen_constant_list(o);
1770 kid = cLISTOPo->op_first;
1772 kid = kid->op_sibling;
1775 OP *sib = kid->op_sibling;
1776 if (sib && kid->op_type != OP_LEAVEWHEN)
1782 PL_curcop = &PL_compiling;
1786 kid = cLISTOPo->op_first;
1793 S_scalarseq(pTHX_ OP *o)
1797 const OPCODE type = o->op_type;
1799 if (type == OP_LINESEQ || type == OP_SCOPE ||
1800 type == OP_LEAVE || type == OP_LEAVETRY)
1803 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1804 if (kid->op_sibling) {
1808 PL_curcop = &PL_compiling;
1810 o->op_flags &= ~OPf_PARENS;
1811 if (PL_hints & HINT_BLOCK_SCOPE)
1812 o->op_flags |= OPf_PARENS;
1815 o = newOP(OP_STUB, 0);
1820 S_modkids(pTHX_ OP *o, I32 type)
1822 if (o && o->op_flags & OPf_KIDS) {
1824 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1825 op_lvalue(kid, type);
1831 =for apidoc finalize_optree
1833 This function finalizes the optree. Should be called directly after
1834 the complete optree is built. It does some additional
1835 checking which can't be done in the normal ck_xxx functions and makes
1836 the tree thread-safe.
1841 Perl_finalize_optree(pTHX_ OP* o)
1843 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1846 SAVEVPTR(PL_curcop);
1854 S_finalize_op(pTHX_ OP* o)
1856 PERL_ARGS_ASSERT_FINALIZE_OP;
1859 switch (o->op_type) {
1862 PL_curcop = ((COP*)o); /* for warnings */
1866 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1867 && ckWARN(WARN_EXEC))
1869 if (o->op_sibling->op_sibling) {
1870 const OPCODE type = o->op_sibling->op_sibling->op_type;
1871 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1872 const line_t oldline = CopLINE(PL_curcop);
1873 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1874 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1875 "Statement unlikely to be reached");
1876 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1877 "\t(Maybe you meant system() when you said exec()?)\n");
1878 CopLINE_set(PL_curcop, oldline);
1885 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1886 GV * const gv = cGVOPo_gv;
1887 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1888 /* XXX could check prototype here instead of just carping */
1889 SV * const sv = sv_newmortal();
1890 gv_efullname3(sv, gv, NULL);
1891 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1892 "%"SVf"() called too early to check prototype",
1899 if (cSVOPo->op_private & OPpCONST_STRICT)
1900 no_bareword_allowed(o);
1904 case OP_METHOD_NAMED:
1905 /* Relocate sv to the pad for thread safety.
1906 * Despite being a "constant", the SV is written to,
1907 * for reference counts, sv_upgrade() etc. */
1908 if (cSVOPo->op_sv) {
1909 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1910 SvREFCNT_dec(PAD_SVl(ix));
1911 PAD_SETSV(ix, cSVOPo->op_sv);
1912 /* XXX I don't know how this isn't readonly already. */
1913 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1914 cSVOPo->op_sv = NULL;
1928 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
1931 rop = (UNOP*)((BINOP*)o)->op_first;
1936 S_scalar_slice_warning(aTHX_ o);
1940 kid = cLISTOPo->op_first->op_sibling;
1941 if (/* I bet there's always a pushmark... */
1942 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
1943 && OP_TYPE_ISNT_NN(kid, OP_CONST))
1948 key_op = (SVOP*)(kid->op_type == OP_CONST
1950 : kLISTOP->op_first->op_sibling);
1952 rop = (UNOP*)((LISTOP*)o)->op_last;
1955 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
1957 else if (rop->op_first->op_type == OP_PADSV)
1958 /* @$hash{qw(keys here)} */
1959 rop = (UNOP*)rop->op_first;
1961 /* @{$hash}{qw(keys here)} */
1962 if (rop->op_first->op_type == OP_SCOPE
1963 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1965 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1971 lexname = NULL; /* just to silence compiler warnings */
1972 fields = NULL; /* just to silence compiler warnings */
1976 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
1977 SvPAD_TYPED(lexname))
1978 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
1979 && isGV(*fields) && GvHV(*fields);
1981 key_op = (SVOP*)key_op->op_sibling) {
1983 if (key_op->op_type != OP_CONST)
1985 svp = cSVOPx_svp(key_op);
1987 /* Make the CONST have a shared SV */
1988 if ((!SvIsCOW_shared_hash(sv = *svp))
1989 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
1991 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
1992 SV *nsv = newSVpvn_share(key,
1993 SvUTF8(sv) ? -keylen : keylen, 0);
1994 SvREFCNT_dec_NN(sv);
1999 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2000 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2001 "in variable %"SVf" of type %"HEKf,
2002 SVfARG(*svp), SVfARG(lexname),
2003 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2009 S_scalar_slice_warning(aTHX_ o);
2013 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2014 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2021 if (o->op_flags & OPf_KIDS) {
2023 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2029 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2031 Propagate lvalue ("modifiable") context to an op and its children.
2032 I<type> represents the context type, roughly based on the type of op that
2033 would do the modifying, although C<local()> is represented by OP_NULL,
2034 because it has no op type of its own (it is signalled by a flag on
2037 This function detects things that can't be modified, such as C<$x+1>, and
2038 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2039 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2041 It also flags things that need to behave specially in an lvalue context,
2042 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2048 S_vivifies(const OPCODE type)
2051 case OP_RV2AV: case OP_ASLICE:
2052 case OP_RV2HV: case OP_KVASLICE:
2053 case OP_RV2SV: case OP_HSLICE:
2054 case OP_AELEMFAST: case OP_KVHSLICE:
2063 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2067 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2070 if (!o || (PL_parser && PL_parser->error_count))
2073 if ((o->op_private & OPpTARGET_MY)
2074 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2079 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2081 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2083 switch (o->op_type) {
2088 if ((o->op_flags & OPf_PARENS))
2092 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2093 !(o->op_flags & OPf_STACKED)) {
2094 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2095 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2096 poses, so we need it clear. */
2097 o->op_private &= ~1;
2098 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2099 assert(cUNOPo->op_first->op_type == OP_NULL);
2100 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2103 else { /* lvalue subroutine call */
2104 o->op_private |= OPpLVAL_INTRO
2105 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2106 PL_modcount = RETURN_UNLIMITED_NUMBER;
2107 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2108 /* Potential lvalue context: */
2109 o->op_private |= OPpENTERSUB_INARGS;
2112 else { /* Compile-time error message: */
2113 OP *kid = cUNOPo->op_first;
2116 if (kid->op_type != OP_PUSHMARK) {
2117 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2119 "panic: unexpected lvalue entersub "
2120 "args: type/targ %ld:%"UVuf,
2121 (long)kid->op_type, (UV)kid->op_targ);
2122 kid = kLISTOP->op_first;
2124 while (kid->op_sibling)
2125 kid = kid->op_sibling;
2126 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2127 break; /* Postpone until runtime */
2130 kid = kUNOP->op_first;
2131 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2132 kid = kUNOP->op_first;
2133 if (kid->op_type == OP_NULL)
2135 "Unexpected constant lvalue entersub "
2136 "entry via type/targ %ld:%"UVuf,
2137 (long)kid->op_type, (UV)kid->op_targ);
2138 if (kid->op_type != OP_GV) {
2142 cv = GvCV(kGVOP_gv);
2152 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2153 /* grep, foreach, subcalls, refgen */
2154 if (type == OP_GREPSTART || type == OP_ENTERSUB
2155 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2157 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2158 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2160 : (o->op_type == OP_ENTERSUB
2161 ? "non-lvalue subroutine call"
2163 type ? PL_op_desc[type] : "local"));
2177 case OP_RIGHT_SHIFT:
2186 if (!(o->op_flags & OPf_STACKED))
2193 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2194 op_lvalue(kid, type);
2199 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2200 PL_modcount = RETURN_UNLIMITED_NUMBER;
2201 return o; /* Treat \(@foo) like ordinary list. */
2205 if (scalar_mod_type(o, type))
2207 ref(cUNOPo->op_first, o->op_type);
2214 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2215 if (type == OP_LEAVESUBLV && (
2216 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2217 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2219 o->op_private |= OPpMAYBE_LVSUB;
2223 PL_modcount = RETURN_UNLIMITED_NUMBER;
2227 if (type == OP_LEAVESUBLV)
2228 o->op_private |= OPpMAYBE_LVSUB;
2231 PL_hints |= HINT_BLOCK_SCOPE;
2232 if (type == OP_LEAVESUBLV)
2233 o->op_private |= OPpMAYBE_LVSUB;
2237 ref(cUNOPo->op_first, o->op_type);
2241 PL_hints |= HINT_BLOCK_SCOPE;
2251 case OP_AELEMFAST_LEX:
2258 PL_modcount = RETURN_UNLIMITED_NUMBER;
2259 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2260 return o; /* Treat \(@foo) like ordinary list. */
2261 if (scalar_mod_type(o, type))
2263 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2264 && type == OP_LEAVESUBLV)
2265 o->op_private |= OPpMAYBE_LVSUB;
2269 if (!type) /* local() */
2270 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2271 PAD_COMPNAME_SV(o->op_targ));
2280 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2284 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2290 if (type == OP_LEAVESUBLV)
2291 o->op_private |= OPpMAYBE_LVSUB;
2292 if (o->op_flags & OPf_KIDS)
2293 op_lvalue(cBINOPo->op_first->op_sibling, type);
2298 ref(cBINOPo->op_first, o->op_type);
2299 if (type == OP_ENTERSUB &&
2300 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2301 o->op_private |= OPpLVAL_DEFER;
2302 if (type == OP_LEAVESUBLV)
2303 o->op_private |= OPpMAYBE_LVSUB;
2310 o->op_private |= OPpLVALUE;
2316 if (o->op_flags & OPf_KIDS)
2317 op_lvalue(cLISTOPo->op_last, type);
2322 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2324 else if (!(o->op_flags & OPf_KIDS))
2326 if (o->op_targ != OP_LIST) {
2327 op_lvalue(cBINOPo->op_first, type);
2333 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2334 /* elements might be in void context because the list is
2335 in scalar context or because they are attribute sub calls */
2336 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2337 op_lvalue(kid, type);
2341 if (type != OP_LEAVESUBLV)
2343 break; /* op_lvalue()ing was handled by ck_return() */
2350 if (type == OP_LEAVESUBLV
2351 || !S_vivifies(cLOGOPo->op_first->op_type))
2352 op_lvalue(cLOGOPo->op_first, type);
2353 if (type == OP_LEAVESUBLV
2354 || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type))
2355 op_lvalue(cLOGOPo->op_first->op_sibling, type);
2359 /* [20011101.069] File test operators interpret OPf_REF to mean that
2360 their argument is a filehandle; thus \stat(".") should not set
2362 if (type == OP_REFGEN &&
2363 PL_check[o->op_type] == Perl_ck_ftst)
2366 if (type != OP_LEAVESUBLV)
2367 o->op_flags |= OPf_MOD;
2369 if (type == OP_AASSIGN || type == OP_SASSIGN)
2370 o->op_flags |= OPf_SPECIAL|OPf_REF;
2371 else if (!type) { /* local() */
2374 o->op_private |= OPpLVAL_INTRO;
2375 o->op_flags &= ~OPf_SPECIAL;
2376 PL_hints |= HINT_BLOCK_SCOPE;
2381 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2382 "Useless localization of %s", OP_DESC(o));
2385 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2386 && type != OP_LEAVESUBLV)
2387 o->op_flags |= OPf_REF;
2392 S_scalar_mod_type(const OP *o, I32 type)
2397 if (o && o->op_type == OP_RV2GV)
2421 case OP_RIGHT_SHIFT:
2442 S_is_handle_constructor(const OP *o, I32 numargs)
2444 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2446 switch (o->op_type) {
2454 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2467 S_refkids(pTHX_ OP *o, I32 type)
2469 if (o && o->op_flags & OPf_KIDS) {
2471 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2478 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2483 PERL_ARGS_ASSERT_DOREF;
2485 if (!o || (PL_parser && PL_parser->error_count))
2488 switch (o->op_type) {
2490 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2491 !(o->op_flags & OPf_STACKED)) {
2492 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2493 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2494 assert(cUNOPo->op_first->op_type == OP_NULL);
2495 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2496 o->op_flags |= OPf_SPECIAL;
2497 o->op_private &= ~1;
2499 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2500 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2501 : type == OP_RV2HV ? OPpDEREF_HV
2503 o->op_flags |= OPf_MOD;
2509 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2510 doref(kid, type, set_op_ref);
2513 if (type == OP_DEFINED)
2514 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2515 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2518 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2519 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2520 : type == OP_RV2HV ? OPpDEREF_HV
2522 o->op_flags |= OPf_MOD;
2529 o->op_flags |= OPf_REF;
2532 if (type == OP_DEFINED)
2533 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2534 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2540 o->op_flags |= OPf_REF;
2545 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2547 doref(cBINOPo->op_first, type, set_op_ref);
2551 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2552 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2553 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2554 : type == OP_RV2HV ? OPpDEREF_HV
2556 o->op_flags |= OPf_MOD;
2566 if (!(o->op_flags & OPf_KIDS))
2568 doref(cLISTOPo->op_last, type, set_op_ref);
2578 S_dup_attrlist(pTHX_ OP *o)
2583 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2585 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2586 * where the first kid is OP_PUSHMARK and the remaining ones
2587 * are OP_CONST. We need to push the OP_CONST values.
2589 if (o->op_type == OP_CONST)
2590 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2592 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2594 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2595 if (o->op_type == OP_CONST)
2596 rop = op_append_elem(OP_LIST, rop,
2597 newSVOP(OP_CONST, o->op_flags,
2598 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2605 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2608 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2610 PERL_ARGS_ASSERT_APPLY_ATTRS;
2612 /* fake up C<use attributes $pkg,$rv,@attrs> */
2614 #define ATTRSMODULE "attributes"
2615 #define ATTRSMODULE_PM "attributes.pm"
2617 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2618 newSVpvs(ATTRSMODULE),
2620 op_prepend_elem(OP_LIST,
2621 newSVOP(OP_CONST, 0, stashsv),
2622 op_prepend_elem(OP_LIST,
2623 newSVOP(OP_CONST, 0,
2625 dup_attrlist(attrs))));
2629 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2632 OP *pack, *imop, *arg;
2633 SV *meth, *stashsv, **svp;
2635 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2640 assert(target->op_type == OP_PADSV ||
2641 target->op_type == OP_PADHV ||
2642 target->op_type == OP_PADAV);
2644 /* Ensure that attributes.pm is loaded. */
2645 /* Don't force the C<use> if we don't need it. */
2646 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2647 if (svp && *svp != &PL_sv_undef)
2648 NOOP; /* already in %INC */
2650 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2651 newSVpvs(ATTRSMODULE), NULL);
2653 /* Need package name for method call. */
2654 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2656 /* Build up the real arg-list. */
2657 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2659 arg = newOP(OP_PADSV, 0);
2660 arg->op_targ = target->op_targ;
2661 arg = op_prepend_elem(OP_LIST,
2662 newSVOP(OP_CONST, 0, stashsv),
2663 op_prepend_elem(OP_LIST,
2664 newUNOP(OP_REFGEN, 0,
2665 op_lvalue(arg, OP_REFGEN)),
2666 dup_attrlist(attrs)));
2668 /* Fake up a method call to import */
2669 meth = newSVpvs_share("import");
2670 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2671 op_append_elem(OP_LIST,
2672 op_prepend_elem(OP_LIST, pack, list(arg)),
2673 newSVOP(OP_METHOD_NAMED, 0, meth)));
2675 /* Combine the ops. */
2676 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2680 =notfor apidoc apply_attrs_string
2682 Attempts to apply a list of attributes specified by the C<attrstr> and
2683 C<len> arguments to the subroutine identified by the C<cv> argument which
2684 is expected to be associated with the package identified by the C<stashpv>
2685 argument (see L<attributes>). It gets this wrong, though, in that it
2686 does not correctly identify the boundaries of the individual attribute
2687 specifications within C<attrstr>. This is not really intended for the
2688 public API, but has to be listed here for systems such as AIX which
2689 need an explicit export list for symbols. (It's called from XS code
2690 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2691 to respect attribute syntax properly would be welcome.
2697 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2698 const char *attrstr, STRLEN len)
2702 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2705 len = strlen(attrstr);
2709 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2711 const char * const sstr = attrstr;
2712 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2713 attrs = op_append_elem(OP_LIST, attrs,
2714 newSVOP(OP_CONST, 0,
2715 newSVpvn(sstr, attrstr-sstr)));
2719 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2720 newSVpvs(ATTRSMODULE),
2721 NULL, op_prepend_elem(OP_LIST,
2722 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2723 op_prepend_elem(OP_LIST,
2724 newSVOP(OP_CONST, 0,
2725 newRV(MUTABLE_SV(cv))),
2730 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2732 OP *new_proto = NULL;
2737 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2743 if (o->op_type == OP_CONST) {
2744 pv = SvPV(cSVOPo_sv, pvlen);
2745 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2746 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2747 SV ** const tmpo = cSVOPx_svp(o);
2748 SvREFCNT_dec(cSVOPo_sv);
2753 } else if (o->op_type == OP_LIST) {
2755 assert(o->op_flags & OPf_KIDS);
2756 assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
2757 /* Counting on the first op to hit the lasto = o line */
2758 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2759 if (o->op_type == OP_CONST) {
2760 pv = SvPV(cSVOPo_sv, pvlen);
2761 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2762 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2763 SV ** const tmpo = cSVOPx_svp(o);
2764 SvREFCNT_dec(cSVOPo_sv);
2766 if (new_proto && ckWARN(WARN_MISC)) {
2768 const char * newp = SvPV(cSVOPo_sv, new_len);
2769 Perl_warner(aTHX_ packWARN(WARN_MISC),
2770 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2771 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2777 lasto->op_sibling = o->op_sibling;
2783 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2784 would get pulled in with no real need */
2785 if (!cLISTOPx(*attrs)->op_first->op_sibling) {
2794 svname = sv_newmortal();
2795 gv_efullname3(svname, name, NULL);
2797 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2798 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2800 svname = (SV *)name;
2801 if (ckWARN(WARN_ILLEGALPROTO))
2802 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
2803 if (*proto && ckWARN(WARN_PROTOTYPE)) {
2804 STRLEN old_len, new_len;
2805 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
2806 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
2808 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2809 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
2811 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
2812 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
2822 S_cant_declare(pTHX_ OP *o)
2824 if (o->op_type == OP_NULL
2825 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
2826 o = cUNOPo->op_first;
2827 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2828 o->op_type == OP_NULL
2829 && o->op_flags & OPf_SPECIAL
2832 PL_parser->in_my == KEY_our ? "our" :
2833 PL_parser->in_my == KEY_state ? "state" :
2838 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2842 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2844 PERL_ARGS_ASSERT_MY_KID;
2846 if (!o || (PL_parser && PL_parser->error_count))
2851 if (type == OP_LIST) {
2853 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2854 my_kid(kid, attrs, imopsp);
2856 } else if (type == OP_UNDEF || type == OP_STUB) {
2858 } else if (type == OP_RV2SV || /* "our" declaration */
2860 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2861 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2862 S_cant_declare(aTHX_ o);
2864 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2866 PL_parser->in_my = FALSE;
2867 PL_parser->in_my_stash = NULL;
2868 apply_attrs(GvSTASH(gv),
2869 (type == OP_RV2SV ? GvSV(gv) :
2870 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2871 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2874 o->op_private |= OPpOUR_INTRO;
2877 else if (type != OP_PADSV &&
2880 type != OP_PUSHMARK)
2882 S_cant_declare(aTHX_ o);
2885 else if (attrs && type != OP_PUSHMARK) {
2889 PL_parser->in_my = FALSE;
2890 PL_parser->in_my_stash = NULL;
2892 /* check for C<my Dog $spot> when deciding package */
2893 stash = PAD_COMPNAME_TYPE(o->op_targ);
2895 stash = PL_curstash;
2896 apply_attrs_my(stash, o, attrs, imopsp);
2898 o->op_flags |= OPf_MOD;
2899 o->op_private |= OPpLVAL_INTRO;
2901 o->op_private |= OPpPAD_STATE;
2906 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2910 int maybe_scalar = 0;
2912 PERL_ARGS_ASSERT_MY_ATTRS;
2914 /* [perl #17376]: this appears to be premature, and results in code such as
2915 C< our(%x); > executing in list mode rather than void mode */
2917 if (o->op_flags & OPf_PARENS)
2927 o = my_kid(o, attrs, &rops);
2929 if (maybe_scalar && o->op_type == OP_PADSV) {
2930 o = scalar(op_append_list(OP_LIST, rops, o));
2931 o->op_private |= OPpLVAL_INTRO;
2934 /* The listop in rops might have a pushmark at the beginning,
2935 which will mess up list assignment. */
2936 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2937 if (rops->op_type == OP_LIST &&
2938 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2940 OP * const pushmark = lrops->op_first;
2941 lrops->op_first = pushmark->op_sibling;
2944 o = op_append_list(OP_LIST, o, rops);
2947 PL_parser->in_my = FALSE;
2948 PL_parser->in_my_stash = NULL;
2953 Perl_sawparens(pTHX_ OP *o)
2955 PERL_UNUSED_CONTEXT;
2957 o->op_flags |= OPf_PARENS;
2962 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2966 const OPCODE ltype = left->op_type;
2967 const OPCODE rtype = right->op_type;
2969 PERL_ARGS_ASSERT_BIND_MATCH;
2971 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2972 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2974 const char * const desc
2976 rtype == OP_SUBST || rtype == OP_TRANS
2977 || rtype == OP_TRANSR
2979 ? (int)rtype : OP_MATCH];
2980 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2982 S_op_varname(aTHX_ left);
2984 Perl_warner(aTHX_ packWARN(WARN_MISC),
2985 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2986 desc, SVfARG(name), SVfARG(name));
2988 const char * const sample = (isary
2989 ? "@array" : "%hash");
2990 Perl_warner(aTHX_ packWARN(WARN_MISC),
2991 "Applying %s to %s will act on scalar(%s)",
2992 desc, sample, sample);
2996 if (rtype == OP_CONST &&
2997 cSVOPx(right)->op_private & OPpCONST_BARE &&
2998 cSVOPx(right)->op_private & OPpCONST_STRICT)
3000 no_bareword_allowed(right);
3003 /* !~ doesn't make sense with /r, so error on it for now */
3004 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3006 /* diag_listed_as: Using !~ with %s doesn't make sense */
3007 yyerror("Using !~ with s///r doesn't make sense");
3008 if (rtype == OP_TRANSR && type == OP_NOT)
3009 /* diag_listed_as: Using !~ with %s doesn't make sense */
3010 yyerror("Using !~ with tr///r doesn't make sense");
3012 ismatchop = (rtype == OP_MATCH ||
3013 rtype == OP_SUBST ||
3014 rtype == OP_TRANS || rtype == OP_TRANSR)
3015 && !(right->op_flags & OPf_SPECIAL);
3016 if (ismatchop && right->op_private & OPpTARGET_MY) {
3018 right->op_private &= ~OPpTARGET_MY;
3020 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3023 right->op_flags |= OPf_STACKED;
3024 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3025 ! (rtype == OP_TRANS &&
3026 right->op_private & OPpTRANS_IDENTICAL) &&
3027 ! (rtype == OP_SUBST &&
3028 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3029 newleft = op_lvalue(left, rtype);
3032 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3033 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3035 o = op_prepend_elem(rtype, scalar(newleft), right);
3037 return newUNOP(OP_NOT, 0, scalar(o));
3041 return bind_match(type, left,
3042 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3046 Perl_invert(pTHX_ OP *o)
3050 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3054 =for apidoc Amx|OP *|op_scope|OP *o
3056 Wraps up an op tree with some additional ops so that at runtime a dynamic
3057 scope will be created. The original ops run in the new dynamic scope,
3058 and then, provided that they exit normally, the scope will be unwound.
3059 The additional ops used to create and unwind the dynamic scope will
3060 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3061 instead if the ops are simple enough to not need the full dynamic scope
3068 Perl_op_scope(pTHX_ OP *o)
3072 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3073 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3074 o->op_type = OP_LEAVE;
3075 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3077 else if (o->op_type == OP_LINESEQ) {
3079 o->op_type = OP_SCOPE;
3080 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3081 kid = ((LISTOP*)o)->op_first;
3082 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3085 /* The following deals with things like 'do {1 for 1}' */
3086 kid = kid->op_sibling;
3088 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3093 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3099 Perl_op_unscope(pTHX_ OP *o)
3101 if (o && o->op_type == OP_LINESEQ) {
3102 OP *kid = cLISTOPo->op_first;
3103 for(; kid; kid = kid->op_sibling)
3104 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3111 Perl_block_start(pTHX_ int full)
3114 const int retval = PL_savestack_ix;
3116 pad_block_start(full);
3118 PL_hints &= ~HINT_BLOCK_SCOPE;
3119 SAVECOMPILEWARNINGS();
3120 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3122 CALL_BLOCK_HOOKS(bhk_start, full);
3128 Perl_block_end(pTHX_ I32 floor, OP *seq)
3131 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3132 OP* retval = scalarseq(seq);
3135 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3139 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3143 /* pad_leavemy has created a sequence of introcv ops for all my
3144 subs declared in the block. We have to replicate that list with
3145 clonecv ops, to deal with this situation:
3150 sub s1 { state sub foo { \&s2 } }
3153 Originally, I was going to have introcv clone the CV and turn
3154 off the stale flag. Since &s1 is declared before &s2, the
3155 introcv op for &s1 is executed (on sub entry) before the one for
3156 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3157 cloned, since it is a state sub) closes over &s2 and expects
3158 to see it in its outer CV’s pad. If the introcv op clones &s1,
3159 then &s2 is still marked stale. Since &s1 is not active, and
3160 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3161 ble will not stay shared’ warning. Because it is the same stub
3162 that will be used when the introcv op for &s2 is executed, clos-
3163 ing over it is safe. Hence, we have to turn off the stale flag
3164 on all lexical subs in the block before we clone any of them.
3165 Hence, having introcv clone the sub cannot work. So we create a
3166 list of ops like this:
3190 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3191 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3192 for (;; kid = kid->op_sibling) {
3193 OP *newkid = newOP(OP_CLONECV, 0);
3194 newkid->op_targ = kid->op_targ;
3195 o = op_append_elem(OP_LINESEQ, o, newkid);
3196 if (kid == last) break;
3198 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3201 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3207 =head1 Compile-time scope hooks
3209 =for apidoc Aox||blockhook_register
3211 Register a set of hooks to be called when the Perl lexical scope changes
3212 at compile time. See L<perlguts/"Compile-time scope hooks">.
3218 Perl_blockhook_register(pTHX_ BHK *hk)
3220 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3222 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3229 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3230 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3231 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3234 OP * const o = newOP(OP_PADSV, 0);
3235 o->op_targ = offset;
3241 Perl_newPROG(pTHX_ OP *o)
3245 PERL_ARGS_ASSERT_NEWPROG;
3252 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3253 ((PL_in_eval & EVAL_KEEPERR)
3254 ? OPf_SPECIAL : 0), o);
3256 cx = &cxstack[cxstack_ix];
3257 assert(CxTYPE(cx) == CXt_EVAL);
3259 if ((cx->blk_gimme & G_WANT) == G_VOID)
3260 scalarvoid(PL_eval_root);
3261 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3264 scalar(PL_eval_root);
3266 PL_eval_start = op_linklist(PL_eval_root);
3267 PL_eval_root->op_private |= OPpREFCOUNTED;
3268 OpREFCNT_set(PL_eval_root, 1);
3269 PL_eval_root->op_next = 0;
3270 i = PL_savestack_ix;
3273 CALL_PEEP(PL_eval_start);
3274 finalize_optree(PL_eval_root);
3275 S_prune_chain_head(&PL_eval_start);
3277 PL_savestack_ix = i;
3280 if (o->op_type == OP_STUB) {
3281 /* This block is entered if nothing is compiled for the main
3282 program. This will be the case for an genuinely empty main
3283 program, or one which only has BEGIN blocks etc, so already
3286 Historically (5.000) the guard above was !o. However, commit
3287 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3288 c71fccf11fde0068, changed perly.y so that newPROG() is now
3289 called with the output of block_end(), which returns a new
3290 OP_STUB for the case of an empty optree. ByteLoader (and
3291 maybe other things) also take this path, because they set up
3292 PL_main_start and PL_main_root directly, without generating an
3295 If the parsing the main program aborts (due to parse errors,
3296 or due to BEGIN or similar calling exit), then newPROG()
3297 isn't even called, and hence this code path and its cleanups
3298 are skipped. This shouldn't make a make a difference:
3299 * a non-zero return from perl_parse is a failure, and
3300 perl_destruct() should be called immediately.
3301 * however, if exit(0) is called during the parse, then
3302 perl_parse() returns 0, and perl_run() is called. As
3303 PL_main_start will be NULL, perl_run() will return
3304 promptly, and the exit code will remain 0.
3307 PL_comppad_name = 0;
3309 S_op_destroy(aTHX_ o);
3312 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3313 PL_curcop = &PL_compiling;
3314 PL_main_start = LINKLIST(PL_main_root);
3315 PL_main_root->op_private |= OPpREFCOUNTED;
3316 OpREFCNT_set(PL_main_root, 1);
3317 PL_main_root->op_next = 0;
3318 CALL_PEEP(PL_main_start);
3319 finalize_optree(PL_main_root);
3320 S_prune_chain_head(&PL_main_start);
3321 cv_forget_slab(PL_compcv);
3324 /* Register with debugger */
3326 CV * const cv = get_cvs("DB::postponed", 0);
3330 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3332 call_sv(MUTABLE_SV(cv), G_DISCARD);
3339 Perl_localize(pTHX_ OP *o, I32 lex)
3343 PERL_ARGS_ASSERT_LOCALIZE;
3345 if (o->op_flags & OPf_PARENS)
3346 /* [perl #17376]: this appears to be premature, and results in code such as
3347 C< our(%x); > executing in list mode rather than void mode */
3354 if ( PL_parser->bufptr > PL_parser->oldbufptr
3355 && PL_parser->bufptr[-1] == ','
3356 && ckWARN(WARN_PARENTHESIS))
3358 char *s = PL_parser->bufptr;
3361 /* some heuristics to detect a potential error */
3362 while (*s && (strchr(", \t\n", *s)))
3366 if (*s && strchr("@$%*", *s) && *++s
3367 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3370 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3372 while (*s && (strchr(", \t\n", *s)))
3378 if (sigil && (*s == ';' || *s == '=')) {
3379 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3380 "Parentheses missing around \"%s\" list",
3382 ? (PL_parser->in_my == KEY_our
3384 : PL_parser->in_my == KEY_state
3394 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3395 PL_parser->in_my = FALSE;
3396 PL_parser->in_my_stash = NULL;
3401 Perl_jmaybe(pTHX_ OP *o)
3403 PERL_ARGS_ASSERT_JMAYBE;
3405 if (o->op_type == OP_LIST) {
3407 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3408 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3413 PERL_STATIC_INLINE OP *
3414 S_op_std_init(pTHX_ OP *o)
3416 I32 type = o->op_type;
3418 PERL_ARGS_ASSERT_OP_STD_INIT;
3420 if (PL_opargs[type] & OA_RETSCALAR)
3422 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3423 o->op_targ = pad_alloc(type, SVs_PADTMP);
3428 PERL_STATIC_INLINE OP *
3429 S_op_integerize(pTHX_ OP *o)
3431 I32 type = o->op_type;
3433 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3435 /* integerize op. */
3436 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3439 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3442 if (type == OP_NEGATE)
3443 /* XXX might want a ck_negate() for this */
3444 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3450 S_fold_constants(pTHX_ OP *o)
3455 VOL I32 type = o->op_type;
3460 SV * const oldwarnhook = PL_warnhook;
3461 SV * const olddiehook = PL_diehook;
3465 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3467 if (!(PL_opargs[type] & OA_FOLDCONST))
3476 #ifdef USE_LOCALE_CTYPE
3477 if (IN_LC_COMPILETIME(LC_CTYPE))
3486 #ifdef USE_LOCALE_COLLATE
3487 if (IN_LC_COMPILETIME(LC_COLLATE))
3492 /* XXX what about the numeric ops? */
3493 #ifdef USE_LOCALE_NUMERIC
3494 if (IN_LC_COMPILETIME(LC_NUMERIC))
3499 if (!cLISTOPo->op_first->op_sibling
3500 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3503 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3504 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3506 const char *s = SvPVX_const(sv);
3507 while (s < SvEND(sv)) {
3508 if (*s == 'p' || *s == 'P') goto nope;
3515 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3518 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3519 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3523 if (PL_parser && PL_parser->error_count)
3524 goto nope; /* Don't try to run w/ errors */
3526 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3527 const OPCODE type = curop->op_type;
3528 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3530 type != OP_SCALAR &&
3532 type != OP_PUSHMARK)
3538 curop = LINKLIST(o);
3539 old_next = o->op_next;
3543 oldscope = PL_scopestack_ix;
3544 create_eval_scope(G_FAKINGEVAL);
3546 /* Verify that we don't need to save it: */
3547 assert(PL_curcop == &PL_compiling);
3548 StructCopy(&PL_compiling, ¬_compiling, COP);
3549 PL_curcop = ¬_compiling;
3550 /* The above ensures that we run with all the correct hints of the
3551 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3552 assert(IN_PERL_RUNTIME);
3553 PL_warnhook = PERL_WARNHOOK_FATAL;
3560 sv = *(PL_stack_sp--);
3561 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3562 pad_swipe(o->op_targ, FALSE);
3564 else if (SvTEMP(sv)) { /* grab mortal temp? */
3565 SvREFCNT_inc_simple_void(sv);
3568 else { assert(SvIMMORTAL(sv)); }
3571 /* Something tried to die. Abandon constant folding. */
3572 /* Pretend the error never happened. */
3574 o->op_next = old_next;
3578 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3579 PL_warnhook = oldwarnhook;
3580 PL_diehook = olddiehook;
3581 /* XXX note that this croak may fail as we've already blown away
3582 * the stack - eg any nested evals */
3583 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3586 PL_warnhook = oldwarnhook;
3587 PL_diehook = olddiehook;
3588 PL_curcop = &PL_compiling;
3590 if (PL_scopestack_ix > oldscope)
3591 delete_eval_scope();
3598 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3599 else if (!SvIMMORTAL(sv)) {
3603 if (type == OP_RV2GV)
3604 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3607 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3608 if (type != OP_STRINGIFY) newop->op_folded = 1;
3617 S_gen_constant_list(pTHX_ OP *o)
3621 const SSize_t oldtmps_floor = PL_tmps_floor;
3626 if (PL_parser && PL_parser->error_count)
3627 return o; /* Don't attempt to run with errors */
3629 curop = LINKLIST(o);
3632 S_prune_chain_head(&curop);
3634 Perl_pp_pushmark(aTHX);
3637 assert (!(curop->op_flags & OPf_SPECIAL));
3638 assert(curop->op_type == OP_RANGE);
3639 Perl_pp_anonlist(aTHX);
3640 PL_tmps_floor = oldtmps_floor;
3642 o->op_type = OP_RV2AV;
3643 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3644 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3645 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3646 o->op_opt = 0; /* needs to be revisited in rpeep() */
3647 curop = ((UNOP*)o)->op_first;
3648 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3649 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3650 if (AvFILLp(av) != -1)
3651 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3654 SvREADONLY_on(*svp);
3662 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3665 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3666 if (!o || o->op_type != OP_LIST)
3667 o = newLISTOP(OP_LIST, 0, o, NULL);
3669 o->op_flags &= ~OPf_WANT;
3671 if (!(PL_opargs[type] & OA_MARK))
3672 op_null(cLISTOPo->op_first);
3674 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3675 if (kid2 && kid2->op_type == OP_COREARGS) {
3676 op_null(cLISTOPo->op_first);
3677 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3681 o->op_type = (OPCODE)type;
3682 o->op_ppaddr = PL_ppaddr[type];
3683 o->op_flags |= flags;
3685 o = CHECKOP(type, o);
3686 if (o->op_type != (unsigned)type)
3689 return fold_constants(op_integerize(op_std_init(o)));
3693 =head1 Optree Manipulation Functions
3696 /* List constructors */
3699 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3701 Append an item to the list of ops contained directly within a list-type
3702 op, returning the lengthened list. I<first> is the list-type op,
3703 and I<last> is the op to append to the list. I<optype> specifies the
3704 intended opcode for the list. If I<first> is not already a list of the
3705 right type, it will be upgraded into one. If either I<first> or I<last>
3706 is null, the other is returned unchanged.
3712 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3720 if (first->op_type != (unsigned)type
3721 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3723 return newLISTOP(type, 0, first, last);
3726 if (first->op_flags & OPf_KIDS)
3727 ((LISTOP*)first)->op_last->op_sibling = last;
3729 first->op_flags |= OPf_KIDS;
3730 ((LISTOP*)first)->op_first = last;
3732 ((LISTOP*)first)->op_last = last;
3737 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3739 Concatenate the lists of ops contained directly within two list-type ops,
3740 returning the combined list. I<first> and I<last> are the list-type ops
3741 to concatenate. I<optype> specifies the intended opcode for the list.
3742 If either I<first> or I<last> is not already a list of the right type,
3743 it will be upgraded into one. If either I<first> or I<last> is null,
3744 the other is returned unchanged.
3750 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3758 if (first->op_type != (unsigned)type)
3759 return op_prepend_elem(type, first, last);
3761 if (last->op_type != (unsigned)type)
3762 return op_append_elem(type, first, last);
3764 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3765 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3766 first->op_flags |= (last->op_flags & OPf_KIDS);
3769 S_op_destroy(aTHX_ last);
3775 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3777 Prepend an item to the list of ops contained directly within a list-type
3778 op, returning the lengthened list. I<first> is the op to prepend to the
3779 list, and I<last> is the list-type op. I<optype> specifies the intended
3780 opcode for the list. If I<last> is not already a list of the right type,
3781 it will be upgraded into one. If either I<first> or I<last> is null,
3782 the other is returned unchanged.
3788 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3796 if (last->op_type == (unsigned)type) {
3797 if (type == OP_LIST) { /* already a PUSHMARK there */
3798 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3799 ((LISTOP*)last)->op_first->op_sibling = first;
3800 if (!(first->op_flags & OPf_PARENS))
3801 last->op_flags &= ~OPf_PARENS;
3804 if (!(last->op_flags & OPf_KIDS)) {
3805 ((LISTOP*)last)->op_last = first;
3806 last->op_flags |= OPf_KIDS;
3808 first->op_sibling = ((LISTOP*)last)->op_first;
3809 ((LISTOP*)last)->op_first = first;
3811 last->op_flags |= OPf_KIDS;
3815 return newLISTOP(type, 0, first, last);
3822 =head1 Optree construction
3824 =for apidoc Am|OP *|newNULLLIST
3826 Constructs, checks, and returns a new C<stub> op, which represents an
3827 empty list expression.
3833 Perl_newNULLLIST(pTHX)
3835 return newOP(OP_STUB, 0);
3839 S_force_list(pTHX_ OP *o)
3841 if (!o || o->op_type != OP_LIST)
3842 o = newLISTOP(OP_LIST, 0, o, NULL);
3848 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3850 Constructs, checks, and returns an op of any list type. I<type> is
3851 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3852 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3853 supply up to two ops to be direct children of the list op; they are
3854 consumed by this function and become part of the constructed op tree.
3860 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3865 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3867 NewOp(1101, listop, 1, LISTOP);
3869 listop->op_type = (OPCODE)type;
3870 listop->op_ppaddr = PL_ppaddr[type];
3873 listop->op_flags = (U8)flags;
3877 else if (!first && last)
3880 first->op_sibling = last;
3881 listop->op_first = first;
3882 listop->op_last = last;
3883 if (type == OP_LIST) {
3884 OP* const pushop = newOP(OP_PUSHMARK, 0);
3885 pushop->op_sibling = first;
3886 listop->op_first = pushop;
3887 listop->op_flags |= OPf_KIDS;
3889 listop->op_last = pushop;
3892 return CHECKOP(type, listop);
3896 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3898 Constructs, checks, and returns an op of any base type (any type that
3899 has no extra fields). I<type> is the opcode. I<flags> gives the
3900 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3907 Perl_newOP(pTHX_ I32 type, I32 flags)
3912 if (type == -OP_ENTEREVAL) {
3913 type = OP_ENTEREVAL;
3914 flags |= OPpEVAL_BYTES<<8;
3917 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3918 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3919 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3920 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3922 NewOp(1101, o, 1, OP);
3923 o->op_type = (OPCODE)type;
3924 o->op_ppaddr = PL_ppaddr[type];
3925 o->op_flags = (U8)flags;
3928 o->op_private = (U8)(0 | (flags >> 8));
3929 if (PL_opargs[type] & OA_RETSCALAR)
3931 if (PL_opargs[type] & OA_TARGET)
3932 o->op_targ = pad_alloc(type, SVs_PADTMP);
3933 return CHECKOP(type, o);
3937 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3939 Constructs, checks, and returns an op of any unary type. I<type> is
3940 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3941 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3942 bits, the eight bits of C<op_private>, except that the bit with value 1
3943 is automatically set. I<first> supplies an optional op to be the direct
3944 child of the unary op; it is consumed by this function and become part
3945 of the constructed op tree.
3951 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3956 if (type == -OP_ENTEREVAL) {
3957 type = OP_ENTEREVAL;
3958 flags |= OPpEVAL_BYTES<<8;
3961 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3962 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3963 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3964 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3965 || type == OP_SASSIGN
3966 || type == OP_ENTERTRY
3967 || type == OP_NULL );
3970 first = newOP(OP_STUB, 0);
3971 if (PL_opargs[type] & OA_MARK)
3972 first = force_list(first);
3974 NewOp(1101, unop, 1, UNOP);
3975 unop->op_type = (OPCODE)type;
3976 unop->op_ppaddr = PL_ppaddr[type];
3977 unop->op_first = first;
3978 unop->op_flags = (U8)(flags | OPf_KIDS);
3979 unop->op_private = (U8)(1 | (flags >> 8));
3980 unop = (UNOP*) CHECKOP(type, unop);
3984 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3988 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3990 Constructs, checks, and returns an op of any binary type. I<type>
3991 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3992 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3993 the eight bits of C<op_private>, except that the bit with value 1 or
3994 2 is automatically set as required. I<first> and I<last> supply up to
3995 two ops to be the direct children of the binary op; they are consumed
3996 by this function and become part of the constructed op tree.
4002 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4007 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4008 || type == OP_SASSIGN || type == OP_NULL );
4010 NewOp(1101, binop, 1, BINOP);
4013 first = newOP(OP_NULL, 0);
4015 binop->op_type = (OPCODE)type;
4016 binop->op_ppaddr = PL_ppaddr[type];
4017 binop->op_first = first;
4018 binop->op_flags = (U8)(flags | OPf_KIDS);
4021 binop->op_private = (U8)(1 | (flags >> 8));
4024 binop->op_private = (U8)(2 | (flags >> 8));
4025 first->op_sibling = last;
4028 binop = (BINOP*)CHECKOP(type, binop);
4029 if (binop->op_next || binop->op_type != (OPCODE)type)
4032 binop->op_last = binop->op_first->op_sibling;
4034 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4037 static int uvcompare(const void *a, const void *b)
4038 __attribute__nonnull__(1)
4039 __attribute__nonnull__(2)
4040 __attribute__pure__;
4041 static int uvcompare(const void *a, const void *b)
4043 if (*((const UV *)a) < (*(const UV *)b))
4045 if (*((const UV *)a) > (*(const UV *)b))
4047 if (*((const UV *)a+1) < (*(const UV *)b+1))
4049 if (*((const UV *)a+1) > (*(const UV *)b+1))
4055 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4058 SV * const tstr = ((SVOP*)expr)->op_sv;
4060 ((SVOP*)repl)->op_sv;
4063 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4064 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4070 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4071 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4072 I32 del = o->op_private & OPpTRANS_DELETE;
4075 PERL_ARGS_ASSERT_PMTRANS;
4077 PL_hints |= HINT_BLOCK_SCOPE;
4080 o->op_private |= OPpTRANS_FROM_UTF;
4083 o->op_private |= OPpTRANS_TO_UTF;
4085 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4086 SV* const listsv = newSVpvs("# comment\n");
4088 const U8* tend = t + tlen;
4089 const U8* rend = r + rlen;
4103 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4104 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4107 const U32 flags = UTF8_ALLOW_DEFAULT;
4111 t = tsave = bytes_to_utf8(t, &len);
4114 if (!to_utf && rlen) {
4116 r = rsave = bytes_to_utf8(r, &len);
4120 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4121 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4125 U8 tmpbuf[UTF8_MAXBYTES+1];
4128 Newx(cp, 2*tlen, UV);
4130 transv = newSVpvs("");
4132 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4134 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4136 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4140 cp[2*i+1] = cp[2*i];
4144 qsort(cp, i, 2*sizeof(UV), uvcompare);
4145 for (j = 0; j < i; j++) {
4147 diff = val - nextmin;
4149 t = uvchr_to_utf8(tmpbuf,nextmin);
4150 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4152 U8 range_mark = ILLEGAL_UTF8_BYTE;
4153 t = uvchr_to_utf8(tmpbuf, val - 1);
4154 sv_catpvn(transv, (char *)&range_mark, 1);
4155 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4162 t = uvchr_to_utf8(tmpbuf,nextmin);
4163 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4165 U8 range_mark = ILLEGAL_UTF8_BYTE;
4166 sv_catpvn(transv, (char *)&range_mark, 1);
4168 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4169 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4170 t = (const U8*)SvPVX_const(transv);
4171 tlen = SvCUR(transv);
4175 else if (!rlen && !del) {
4176 r = t; rlen = tlen; rend = tend;
4179 if ((!rlen && !del) || t == r ||
4180 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4182 o->op_private |= OPpTRANS_IDENTICAL;
4186 while (t < tend || tfirst <= tlast) {
4187 /* see if we need more "t" chars */
4188 if (tfirst > tlast) {
4189 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4191 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4193 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4200 /* now see if we need more "r" chars */
4201 if (rfirst > rlast) {
4203 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4205 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4207 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4216 rfirst = rlast = 0xffffffff;
4220 /* now see which range will peter our first, if either. */
4221 tdiff = tlast - tfirst;
4222 rdiff = rlast - rfirst;
4229 if (rfirst == 0xffffffff) {
4230 diff = tdiff; /* oops, pretend rdiff is infinite */
4232 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4233 (long)tfirst, (long)tlast);
4235 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4239 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4240 (long)tfirst, (long)(tfirst + diff),
4243 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4244 (long)tfirst, (long)rfirst);
4246 if (rfirst + diff > max)
4247 max = rfirst + diff;
4249 grows = (tfirst < rfirst &&
4250 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4262 else if (max > 0xff)
4267 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4269 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4270 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4271 PAD_SETSV(cPADOPo->op_padix, swash);
4273 SvREADONLY_on(swash);
4275 cSVOPo->op_sv = swash;
4277 SvREFCNT_dec(listsv);
4278 SvREFCNT_dec(transv);
4280 if (!del && havefinal && rlen)
4281 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4282 newSVuv((UV)final), 0);
4285 o->op_private |= OPpTRANS_GROWS;
4295 tbl = (short*)PerlMemShared_calloc(
4296 (o->op_private & OPpTRANS_COMPLEMENT) &&
4297 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4299 cPVOPo->op_pv = (char*)tbl;
4301 for (i = 0; i < (I32)tlen; i++)
4303 for (i = 0, j = 0; i < 256; i++) {
4305 if (j >= (I32)rlen) {
4314 if (i < 128 && r[j] >= 128)
4324 o->op_private |= OPpTRANS_IDENTICAL;
4326 else if (j >= (I32)rlen)
4331 PerlMemShared_realloc(tbl,
4332 (0x101+rlen-j) * sizeof(short));
4333 cPVOPo->op_pv = (char*)tbl;
4335 tbl[0x100] = (short)(rlen - j);
4336 for (i=0; i < (I32)rlen - j; i++)
4337 tbl[0x101+i] = r[j+i];
4341 if (!rlen && !del) {
4344 o->op_private |= OPpTRANS_IDENTICAL;
4346 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4347 o->op_private |= OPpTRANS_IDENTICAL;
4349 for (i = 0; i < 256; i++)
4351 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4352 if (j >= (I32)rlen) {
4354 if (tbl[t[i]] == -1)
4360 if (tbl[t[i]] == -1) {
4361 if (t[i] < 128 && r[j] >= 128)
4368 if(del && rlen == tlen) {
4369 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4370 } else if(rlen > tlen && !complement) {
4371 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4375 o->op_private |= OPpTRANS_GROWS;
4383 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4385 Constructs, checks, and returns an op of any pattern matching type.
4386 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4387 and, shifted up eight bits, the eight bits of C<op_private>.
4393 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4398 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4400 NewOp(1101, pmop, 1, PMOP);
4401 pmop->op_type = (OPCODE)type;
4402 pmop->op_ppaddr = PL_ppaddr[type];
4403 pmop->op_flags = (U8)flags;
4404 pmop->op_private = (U8)(0 | (flags >> 8));
4406 if (PL_hints & HINT_RE_TAINT)
4407 pmop->op_pmflags |= PMf_RETAINT;
4408 #ifdef USE_LOCALE_CTYPE
4409 if (IN_LC_COMPILETIME(LC_CTYPE)) {
4410 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4415 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4417 if (PL_hints & HINT_RE_FLAGS) {
4418 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4419 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4421 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4422 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4423 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4425 if (reflags && SvOK(reflags)) {
4426 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4432 assert(SvPOK(PL_regex_pad[0]));
4433 if (SvCUR(PL_regex_pad[0])) {
4434 /* Pop off the "packed" IV from the end. */
4435 SV *const repointer_list = PL_regex_pad[0];
4436 const char *p = SvEND(repointer_list) - sizeof(IV);
4437 const IV offset = *((IV*)p);
4439 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4441 SvEND_set(repointer_list, p);
4443 pmop->op_pmoffset = offset;
4444 /* This slot should be free, so assert this: */
4445 assert(PL_regex_pad[offset] == &PL_sv_undef);
4447 SV * const repointer = &PL_sv_undef;
4448 av_push(PL_regex_padav, repointer);
4449 pmop->op_pmoffset = av_tindex(PL_regex_padav);
4450 PL_regex_pad = AvARRAY(PL_regex_padav);
4454 return CHECKOP(type, pmop);
4457 /* Given some sort of match op o, and an expression expr containing a
4458 * pattern, either compile expr into a regex and attach it to o (if it's
4459 * constant), or convert expr into a runtime regcomp op sequence (if it's
4462 * isreg indicates that the pattern is part of a regex construct, eg
4463 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4464 * split "pattern", which aren't. In the former case, expr will be a list
4465 * if the pattern contains more than one term (eg /a$b/) or if it contains
4466 * a replacement, ie s/// or tr///.
4468 * When the pattern has been compiled within a new anon CV (for
4469 * qr/(?{...})/ ), then floor indicates the savestack level just before
4470 * the new sub was created
4474 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4479 I32 repl_has_vars = 0;
4481 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4482 bool is_compiletime;
4485 PERL_ARGS_ASSERT_PMRUNTIME;
4487 /* for s/// and tr///, last element in list is the replacement; pop it */
4489 if (is_trans || o->op_type == OP_SUBST) {
4491 repl = cLISTOPx(expr)->op_last;
4492 kid = cLISTOPx(expr)->op_first;
4493 while (kid->op_sibling != repl)
4494 kid = kid->op_sibling;
4495 kid->op_sibling = NULL;
4496 cLISTOPx(expr)->op_last = kid;
4499 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4502 OP* const oe = expr;
4503 assert(expr->op_type == OP_LIST);
4504 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4505 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4506 expr = cLISTOPx(oe)->op_last;
4507 cLISTOPx(oe)->op_first->op_sibling = NULL;
4508 cLISTOPx(oe)->op_last = NULL;
4511 return pmtrans(o, expr, repl);
4514 /* find whether we have any runtime or code elements;
4515 * at the same time, temporarily set the op_next of each DO block;
4516 * then when we LINKLIST, this will cause the DO blocks to be excluded
4517 * from the op_next chain (and from having LINKLIST recursively
4518 * applied to them). We fix up the DOs specially later */
4522 if (expr->op_type == OP_LIST) {
4524 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4525 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4527 assert(!o->op_next && o->op_sibling);
4528 o->op_next = o->op_sibling;
4530 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4534 else if (expr->op_type != OP_CONST)
4539 /* fix up DO blocks; treat each one as a separate little sub;
4540 * also, mark any arrays as LIST/REF */
4542 if (expr->op_type == OP_LIST) {
4544 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4546 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4547 assert( !(o->op_flags & OPf_WANT));
4548 /* push the array rather than its contents. The regex
4549 * engine will retrieve and join the elements later */
4550 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4554 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4556 o->op_next = NULL; /* undo temporary hack from above */
4559 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4560 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4562 assert(leaveop->op_first->op_type == OP_ENTER);
4563 assert(leaveop->op_first->op_sibling);
4564 o->op_next = leaveop->op_first->op_sibling;
4566 assert(leaveop->op_flags & OPf_KIDS);
4567 assert(leaveop->op_last->op_next == (OP*)leaveop);
4568 leaveop->op_next = NULL; /* stop on last op */
4569 op_null((OP*)leaveop);
4573 OP *scope = cLISTOPo->op_first;
4574 assert(scope->op_type == OP_SCOPE);
4575 assert(scope->op_flags & OPf_KIDS);
4576 scope->op_next = NULL; /* stop on last op */
4579 /* have to peep the DOs individually as we've removed it from
4580 * the op_next chain */
4582 S_prune_chain_head(&(o->op_next));
4584 /* runtime finalizes as part of finalizing whole tree */
4588 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4589 assert( !(expr->op_flags & OPf_WANT));
4590 /* push the array rather than its contents. The regex
4591 * engine will retrieve and join the elements later */
4592 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4595 PL_hints |= HINT_BLOCK_SCOPE;
4597 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4599 if (is_compiletime) {
4600 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4601 regexp_engine const *eng = current_re_engine();
4603 if (o->op_flags & OPf_SPECIAL)
4604 rx_flags |= RXf_SPLIT;
4606 if (!has_code || !eng->op_comp) {
4607 /* compile-time simple constant pattern */
4609 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4610 /* whoops! we guessed that a qr// had a code block, but we
4611 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4612 * that isn't required now. Note that we have to be pretty
4613 * confident that nothing used that CV's pad while the
4614 * regex was parsed */
4615 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4616 /* But we know that one op is using this CV's slab. */
4617 cv_forget_slab(PL_compcv);
4619 pm->op_pmflags &= ~PMf_HAS_CV;
4624 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4625 rx_flags, pm->op_pmflags)
4626 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4627 rx_flags, pm->op_pmflags)
4632 /* compile-time pattern that includes literal code blocks */
4633 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4636 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4639 if (pm->op_pmflags & PMf_HAS_CV) {
4641 /* this QR op (and the anon sub we embed it in) is never
4642 * actually executed. It's just a placeholder where we can
4643 * squirrel away expr in op_code_list without the peephole
4644 * optimiser etc processing it for a second time */
4645 OP *qr = newPMOP(OP_QR, 0);
4646 ((PMOP*)qr)->op_code_list = expr;
4648 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4649 SvREFCNT_inc_simple_void(PL_compcv);
4650 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4651 ReANY(re)->qr_anoncv = cv;
4653 /* attach the anon CV to the pad so that
4654 * pad_fixup_inner_anons() can find it */
4655 (void)pad_add_anon(cv, o->op_type);
4656 SvREFCNT_inc_simple_void(cv);
4659 pm->op_code_list = expr;
4664 /* runtime pattern: build chain of regcomp etc ops */
4666 PADOFFSET cv_targ = 0;
4668 reglist = isreg && expr->op_type == OP_LIST;
4673 pm->op_code_list = expr;
4674 /* don't free op_code_list; its ops are embedded elsewhere too */
4675 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4678 if (o->op_flags & OPf_SPECIAL)
4679 pm->op_pmflags |= PMf_SPLIT;
4681 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4682 * to allow its op_next to be pointed past the regcomp and
4683 * preceding stacking ops;
4684 * OP_REGCRESET is there to reset taint before executing the
4686 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4687 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4689 if (pm->op_pmflags & PMf_HAS_CV) {
4690 /* we have a runtime qr with literal code. This means
4691 * that the qr// has been wrapped in a new CV, which
4692 * means that runtime consts, vars etc will have been compiled
4693 * against a new pad. So... we need to execute those ops
4694 * within the environment of the new CV. So wrap them in a call
4695 * to a new anon sub. i.e. for
4699 * we build an anon sub that looks like
4701 * sub { "a", $b, '(?{...})' }
4703 * and call it, passing the returned list to regcomp.
4704 * Or to put it another way, the list of ops that get executed
4708 * ------ -------------------
4709 * pushmark (for regcomp)
4710 * pushmark (for entersub)
4711 * pushmark (for refgen)
4715 * regcreset regcreset
4717 * const("a") const("a")
4719 * const("(?{...})") const("(?{...})")
4724 SvREFCNT_inc_simple_void(PL_compcv);
4725 /* these lines are just an unrolled newANONATTRSUB */
4726 expr = newSVOP(OP_ANONCODE, 0,
4727 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4728 cv_targ = expr->op_targ;
4729 expr = newUNOP(OP_REFGEN, 0, expr);
4731 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4734 NewOp(1101, rcop, 1, LOGOP);
4735 rcop->op_type = OP_REGCOMP;
4736 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4737 rcop->op_first = scalar(expr);
4738 rcop->op_flags |= OPf_KIDS
4739 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4740 | (reglist ? OPf_STACKED : 0);
4741 rcop->op_private = 0;
4743 rcop->op_targ = cv_targ;
4745 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4746 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4748 /* establish postfix order */
4749 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4751 rcop->op_next = expr;
4752 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4755 rcop->op_next = LINKLIST(expr);
4756 expr->op_next = (OP*)rcop;
4759 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4765 /* If we are looking at s//.../e with a single statement, get past
4766 the implicit do{}. */
4767 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
4768 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
4769 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
4770 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
4771 if (kid->op_type == OP_NULL && kid->op_sibling
4772 && !kid->op_sibling->op_sibling)
4773 curop = kid->op_sibling;
4775 if (curop->op_type == OP_CONST)
4777 else if (( (curop->op_type == OP_RV2SV ||
4778 curop->op_type == OP_RV2AV ||
4779 curop->op_type == OP_RV2HV ||
4780 curop->op_type == OP_RV2GV)
4781 && cUNOPx(curop)->op_first
4782 && cUNOPx(curop)->op_first->op_type == OP_GV )
4783 || curop->op_type == OP_PADSV
4784 || curop->op_type == OP_PADAV
4785 || curop->op_type == OP_PADHV
4786 || curop->op_type == OP_PADANY) {
4794 || !RX_PRELEN(PM_GETRE(pm))
4795 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4797 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4798 op_prepend_elem(o->op_type, scalar(repl), o);
4801 NewOp(1101, rcop, 1, LOGOP);
4802 rcop->op_type = OP_SUBSTCONT;
4803 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4804 rcop->op_first = scalar(repl);
4805 rcop->op_flags |= OPf_KIDS;
4806 rcop->op_private = 1;
4809 /* establish postfix order */
4810 rcop->op_next = LINKLIST(repl);
4811 repl->op_next = (OP*)rcop;
4813 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4814 assert(!(pm->op_pmflags & PMf_ONCE));
4815 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4824 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4826 Constructs, checks, and returns an op of any type that involves an
4827 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4828 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4829 takes ownership of one reference to it.
4835 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4840 PERL_ARGS_ASSERT_NEWSVOP;
4842 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4843 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4844 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4846 NewOp(1101, svop, 1, SVOP);
4847 svop->op_type = (OPCODE)type;
4848 svop->op_ppaddr = PL_ppaddr[type];
4850 svop->op_next = (OP*)svop;
4851 svop->op_flags = (U8)flags;
4852 svop->op_private = (U8)(0 | (flags >> 8));
4853 if (PL_opargs[type] & OA_RETSCALAR)
4855 if (PL_opargs[type] & OA_TARGET)
4856 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4857 return CHECKOP(type, svop);
4863 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4865 Constructs, checks, and returns an op of any type that involves a
4866 reference to a pad element. I<type> is the opcode. I<flags> gives the
4867 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4868 is populated with I<sv>; this function takes ownership of one reference
4871 This function only exists if Perl has been compiled to use ithreads.
4877 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4882 PERL_ARGS_ASSERT_NEWPADOP;
4884 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4885 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4886 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4888 NewOp(1101, padop, 1, PADOP);
4889 padop->op_type = (OPCODE)type;
4890 padop->op_ppaddr = PL_ppaddr[type];
4891 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4892 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4893 PAD_SETSV(padop->op_padix, sv);
4895 padop->op_next = (OP*)padop;
4896 padop->op_flags = (U8)flags;
4897 if (PL_opargs[type] & OA_RETSCALAR)
4899 if (PL_opargs[type] & OA_TARGET)
4900 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4901 return CHECKOP(type, padop);
4904 #endif /* USE_ITHREADS */
4907 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4909 Constructs, checks, and returns an op of any type that involves an
4910 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4911 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4912 reference; calling this function does not transfer ownership of any
4919 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4923 PERL_ARGS_ASSERT_NEWGVOP;
4927 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4929 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4934 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4936 Constructs, checks, and returns an op of any type that involves an
4937 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4938 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4939 must have been allocated using C<PerlMemShared_malloc>; the memory will
4940 be freed when the op is destroyed.
4946 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4949 const bool utf8 = cBOOL(flags & SVf_UTF8);
4954 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4956 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4958 NewOp(1101, pvop, 1, PVOP);
4959 pvop->op_type = (OPCODE)type;
4960 pvop->op_ppaddr = PL_ppaddr[type];
4962 pvop->op_next = (OP*)pvop;
4963 pvop->op_flags = (U8)flags;
4964 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4965 if (PL_opargs[type] & OA_RETSCALAR)
4967 if (PL_opargs[type] & OA_TARGET)
4968 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4969 return CHECKOP(type, pvop);
4973 Perl_package(pTHX_ OP *o)
4976 SV *const sv = cSVOPo->op_sv;
4978 PERL_ARGS_ASSERT_PACKAGE;
4980 SAVEGENERICSV(PL_curstash);
4981 save_item(PL_curstname);
4983 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4985 sv_setsv(PL_curstname, sv);
4987 PL_hints |= HINT_BLOCK_SCOPE;
4988 PL_parser->copline = NOLINE;
4989 PL_parser->expect = XSTATE;
4995 Perl_package_version( pTHX_ OP *v )
4998 U32 savehints = PL_hints;
4999 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5000 PL_hints &= ~HINT_STRICT_VARS;
5001 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5002 PL_hints = savehints;
5007 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5013 SV *use_version = NULL;
5015 PERL_ARGS_ASSERT_UTILIZE;
5017 if (idop->op_type != OP_CONST)
5018 Perl_croak(aTHX_ "Module name must be constant");
5023 SV * const vesv = ((SVOP*)version)->op_sv;
5025 if (!arg && !SvNIOKp(vesv)) {
5032 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5033 Perl_croak(aTHX_ "Version number must be a constant number");
5035 /* Make copy of idop so we don't free it twice */
5036 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5038 /* Fake up a method call to VERSION */
5039 meth = newSVpvs_share("VERSION");
5040 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5041 op_append_elem(OP_LIST,
5042 op_prepend_elem(OP_LIST, pack, list(version)),
5043 newSVOP(OP_METHOD_NAMED, 0, meth)));
5047 /* Fake up an import/unimport */
5048 if (arg && arg->op_type == OP_STUB) {
5049 imop = arg; /* no import on explicit () */
5051 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5052 imop = NULL; /* use 5.0; */
5054 use_version = ((SVOP*)idop)->op_sv;
5056 idop->op_private |= OPpCONST_NOVER;
5061 /* Make copy of idop so we don't free it twice */
5062 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5064 /* Fake up a method call to import/unimport */
5066 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5067 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5068 op_append_elem(OP_LIST,
5069 op_prepend_elem(OP_LIST, pack, list(arg)),
5070 newSVOP(OP_METHOD_NAMED, 0, meth)));
5073 /* Fake up the BEGIN {}, which does its thing immediately. */
5075 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5078 op_append_elem(OP_LINESEQ,
5079 op_append_elem(OP_LINESEQ,
5080 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5081 newSTATEOP(0, NULL, veop)),
5082 newSTATEOP(0, NULL, imop) ));
5086 * feature bundle that corresponds to the required version. */
5087 use_version = sv_2mortal(new_version(use_version));
5088 S_enable_feature_bundle(aTHX_ use_version);
5090 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5091 if (vcmp(use_version,
5092 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5093 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5094 PL_hints |= HINT_STRICT_REFS;
5095 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5096 PL_hints |= HINT_STRICT_SUBS;
5097 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5098 PL_hints |= HINT_STRICT_VARS;
5100 /* otherwise they are off */
5102 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5103 PL_hints &= ~HINT_STRICT_REFS;
5104 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5105 PL_hints &= ~HINT_STRICT_SUBS;
5106 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5107 PL_hints &= ~HINT_STRICT_VARS;
5111 /* The "did you use incorrect case?" warning used to be here.
5112 * The problem is that on case-insensitive filesystems one
5113 * might get false positives for "use" (and "require"):
5114 * "use Strict" or "require CARP" will work. This causes
5115 * portability problems for the script: in case-strict
5116 * filesystems the script will stop working.
5118 * The "incorrect case" warning checked whether "use Foo"
5119 * imported "Foo" to your namespace, but that is wrong, too:
5120 * there is no requirement nor promise in the language that
5121 * a Foo.pm should or would contain anything in package "Foo".
5123 * There is very little Configure-wise that can be done, either:
5124 * the case-sensitivity of the build filesystem of Perl does not
5125 * help in guessing the case-sensitivity of the runtime environment.
5128 PL_hints |= HINT_BLOCK_SCOPE;
5129 PL_parser->copline = NOLINE;
5130 PL_parser->expect = XSTATE;
5131 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5132 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5138 =head1 Embedding Functions
5140 =for apidoc load_module
5142 Loads the module whose name is pointed to by the string part of name.
5143 Note that the actual module name, not its filename, should be given.
5144 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5145 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5146 (or 0 for no flags). ver, if specified
5147 and not NULL, provides version semantics
5148 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5149 arguments can be used to specify arguments to the module's import()
5150 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5151 terminated with a final NULL pointer. Note that this list can only
5152 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5153 Otherwise at least a single NULL pointer to designate the default
5154 import list is required.
5156 The reference count for each specified C<SV*> parameter is decremented.
5161 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5165 PERL_ARGS_ASSERT_LOAD_MODULE;
5167 va_start(args, ver);
5168 vload_module(flags, name, ver, &args);
5172 #ifdef PERL_IMPLICIT_CONTEXT
5174 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5178 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5179 va_start(args, ver);
5180 vload_module(flags, name, ver, &args);
5186 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5190 OP * const modname = newSVOP(OP_CONST, 0, name);
5192 PERL_ARGS_ASSERT_VLOAD_MODULE;
5194 modname->op_private |= OPpCONST_BARE;
5196 veop = newSVOP(OP_CONST, 0, ver);
5200 if (flags & PERL_LOADMOD_NOIMPORT) {
5201 imop = sawparens(newNULLLIST());
5203 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5204 imop = va_arg(*args, OP*);
5209 sv = va_arg(*args, SV*);
5211 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5212 sv = va_arg(*args, SV*);
5216 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5217 * that it has a PL_parser to play with while doing that, and also
5218 * that it doesn't mess with any existing parser, by creating a tmp
5219 * new parser with lex_start(). This won't actually be used for much,
5220 * since pp_require() will create another parser for the real work.
5221 * The ENTER/LEAVE pair protect callers from any side effects of use. */
5224 SAVEVPTR(PL_curcop);
5225 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5226 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5227 veop, modname, imop);
5231 PERL_STATIC_INLINE OP *
5232 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5234 return newUNOP(OP_ENTERSUB, OPf_STACKED,
5235 newLISTOP(OP_LIST, 0, arg,
5236 newUNOP(OP_RV2CV, 0,
5237 newGVOP(OP_GV, 0, gv))));
5241 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5247 PERL_ARGS_ASSERT_DOFILE;
5249 if (!force_builtin && (gv = gv_override("do", 2))) {
5250 doop = S_new_entersubop(aTHX_ gv, term);
5253 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5259 =head1 Optree construction
5261 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5263 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5264 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5265 be set automatically, and, shifted up eight bits, the eight bits of
5266 C<op_private>, except that the bit with value 1 or 2 is automatically
5267 set as required. I<listval> and I<subscript> supply the parameters of
5268 the slice; they are consumed by this function and become part of the
5269 constructed op tree.
5275 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5277 return newBINOP(OP_LSLICE, flags,
5278 list(force_list(subscript)),
5279 list(force_list(listval)) );
5283 S_is_list_assignment(pTHX_ const OP *o)
5291 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5292 o = cUNOPo->op_first;
5294 flags = o->op_flags;
5296 if (type == OP_COND_EXPR) {
5297 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5298 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5303 yyerror("Assignment to both a list and a scalar");
5307 if (type == OP_LIST &&
5308 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5309 o->op_private & OPpLVAL_INTRO)
5312 if (type == OP_LIST || flags & OPf_PARENS ||
5313 type == OP_RV2AV || type == OP_RV2HV ||
5314 type == OP_ASLICE || type == OP_HSLICE ||
5315 type == OP_KVASLICE || type == OP_KVHSLICE)
5318 if (type == OP_PADAV || type == OP_PADHV)
5321 if (type == OP_RV2SV)
5328 Helper function for newASSIGNOP to detection commonality between the
5329 lhs and the rhs. Marks all variables with PL_generation. If it
5330 returns TRUE the assignment must be able to handle common variables.
5332 PERL_STATIC_INLINE bool
5333 S_aassign_common_vars(pTHX_ OP* o)
5336 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5337 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5338 if (curop->op_type == OP_GV) {
5339 GV *gv = cGVOPx_gv(curop);
5341 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5343 GvASSIGN_GENERATION_set(gv, PL_generation);
5345 else if (curop->op_type == OP_PADSV ||
5346 curop->op_type == OP_PADAV ||
5347 curop->op_type == OP_PADHV ||
5348 curop->op_type == OP_PADANY)
5350 if (PAD_COMPNAME_GEN(curop->op_targ)
5351 == (STRLEN)PL_generation)
5353 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5356 else if (curop->op_type == OP_RV2CV)
5358 else if (curop->op_type == OP_RV2SV ||
5359 curop->op_type == OP_RV2AV ||
5360 curop->op_type == OP_RV2HV ||
5361 curop->op_type == OP_RV2GV) {
5362 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5365 else if (curop->op_type == OP_PUSHRE) {
5368 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5369 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5372 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5376 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5378 GvASSIGN_GENERATION_set(gv, PL_generation);
5385 if (curop->op_flags & OPf_KIDS) {
5386 if (aassign_common_vars(curop))
5394 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5396 Constructs, checks, and returns an assignment op. I<left> and I<right>
5397 supply the parameters of the assignment; they are consumed by this
5398 function and become part of the constructed op tree.
5400 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5401 a suitable conditional optree is constructed. If I<optype> is the opcode
5402 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5403 performs the binary operation and assigns the result to the left argument.
5404 Either way, if I<optype> is non-zero then I<flags> has no effect.
5406 If I<optype> is zero, then a plain scalar or list assignment is
5407 constructed. Which type of assignment it is is automatically determined.
5408 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5409 will be set automatically, and, shifted up eight bits, the eight bits
5410 of C<op_private>, except that the bit with value 1 or 2 is automatically
5417 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5423 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5424 return newLOGOP(optype, 0,
5425 op_lvalue(scalar(left), optype),
5426 newUNOP(OP_SASSIGN, 0, scalar(right)));
5429 return newBINOP(optype, OPf_STACKED,
5430 op_lvalue(scalar(left), optype), scalar(right));
5434 if (is_list_assignment(left)) {
5435 static const char no_list_state[] = "Initialization of state variables"
5436 " in list context currently forbidden";
5438 bool maybe_common_vars = TRUE;
5440 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5441 left->op_private &= ~ OPpSLICEWARNING;
5444 left = op_lvalue(left, OP_AASSIGN);
5445 curop = list(force_list(left));
5446 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5447 o->op_private = (U8)(0 | (flags >> 8));
5449 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
5451 OP* lop = ((LISTOP*)left)->op_first;
5452 maybe_common_vars = FALSE;
5454 if (lop->op_type == OP_PADSV ||
5455 lop->op_type == OP_PADAV ||
5456 lop->op_type == OP_PADHV ||
5457 lop->op_type == OP_PADANY) {
5458 if (!(lop->op_private & OPpLVAL_INTRO))
5459 maybe_common_vars = TRUE;
5461 if (lop->op_private & OPpPAD_STATE) {
5462 if (left->op_private & OPpLVAL_INTRO) {
5463 /* Each variable in state($a, $b, $c) = ... */
5466 /* Each state variable in
5467 (state $a, my $b, our $c, $d, undef) = ... */
5469 yyerror(no_list_state);
5471 /* Each my variable in
5472 (state $a, my $b, our $c, $d, undef) = ... */
5474 } else if (lop->op_type == OP_UNDEF ||
5475 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
5476 /* undef may be interesting in
5477 (state $a, undef, state $c) */
5479 /* Other ops in the list. */
5480 maybe_common_vars = TRUE;
5482 lop = lop->op_sibling;
5485 else if ((left->op_private & OPpLVAL_INTRO)
5486 && ( left->op_type == OP_PADSV
5487 || left->op_type == OP_PADAV
5488 || left->op_type == OP_PADHV
5489 || left->op_type == OP_PADANY))
5491 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5492 if (left->op_private & OPpPAD_STATE) {
5493 /* All single variable list context state assignments, hence
5503 yyerror(no_list_state);
5507 /* PL_generation sorcery:
5508 * an assignment like ($a,$b) = ($c,$d) is easier than
5509 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5510 * To detect whether there are common vars, the global var
5511 * PL_generation is incremented for each assign op we compile.
5512 * Then, while compiling the assign op, we run through all the
5513 * variables on both sides of the assignment, setting a spare slot
5514 * in each of them to PL_generation. If any of them already have
5515 * that value, we know we've got commonality. We could use a
5516 * single bit marker, but then we'd have to make 2 passes, first
5517 * to clear the flag, then to test and set it. To find somewhere
5518 * to store these values, evil chicanery is done with SvUVX().
5521 if (maybe_common_vars) {
5523 if (aassign_common_vars(o))
5524 o->op_private |= OPpASSIGN_COMMON;
5528 if (right && right->op_type == OP_SPLIT) {
5529 OP* tmpop = ((LISTOP*)right)->op_first;
5530 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5531 PMOP * const pm = (PMOP*)tmpop;
5532 if (left->op_type == OP_RV2AV &&
5533 !(left->op_private & OPpLVAL_INTRO) &&
5534 !(o->op_private & OPpASSIGN_COMMON) )
5536 tmpop = ((UNOP*)left)->op_first;
5537 if (tmpop->op_type == OP_GV
5539 && !pm->op_pmreplrootu.op_pmtargetoff
5541 && !pm->op_pmreplrootu.op_pmtargetgv
5545 pm->op_pmreplrootu.op_pmtargetoff
5546 = cPADOPx(tmpop)->op_padix;
5547 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5549 pm->op_pmreplrootu.op_pmtargetgv
5550 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5551 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5553 tmpop = cUNOPo->op_first; /* to list (nulled) */
5554 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5555 tmpop->op_sibling = NULL; /* don't free split */
5556 right->op_next = tmpop->op_next; /* fix starting loc */
5557 op_free(o); /* blow off assign */
5558 right->op_flags &= ~OPf_WANT;
5559 /* "I don't know and I don't care." */
5564 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5565 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5568 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5569 SV * const sv = *svp;
5570 if (SvIOK(sv) && SvIVX(sv) == 0)
5572 if (right->op_private & OPpSPLIT_IMPLIM) {
5573 /* our own SV, created in ck_split */
5575 sv_setiv(sv, PL_modcount+1);
5578 /* SV may belong to someone else */
5580 *svp = newSViv(PL_modcount+1);
5590 right = newOP(OP_UNDEF, 0);
5591 if (right->op_type == OP_READLINE) {
5592 right->op_flags |= OPf_STACKED;
5593 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5597 o = newBINOP(OP_SASSIGN, flags,
5598 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5604 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5606 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5607 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5608 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5609 If I<label> is non-null, it supplies the name of a label to attach to
5610 the state op; this function takes ownership of the memory pointed at by
5611 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5614 If I<o> is null, the state op is returned. Otherwise the state op is
5615 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5616 is consumed by this function and becomes part of the returned op tree.
5622 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5625 const U32 seq = intro_my();
5626 const U32 utf8 = flags & SVf_UTF8;
5631 NewOp(1101, cop, 1, COP);
5632 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5633 cop->op_type = OP_DBSTATE;
5634 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5637 cop->op_type = OP_NEXTSTATE;
5638 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5640 cop->op_flags = (U8)flags;
5641 CopHINTS_set(cop, PL_hints);
5643 cop->op_private |= NATIVE_HINTS;
5646 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
5648 cop->op_next = (OP*)cop;
5651 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5652 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5654 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5656 PL_hints |= HINT_BLOCK_SCOPE;
5657 /* It seems that we need to defer freeing this pointer, as other parts
5658 of the grammar end up wanting to copy it after this op has been
5663 if (PL_parser->preambling != NOLINE) {
5664 CopLINE_set(cop, PL_parser->preambling);
5665 PL_parser->copline = NOLINE;
5667 else if (PL_parser->copline == NOLINE)
5668 CopLINE_set(cop, CopLINE(PL_curcop));
5670 CopLINE_set(cop, PL_parser->copline);
5671 PL_parser->copline = NOLINE;
5674 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5676 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5678 CopSTASH_set(cop, PL_curstash);
5680 if (cop->op_type == OP_DBSTATE) {
5681 /* this line can have a breakpoint - store the cop in IV */
5682 AV *av = CopFILEAVx(PL_curcop);
5684 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
5685 if (svp && *svp != &PL_sv_undef ) {
5686 (void)SvIOK_on(*svp);
5687 SvIV_set(*svp, PTR2IV(cop));
5692 if (flags & OPf_SPECIAL)
5694 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5698 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5700 Constructs, checks, and returns a logical (flow control) op. I<type>
5701 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5702 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5703 the eight bits of C<op_private>, except that the bit with value 1 is
5704 automatically set. I<first> supplies the expression controlling the
5705 flow, and I<other> supplies the side (alternate) chain of ops; they are
5706 consumed by this function and become part of the constructed op tree.
5712 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5716 PERL_ARGS_ASSERT_NEWLOGOP;
5718 return new_logop(type, flags, &first, &other);
5722 S_search_const(pTHX_ OP *o)
5724 PERL_ARGS_ASSERT_SEARCH_CONST;
5726 switch (o->op_type) {
5730 if (o->op_flags & OPf_KIDS)
5731 return search_const(cUNOPo->op_first);
5738 if (!(o->op_flags & OPf_KIDS))
5740 kid = cLISTOPo->op_first;
5742 switch (kid->op_type) {
5746 kid = kid->op_sibling;
5749 if (kid != cLISTOPo->op_last)
5755 kid = cLISTOPo->op_last;
5757 return search_const(kid);
5765 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5773 int prepend_not = 0;
5775 PERL_ARGS_ASSERT_NEW_LOGOP;
5780 /* [perl #59802]: Warn about things like "return $a or $b", which
5781 is parsed as "(return $a) or $b" rather than "return ($a or
5782 $b)". NB: This also applies to xor, which is why we do it
5785 switch (first->op_type) {
5789 /* XXX: Perhaps we should emit a stronger warning for these.
5790 Even with the high-precedence operator they don't seem to do
5793 But until we do, fall through here.
5799 /* XXX: Currently we allow people to "shoot themselves in the
5800 foot" by explicitly writing "(return $a) or $b".
5802 Warn unless we are looking at the result from folding or if
5803 the programmer explicitly grouped the operators like this.
5804 The former can occur with e.g.
5806 use constant FEATURE => ( $] >= ... );
5807 sub { not FEATURE and return or do_stuff(); }
5809 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
5810 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
5811 "Possible precedence issue with control flow operator");
5812 /* XXX: Should we optimze this to "return $a;" (i.e. remove
5818 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5819 return newBINOP(type, flags, scalar(first), scalar(other));
5821 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5823 scalarboolean(first);
5824 /* optimize AND and OR ops that have NOTs as children */
5825 if (first->op_type == OP_NOT
5826 && (first->op_flags & OPf_KIDS)
5827 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5828 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5830 if (type == OP_AND || type == OP_OR) {
5836 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5838 prepend_not = 1; /* prepend a NOT op later */
5842 /* search for a constant op that could let us fold the test */
5843 if ((cstop = search_const(first))) {
5844 if (cstop->op_private & OPpCONST_STRICT)
5845 no_bareword_allowed(cstop);
5846 else if ((cstop->op_private & OPpCONST_BARE))
5847 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5848 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5849 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5850 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5852 if (other->op_type == OP_CONST)
5853 other->op_private |= OPpCONST_SHORTCIRCUIT;
5855 if (other->op_type == OP_LEAVE)
5856 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5857 else if (other->op_type == OP_MATCH
5858 || other->op_type == OP_SUBST
5859 || other->op_type == OP_TRANSR
5860 || other->op_type == OP_TRANS)
5861 /* Mark the op as being unbindable with =~ */
5862 other->op_flags |= OPf_SPECIAL;
5864 other->op_folded = 1;
5868 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5869 const OP *o2 = other;
5870 if ( ! (o2->op_type == OP_LIST
5871 && (( o2 = cUNOPx(o2)->op_first))
5872 && o2->op_type == OP_PUSHMARK
5873 && (( o2 = o2->op_sibling)) )
5876 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5877 || o2->op_type == OP_PADHV)
5878 && o2->op_private & OPpLVAL_INTRO
5879 && !(o2->op_private & OPpPAD_STATE))
5881 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5882 "Deprecated use of my() in false conditional");
5886 if (cstop->op_type == OP_CONST)
5887 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
5892 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5893 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5895 const OP * const k1 = ((UNOP*)first)->op_first;
5896 const OP * const k2 = k1->op_sibling;
5898 switch (first->op_type)
5901 if (k2 && k2->op_type == OP_READLINE
5902 && (k2->op_flags & OPf_STACKED)
5903 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5905 warnop = k2->op_type;
5910 if (k1->op_type == OP_READDIR
5911 || k1->op_type == OP_GLOB
5912 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5913 || k1->op_type == OP_EACH
5914 || k1->op_type == OP_AEACH)
5916 warnop = ((k1->op_type == OP_NULL)
5917 ? (OPCODE)k1->op_targ : k1->op_type);
5922 const line_t oldline = CopLINE(PL_curcop);
5923 /* This ensures that warnings are reported at the first line
5924 of the construction, not the last. */
5925 CopLINE_set(PL_curcop, PL_parser->copline);
5926 Perl_warner(aTHX_ packWARN(WARN_MISC),
5927 "Value of %s%s can be \"0\"; test with defined()",
5929 ((warnop == OP_READLINE || warnop == OP_GLOB)
5930 ? " construct" : "() operator"));
5931 CopLINE_set(PL_curcop, oldline);
5938 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5939 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5941 NewOp(1101, logop, 1, LOGOP);
5943 logop->op_type = (OPCODE)type;
5944 logop->op_ppaddr = PL_ppaddr[type];
5945 logop->op_first = first;
5946 logop->op_flags = (U8)(flags | OPf_KIDS);
5947 logop->op_other = LINKLIST(other);
5948 logop->op_private = (U8)(1 | (flags >> 8));
5950 /* establish postfix order */
5951 logop->op_next = LINKLIST(first);
5952 first->op_next = (OP*)logop;
5953 first->op_sibling = other;
5955 CHECKOP(type,logop);
5957 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5964 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5966 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5967 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5968 will be set automatically, and, shifted up eight bits, the eight bits of
5969 C<op_private>, except that the bit with value 1 is automatically set.
5970 I<first> supplies the expression selecting between the two branches,
5971 and I<trueop> and I<falseop> supply the branches; they are consumed by
5972 this function and become part of the constructed op tree.
5978 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5986 PERL_ARGS_ASSERT_NEWCONDOP;
5989 return newLOGOP(OP_AND, 0, first, trueop);
5991 return newLOGOP(OP_OR, 0, first, falseop);
5993 scalarboolean(first);
5994 if ((cstop = search_const(first))) {
5995 /* Left or right arm of the conditional? */
5996 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5997 OP *live = left ? trueop : falseop;
5998 OP *const dead = left ? falseop : trueop;
5999 if (cstop->op_private & OPpCONST_BARE &&
6000 cstop->op_private & OPpCONST_STRICT) {
6001 no_bareword_allowed(cstop);
6005 if (live->op_type == OP_LEAVE)
6006 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6007 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6008 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6009 /* Mark the op as being unbindable with =~ */
6010 live->op_flags |= OPf_SPECIAL;
6011 live->op_folded = 1;
6014 NewOp(1101, logop, 1, LOGOP);
6015 logop->op_type = OP_COND_EXPR;
6016 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6017 logop->op_first = first;
6018 logop->op_flags = (U8)(flags | OPf_KIDS);
6019 logop->op_private = (U8)(1 | (flags >> 8));
6020 logop->op_other = LINKLIST(trueop);
6021 logop->op_next = LINKLIST(falseop);
6023 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6026 /* establish postfix order */
6027 start = LINKLIST(first);
6028 first->op_next = (OP*)logop;
6030 first->op_sibling = trueop;
6031 trueop->op_sibling = falseop;
6032 o = newUNOP(OP_NULL, 0, (OP*)logop);
6034 trueop->op_next = falseop->op_next = o;
6041 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6043 Constructs and returns a C<range> op, with subordinate C<flip> and
6044 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6045 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6046 for both the C<flip> and C<range> ops, except that the bit with value
6047 1 is automatically set. I<left> and I<right> supply the expressions
6048 controlling the endpoints of the range; they are consumed by this function
6049 and become part of the constructed op tree.
6055 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6064 PERL_ARGS_ASSERT_NEWRANGE;
6066 NewOp(1101, range, 1, LOGOP);
6068 range->op_type = OP_RANGE;
6069 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6070 range->op_first = left;
6071 range->op_flags = OPf_KIDS;
6072 leftstart = LINKLIST(left);
6073 range->op_other = LINKLIST(right);
6074 range->op_private = (U8)(1 | (flags >> 8));
6076 left->op_sibling = right;
6078 range->op_next = (OP*)range;
6079 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6080 flop = newUNOP(OP_FLOP, 0, flip);
6081 o = newUNOP(OP_NULL, 0, flop);
6083 range->op_next = leftstart;
6085 left->op_next = flip;
6086 right->op_next = flop;
6088 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6089 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6090 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6091 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6093 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6094 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6096 /* check barewords before they might be optimized aways */
6097 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6098 no_bareword_allowed(left);
6099 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6100 no_bareword_allowed(right);
6103 if (!flip->op_private || !flop->op_private)
6104 LINKLIST(o); /* blow off optimizer unless constant */
6110 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6112 Constructs, checks, and returns an op tree expressing a loop. This is
6113 only a loop in the control flow through the op tree; it does not have
6114 the heavyweight loop structure that allows exiting the loop by C<last>
6115 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6116 top-level op, except that some bits will be set automatically as required.
6117 I<expr> supplies the expression controlling loop iteration, and I<block>
6118 supplies the body of the loop; they are consumed by this function and
6119 become part of the constructed op tree. I<debuggable> is currently
6120 unused and should always be 1.
6126 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6131 const bool once = block && block->op_flags & OPf_SPECIAL &&
6132 block->op_type == OP_NULL;
6134 PERL_UNUSED_ARG(debuggable);
6138 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6139 || ( expr->op_type == OP_NOT
6140 && cUNOPx(expr)->op_first->op_type == OP_CONST
6141 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6144 /* Return the block now, so that S_new_logop does not try to
6146 return block; /* do {} while 0 does once */
6147 if (expr->op_type == OP_READLINE
6148 || expr->op_type == OP_READDIR
6149 || expr->op_type == OP_GLOB
6150 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6151 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6152 expr = newUNOP(OP_DEFINED, 0,
6153 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6154 } else if (expr->op_flags & OPf_KIDS) {
6155 const OP * const k1 = ((UNOP*)expr)->op_first;
6156 const OP * const k2 = k1 ? k1->op_sibling : NULL;
6157 switch (expr->op_type) {
6159 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6160 && (k2->op_flags & OPf_STACKED)
6161 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6162 expr = newUNOP(OP_DEFINED, 0, expr);
6166 if (k1 && (k1->op_type == OP_READDIR
6167 || k1->op_type == OP_GLOB
6168 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6169 || k1->op_type == OP_EACH
6170 || k1->op_type == OP_AEACH))
6171 expr = newUNOP(OP_DEFINED, 0, expr);
6177 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6178 * op, in listop. This is wrong. [perl #27024] */
6180 block = newOP(OP_NULL, 0);
6181 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6182 o = new_logop(OP_AND, 0, &expr, &listop);
6189 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6191 if (once && o != listop)
6193 assert(cUNOPo->op_first->op_type == OP_AND
6194 || cUNOPo->op_first->op_type == OP_OR);
6195 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6199 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6201 o->op_flags |= flags;
6203 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6208 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6210 Constructs, checks, and returns an op tree expressing a C<while> loop.
6211 This is a heavyweight loop, with structure that allows exiting the loop
6212 by C<last> and suchlike.
6214 I<loop> is an optional preconstructed C<enterloop> op to use in the
6215 loop; if it is null then a suitable op will be constructed automatically.
6216 I<expr> supplies the loop's controlling expression. I<block> supplies the
6217 main body of the loop, and I<cont> optionally supplies a C<continue> block
6218 that operates as a second half of the body. All of these optree inputs
6219 are consumed by this function and become part of the constructed op tree.
6221 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6222 op and, shifted up eight bits, the eight bits of C<op_private> for
6223 the C<leaveloop> op, except that (in both cases) some bits will be set
6224 automatically. I<debuggable> is currently unused and should always be 1.
6225 I<has_my> can be supplied as true to force the
6226 loop body to be enclosed in its own scope.
6232 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6233 OP *expr, OP *block, OP *cont, I32 has_my)
6242 PERL_UNUSED_ARG(debuggable);
6245 if (expr->op_type == OP_READLINE
6246 || expr->op_type == OP_READDIR
6247 || expr->op_type == OP_GLOB
6248 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6249 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6250 expr = newUNOP(OP_DEFINED, 0,
6251 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6252 } else if (expr->op_flags & OPf_KIDS) {
6253 const OP * const k1 = ((UNOP*)expr)->op_first;
6254 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6255 switch (expr->op_type) {
6257 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6258 && (k2->op_flags & OPf_STACKED)
6259 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6260 expr = newUNOP(OP_DEFINED, 0, expr);
6264 if (k1 && (k1->op_type == OP_READDIR
6265 || k1->op_type == OP_GLOB
6266 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6267 || k1->op_type == OP_EACH
6268 || k1->op_type == OP_AEACH))
6269 expr = newUNOP(OP_DEFINED, 0, expr);
6276 block = newOP(OP_NULL, 0);
6277 else if (cont || has_my) {
6278 block = op_scope(block);
6282 next = LINKLIST(cont);
6285 OP * const unstack = newOP(OP_UNSTACK, 0);
6288 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6292 listop = op_append_list(OP_LINESEQ, block, cont);
6294 redo = LINKLIST(listop);
6298 o = new_logop(OP_AND, 0, &expr, &listop);
6299 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6301 return expr; /* listop already freed by new_logop */
6304 ((LISTOP*)listop)->op_last->op_next =
6305 (o == listop ? redo : LINKLIST(o));
6311 NewOp(1101,loop,1,LOOP);
6312 loop->op_type = OP_ENTERLOOP;
6313 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6314 loop->op_private = 0;
6315 loop->op_next = (OP*)loop;
6318 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6320 loop->op_redoop = redo;
6321 loop->op_lastop = o;
6322 o->op_private |= loopflags;
6325 loop->op_nextop = next;
6327 loop->op_nextop = o;
6329 o->op_flags |= flags;
6330 o->op_private |= (flags >> 8);
6335 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6337 Constructs, checks, and returns an op tree expressing a C<foreach>
6338 loop (iteration through a list of values). This is a heavyweight loop,
6339 with structure that allows exiting the loop by C<last> and suchlike.
6341 I<sv> optionally supplies the variable that will be aliased to each
6342 item in turn; if null, it defaults to C<$_> (either lexical or global).
6343 I<expr> supplies the list of values to iterate over. I<block> supplies
6344 the main body of the loop, and I<cont> optionally supplies a C<continue>
6345 block that operates as a second half of the body. All of these optree
6346 inputs are consumed by this function and become part of the constructed
6349 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6350 op and, shifted up eight bits, the eight bits of C<op_private> for
6351 the C<leaveloop> op, except that (in both cases) some bits will be set
6358 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6363 PADOFFSET padoff = 0;
6367 PERL_ARGS_ASSERT_NEWFOROP;
6370 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6371 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6372 sv->op_type = OP_RV2GV;
6373 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6375 /* The op_type check is needed to prevent a possible segfault
6376 * if the loop variable is undeclared and 'strict vars' is in
6377 * effect. This is illegal but is nonetheless parsed, so we
6378 * may reach this point with an OP_CONST where we're expecting
6381 if (cUNOPx(sv)->op_first->op_type == OP_GV
6382 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6383 iterpflags |= OPpITER_DEF;
6385 else if (sv->op_type == OP_PADSV) { /* private variable */
6386 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6387 padoff = sv->op_targ;
6393 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6395 SV *const namesv = PAD_COMPNAME_SV(padoff);
6397 const char *const name = SvPV_const(namesv, len);
6399 if (len == 2 && name[0] == '$' && name[1] == '_')
6400 iterpflags |= OPpITER_DEF;
6404 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6405 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6406 sv = newGVOP(OP_GV, 0, PL_defgv);
6411 iterpflags |= OPpITER_DEF;
6413 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6414 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6415 iterflags |= OPf_STACKED;
6417 else if (expr->op_type == OP_NULL &&
6418 (expr->op_flags & OPf_KIDS) &&
6419 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6421 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6422 * set the STACKED flag to indicate that these values are to be
6423 * treated as min/max values by 'pp_enteriter'.
6425 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6426 LOGOP* const range = (LOGOP*) flip->op_first;
6427 OP* const left = range->op_first;
6428 OP* const right = left->op_sibling;
6431 range->op_flags &= ~OPf_KIDS;
6432 range->op_first = NULL;
6434 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6435 listop->op_first->op_next = range->op_next;
6436 left->op_next = range->op_other;
6437 right->op_next = (OP*)listop;
6438 listop->op_next = listop->op_first;
6441 expr = (OP*)(listop);
6443 iterflags |= OPf_STACKED;
6446 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6449 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6450 op_append_elem(OP_LIST, expr, scalar(sv))));
6451 assert(!loop->op_next);
6452 /* for my $x () sets OPpLVAL_INTRO;
6453 * for our $x () sets OPpOUR_INTRO */
6454 loop->op_private = (U8)iterpflags;
6455 if (loop->op_slabbed
6456 && DIFF(loop, OpSLOT(loop)->opslot_next)
6457 < SIZE_TO_PSIZE(sizeof(LOOP)))
6460 NewOp(1234,tmp,1,LOOP);
6461 Copy(loop,tmp,1,LISTOP);
6462 S_op_destroy(aTHX_ (OP*)loop);
6465 else if (!loop->op_slabbed)
6466 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6467 loop->op_targ = padoff;
6468 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6473 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6475 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6476 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6477 determining the target of the op; it is consumed by this function and
6478 becomes part of the constructed op tree.
6484 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6489 PERL_ARGS_ASSERT_NEWLOOPEX;
6491 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6493 if (type != OP_GOTO) {
6494 /* "last()" means "last" */
6495 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6496 o = newOP(type, OPf_SPECIAL);
6500 /* Check whether it's going to be a goto &function */
6501 if (label->op_type == OP_ENTERSUB
6502 && !(label->op_flags & OPf_STACKED))
6503 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6506 /* Check for a constant argument */
6507 if (label->op_type == OP_CONST) {
6508 SV * const sv = ((SVOP *)label)->op_sv;
6510 const char *s = SvPV_const(sv,l);
6511 if (l == strlen(s)) {
6513 SvUTF8(((SVOP*)label)->op_sv),
6515 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6519 /* If we have already created an op, we do not need the label. */
6522 else o = newUNOP(type, OPf_STACKED, label);
6524 PL_hints |= HINT_BLOCK_SCOPE;
6528 /* if the condition is a literal array or hash
6529 (or @{ ... } etc), make a reference to it.
6532 S_ref_array_or_hash(pTHX_ OP *cond)
6535 && (cond->op_type == OP_RV2AV
6536 || cond->op_type == OP_PADAV
6537 || cond->op_type == OP_RV2HV
6538 || cond->op_type == OP_PADHV))
6540 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6543 && (cond->op_type == OP_ASLICE
6544 || cond->op_type == OP_KVASLICE
6545 || cond->op_type == OP_HSLICE
6546 || cond->op_type == OP_KVHSLICE)) {
6548 /* anonlist now needs a list from this op, was previously used in
6550 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6551 cond->op_flags |= OPf_WANT_LIST;
6553 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6560 /* These construct the optree fragments representing given()
6563 entergiven and enterwhen are LOGOPs; the op_other pointer
6564 points up to the associated leave op. We need this so we
6565 can put it in the context and make break/continue work.
6566 (Also, of course, pp_enterwhen will jump straight to
6567 op_other if the match fails.)
6571 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6572 I32 enter_opcode, I32 leave_opcode,
6573 PADOFFSET entertarg)
6579 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6581 NewOp(1101, enterop, 1, LOGOP);
6582 enterop->op_type = (Optype)enter_opcode;
6583 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6584 enterop->op_flags = (U8) OPf_KIDS;
6585 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6586 enterop->op_private = 0;
6588 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6591 enterop->op_first = scalar(cond);
6592 cond->op_sibling = block;
6594 o->op_next = LINKLIST(cond);
6595 cond->op_next = (OP *) enterop;
6598 /* This is a default {} block */
6599 enterop->op_first = block;
6600 enterop->op_flags |= OPf_SPECIAL;
6601 o ->op_flags |= OPf_SPECIAL;
6603 o->op_next = (OP *) enterop;
6606 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6607 entergiven and enterwhen both
6610 enterop->op_next = LINKLIST(block);
6611 block->op_next = enterop->op_other = o;
6616 /* Does this look like a boolean operation? For these purposes
6617 a boolean operation is:
6618 - a subroutine call [*]
6619 - a logical connective
6620 - a comparison operator
6621 - a filetest operator, with the exception of -s -M -A -C
6622 - defined(), exists() or eof()
6623 - /$re/ or $foo =~ /$re/
6625 [*] possibly surprising
6628 S_looks_like_bool(pTHX_ const OP *o)
6632 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6634 switch(o->op_type) {
6637 return looks_like_bool(cLOGOPo->op_first);
6641 looks_like_bool(cLOGOPo->op_first)
6642 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6647 o->op_flags & OPf_KIDS
6648 && looks_like_bool(cUNOPo->op_first));
6652 case OP_NOT: case OP_XOR:
6654 case OP_EQ: case OP_NE: case OP_LT:
6655 case OP_GT: case OP_LE: case OP_GE:
6657 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6658 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6660 case OP_SEQ: case OP_SNE: case OP_SLT:
6661 case OP_SGT: case OP_SLE: case OP_SGE:
6665 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6666 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6667 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6668 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6669 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6670 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6671 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6672 case OP_FTTEXT: case OP_FTBINARY:
6674 case OP_DEFINED: case OP_EXISTS:
6675 case OP_MATCH: case OP_EOF:
6682 /* Detect comparisons that have been optimized away */
6683 if (cSVOPo->op_sv == &PL_sv_yes
6684 || cSVOPo->op_sv == &PL_sv_no)
6697 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6699 Constructs, checks, and returns an op tree expressing a C<given> block.
6700 I<cond> supplies the expression that will be locally assigned to a lexical
6701 variable, and I<block> supplies the body of the C<given> construct; they
6702 are consumed by this function and become part of the constructed op tree.
6703 I<defsv_off> is the pad offset of the scalar lexical variable that will
6704 be affected. If it is 0, the global $_ will be used.
6710 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6713 PERL_ARGS_ASSERT_NEWGIVENOP;
6714 return newGIVWHENOP(
6715 ref_array_or_hash(cond),
6717 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6722 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6724 Constructs, checks, and returns an op tree expressing a C<when> block.
6725 I<cond> supplies the test expression, and I<block> supplies the block
6726 that will be executed if the test evaluates to true; they are consumed
6727 by this function and become part of the constructed op tree. I<cond>
6728 will be interpreted DWIMically, often as a comparison against C<$_>,
6729 and may be null to generate a C<default> block.
6735 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6737 const bool cond_llb = (!cond || looks_like_bool(cond));
6740 PERL_ARGS_ASSERT_NEWWHENOP;
6745 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6747 scalar(ref_array_or_hash(cond)));
6750 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6754 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6755 const STRLEN len, const U32 flags)
6757 SV *name = NULL, *msg;
6758 const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
6759 STRLEN clen = CvPROTOLEN(cv), plen = len;
6761 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6763 if (p == NULL && cvp == NULL)
6766 if (!ckWARN_d(WARN_PROTOTYPE))
6770 p = S_strip_spaces(aTHX_ p, &plen);
6771 cvp = S_strip_spaces(aTHX_ cvp, &clen);
6772 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
6773 if (plen == clen && memEQ(cvp, p, plen))
6776 if (flags & SVf_UTF8) {
6777 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
6781 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
6787 msg = sv_newmortal();
6792 gv_efullname3(name = sv_newmortal(), gv, NULL);
6793 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
6794 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
6795 else name = (SV *)gv;
6797 sv_setpvs(msg, "Prototype mismatch:");
6799 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6801 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
6802 UTF8fARG(SvUTF8(cv),clen,cvp)
6805 sv_catpvs(msg, ": none");
6806 sv_catpvs(msg, " vs ");
6808 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
6810 sv_catpvs(msg, "none");
6811 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6814 static void const_sv_xsub(pTHX_ CV* cv);
6815 static void const_av_xsub(pTHX_ CV* cv);
6819 =head1 Optree Manipulation Functions
6821 =for apidoc cv_const_sv
6823 If C<cv> is a constant sub eligible for inlining, returns the constant
6824 value returned by the sub. Otherwise, returns NULL.
6826 Constant subs can be created with C<newCONSTSUB> or as described in
6827 L<perlsub/"Constant Functions">.
6832 Perl_cv_const_sv(pTHX_ const CV *const cv)
6835 PERL_UNUSED_CONTEXT;
6838 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6840 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6841 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
6846 Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
6848 PERL_UNUSED_CONTEXT;
6851 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
6852 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6855 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6856 * Can be called in 3 ways:
6859 * look for a single OP_CONST with attached value: return the value
6861 * cv && CvCLONE(cv) && !CvCONST(cv)
6863 * examine the clone prototype, and if contains only a single
6864 * OP_CONST referencing a pad const, or a single PADSV referencing
6865 * an outer lexical, return a non-zero value to indicate the CV is
6866 * a candidate for "constizing" at clone time
6870 * We have just cloned an anon prototype that was marked as a const
6871 * candidate. Try to grab the current value, and in the case of
6872 * PADSV, ignore it if it has multiple references. In this case we
6873 * return a newly created *copy* of the value.
6877 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6885 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6886 o = cLISTOPo->op_first->op_sibling;
6888 for (; o; o = o->op_next) {
6889 const OPCODE type = o->op_type;
6891 if (sv && o->op_next == o)
6893 if (o->op_next != o) {
6894 if (type == OP_NEXTSTATE
6895 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6896 || type == OP_PUSHMARK)
6898 if (type == OP_DBSTATE)
6901 if (type == OP_LEAVESUB || type == OP_RETURN)
6905 if (type == OP_CONST && cSVOPo->op_sv)
6907 else if (cv && type == OP_CONST) {
6908 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6912 else if (cv && type == OP_PADSV) {
6913 if (CvCONST(cv)) { /* newly cloned anon */
6914 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6915 /* the candidate should have 1 ref from this pad and 1 ref
6916 * from the parent */
6917 if (!sv || SvREFCNT(sv) != 2)
6924 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6925 sv = &PL_sv_undef; /* an arbitrary non-null value */
6936 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
6937 PADNAME * const name, SV ** const const_svp)
6944 if (CvFLAGS(PL_compcv)) {
6945 /* might have had built-in attrs applied */
6946 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6947 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6948 && ckWARN(WARN_MISC))
6950 /* protect against fatal warnings leaking compcv */
6951 SAVEFREESV(PL_compcv);
6952 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6953 SvREFCNT_inc_simple_void_NN(PL_compcv);
6956 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6957 & ~(CVf_LVALUE * pureperl));
6962 /* redundant check for speed: */
6963 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
6964 const line_t oldline = CopLINE(PL_curcop);
6967 : sv_2mortal(newSVpvn_utf8(
6968 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
6970 if (PL_parser && PL_parser->copline != NOLINE)
6971 /* This ensures that warnings are reported at the first
6972 line of a redefinition, not the last. */
6973 CopLINE_set(PL_curcop, PL_parser->copline);
6974 /* protect against fatal warnings leaking compcv */
6975 SAVEFREESV(PL_compcv);
6976 report_redefined_cv(namesv, cv, const_svp);
6977 SvREFCNT_inc_simple_void_NN(PL_compcv);
6978 CopLINE_set(PL_curcop, oldline);
6985 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6991 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6994 CV *compcv = PL_compcv;
6997 PADOFFSET pax = o->op_targ;
6998 CV *outcv = CvOUTSIDE(PL_compcv);
7001 bool reusable = FALSE;
7003 PERL_ARGS_ASSERT_NEWMYSUB;
7005 /* Find the pad slot for storing the new sub.
7006 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7007 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7008 ing sub. And then we need to dig deeper if this is a lexical from
7010 my sub foo; sub { sub foo { } }
7013 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7014 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7015 pax = PARENT_PAD_INDEX(name);
7016 outcv = CvOUTSIDE(outcv);
7021 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7022 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7023 spot = (CV **)svspot;
7025 if (!(PL_parser && PL_parser->error_count))
7026 move_proto_attr(&proto, &attrs, (GV *)name);
7029 assert(proto->op_type == OP_CONST);
7030 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7031 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7041 if (PL_parser && PL_parser->error_count) {
7043 SvREFCNT_dec(PL_compcv);
7048 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7050 svspot = (SV **)(spot = &clonee);
7052 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7056 SvUPGRADE(name, SVt_PVMG);
7057 mg = mg_find(name, PERL_MAGIC_proto);
7058 assert (SvTYPE(*spot) == SVt_PVCV);
7060 hek = CvNAME_HEK(*spot);
7062 CvNAME_HEK_set(*spot, hek =
7065 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
7071 cv = (CV *)mg->mg_obj;
7074 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7075 mg = mg_find(name, PERL_MAGIC_proto);
7077 spot = (CV **)(svspot = &mg->mg_obj);
7080 if (!block || !ps || *ps || attrs
7081 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7085 const_sv = op_const_sv(block, NULL);
7088 const bool exists = CvROOT(cv) || CvXSUB(cv);
7090 /* if the subroutine doesn't exist and wasn't pre-declared
7091 * with a prototype, assume it will be AUTOLOADed,
7092 * skipping the prototype check
7094 if (exists || SvPOK(cv))
7095 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7096 /* already defined? */
7098 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7101 if (attrs) goto attrs;
7102 /* just a "sub foo;" when &foo is already defined */
7107 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7113 SvREFCNT_inc_simple_void_NN(const_sv);
7114 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7116 assert(!CvROOT(cv) && !CvCONST(cv));
7120 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7121 CvFILE_set_from_cop(cv, PL_curcop);
7122 CvSTASH_set(cv, PL_curstash);
7125 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7126 CvXSUBANY(cv).any_ptr = const_sv;
7127 CvXSUB(cv) = const_sv_xsub;
7131 SvREFCNT_dec(compcv);
7135 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7136 determine whether this sub definition is in the same scope as its
7137 declaration. If this sub definition is inside an inner named pack-
7138 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7139 the package sub. So check PadnameOUTER(name) too.
7141 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7142 assert(!CvWEAKOUTSIDE(compcv));
7143 SvREFCNT_dec(CvOUTSIDE(compcv));
7144 CvWEAKOUTSIDE_on(compcv);
7146 /* XXX else do we have a circular reference? */
7147 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7148 /* transfer PL_compcv to cv */
7151 cv_flags_t preserved_flags =
7152 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7153 PADLIST *const temp_padl = CvPADLIST(cv);
7154 CV *const temp_cv = CvOUTSIDE(cv);
7155 const cv_flags_t other_flags =
7156 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7157 OP * const cvstart = CvSTART(cv);
7161 CvFLAGS(compcv) | preserved_flags;
7162 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7163 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7164 CvPADLIST(cv) = CvPADLIST(compcv);
7165 CvOUTSIDE(compcv) = temp_cv;
7166 CvPADLIST(compcv) = temp_padl;
7167 CvSTART(cv) = CvSTART(compcv);
7168 CvSTART(compcv) = cvstart;
7169 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7170 CvFLAGS(compcv) |= other_flags;
7172 if (CvFILE(cv) && CvDYNFILE(cv)) {
7173 Safefree(CvFILE(cv));
7176 /* inner references to compcv must be fixed up ... */
7177 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7178 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7179 ++PL_sub_generation;
7182 /* Might have had built-in attributes applied -- propagate them. */
7183 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7185 /* ... before we throw it away */
7186 SvREFCNT_dec(compcv);
7187 PL_compcv = compcv = cv;
7194 if (!CvNAME_HEK(cv)) {
7197 ? share_hek_hek(hek)
7198 : share_hek(PadnamePV(name)+1,
7199 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7203 if (const_sv) goto clone;
7205 CvFILE_set_from_cop(cv, PL_curcop);
7206 CvSTASH_set(cv, PL_curstash);
7209 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7210 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7216 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7217 the debugger could be able to set a breakpoint in, so signal to
7218 pp_entereval that it should not throw away any saved lines at scope
7221 PL_breakable_sub_gen++;
7222 /* This makes sub {}; work as expected. */
7223 if (block->op_type == OP_STUB) {
7224 OP* const newblock = newSTATEOP(0, NULL, 0);
7228 CvROOT(cv) = CvLVALUE(cv)
7229 ? newUNOP(OP_LEAVESUBLV, 0,
7230 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7231 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7232 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7233 OpREFCNT_set(CvROOT(cv), 1);
7234 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7235 itself has a refcount. */
7237 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7238 CvSTART(cv) = LINKLIST(CvROOT(cv));
7239 CvROOT(cv)->op_next = 0;
7240 CALL_PEEP(CvSTART(cv));
7241 finalize_optree(CvROOT(cv));
7242 S_prune_chain_head(&CvSTART(cv));
7244 /* now that optimizer has done its work, adjust pad values */
7246 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7249 assert(!CvCONST(cv));
7250 if (ps && !*ps && op_const_sv(block, cv))
7256 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7257 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7261 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7262 SV * const tmpstr = sv_newmortal();
7263 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7264 GV_ADDMULTI, SVt_PVHV);
7266 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7269 (long)CopLINE(PL_curcop));
7270 if (HvNAME_HEK(PL_curstash)) {
7271 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7272 sv_catpvs(tmpstr, "::");
7274 else sv_setpvs(tmpstr, "__ANON__::");
7275 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7276 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7277 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7278 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7279 hv = GvHVn(db_postponed);
7280 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7281 CV * const pcv = GvCV(db_postponed);
7287 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7295 assert(CvDEPTH(outcv));
7297 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7298 if (reusable) cv_clone_into(clonee, *spot);
7299 else *spot = cv_clone(clonee);
7300 SvREFCNT_dec_NN(clonee);
7304 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7305 PADOFFSET depth = CvDEPTH(outcv);
7308 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7310 *svspot = SvREFCNT_inc_simple_NN(cv);
7311 SvREFCNT_dec(oldcv);
7317 PL_parser->copline = NOLINE;
7325 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7326 OP *block, bool o_is_gv)
7331 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7335 const bool ec = PL_parser && PL_parser->error_count;
7336 /* If the subroutine has no body, no attributes, and no builtin attributes
7337 then it's just a sub declaration, and we may be able to get away with
7338 storing with a placeholder scalar in the symbol table, rather than a
7339 full GV and CV. If anything is present then it will take a full CV to
7341 const I32 gv_fetch_flags
7342 = ec ? GV_NOADD_NOINIT :
7343 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
7344 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7346 const char * const name =
7347 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7349 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7350 #ifdef PERL_DEBUG_READONLY_OPS
7351 OPSLAB *slab = NULL;
7359 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7361 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7362 SV * const sv = sv_newmortal();
7363 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7364 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7365 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7366 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7368 } else if (PL_curstash) {
7369 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7372 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7377 move_proto_attr(&proto, &attrs, gv);
7380 assert(proto->op_type == OP_CONST);
7381 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7382 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7396 if (name) SvREFCNT_dec(PL_compcv);
7397 else cv = PL_compcv;
7399 if (name && block) {
7400 const char *s = strrchr(name, ':');
7402 if (strEQ(s, "BEGIN")) {
7403 if (PL_in_eval & EVAL_KEEPERR)
7404 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7406 SV * const errsv = ERRSV;
7407 /* force display of errors found but not reported */
7408 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7409 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7416 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
7417 maximum a prototype before. */
7418 if (SvTYPE(gv) > SVt_NULL) {
7419 cv_ckproto_len_flags((const CV *)gv,
7420 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7424 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7425 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7428 sv_setiv(MUTABLE_SV(gv), -1);
7430 SvREFCNT_dec(PL_compcv);
7431 cv = PL_compcv = NULL;
7435 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7437 if (!block || !ps || *ps || attrs
7438 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7442 const_sv = op_const_sv(block, NULL);
7445 const bool exists = CvROOT(cv) || CvXSUB(cv);
7447 /* if the subroutine doesn't exist and wasn't pre-declared
7448 * with a prototype, assume it will be AUTOLOADed,
7449 * skipping the prototype check
7451 if (exists || SvPOK(cv))
7452 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7453 /* already defined (or promised)? */
7454 if (exists || GvASSUMECV(gv)) {
7455 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7458 if (attrs) goto attrs;
7459 /* just a "sub foo;" when &foo is already defined */
7460 SAVEFREESV(PL_compcv);
7466 SvREFCNT_inc_simple_void_NN(const_sv);
7467 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7469 assert(!CvROOT(cv) && !CvCONST(cv));
7471 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7472 CvXSUBANY(cv).any_ptr = const_sv;
7473 CvXSUB(cv) = const_sv_xsub;
7479 cv = newCONSTSUB_flags(
7480 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7485 SvREFCNT_dec(PL_compcv);
7489 if (cv) { /* must reuse cv if autoloaded */
7490 /* transfer PL_compcv to cv */
7493 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7494 PADLIST *const temp_av = CvPADLIST(cv);
7495 CV *const temp_cv = CvOUTSIDE(cv);
7496 const cv_flags_t other_flags =
7497 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7498 OP * const cvstart = CvSTART(cv);
7501 assert(!CvCVGV_RC(cv));
7502 assert(CvGV(cv) == gv);
7505 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7506 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7507 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7508 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7509 CvOUTSIDE(PL_compcv) = temp_cv;
7510 CvPADLIST(PL_compcv) = temp_av;
7511 CvSTART(cv) = CvSTART(PL_compcv);
7512 CvSTART(PL_compcv) = cvstart;
7513 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7514 CvFLAGS(PL_compcv) |= other_flags;
7516 if (CvFILE(cv) && CvDYNFILE(cv)) {
7517 Safefree(CvFILE(cv));
7519 CvFILE_set_from_cop(cv, PL_curcop);
7520 CvSTASH_set(cv, PL_curstash);
7522 /* inner references to PL_compcv must be fixed up ... */
7523 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7524 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7525 ++PL_sub_generation;
7528 /* Might have had built-in attributes applied -- propagate them. */
7529 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7531 /* ... before we throw it away */
7532 SvREFCNT_dec(PL_compcv);
7540 if (HvENAME_HEK(GvSTASH(gv)))
7541 /* sub Foo::bar { (shift)+1 } */
7542 gv_method_changed(gv);
7547 CvFILE_set_from_cop(cv, PL_curcop);
7548 CvSTASH_set(cv, PL_curstash);
7552 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7553 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7559 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7560 the debugger could be able to set a breakpoint in, so signal to
7561 pp_entereval that it should not throw away any saved lines at scope
7564 PL_breakable_sub_gen++;
7565 /* This makes sub {}; work as expected. */
7566 if (block->op_type == OP_STUB) {
7567 OP* const newblock = newSTATEOP(0, NULL, 0);
7571 CvROOT(cv) = CvLVALUE(cv)
7572 ? newUNOP(OP_LEAVESUBLV, 0,
7573 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7574 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7575 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7576 OpREFCNT_set(CvROOT(cv), 1);
7577 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7578 itself has a refcount. */
7580 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7581 #ifdef PERL_DEBUG_READONLY_OPS
7582 slab = (OPSLAB *)CvSTART(cv);
7584 CvSTART(cv) = LINKLIST(CvROOT(cv));
7585 CvROOT(cv)->op_next = 0;
7586 CALL_PEEP(CvSTART(cv));
7587 finalize_optree(CvROOT(cv));
7588 S_prune_chain_head(&CvSTART(cv));
7590 /* now that optimizer has done its work, adjust pad values */
7592 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7595 assert(!CvCONST(cv));
7596 if (ps && !*ps && op_const_sv(block, cv))
7602 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7603 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7604 if (!name) SAVEFREESV(cv);
7605 apply_attrs(stash, MUTABLE_SV(cv), attrs);
7606 if (!name) SvREFCNT_inc_simple_void_NN(cv);
7609 if (block && has_name) {
7610 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7611 SV * const tmpstr = sv_newmortal();
7612 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7613 GV_ADDMULTI, SVt_PVHV);
7615 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7618 (long)CopLINE(PL_curcop));
7619 gv_efullname3(tmpstr, gv, NULL);
7620 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7621 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7622 hv = GvHVn(db_postponed);
7623 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7624 CV * const pcv = GvCV(db_postponed);
7630 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7635 if (name && ! (PL_parser && PL_parser->error_count))
7636 process_special_blocks(floor, name, gv, cv);
7641 PL_parser->copline = NOLINE;
7643 #ifdef PERL_DEBUG_READONLY_OPS
7644 /* Watch out for BEGIN blocks */
7645 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7651 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7655 const char *const colon = strrchr(fullname,':');
7656 const char *const name = colon ? colon + 1 : fullname;
7658 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7661 if (strEQ(name, "BEGIN")) {
7662 const I32 oldscope = PL_scopestack_ix;
7664 if (floor) LEAVE_SCOPE(floor);
7666 PUSHSTACKi(PERLSI_REQUIRE);
7667 SAVECOPFILE(&PL_compiling);
7668 SAVECOPLINE(&PL_compiling);
7669 SAVEVPTR(PL_curcop);
7671 DEBUG_x( dump_sub(gv) );
7672 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7673 GvCV_set(gv,0); /* cv has been hijacked */
7674 call_list(oldscope, PL_beginav);
7683 if strEQ(name, "END") {
7684 DEBUG_x( dump_sub(gv) );
7685 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7688 } else if (*name == 'U') {
7689 if (strEQ(name, "UNITCHECK")) {
7690 /* It's never too late to run a unitcheck block */
7691 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7695 } else if (*name == 'C') {
7696 if (strEQ(name, "CHECK")) {
7698 /* diag_listed_as: Too late to run %s block */
7699 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7700 "Too late to run CHECK block");
7701 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7705 } else if (*name == 'I') {
7706 if (strEQ(name, "INIT")) {
7708 /* diag_listed_as: Too late to run %s block */
7709 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7710 "Too late to run INIT block");
7711 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7717 DEBUG_x( dump_sub(gv) );
7718 GvCV_set(gv,0); /* cv has been hijacked */
7723 =for apidoc newCONSTSUB
7725 See L</newCONSTSUB_flags>.
7731 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7733 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7737 =for apidoc newCONSTSUB_flags
7739 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7740 eligible for inlining at compile-time.
7742 Currently, the only useful value for C<flags> is SVf_UTF8.
7744 The newly created subroutine takes ownership of a reference to the passed in
7747 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7748 which won't be called if used as a destructor, but will suppress the overhead
7749 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7756 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7761 const char *const file = CopFILE(PL_curcop);
7765 if (IN_PERL_RUNTIME) {
7766 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7767 * an op shared between threads. Use a non-shared COP for our
7769 SAVEVPTR(PL_curcop);
7770 SAVECOMPILEWARNINGS();
7771 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7772 PL_curcop = &PL_compiling;
7774 SAVECOPLINE(PL_curcop);
7775 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7778 PL_hints &= ~HINT_BLOCK_SCOPE;
7781 SAVEGENERICSV(PL_curstash);
7782 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7785 /* Protect sv against leakage caused by fatal warnings. */
7786 if (sv) SAVEFREESV(sv);
7788 /* file becomes the CvFILE. For an XS, it's usually static storage,
7789 and so doesn't get free()d. (It's expected to be from the C pre-
7790 processor __FILE__ directive). But we need a dynamically allocated one,
7791 and we need it to get freed. */
7792 cv = newXS_len_flags(name, len,
7793 sv && SvTYPE(sv) == SVt_PVAV
7796 file ? file : "", "",
7797 &sv, XS_DYNAMIC_FILENAME | flags);
7798 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
7807 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7808 const char *const filename, const char *const proto,
7811 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7812 return newXS_len_flags(
7813 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7818 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7819 XSUBADDR_t subaddr, const char *const filename,
7820 const char *const proto, SV **const_svp,
7824 bool interleave = FALSE;
7826 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7829 GV * const gv = gv_fetchpvn(
7830 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7831 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
7832 sizeof("__ANON__::__ANON__") - 1,
7833 GV_ADDMULTI | flags, SVt_PVCV);
7836 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7838 if ((cv = (name ? GvCV(gv) : NULL))) {
7840 /* just a cached method */
7844 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7845 /* already defined (or promised) */
7846 /* Redundant check that allows us to avoid creating an SV
7847 most of the time: */
7848 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7849 report_redefined_cv(newSVpvn_flags(
7850 name,len,(flags&SVf_UTF8)|SVs_TEMP
7861 if (cv) /* must reuse cv if autoloaded */
7864 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7868 if (HvENAME_HEK(GvSTASH(gv)))
7869 gv_method_changed(gv); /* newXS */
7875 (void)gv_fetchfile(filename);
7876 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7877 an external constant string */
7878 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7880 CvXSUB(cv) = subaddr;
7883 process_special_blocks(0, name, gv, cv);
7886 if (flags & XS_DYNAMIC_FILENAME) {
7887 CvFILE(cv) = savepv(filename);
7890 sv_setpv(MUTABLE_SV(cv), proto);
7891 if (interleave) LEAVE;
7896 Perl_newSTUB(pTHX_ GV *gv, bool fake)
7898 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7900 PERL_ARGS_ASSERT_NEWSTUB;
7904 if (!fake && HvENAME_HEK(GvSTASH(gv)))
7905 gv_method_changed(gv);
7907 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
7912 CvFILE_set_from_cop(cv, PL_curcop);
7913 CvSTASH_set(cv, PL_curstash);
7919 =for apidoc U||newXS
7921 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7922 static storage, as it is used directly as CvFILE(), without a copy being made.
7928 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7930 PERL_ARGS_ASSERT_NEWXS;
7931 return newXS_len_flags(
7932 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7937 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7944 if (PL_parser && PL_parser->error_count) {
7950 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7951 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7954 if ((cv = GvFORM(gv))) {
7955 if (ckWARN(WARN_REDEFINE)) {
7956 const line_t oldline = CopLINE(PL_curcop);
7957 if (PL_parser && PL_parser->copline != NOLINE)
7958 CopLINE_set(PL_curcop, PL_parser->copline);
7960 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7961 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7963 /* diag_listed_as: Format %s redefined */
7964 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7965 "Format STDOUT redefined");
7967 CopLINE_set(PL_curcop, oldline);
7972 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
7974 CvFILE_set_from_cop(cv, PL_curcop);
7977 pad_tidy(padtidy_FORMAT);
7978 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7979 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7980 OpREFCNT_set(CvROOT(cv), 1);
7981 CvSTART(cv) = LINKLIST(CvROOT(cv));
7982 CvROOT(cv)->op_next = 0;
7983 CALL_PEEP(CvSTART(cv));
7984 finalize_optree(CvROOT(cv));
7985 S_prune_chain_head(&CvSTART(cv));
7991 PL_parser->copline = NOLINE;
7996 Perl_newANONLIST(pTHX_ OP *o)
7998 return convert(OP_ANONLIST, OPf_SPECIAL, o);
8002 Perl_newANONHASH(pTHX_ OP *o)
8004 return convert(OP_ANONHASH, OPf_SPECIAL, o);
8008 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8010 return newANONATTRSUB(floor, proto, NULL, block);
8014 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8016 return newUNOP(OP_REFGEN, 0,
8017 newSVOP(OP_ANONCODE, 0,
8018 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8022 Perl_oopsAV(pTHX_ OP *o)
8026 PERL_ARGS_ASSERT_OOPSAV;
8028 switch (o->op_type) {
8031 o->op_type = OP_PADAV;
8032 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8033 return ref(o, OP_RV2AV);
8037 o->op_type = OP_RV2AV;
8038 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8043 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8050 Perl_oopsHV(pTHX_ OP *o)
8054 PERL_ARGS_ASSERT_OOPSHV;
8056 switch (o->op_type) {
8059 o->op_type = OP_PADHV;
8060 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8061 return ref(o, OP_RV2HV);
8065 o->op_type = OP_RV2HV;
8066 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8071 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8078 Perl_newAVREF(pTHX_ OP *o)
8082 PERL_ARGS_ASSERT_NEWAVREF;
8084 if (o->op_type == OP_PADANY) {
8085 o->op_type = OP_PADAV;
8086 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8089 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8090 Perl_croak(aTHX_ "Can't use an array as a reference");
8092 return newUNOP(OP_RV2AV, 0, scalar(o));
8096 Perl_newGVREF(pTHX_ I32 type, OP *o)
8098 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8099 return newUNOP(OP_NULL, 0, o);
8100 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8104 Perl_newHVREF(pTHX_ OP *o)
8108 PERL_ARGS_ASSERT_NEWHVREF;
8110 if (o->op_type == OP_PADANY) {
8111 o->op_type = OP_PADHV;
8112 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8115 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8116 Perl_croak(aTHX_ "Can't use a hash as a reference");
8118 return newUNOP(OP_RV2HV, 0, scalar(o));
8122 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8124 if (o->op_type == OP_PADANY) {
8126 o->op_type = OP_PADCV;
8127 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8129 return newUNOP(OP_RV2CV, flags, scalar(o));
8133 Perl_newSVREF(pTHX_ OP *o)
8137 PERL_ARGS_ASSERT_NEWSVREF;
8139 if (o->op_type == OP_PADANY) {
8140 o->op_type = OP_PADSV;
8141 o->op_ppaddr = PL_ppaddr[OP_PADSV];
8144 return newUNOP(OP_RV2SV, 0, scalar(o));
8147 /* Check routines. See the comments at the top of this file for details
8148 * on when these are called */
8151 Perl_ck_anoncode(pTHX_ OP *o)
8153 PERL_ARGS_ASSERT_CK_ANONCODE;
8155 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8156 cSVOPo->op_sv = NULL;
8161 S_io_hints(pTHX_ OP *o)
8163 #if O_BINARY != 0 || O_TEXT != 0
8165 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8167 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8170 const char *d = SvPV_const(*svp, len);
8171 const I32 mode = mode_from_discipline(d, len);
8172 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8174 if (mode & O_BINARY)
8175 o->op_private |= OPpOPEN_IN_RAW;
8179 o->op_private |= OPpOPEN_IN_CRLF;
8183 svp = hv_fetchs(table, "open_OUT", FALSE);
8186 const char *d = SvPV_const(*svp, len);
8187 const I32 mode = mode_from_discipline(d, len);
8188 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8190 if (mode & O_BINARY)
8191 o->op_private |= OPpOPEN_OUT_RAW;
8195 o->op_private |= OPpOPEN_OUT_CRLF;
8200 PERL_UNUSED_CONTEXT;
8206 Perl_ck_backtick(pTHX_ OP *o)
8210 PERL_ARGS_ASSERT_CK_BACKTICK;
8211 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8212 if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling
8213 && (gv = gv_override("readpipe",8))) {
8214 newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling);
8215 cUNOPo->op_first->op_sibling = NULL;
8217 else if (!(o->op_flags & OPf_KIDS))
8218 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8223 S_io_hints(aTHX_ o);
8228 Perl_ck_bitop(pTHX_ OP *o)
8232 PERL_ARGS_ASSERT_CK_BITOP;
8234 o->op_private = (U8)(PL_hints & HINT_INTEGER);
8235 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8236 && (o->op_type == OP_BIT_OR
8237 || o->op_type == OP_BIT_AND
8238 || o->op_type == OP_BIT_XOR))
8240 const OP * const left = cBINOPo->op_first;
8241 const OP * const right = left->op_sibling;
8242 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8243 (left->op_flags & OPf_PARENS) == 0) ||
8244 (OP_IS_NUMCOMPARE(right->op_type) &&
8245 (right->op_flags & OPf_PARENS) == 0))
8246 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8247 "Possible precedence problem on bitwise %c operator",
8248 o->op_type == OP_BIT_OR ? '|'
8249 : o->op_type == OP_BIT_AND ? '&' : '^'
8255 PERL_STATIC_INLINE bool
8256 is_dollar_bracket(pTHX_ const OP * const o)
8259 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8260 && (kid = cUNOPx(o)->op_first)
8261 && kid->op_type == OP_GV
8262 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8266 Perl_ck_cmp(pTHX_ OP *o)
8268 PERL_ARGS_ASSERT_CK_CMP;
8269 if (ckWARN(WARN_SYNTAX)) {
8270 const OP *kid = cUNOPo->op_first;
8273 is_dollar_bracket(aTHX_ kid)
8274 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8276 || ( kid->op_type == OP_CONST
8277 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8279 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8280 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8286 Perl_ck_concat(pTHX_ OP *o)
8288 const OP * const kid = cUNOPo->op_first;
8290 PERL_ARGS_ASSERT_CK_CONCAT;
8291 PERL_UNUSED_CONTEXT;
8293 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8294 !(kUNOP->op_first->op_flags & OPf_MOD))
8295 o->op_flags |= OPf_STACKED;
8300 Perl_ck_spair(pTHX_ OP *o)
8304 PERL_ARGS_ASSERT_CK_SPAIR;
8306 if (o->op_flags & OPf_KIDS) {
8309 const OPCODE type = o->op_type;
8310 o = modkids(ck_fun(o), type);
8311 kid = cUNOPo->op_first;
8312 newop = kUNOP->op_first->op_sibling;
8314 const OPCODE type = newop->op_type;
8315 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8316 type == OP_PADAV || type == OP_PADHV ||
8317 type == OP_RV2AV || type == OP_RV2HV)
8320 op_free(kUNOP->op_first);
8321 kUNOP->op_first = newop;
8323 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8324 * and OP_CHOMP into OP_SCHOMP */
8325 o->op_ppaddr = PL_ppaddr[++o->op_type];
8330 Perl_ck_delete(pTHX_ OP *o)
8332 PERL_ARGS_ASSERT_CK_DELETE;
8336 if (o->op_flags & OPf_KIDS) {
8337 OP * const kid = cUNOPo->op_first;
8338 switch (kid->op_type) {
8340 o->op_flags |= OPf_SPECIAL;
8343 o->op_private |= OPpSLICE;
8346 o->op_flags |= OPf_SPECIAL;
8351 Perl_croak(aTHX_ "delete argument is index/value array slice,"
8352 " use array slice");
8354 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8357 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8358 "element or slice");
8360 if (kid->op_private & OPpLVAL_INTRO)
8361 o->op_private |= OPpLVAL_INTRO;
8368 Perl_ck_eof(pTHX_ OP *o)
8372 PERL_ARGS_ASSERT_CK_EOF;
8374 if (o->op_flags & OPf_KIDS) {
8376 if (cLISTOPo->op_first->op_type == OP_STUB) {
8378 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8383 kid = cLISTOPo->op_first;
8384 if (kid->op_type == OP_RV2GV)
8385 kid->op_private |= OPpALLOW_FAKE;
8391 Perl_ck_eval(pTHX_ OP *o)
8395 PERL_ARGS_ASSERT_CK_EVAL;
8397 PL_hints |= HINT_BLOCK_SCOPE;
8398 if (o->op_flags & OPf_KIDS) {
8399 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8402 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8405 cUNOPo->op_first = 0;
8408 NewOp(1101, enter, 1, LOGOP);
8409 enter->op_type = OP_ENTERTRY;
8410 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8411 enter->op_private = 0;
8413 /* establish postfix order */
8414 enter->op_next = (OP*)enter;
8416 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8417 o->op_type = OP_LEAVETRY;
8418 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8419 enter->op_other = o;
8428 const U8 priv = o->op_private;
8430 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8432 o->op_targ = (PADOFFSET)PL_hints;
8433 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8434 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8435 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8436 /* Store a copy of %^H that pp_entereval can pick up. */
8437 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8438 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8439 cUNOPo->op_first->op_sibling = hhop;
8440 o->op_private |= OPpEVAL_HAS_HH;
8442 if (!(o->op_private & OPpEVAL_BYTES)
8443 && FEATURE_UNIEVAL_IS_ENABLED)
8444 o->op_private |= OPpEVAL_UNICODE;
8449 Perl_ck_exec(pTHX_ OP *o)
8451 PERL_ARGS_ASSERT_CK_EXEC;
8453 if (o->op_flags & OPf_STACKED) {
8456 kid = cUNOPo->op_first->op_sibling;
8457 if (kid->op_type == OP_RV2GV)
8466 Perl_ck_exists(pTHX_ OP *o)
8470 PERL_ARGS_ASSERT_CK_EXISTS;
8473 if (o->op_flags & OPf_KIDS) {
8474 OP * const kid = cUNOPo->op_first;
8475 if (kid->op_type == OP_ENTERSUB) {
8476 (void) ref(kid, o->op_type);
8477 if (kid->op_type != OP_RV2CV
8478 && !(PL_parser && PL_parser->error_count))
8480 "exists argument is not a subroutine name");
8481 o->op_private |= OPpEXISTS_SUB;
8483 else if (kid->op_type == OP_AELEM)
8484 o->op_flags |= OPf_SPECIAL;
8485 else if (kid->op_type != OP_HELEM)
8486 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8487 "element or a subroutine");
8494 Perl_ck_rvconst(pTHX_ OP *o)
8497 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8499 PERL_ARGS_ASSERT_CK_RVCONST;
8501 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8502 if (o->op_type == OP_RV2CV)
8503 o->op_private &= ~1;
8505 if (kid->op_type == OP_CONST) {
8508 SV * const kidsv = kid->op_sv;
8510 /* Is it a constant from cv_const_sv()? */
8511 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8512 SV * const rsv = SvRV(kidsv);
8513 const svtype type = SvTYPE(rsv);
8514 const char *badtype = NULL;
8516 switch (o->op_type) {
8518 if (type > SVt_PVMG)
8519 badtype = "a SCALAR";
8522 if (type != SVt_PVAV)
8523 badtype = "an ARRAY";
8526 if (type != SVt_PVHV)
8530 if (type != SVt_PVCV)
8535 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8538 if (SvTYPE(kidsv) == SVt_PVAV) return o;
8539 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8540 const char *badthing;
8541 switch (o->op_type) {
8543 badthing = "a SCALAR";
8546 badthing = "an ARRAY";
8549 badthing = "a HASH";
8557 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8558 SVfARG(kidsv), badthing);
8561 * This is a little tricky. We only want to add the symbol if we
8562 * didn't add it in the lexer. Otherwise we get duplicate strict
8563 * warnings. But if we didn't add it in the lexer, we must at
8564 * least pretend like we wanted to add it even if it existed before,
8565 * or we get possible typo warnings. OPpCONST_ENTERED says
8566 * whether the lexer already added THIS instance of this symbol.
8568 iscv = (o->op_type == OP_RV2CV) * 2;
8570 gv = gv_fetchsv(kidsv,
8571 iscv | !(kid->op_private & OPpCONST_ENTERED),
8574 : o->op_type == OP_RV2SV
8576 : o->op_type == OP_RV2AV
8578 : o->op_type == OP_RV2HV
8581 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8583 kid->op_type = OP_GV;
8584 SvREFCNT_dec(kid->op_sv);
8586 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8587 assert (sizeof(PADOP) <= sizeof(SVOP));
8588 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8589 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8591 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8593 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8595 kid->op_private = 0;
8596 kid->op_ppaddr = PL_ppaddr[OP_GV];
8597 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8605 Perl_ck_ftst(pTHX_ OP *o)
8608 const I32 type = o->op_type;
8610 PERL_ARGS_ASSERT_CK_FTST;
8612 if (o->op_flags & OPf_REF) {
8615 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8616 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8617 const OPCODE kidtype = kid->op_type;
8619 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8620 && !kid->op_folded) {
8621 OP * const newop = newGVOP(type, OPf_REF,
8622 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8626 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8627 o->op_private |= OPpFT_ACCESS;
8628 if (PL_check[kidtype] == Perl_ck_ftst
8629 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8630 o->op_private |= OPpFT_STACKED;
8631 kid->op_private |= OPpFT_STACKING;
8632 if (kidtype == OP_FTTTY && (
8633 !(kid->op_private & OPpFT_STACKED)
8634 || kid->op_private & OPpFT_AFTER_t
8636 o->op_private |= OPpFT_AFTER_t;
8641 if (type == OP_FTTTY)
8642 o = newGVOP(type, OPf_REF, PL_stdingv);
8644 o = newUNOP(type, 0, newDEFSVOP());
8650 Perl_ck_fun(pTHX_ OP *o)
8653 const int type = o->op_type;
8654 I32 oa = PL_opargs[type] >> OASHIFT;
8656 PERL_ARGS_ASSERT_CK_FUN;
8658 if (o->op_flags & OPf_STACKED) {
8659 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8662 return no_fh_allowed(o);
8665 if (o->op_flags & OPf_KIDS) {
8666 OP **tokid = &cLISTOPo->op_first;
8667 OP *kid = cLISTOPo->op_first;
8670 bool seen_optional = FALSE;
8672 if (kid->op_type == OP_PUSHMARK ||
8673 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8675 tokid = &kid->op_sibling;
8676 kid = kid->op_sibling;
8678 if (kid && kid->op_type == OP_COREARGS) {
8679 bool optional = FALSE;
8682 if (oa & OA_OPTIONAL) optional = TRUE;
8685 if (optional) o->op_private |= numargs;
8690 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8691 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8692 *tokid = kid = newDEFSVOP();
8693 seen_optional = TRUE;
8698 sibl = kid->op_sibling;
8701 /* list seen where single (scalar) arg expected? */
8702 if (numargs == 1 && !(oa >> 4)
8703 && kid->op_type == OP_LIST && type != OP_SCALAR)
8705 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8707 if (type != OP_DELETE) scalar(kid);
8718 if ((type == OP_PUSH || type == OP_UNSHIFT)
8719 && !kid->op_sibling)
8720 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8721 "Useless use of %s with no values",
8724 if (kid->op_type == OP_CONST
8725 && ( !SvROK(cSVOPx_sv(kid))
8726 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8728 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8729 /* Defer checks to run-time if we have a scalar arg */
8730 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8731 op_lvalue(kid, type);
8734 /* diag_listed_as: push on reference is experimental */
8735 Perl_ck_warner_d(aTHX_
8736 packWARN(WARN_EXPERIMENTAL__AUTODEREF),
8737 "%s on reference is experimental",
8742 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8743 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8744 op_lvalue(kid, type);
8748 OP * const newop = newUNOP(OP_NULL, 0, kid);
8749 kid->op_sibling = 0;
8750 newop->op_next = newop;
8752 kid->op_sibling = sibl;
8757 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8758 if (kid->op_type == OP_CONST &&
8759 (kid->op_private & OPpCONST_BARE))
8761 OP * const newop = newGVOP(OP_GV, 0,
8762 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8763 if (!(o->op_private & 1) && /* if not unop */
8764 kid == cLISTOPo->op_last)
8765 cLISTOPo->op_last = newop;
8769 else if (kid->op_type == OP_READLINE) {
8770 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8771 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8774 I32 flags = OPf_SPECIAL;
8778 /* is this op a FH constructor? */
8779 if (is_handle_constructor(o,numargs)) {
8780 const char *name = NULL;
8783 bool want_dollar = TRUE;
8786 /* Set a flag to tell rv2gv to vivify
8787 * need to "prove" flag does not mean something
8788 * else already - NI-S 1999/05/07
8791 if (kid->op_type == OP_PADSV) {
8793 = PAD_COMPNAME_SV(kid->op_targ);
8794 name = SvPV_const(namesv, len);
8795 name_utf8 = SvUTF8(namesv);
8797 else if (kid->op_type == OP_RV2SV
8798 && kUNOP->op_first->op_type == OP_GV)
8800 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8802 len = GvNAMELEN(gv);
8803 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8805 else if (kid->op_type == OP_AELEM
8806 || kid->op_type == OP_HELEM)
8809 OP *op = ((BINOP*)kid)->op_first;
8813 const char * const a =
8814 kid->op_type == OP_AELEM ?
8816 if (((op->op_type == OP_RV2AV) ||
8817 (op->op_type == OP_RV2HV)) &&
8818 (firstop = ((UNOP*)op)->op_first) &&
8819 (firstop->op_type == OP_GV)) {
8820 /* packagevar $a[] or $h{} */
8821 GV * const gv = cGVOPx_gv(firstop);
8829 else if (op->op_type == OP_PADAV
8830 || op->op_type == OP_PADHV) {
8831 /* lexicalvar $a[] or $h{} */
8832 const char * const padname =
8833 PAD_COMPNAME_PV(op->op_targ);
8842 name = SvPV_const(tmpstr, len);
8843 name_utf8 = SvUTF8(tmpstr);
8848 name = "__ANONIO__";
8850 want_dollar = FALSE;
8852 op_lvalue(kid, type);
8856 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
8857 namesv = PAD_SVl(targ);
8858 if (want_dollar && *name != '$')
8859 sv_setpvs(namesv, "$");
8861 sv_setpvs(namesv, "");
8862 sv_catpvn(namesv, name, len);
8863 if ( name_utf8 ) SvUTF8_on(namesv);
8866 kid->op_sibling = 0;
8867 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8868 kid->op_targ = targ;
8869 kid->op_private |= priv;
8871 kid->op_sibling = sibl;
8877 if ((type == OP_UNDEF || type == OP_POS)
8878 && numargs == 1 && !(oa >> 4)
8879 && kid->op_type == OP_LIST)
8880 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8881 op_lvalue(scalar(kid), type);
8885 tokid = &kid->op_sibling;
8886 kid = kid->op_sibling;
8888 /* FIXME - should the numargs or-ing move after the too many
8889 * arguments check? */
8890 o->op_private |= numargs;
8892 return too_many_arguments_pv(o,OP_DESC(o), 0);
8895 else if (PL_opargs[type] & OA_DEFGV) {
8896 /* Ordering of these two is important to keep f_map.t passing. */
8898 return newUNOP(type, 0, newDEFSVOP());
8902 while (oa & OA_OPTIONAL)
8904 if (oa && oa != OA_LIST)
8905 return too_few_arguments_pv(o,OP_DESC(o), 0);
8911 Perl_ck_glob(pTHX_ OP *o)
8916 PERL_ARGS_ASSERT_CK_GLOB;
8919 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8920 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8922 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
8926 * \ null - const(wildcard)
8931 * \ mark - glob - rv2cv
8932 * | \ gv(CORE::GLOBAL::glob)
8934 * \ null - const(wildcard)
8936 o->op_flags |= OPf_SPECIAL;
8937 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8938 o = S_new_entersubop(aTHX_ gv, o);
8939 o = newUNOP(OP_NULL, 0, o);
8940 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8943 else o->op_flags &= ~OPf_SPECIAL;
8944 #if !defined(PERL_EXTERNAL_GLOB)
8947 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8948 newSVpvs("File::Glob"), NULL, NULL, NULL);
8951 #endif /* !PERL_EXTERNAL_GLOB */
8952 gv = (GV *)newSV(0);
8953 gv_init(gv, 0, "", 0, 0);
8955 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8956 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
8962 Perl_ck_grep(pTHX_ OP *o)
8967 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8970 PERL_ARGS_ASSERT_CK_GREP;
8972 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8973 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8975 if (o->op_flags & OPf_STACKED) {
8976 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8977 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8978 return no_fh_allowed(o);
8979 o->op_flags &= ~OPf_STACKED;
8981 kid = cLISTOPo->op_first->op_sibling;
8982 if (type == OP_MAPWHILE)
8987 if (PL_parser && PL_parser->error_count)
8989 kid = cLISTOPo->op_first->op_sibling;
8990 if (kid->op_type != OP_NULL)
8991 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8992 kid = kUNOP->op_first;
8994 NewOp(1101, gwop, 1, LOGOP);
8995 gwop->op_type = type;
8996 gwop->op_ppaddr = PL_ppaddr[type];
8998 gwop->op_flags |= OPf_KIDS;
8999 gwop->op_other = LINKLIST(kid);
9000 kid->op_next = (OP*)gwop;
9001 offset = pad_findmy_pvs("$_", 0);
9002 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9003 o->op_private = gwop->op_private = 0;
9004 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9007 o->op_private = gwop->op_private = OPpGREP_LEX;
9008 gwop->op_targ = o->op_targ = offset;
9011 kid = cLISTOPo->op_first->op_sibling;
9012 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
9013 op_lvalue(kid, OP_GREPSTART);
9019 Perl_ck_index(pTHX_ OP *o)
9021 PERL_ARGS_ASSERT_CK_INDEX;
9023 if (o->op_flags & OPf_KIDS) {
9024 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9026 kid = kid->op_sibling; /* get past "big" */
9027 if (kid && kid->op_type == OP_CONST) {
9028 const bool save_taint = TAINT_get;
9029 SV *sv = kSVOP->op_sv;
9030 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9032 sv_copypv(sv, kSVOP->op_sv);
9033 SvREFCNT_dec_NN(kSVOP->op_sv);
9036 if (SvOK(sv)) fbm_compile(sv, 0);
9037 TAINT_set(save_taint);
9038 #ifdef NO_TAINT_SUPPORT
9039 PERL_UNUSED_VAR(save_taint);
9047 Perl_ck_lfun(pTHX_ OP *o)
9049 const OPCODE type = o->op_type;
9051 PERL_ARGS_ASSERT_CK_LFUN;
9053 return modkids(ck_fun(o), type);
9057 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
9059 PERL_ARGS_ASSERT_CK_DEFINED;
9061 if ((o->op_flags & OPf_KIDS)) {
9062 switch (cUNOPo->op_first->op_type) {
9065 case OP_AASSIGN: /* Is this a good idea? */
9066 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
9067 " (Maybe you should just omit the defined()?)");
9071 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
9072 " (Maybe you should just omit the defined()?)");
9083 Perl_ck_readline(pTHX_ OP *o)
9085 PERL_ARGS_ASSERT_CK_READLINE;
9087 if (o->op_flags & OPf_KIDS) {
9088 OP *kid = cLISTOPo->op_first;
9089 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9093 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9101 Perl_ck_rfun(pTHX_ OP *o)
9103 const OPCODE type = o->op_type;
9105 PERL_ARGS_ASSERT_CK_RFUN;
9107 return refkids(ck_fun(o), type);
9111 Perl_ck_listiob(pTHX_ OP *o)
9115 PERL_ARGS_ASSERT_CK_LISTIOB;
9117 kid = cLISTOPo->op_first;
9120 kid = cLISTOPo->op_first;
9122 if (kid->op_type == OP_PUSHMARK)
9123 kid = kid->op_sibling;
9124 if (kid && o->op_flags & OPf_STACKED)
9125 kid = kid->op_sibling;
9126 else if (kid && !kid->op_sibling) { /* print HANDLE; */
9127 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9128 && !kid->op_folded) {
9129 o->op_flags |= OPf_STACKED; /* make it a filehandle */
9130 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9131 cLISTOPo->op_first->op_sibling = kid;
9132 cLISTOPo->op_last = kid;
9133 kid = kid->op_sibling;
9138 op_append_elem(o->op_type, o, newDEFSVOP());
9140 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9145 Perl_ck_smartmatch(pTHX_ OP *o)
9148 PERL_ARGS_ASSERT_CK_SMARTMATCH;
9149 if (0 == (o->op_flags & OPf_SPECIAL)) {
9150 OP *first = cBINOPo->op_first;
9151 OP *second = first->op_sibling;
9153 /* Implicitly take a reference to an array or hash */
9154 first->op_sibling = NULL;
9155 first = cBINOPo->op_first = ref_array_or_hash(first);
9156 second = first->op_sibling = ref_array_or_hash(second);
9158 /* Implicitly take a reference to a regular expression */
9159 if (first->op_type == OP_MATCH) {
9160 first->op_type = OP_QR;
9161 first->op_ppaddr = PL_ppaddr[OP_QR];
9163 if (second->op_type == OP_MATCH) {
9164 second->op_type = OP_QR;
9165 second->op_ppaddr = PL_ppaddr[OP_QR];
9174 Perl_ck_sassign(pTHX_ OP *o)
9177 OP * const kid = cLISTOPo->op_first;
9179 PERL_ARGS_ASSERT_CK_SASSIGN;
9181 /* has a disposable target? */
9182 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9183 && !(kid->op_flags & OPf_STACKED)
9184 /* Cannot steal the second time! */
9185 && !(kid->op_private & OPpTARGET_MY)
9188 OP * const kkid = kid->op_sibling;
9190 /* Can just relocate the target. */
9191 if (kkid && kkid->op_type == OP_PADSV
9192 && !(kkid->op_private & OPpLVAL_INTRO))
9194 kid->op_targ = kkid->op_targ;
9196 /* Now we do not need PADSV and SASSIGN. */
9197 kid->op_sibling = o->op_sibling; /* NULL */
9198 cLISTOPo->op_first = NULL;
9201 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9205 if (kid->op_sibling) {
9206 OP *kkid = kid->op_sibling;
9207 /* For state variable assignment, kkid is a list op whose op_last
9209 if ((kkid->op_type == OP_PADSV ||
9210 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
9211 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9214 && (kkid->op_private & OPpLVAL_INTRO)
9215 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9216 const PADOFFSET target = kkid->op_targ;
9217 OP *const other = newOP(OP_PADSV,
9219 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9220 OP *const first = newOP(OP_NULL, 0);
9221 OP *const nullop = newCONDOP(0, first, o, other);
9222 OP *const condop = first->op_next;
9223 /* hijacking PADSTALE for uninitialized state variables */
9224 SvPADSTALE_on(PAD_SVl(target));
9226 condop->op_type = OP_ONCE;
9227 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9228 condop->op_targ = target;
9229 other->op_targ = target;
9231 /* Because we change the type of the op here, we will skip the
9232 assignment binop->op_last = binop->op_first->op_sibling; at the
9233 end of Perl_newBINOP(). So need to do it here. */
9234 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9243 Perl_ck_match(pTHX_ OP *o)
9247 PERL_ARGS_ASSERT_CK_MATCH;
9249 if (o->op_type != OP_QR && PL_compcv) {
9250 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9251 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9252 o->op_targ = offset;
9253 o->op_private |= OPpTARGET_MY;
9256 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9257 o->op_private |= OPpRUNTIME;
9262 Perl_ck_method(pTHX_ OP *o)
9264 OP * const kid = cUNOPo->op_first;
9266 PERL_ARGS_ASSERT_CK_METHOD;
9268 if (kid->op_type == OP_CONST) {
9269 SV* sv = kSVOP->op_sv;
9270 const char * const method = SvPVX_const(sv);
9271 if (!(strchr(method, ':') || strchr(method, '\''))) {
9273 if (!SvIsCOW_shared_hash(sv)) {
9274 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9277 kSVOP->op_sv = NULL;
9279 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9288 Perl_ck_null(pTHX_ OP *o)
9290 PERL_ARGS_ASSERT_CK_NULL;
9291 PERL_UNUSED_CONTEXT;
9296 Perl_ck_open(pTHX_ OP *o)
9300 PERL_ARGS_ASSERT_CK_OPEN;
9302 S_io_hints(aTHX_ o);
9304 /* In case of three-arg dup open remove strictness
9305 * from the last arg if it is a bareword. */
9306 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9307 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
9311 if ((last->op_type == OP_CONST) && /* The bareword. */
9312 (last->op_private & OPpCONST_BARE) &&
9313 (last->op_private & OPpCONST_STRICT) &&
9314 (oa = first->op_sibling) && /* The fh. */
9315 (oa = oa->op_sibling) && /* The mode. */
9316 (oa->op_type == OP_CONST) &&
9317 SvPOK(((SVOP*)oa)->op_sv) &&
9318 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9319 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9320 (last == oa->op_sibling)) /* The bareword. */
9321 last->op_private &= ~OPpCONST_STRICT;
9327 Perl_ck_repeat(pTHX_ OP *o)
9329 PERL_ARGS_ASSERT_CK_REPEAT;
9331 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9332 o->op_private |= OPpREPEAT_DOLIST;
9333 cBINOPo->op_first = force_list(cBINOPo->op_first);
9341 Perl_ck_require(pTHX_ OP *o)
9346 PERL_ARGS_ASSERT_CK_REQUIRE;
9348 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9349 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9351 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9352 SV * const sv = kid->op_sv;
9353 U32 was_readonly = SvREADONLY(sv);
9361 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9366 for (; s < end; s++) {
9367 if (*s == ':' && s[1] == ':') {
9369 Move(s+2, s+1, end - s - 1, char);
9374 sv_catpvs(sv, ".pm");
9375 SvFLAGS(sv) |= was_readonly;
9379 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9380 /* handle override, if any */
9381 && (gv = gv_override("require", 7))) {
9383 if (o->op_flags & OPf_KIDS) {
9384 kid = cUNOPo->op_first;
9385 cUNOPo->op_first = NULL;
9391 newop = S_new_entersubop(aTHX_ gv, kid);
9395 return scalar(ck_fun(o));
9399 Perl_ck_return(pTHX_ OP *o)
9404 PERL_ARGS_ASSERT_CK_RETURN;
9406 kid = cLISTOPo->op_first->op_sibling;
9407 if (CvLVALUE(PL_compcv)) {
9408 for (; kid; kid = kid->op_sibling)
9409 op_lvalue(kid, OP_LEAVESUBLV);
9416 Perl_ck_select(pTHX_ OP *o)
9421 PERL_ARGS_ASSERT_CK_SELECT;
9423 if (o->op_flags & OPf_KIDS) {
9424 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9425 if (kid && kid->op_sibling) {
9426 o->op_type = OP_SSELECT;
9427 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9429 return fold_constants(op_integerize(op_std_init(o)));
9433 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9434 if (kid && kid->op_type == OP_RV2GV)
9435 kid->op_private &= ~HINT_STRICT_REFS;
9440 Perl_ck_shift(pTHX_ OP *o)
9443 const I32 type = o->op_type;
9445 PERL_ARGS_ASSERT_CK_SHIFT;
9447 if (!(o->op_flags & OPf_KIDS)) {
9450 if (!CvUNIQUE(PL_compcv)) {
9451 o->op_flags |= OPf_SPECIAL;
9455 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9457 return newUNOP(type, 0, scalar(argop));
9459 return scalar(ck_fun(o));
9463 Perl_ck_sort(pTHX_ OP *o)
9469 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9472 PERL_ARGS_ASSERT_CK_SORT;
9475 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9477 const I32 sorthints = (I32)SvIV(*svp);
9478 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9479 o->op_private |= OPpSORT_QSORT;
9480 if ((sorthints & HINT_SORT_STABLE) != 0)
9481 o->op_private |= OPpSORT_STABLE;
9485 if (o->op_flags & OPf_STACKED)
9487 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9489 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
9490 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9492 /* if the first arg is a code block, process it and mark sort as
9494 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9496 if (kid->op_type == OP_LEAVE)
9497 op_null(kid); /* wipe out leave */
9498 /* Prevent execution from escaping out of the sort block. */
9501 /* provide scalar context for comparison function/block */
9502 kid = scalar(firstkid);
9504 o->op_flags |= OPf_SPECIAL;
9507 firstkid = firstkid->op_sibling;
9510 for (kid = firstkid; kid; kid = kid->op_sibling) {
9511 /* provide list context for arguments */
9514 op_lvalue(kid, OP_GREPSTART);
9520 /* for sort { X } ..., where X is one of
9521 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
9522 * elide the second child of the sort (the one containing X),
9523 * and set these flags as appropriate
9527 * Also, check and warn on lexical $a, $b.
9531 S_simplify_sort(pTHX_ OP *o)
9534 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9541 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9543 kid = kUNOP->op_first; /* get past null */
9544 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9545 && kid->op_type != OP_LEAVE)
9547 kid = kLISTOP->op_last; /* get past scope */
9548 switch(kid->op_type) {
9552 if (!have_scopeop) goto padkids;
9557 k = kid; /* remember this node*/
9558 if (kBINOP->op_first->op_type != OP_RV2SV
9559 || kBINOP->op_last ->op_type != OP_RV2SV)
9562 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9563 then used in a comparison. This catches most, but not
9564 all cases. For instance, it catches
9565 sort { my($a); $a <=> $b }
9567 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9568 (although why you'd do that is anyone's guess).
9572 if (!ckWARN(WARN_SYNTAX)) return;
9573 kid = kBINOP->op_first;
9575 if (kid->op_type == OP_PADSV) {
9576 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9577 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9578 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9579 /* diag_listed_as: "my %s" used in sort comparison */
9580 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9581 "\"%s %s\" used in sort comparison",
9582 SvPAD_STATE(name) ? "state" : "my",
9585 } while ((kid = kid->op_sibling));
9588 kid = kBINOP->op_first; /* get past cmp */
9589 if (kUNOP->op_first->op_type != OP_GV)
9591 kid = kUNOP->op_first; /* get past rv2sv */
9593 if (GvSTASH(gv) != PL_curstash)
9595 gvname = GvNAME(gv);
9596 if (*gvname == 'a' && gvname[1] == '\0')
9598 else if (*gvname == 'b' && gvname[1] == '\0')
9603 kid = k; /* back to cmp */
9604 /* already checked above that it is rv2sv */
9605 kid = kBINOP->op_last; /* down to 2nd arg */
9606 if (kUNOP->op_first->op_type != OP_GV)
9608 kid = kUNOP->op_first; /* get past rv2sv */
9610 if (GvSTASH(gv) != PL_curstash)
9612 gvname = GvNAME(gv);
9614 ? !(*gvname == 'a' && gvname[1] == '\0')
9615 : !(*gvname == 'b' && gvname[1] == '\0'))
9617 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9619 o->op_private |= OPpSORT_DESCEND;
9620 if (k->op_type == OP_NCMP)
9621 o->op_private |= OPpSORT_NUMERIC;
9622 if (k->op_type == OP_I_NCMP)
9623 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9624 kid = cLISTOPo->op_first->op_sibling;
9625 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9626 op_free(kid); /* then delete it */
9630 Perl_ck_split(pTHX_ OP *o)
9635 PERL_ARGS_ASSERT_CK_SPLIT;
9637 if (o->op_flags & OPf_STACKED)
9638 return no_fh_allowed(o);
9640 kid = cLISTOPo->op_first;
9641 if (kid->op_type != OP_NULL)
9642 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9643 kid = kid->op_sibling;
9644 op_free(cLISTOPo->op_first);
9646 cLISTOPo->op_first = kid;
9648 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9649 cLISTOPo->op_last = kid; /* There was only one element previously */
9652 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9653 OP * const sibl = kid->op_sibling;
9654 kid->op_sibling = 0;
9655 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
9656 if (cLISTOPo->op_first == cLISTOPo->op_last)
9657 cLISTOPo->op_last = kid;
9658 cLISTOPo->op_first = kid;
9659 kid->op_sibling = sibl;
9662 kid->op_type = OP_PUSHRE;
9663 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9665 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9666 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9667 "Use of /g modifier is meaningless in split");
9670 if (!kid->op_sibling)
9671 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9673 kid = kid->op_sibling;
9677 if (!kid->op_sibling)
9679 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9680 o->op_private |= OPpSPLIT_IMPLIM;
9682 assert(kid->op_sibling);
9684 kid = kid->op_sibling;
9687 if (kid->op_sibling)
9688 return too_many_arguments_pv(o,OP_DESC(o), 0);
9694 Perl_ck_join(pTHX_ OP *o)
9696 const OP * const kid = cLISTOPo->op_first->op_sibling;
9698 PERL_ARGS_ASSERT_CK_JOIN;
9700 if (kid && kid->op_type == OP_MATCH) {
9701 if (ckWARN(WARN_SYNTAX)) {
9702 const REGEXP *re = PM_GETRE(kPMOP);
9704 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9705 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9706 : newSVpvs_flags( "STRING", SVs_TEMP );
9707 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9708 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9709 SVfARG(msg), SVfARG(msg));
9716 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9718 Examines an op, which is expected to identify a subroutine at runtime,
9719 and attempts to determine at compile time which subroutine it identifies.
9720 This is normally used during Perl compilation to determine whether
9721 a prototype can be applied to a function call. I<cvop> is the op
9722 being considered, normally an C<rv2cv> op. A pointer to the identified
9723 subroutine is returned, if it could be determined statically, and a null
9724 pointer is returned if it was not possible to determine statically.
9726 Currently, the subroutine can be identified statically if the RV that the
9727 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9728 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9729 suitable if the constant value must be an RV pointing to a CV. Details of
9730 this process may change in future versions of Perl. If the C<rv2cv> op
9731 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9732 the subroutine statically: this flag is used to suppress compile-time
9733 magic on a subroutine call, forcing it to use default runtime behaviour.
9735 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9736 of a GV reference is modified. If a GV was examined and its CV slot was
9737 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9738 If the op is not optimised away, and the CV slot is later populated with
9739 a subroutine having a prototype, that flag eventually triggers the warning
9740 "called too early to check prototype".
9742 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9743 of returning a pointer to the subroutine it returns a pointer to the
9744 GV giving the most appropriate name for the subroutine in this context.
9745 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9746 (C<CvANON>) subroutine that is referenced through a GV it will be the
9747 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9748 A null pointer is returned as usual if there is no statically-determinable
9754 /* shared by toke.c:yylex */
9756 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
9758 PADNAME *name = PAD_COMPNAME(off);
9759 CV *compcv = PL_compcv;
9760 while (PadnameOUTER(name)) {
9761 assert(PARENT_PAD_INDEX(name));
9762 compcv = CvOUTSIDE(PL_compcv);
9763 name = PadlistNAMESARRAY(CvPADLIST(compcv))
9764 [off = PARENT_PAD_INDEX(name)];
9766 assert(!PadnameIsOUR(name));
9767 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
9768 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
9771 return (CV *)mg->mg_obj;
9773 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
9777 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9782 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9783 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9784 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9785 if (cvop->op_type != OP_RV2CV)
9787 if (cvop->op_private & OPpENTERSUB_AMPER)
9789 if (!(cvop->op_flags & OPf_KIDS))
9791 rvop = cUNOPx(cvop)->op_first;
9792 switch (rvop->op_type) {
9794 gv = cGVOPx_gv(rvop);
9797 if (flags & RV2CVOPCV_MARK_EARLY)
9798 rvop->op_private |= OPpEARLY_CV;
9803 SV *rv = cSVOPx_sv(rvop);
9810 cv = find_lexical_cv(rvop->op_targ);
9815 } NOT_REACHED; /* NOTREACHED */
9817 if (SvTYPE((SV*)cv) != SVt_PVCV)
9819 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9820 if (!CvANON(cv) || !gv)
9829 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9831 Performs the default fixup of the arguments part of an C<entersub>
9832 op tree. This consists of applying list context to each of the
9833 argument ops. This is the standard treatment used on a call marked
9834 with C<&>, or a method call, or a call through a subroutine reference,
9835 or any other call where the callee can't be identified at compile time,
9836 or a call where the callee has no prototype.
9842 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9845 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9846 aop = cUNOPx(entersubop)->op_first;
9847 if (!aop->op_sibling)
9848 aop = cUNOPx(aop)->op_first;
9849 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9851 op_lvalue(aop, OP_ENTERSUB);
9857 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9859 Performs the fixup of the arguments part of an C<entersub> op tree
9860 based on a subroutine prototype. This makes various modifications to
9861 the argument ops, from applying context up to inserting C<refgen> ops,
9862 and checking the number and syntactic types of arguments, as directed by
9863 the prototype. This is the standard treatment used on a subroutine call,
9864 not marked with C<&>, where the callee can be identified at compile time
9865 and has a prototype.
9867 I<protosv> supplies the subroutine prototype to be applied to the call.
9868 It may be a normal defined scalar, of which the string value will be used.
9869 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9870 that has been cast to C<SV*>) which has a prototype. The prototype
9871 supplied, in whichever form, does not need to match the actual callee
9872 referenced by the op tree.
9874 If the argument ops disagree with the prototype, for example by having
9875 an unacceptable number of arguments, a valid op tree is returned anyway.
9876 The error is reflected in the parser state, normally resulting in a single
9877 exception at the top level of parsing which covers all the compilation
9878 errors that occurred. In the error message, the callee is referred to
9879 by the name defined by the I<namegv> parameter.
9885 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9888 const char *proto, *proto_end;
9889 OP *aop, *prev, *cvop;
9892 I32 contextclass = 0;
9893 const char *e = NULL;
9894 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9895 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9896 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
9897 "flags=%lx", (unsigned long) SvFLAGS(protosv));
9898 if (SvTYPE(protosv) == SVt_PVCV)
9899 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9900 else proto = SvPV(protosv, proto_len);
9901 proto = S_strip_spaces(aTHX_ proto, &proto_len);
9902 proto_end = proto + proto_len;
9903 aop = cUNOPx(entersubop)->op_first;
9904 if (!aop->op_sibling)
9905 aop = cUNOPx(aop)->op_first;
9907 aop = aop->op_sibling;
9908 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9909 while (aop != cvop) {
9912 if (proto >= proto_end)
9913 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
9921 /* _ must be at the end */
9922 if (proto[1] && !strchr(";@%", proto[1]))
9938 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9940 arg == 1 ? "block or sub {}" : "sub {}",
9944 /* '*' allows any scalar type, including bareword */
9947 if (o3->op_type == OP_RV2GV)
9948 goto wrapref; /* autoconvert GLOB -> GLOBref */
9949 else if (o3->op_type == OP_CONST)
9950 o3->op_private &= ~OPpCONST_STRICT;
9951 else if (o3->op_type == OP_ENTERSUB) {
9952 /* accidental subroutine, revert to bareword */
9953 OP *gvop = ((UNOP*)o3)->op_first;
9954 if (gvop && gvop->op_type == OP_NULL) {
9955 gvop = ((UNOP*)gvop)->op_first;
9957 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9960 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9961 (gvop = ((UNOP*)gvop)->op_first) &&
9962 gvop->op_type == OP_GV)
9964 GV * const gv = cGVOPx_gv(gvop);
9965 OP * const sibling = aop->op_sibling;
9966 SV * const n = newSVpvs("");
9968 gv_fullname4(n, gv, "", FALSE);
9969 aop = newSVOP(OP_CONST, 0, n);
9970 prev->op_sibling = aop;
9971 aop->op_sibling = sibling;
9981 if (o3->op_type == OP_RV2AV ||
9982 o3->op_type == OP_PADAV ||
9983 o3->op_type == OP_RV2HV ||
9984 o3->op_type == OP_PADHV
9999 if (contextclass++ == 0) {
10000 e = strchr(proto, ']');
10001 if (!e || e == proto)
10009 if (contextclass) {
10010 const char *p = proto;
10011 const char *const end = proto;
10013 while (*--p != '[')
10014 /* \[$] accepts any scalar lvalue */
10016 && Perl_op_lvalue_flags(aTHX_
10018 OP_READ, /* not entersub */
10021 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10022 (int)(end - p), p),
10028 if (o3->op_type == OP_RV2GV)
10031 bad_type_gv(arg, "symbol", namegv, 0, o3);
10034 if (o3->op_type == OP_ENTERSUB)
10037 bad_type_gv(arg, "subroutine entry", namegv, 0,
10041 if (o3->op_type == OP_RV2SV ||
10042 o3->op_type == OP_PADSV ||
10043 o3->op_type == OP_HELEM ||
10044 o3->op_type == OP_AELEM)
10046 if (!contextclass) {
10047 /* \$ accepts any scalar lvalue */
10048 if (Perl_op_lvalue_flags(aTHX_
10050 OP_READ, /* not entersub */
10053 bad_type_gv(arg, "scalar", namegv, 0, o3);
10057 if (o3->op_type == OP_RV2AV ||
10058 o3->op_type == OP_PADAV)
10061 bad_type_gv(arg, "array", namegv, 0, o3);
10064 if (o3->op_type == OP_RV2HV ||
10065 o3->op_type == OP_PADHV)
10068 bad_type_gv(arg, "hash", namegv, 0, o3);
10072 OP* const kid = aop;
10073 OP* const sib = kid->op_sibling;
10074 kid->op_sibling = 0;
10075 aop = newUNOP(OP_REFGEN, 0, kid);
10076 aop->op_sibling = sib;
10077 prev->op_sibling = aop;
10079 if (contextclass && e) {
10084 default: goto oops;
10094 SV* const tmpsv = sv_newmortal();
10095 gv_efullname3(tmpsv, namegv, NULL);
10096 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10097 SVfARG(tmpsv), SVfARG(protosv));
10101 op_lvalue(aop, OP_ENTERSUB);
10103 aop = aop->op_sibling;
10105 if (aop == cvop && *proto == '_') {
10106 /* generate an access to $_ */
10107 aop = newDEFSVOP();
10108 aop->op_sibling = prev->op_sibling;
10109 prev->op_sibling = aop; /* instead of cvop */
10111 if (!optional && proto_end > proto &&
10112 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10113 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10118 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10120 Performs the fixup of the arguments part of an C<entersub> op tree either
10121 based on a subroutine prototype or using default list-context processing.
10122 This is the standard treatment used on a subroutine call, not marked
10123 with C<&>, where the callee can be identified at compile time.
10125 I<protosv> supplies the subroutine prototype to be applied to the call,
10126 or indicates that there is no prototype. It may be a normal scalar,
10127 in which case if it is defined then the string value will be used
10128 as a prototype, and if it is undefined then there is no prototype.
10129 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10130 that has been cast to C<SV*>), of which the prototype will be used if it
10131 has one. The prototype (or lack thereof) supplied, in whichever form,
10132 does not need to match the actual callee referenced by the op tree.
10134 If the argument ops disagree with the prototype, for example by having
10135 an unacceptable number of arguments, a valid op tree is returned anyway.
10136 The error is reflected in the parser state, normally resulting in a single
10137 exception at the top level of parsing which covers all the compilation
10138 errors that occurred. In the error message, the callee is referred to
10139 by the name defined by the I<namegv> parameter.
10145 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10146 GV *namegv, SV *protosv)
10148 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10149 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10150 return ck_entersub_args_proto(entersubop, namegv, protosv);
10152 return ck_entersub_args_list(entersubop);
10156 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10158 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10159 OP *aop = cUNOPx(entersubop)->op_first;
10161 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10165 if (!aop->op_sibling)
10166 aop = cUNOPx(aop)->op_first;
10167 aop = aop->op_sibling;
10168 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10170 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10172 op_free(entersubop);
10173 switch(GvNAME(namegv)[2]) {
10174 case 'F': return newSVOP(OP_CONST, 0,
10175 newSVpv(CopFILE(PL_curcop),0));
10176 case 'L': return newSVOP(
10178 Perl_newSVpvf(aTHX_
10179 "%"IVdf, (IV)CopLINE(PL_curcop)
10182 case 'P': return newSVOP(OP_CONST, 0,
10184 ? newSVhek(HvNAME_HEK(PL_curstash))
10194 if (!aop->op_sibling)
10195 aop = cUNOPx(aop)->op_first;
10198 aop = aop->op_sibling;
10199 prev->op_sibling = NULL;
10202 prev=cvop, cvop = cvop->op_sibling)
10204 prev->op_sibling = NULL;
10205 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10207 if (aop == cvop) aop = NULL;
10208 op_free(entersubop);
10210 if (opnum == OP_ENTEREVAL
10211 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10212 flags |= OPpEVAL_BYTES <<8;
10214 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10216 case OA_BASEOP_OR_UNOP:
10217 case OA_FILESTATOP:
10218 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10221 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10224 return opnum == OP_RUNCV
10225 ? newPVOP(OP_RUNCV,0,NULL)
10228 return convert(opnum,0,aop);
10236 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10238 Retrieves the function that will be used to fix up a call to I<cv>.
10239 Specifically, the function is applied to an C<entersub> op tree for a
10240 subroutine call, not marked with C<&>, where the callee can be identified
10241 at compile time as I<cv>.
10243 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10244 argument for it is returned in I<*ckobj_p>. The function is intended
10245 to be called in this manner:
10247 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10249 In this call, I<entersubop> is a pointer to the C<entersub> op,
10250 which may be replaced by the check function, and I<namegv> is a GV
10251 supplying the name that should be used by the check function to refer
10252 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10253 It is permitted to apply the check function in non-standard situations,
10254 such as to a call to a different subroutine or to a method call.
10256 By default, the function is
10257 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10258 and the SV parameter is I<cv> itself. This implements standard
10259 prototype processing. It can be changed, for a particular subroutine,
10260 by L</cv_set_call_checker>.
10266 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10269 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10270 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10272 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10273 *ckobj_p = callmg->mg_obj;
10275 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10276 *ckobj_p = (SV*)cv;
10281 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10283 Sets the function that will be used to fix up a call to I<cv>.
10284 Specifically, the function is applied to an C<entersub> op tree for a
10285 subroutine call, not marked with C<&>, where the callee can be identified
10286 at compile time as I<cv>.
10288 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10289 for it is supplied in I<ckobj>. The function should be defined like this:
10291 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
10293 It is intended to be called in this manner:
10295 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10297 In this call, I<entersubop> is a pointer to the C<entersub> op,
10298 which may be replaced by the check function, and I<namegv> is a GV
10299 supplying the name that should be used by the check function to refer
10300 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10301 It is permitted to apply the check function in non-standard situations,
10302 such as to a call to a different subroutine or to a method call.
10304 The current setting for a particular CV can be retrieved by
10305 L</cv_get_call_checker>.
10311 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10313 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10314 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10315 if (SvMAGICAL((SV*)cv))
10316 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10319 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10320 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10322 if (callmg->mg_flags & MGf_REFCOUNTED) {
10323 SvREFCNT_dec(callmg->mg_obj);
10324 callmg->mg_flags &= ~MGf_REFCOUNTED;
10326 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10327 callmg->mg_obj = ckobj;
10328 if (ckobj != (SV*)cv) {
10329 SvREFCNT_inc_simple_void_NN(ckobj);
10330 callmg->mg_flags |= MGf_REFCOUNTED;
10332 callmg->mg_flags |= MGf_COPY;
10337 Perl_ck_subr(pTHX_ OP *o)
10343 PERL_ARGS_ASSERT_CK_SUBR;
10345 aop = cUNOPx(o)->op_first;
10346 if (!aop->op_sibling)
10347 aop = cUNOPx(aop)->op_first;
10348 aop = aop->op_sibling;
10349 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10350 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10351 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10353 o->op_private &= ~1;
10354 o->op_private |= OPpENTERSUB_HASTARG;
10355 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10356 if (PERLDB_SUB && PL_curstash != PL_debstash)
10357 o->op_private |= OPpENTERSUB_DB;
10358 if (cvop->op_type == OP_RV2CV) {
10359 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10361 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10362 if (aop->op_type == OP_CONST)
10363 aop->op_private &= ~OPpCONST_STRICT;
10364 else if (aop->op_type == OP_LIST) {
10365 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10366 if (sib && sib->op_type == OP_CONST)
10367 sib->op_private &= ~OPpCONST_STRICT;
10372 return ck_entersub_args_list(o);
10374 Perl_call_checker ckfun;
10376 cv_get_call_checker(cv, &ckfun, &ckobj);
10377 if (!namegv) { /* expletive! */
10378 /* XXX The call checker API is public. And it guarantees that
10379 a GV will be provided with the right name. So we have
10380 to create a GV. But it is still not correct, as its
10381 stringification will include the package. What we
10382 really need is a new call checker API that accepts a
10383 GV or string (or GV or CV). */
10384 HEK * const hek = CvNAME_HEK(cv);
10385 /* After a syntax error in a lexical sub, the cv that
10386 rv2cv_op_cv returns may be a nameless stub. */
10387 if (!hek) return ck_entersub_args_list(o);;
10388 namegv = (GV *)sv_newmortal();
10389 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10390 SVf_UTF8 * !!HEK_UTF8(hek));
10392 return ckfun(aTHX_ o, namegv, ckobj);
10397 Perl_ck_svconst(pTHX_ OP *o)
10399 SV * const sv = cSVOPo->op_sv;
10400 PERL_ARGS_ASSERT_CK_SVCONST;
10401 PERL_UNUSED_CONTEXT;
10402 #ifdef PERL_OLD_COPY_ON_WRITE
10403 if (SvIsCOW(sv)) sv_force_normal(sv);
10404 #elif defined(PERL_NEW_COPY_ON_WRITE)
10405 /* Since the read-only flag may be used to protect a string buffer, we
10406 cannot do copy-on-write with existing read-only scalars that are not
10407 already copy-on-write scalars. To allow $_ = "hello" to do COW with
10408 that constant, mark the constant as COWable here, if it is not
10409 already read-only. */
10410 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10413 # ifdef PERL_DEBUG_READONLY_COW
10423 Perl_ck_trunc(pTHX_ OP *o)
10425 PERL_ARGS_ASSERT_CK_TRUNC;
10427 if (o->op_flags & OPf_KIDS) {
10428 SVOP *kid = (SVOP*)cUNOPo->op_first;
10430 if (kid->op_type == OP_NULL)
10431 kid = (SVOP*)kid->op_sibling;
10432 if (kid && kid->op_type == OP_CONST &&
10433 (kid->op_private & OPpCONST_BARE) &&
10436 o->op_flags |= OPf_SPECIAL;
10437 kid->op_private &= ~OPpCONST_STRICT;
10444 Perl_ck_substr(pTHX_ OP *o)
10446 PERL_ARGS_ASSERT_CK_SUBSTR;
10449 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10450 OP *kid = cLISTOPo->op_first;
10452 if (kid->op_type == OP_NULL)
10453 kid = kid->op_sibling;
10455 kid->op_flags |= OPf_MOD;
10462 Perl_ck_tell(pTHX_ OP *o)
10464 PERL_ARGS_ASSERT_CK_TELL;
10466 if (o->op_flags & OPf_KIDS) {
10467 OP *kid = cLISTOPo->op_first;
10468 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10469 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10475 Perl_ck_each(pTHX_ OP *o)
10478 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10479 const unsigned orig_type = o->op_type;
10480 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10481 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10482 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10483 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10485 PERL_ARGS_ASSERT_CK_EACH;
10488 switch (kid->op_type) {
10494 CHANGE_TYPE(o, array_type);
10497 if (kid->op_private == OPpCONST_BARE
10498 || !SvROK(cSVOPx_sv(kid))
10499 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10500 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10502 /* we let ck_fun handle it */
10505 CHANGE_TYPE(o, ref_type);
10509 /* if treating as a reference, defer additional checks to runtime */
10510 if (o->op_type == ref_type) {
10511 /* diag_listed_as: keys on reference is experimental */
10512 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
10513 "%s is experimental", PL_op_desc[ref_type]);
10520 Perl_ck_length(pTHX_ OP *o)
10522 PERL_ARGS_ASSERT_CK_LENGTH;
10526 if (ckWARN(WARN_SYNTAX)) {
10527 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10531 const bool hash = kid->op_type == OP_PADHV
10532 || kid->op_type == OP_RV2HV;
10533 switch (kid->op_type) {
10538 name = S_op_varname(aTHX_ kid);
10544 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10545 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10547 SVfARG(name), hash ? "keys " : "", SVfARG(name)
10550 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10551 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10552 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10554 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10555 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10556 "length() used on @array (did you mean \"scalar(@array)\"?)");
10563 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10564 and modify the optree to make them work inplace */
10567 S_inplace_aassign(pTHX_ OP *o) {
10569 OP *modop, *modop_pushmark;
10571 OP *oleft, *oleft_pushmark;
10573 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10575 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10577 assert(cUNOPo->op_first->op_type == OP_NULL);
10578 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10579 assert(modop_pushmark->op_type == OP_PUSHMARK);
10580 modop = modop_pushmark->op_sibling;
10582 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10585 /* no other operation except sort/reverse */
10586 if (modop->op_sibling)
10589 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10590 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10592 if (modop->op_flags & OPf_STACKED) {
10593 /* skip sort subroutine/block */
10594 assert(oright->op_type == OP_NULL);
10595 oright = oright->op_sibling;
10598 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10599 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10600 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10601 oleft = oleft_pushmark->op_sibling;
10603 /* Check the lhs is an array */
10605 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10606 || oleft->op_sibling
10607 || (oleft->op_private & OPpLVAL_INTRO)
10611 /* Only one thing on the rhs */
10612 if (oright->op_sibling)
10615 /* check the array is the same on both sides */
10616 if (oleft->op_type == OP_RV2AV) {
10617 if (oright->op_type != OP_RV2AV
10618 || !cUNOPx(oright)->op_first
10619 || cUNOPx(oright)->op_first->op_type != OP_GV
10620 || cUNOPx(oleft )->op_first->op_type != OP_GV
10621 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10622 cGVOPx_gv(cUNOPx(oright)->op_first)
10626 else if (oright->op_type != OP_PADAV
10627 || oright->op_targ != oleft->op_targ
10631 /* This actually is an inplace assignment */
10633 modop->op_private |= OPpSORT_INPLACE;
10635 /* transfer MODishness etc from LHS arg to RHS arg */
10636 oright->op_flags = oleft->op_flags;
10638 /* remove the aassign op and the lhs */
10640 op_null(oleft_pushmark);
10641 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10642 op_null(cUNOPx(oleft)->op_first);
10648 /* mechanism for deferring recursion in rpeep() */
10650 #define MAX_DEFERRED 4
10654 if (defer_ix == (MAX_DEFERRED-1)) { \
10655 OP **defer = defer_queue[defer_base]; \
10656 CALL_RPEEP(*defer); \
10657 S_prune_chain_head(defer); \
10658 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10661 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
10664 #define IS_AND_OP(o) (o->op_type == OP_AND)
10665 #define IS_OR_OP(o) (o->op_type == OP_OR)
10669 S_null_listop_in_list_context(pTHX_ OP *o)
10673 PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
10675 /* This is an OP_LIST in list context. That means we
10676 * can ditch the OP_LIST and the OP_PUSHMARK within. */
10678 kid = cLISTOPo->op_first;
10679 /* Find the end of the chain of OPs executed within the OP_LIST. */
10680 while (kid->op_next != o)
10681 kid = kid->op_next;
10683 kid->op_next = o->op_next; /* patch list out of exec chain */
10684 op_null(cUNOPo->op_first); /* NULL the pushmark */
10685 op_null(o); /* NULL the list */
10688 /* A peephole optimizer. We visit the ops in the order they're to execute.
10689 * See the comments at the top of this file for more details about when
10690 * peep() is called */
10693 Perl_rpeep(pTHX_ OP *o)
10697 OP* oldoldop = NULL;
10698 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10699 int defer_base = 0;
10704 if (!o || o->op_opt)
10708 SAVEVPTR(PL_curcop);
10709 for (;; o = o->op_next) {
10710 if (o && o->op_opt)
10713 while (defer_ix >= 0) {
10715 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
10716 CALL_RPEEP(*defer);
10717 S_prune_chain_head(defer);
10722 /* By default, this op has now been optimised. A couple of cases below
10723 clear this again. */
10728 /* The following will have the OP_LIST and OP_PUSHMARK
10729 * patched out later IF the OP_LIST is in list context.
10730 * So in that case, we can set the this OP's op_next
10731 * to skip to after the OP_PUSHMARK:
10737 * will eventually become:
10740 * - ex-pushmark -> -
10746 OP *other_pushmark;
10747 if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
10748 && (sibling = o->op_sibling)
10749 && sibling->op_type == OP_LIST
10750 /* This KIDS check is likely superfluous since OP_LIST
10751 * would otherwise be an OP_STUB. */
10752 && sibling->op_flags & OPf_KIDS
10753 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
10754 && (other_pushmark = cLISTOPx(sibling)->op_first)
10755 /* Pointer equality also effectively checks that it's a
10757 && other_pushmark == o->op_next)
10759 o->op_next = other_pushmark->op_next;
10760 null_listop_in_list_context(sibling);
10764 switch (o->op_type) {
10766 PL_curcop = ((COP*)o); /* for warnings */
10769 PL_curcop = ((COP*)o); /* for warnings */
10771 /* Optimise a "return ..." at the end of a sub to just be "...".
10772 * This saves 2 ops. Before:
10773 * 1 <;> nextstate(main 1 -e:1) v ->2
10774 * 4 <@> return K ->5
10775 * 2 <0> pushmark s ->3
10776 * - <1> ex-rv2sv sK/1 ->4
10777 * 3 <#> gvsv[*cat] s ->4
10780 * - <@> return K ->-
10781 * - <0> pushmark s ->2
10782 * - <1> ex-rv2sv sK/1 ->-
10783 * 2 <$> gvsv(*cat) s ->3
10786 OP *next = o->op_next;
10787 OP *sibling = o->op_sibling;
10788 if ( OP_TYPE_IS(next, OP_PUSHMARK)
10789 && OP_TYPE_IS(sibling, OP_RETURN)
10790 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
10791 && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
10792 && cUNOPx(sibling)->op_first == next
10793 && next->op_sibling && next->op_sibling->op_next
10796 /* Look through the PUSHMARK's siblings for one that
10797 * points to the RETURN */
10798 OP *top = next->op_sibling;
10799 while (top && top->op_next) {
10800 if (top->op_next == sibling) {
10801 top->op_next = sibling->op_next;
10802 o->op_next = next->op_next;
10805 top = top->op_sibling;
10810 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
10812 * This latter form is then suitable for conversion into padrange
10813 * later on. Convert:
10815 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
10819 * nextstate1 -> listop -> nextstate3
10821 * pushmark -> padop1 -> padop2
10823 if (o->op_next && (
10824 o->op_next->op_type == OP_PADSV
10825 || o->op_next->op_type == OP_PADAV
10826 || o->op_next->op_type == OP_PADHV
10828 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
10829 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
10830 && o->op_next->op_next->op_next && (
10831 o->op_next->op_next->op_next->op_type == OP_PADSV
10832 || o->op_next->op_next->op_next->op_type == OP_PADAV
10833 || o->op_next->op_next->op_next->op_type == OP_PADHV
10835 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
10836 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
10837 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
10838 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
10844 first = o->op_next;
10845 last = o->op_next->op_next->op_next;
10847 newop = newLISTOP(OP_LIST, 0, first, last);
10848 newop->op_flags |= OPf_PARENS;
10849 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10851 /* Kill nextstate2 between padop1/padop2 */
10852 op_free(first->op_next);
10854 first->op_next = last; /* padop2 */
10855 first->op_sibling = last; /* ... */
10856 o->op_next = cUNOPx(newop)->op_first; /* pushmark */
10857 o->op_next->op_next = first; /* padop1 */
10858 o->op_next->op_sibling = first; /* ... */
10859 newop->op_next = last->op_next; /* nextstate3 */
10860 newop->op_sibling = last->op_sibling;
10861 last->op_next = newop; /* listop */
10862 last->op_sibling = NULL;
10863 o->op_sibling = newop; /* ... */
10865 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10867 /* Ensure pushmark has this flag if padops do */
10868 if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) {
10869 o->op_next->op_flags |= OPf_MOD;
10875 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10876 to carry two labels. For now, take the easier option, and skip
10877 this optimisation if the first NEXTSTATE has a label. */
10878 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10879 OP *nextop = o->op_next;
10880 while (nextop && nextop->op_type == OP_NULL)
10881 nextop = nextop->op_next;
10883 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10884 COP *firstcop = (COP *)o;
10885 COP *secondcop = (COP *)nextop;
10886 /* We want the COP pointed to by o (and anything else) to
10887 become the next COP down the line. */
10888 cop_free(firstcop);
10890 firstcop->op_next = secondcop->op_next;
10892 /* Now steal all its pointers, and duplicate the other
10894 firstcop->cop_line = secondcop->cop_line;
10895 #ifdef USE_ITHREADS
10896 firstcop->cop_stashoff = secondcop->cop_stashoff;
10897 firstcop->cop_file = secondcop->cop_file;
10899 firstcop->cop_stash = secondcop->cop_stash;
10900 firstcop->cop_filegv = secondcop->cop_filegv;
10902 firstcop->cop_hints = secondcop->cop_hints;
10903 firstcop->cop_seq = secondcop->cop_seq;
10904 firstcop->cop_warnings = secondcop->cop_warnings;
10905 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10907 #ifdef USE_ITHREADS
10908 secondcop->cop_stashoff = 0;
10909 secondcop->cop_file = NULL;
10911 secondcop->cop_stash = NULL;
10912 secondcop->cop_filegv = NULL;
10914 secondcop->cop_warnings = NULL;
10915 secondcop->cop_hints_hash = NULL;
10917 /* If we use op_null(), and hence leave an ex-COP, some
10918 warnings are misreported. For example, the compile-time
10919 error in 'use strict; no strict refs;' */
10920 secondcop->op_type = OP_NULL;
10921 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10927 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10928 if (o->op_next->op_private & OPpTARGET_MY) {
10929 if (o->op_flags & OPf_STACKED) /* chained concats */
10930 break; /* ignore_optimization */
10932 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10933 o->op_targ = o->op_next->op_targ;
10934 o->op_next->op_targ = 0;
10935 o->op_private |= OPpTARGET_MY;
10938 op_null(o->op_next);
10942 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10943 break; /* Scalar stub must produce undef. List stub is noop */
10947 if (o->op_targ == OP_NEXTSTATE
10948 || o->op_targ == OP_DBSTATE)
10950 PL_curcop = ((COP*)o);
10952 /* XXX: We avoid setting op_seq here to prevent later calls
10953 to rpeep() from mistakenly concluding that optimisation
10954 has already occurred. This doesn't fix the real problem,
10955 though (See 20010220.007). AMS 20010719 */
10956 /* op_seq functionality is now replaced by op_opt */
10964 oldop->op_next = o->op_next;
10972 /* Convert a series of PAD ops for my vars plus support into a
10973 * single padrange op. Basically
10975 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
10977 * becomes, depending on circumstances, one of
10979 * padrange ----------------------------------> (list) -> rest
10980 * padrange --------------------------------------------> rest
10982 * where all the pad indexes are sequential and of the same type
10984 * We convert the pushmark into a padrange op, then skip
10985 * any other pad ops, and possibly some trailing ops.
10986 * Note that we don't null() the skipped ops, to make it
10987 * easier for Deparse to undo this optimisation (and none of
10988 * the skipped ops are holding any resourses). It also makes
10989 * it easier for find_uninit_var(), as it can just ignore
10990 * padrange, and examine the original pad ops.
10994 OP *followop = NULL; /* the op that will follow the padrange op */
10997 PADOFFSET base = 0; /* init only to stop compiler whining */
10998 U8 gimme = 0; /* init only to stop compiler whining */
10999 bool defav = 0; /* seen (...) = @_ */
11000 bool reuse = 0; /* reuse an existing padrange op */
11002 /* look for a pushmark -> gv[_] -> rv2av */
11008 if ( p->op_type == OP_GV
11009 && (gv = cGVOPx_gv(p))
11010 && GvNAMELEN_get(gv) == 1
11011 && *GvNAME_get(gv) == '_'
11012 && GvSTASH(gv) == PL_defstash
11013 && (rv2av = p->op_next)
11014 && rv2av->op_type == OP_RV2AV
11015 && !(rv2av->op_flags & OPf_REF)
11016 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11017 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11018 && o->op_sibling == rv2av /* these two for Deparse */
11019 && cUNOPx(rv2av)->op_first == p
11021 q = rv2av->op_next;
11022 if (q->op_type == OP_NULL)
11024 if (q->op_type == OP_PUSHMARK) {
11031 /* To allow Deparse to pessimise this, it needs to be able
11032 * to restore the pushmark's original op_next, which it
11033 * will assume to be the same as op_sibling. */
11034 if (o->op_next != o->op_sibling)
11039 /* scan for PAD ops */
11041 for (p = p->op_next; p; p = p->op_next) {
11042 if (p->op_type == OP_NULL)
11045 if (( p->op_type != OP_PADSV
11046 && p->op_type != OP_PADAV
11047 && p->op_type != OP_PADHV
11049 /* any private flag other than INTRO? e.g. STATE */
11050 || (p->op_private & ~OPpLVAL_INTRO)
11054 /* let $a[N] potentially be optimised into AELEMFAST_LEX
11056 if ( p->op_type == OP_PADAV
11058 && p->op_next->op_type == OP_CONST
11059 && p->op_next->op_next
11060 && p->op_next->op_next->op_type == OP_AELEM
11064 /* for 1st padop, note what type it is and the range
11065 * start; for the others, check that it's the same type
11066 * and that the targs are contiguous */
11068 intro = (p->op_private & OPpLVAL_INTRO);
11070 gimme = (p->op_flags & OPf_WANT);
11073 if ((p->op_private & OPpLVAL_INTRO) != intro)
11075 /* Note that you'd normally expect targs to be
11076 * contiguous in my($a,$b,$c), but that's not the case
11077 * when external modules start doing things, e.g.
11078 i* Function::Parameters */
11079 if (p->op_targ != base + count)
11081 assert(p->op_targ == base + count);
11082 /* all the padops should be in the same context */
11083 if (gimme != (p->op_flags & OPf_WANT))
11087 /* for AV, HV, only when we're not flattening */
11088 if ( p->op_type != OP_PADSV
11089 && gimme != OPf_WANT_VOID
11090 && !(p->op_flags & OPf_REF)
11094 if (count >= OPpPADRANGE_COUNTMASK)
11097 /* there's a biggest base we can fit into a
11098 * SAVEt_CLEARPADRANGE in pp_padrange */
11099 if (intro && base >
11100 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11103 /* Success! We've got another valid pad op to optimise away */
11105 followop = p->op_next;
11111 /* pp_padrange in specifically compile-time void context
11112 * skips pushing a mark and lexicals; in all other contexts
11113 * (including unknown till runtime) it pushes a mark and the
11114 * lexicals. We must be very careful then, that the ops we
11115 * optimise away would have exactly the same effect as the
11117 * In particular in void context, we can only optimise to
11118 * a padrange if see see the complete sequence
11119 * pushmark, pad*v, ...., list, nextstate
11120 * which has the net effect of of leaving the stack empty
11121 * (for now we leave the nextstate in the execution chain, for
11122 * its other side-effects).
11125 if (gimme == OPf_WANT_VOID) {
11126 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
11127 && gimme == (followop->op_flags & OPf_WANT)
11128 && ( followop->op_next->op_type == OP_NEXTSTATE
11129 || followop->op_next->op_type == OP_DBSTATE))
11131 followop = followop->op_next; /* skip OP_LIST */
11133 /* consolidate two successive my(...);'s */
11136 && oldoldop->op_type == OP_PADRANGE
11137 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11138 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11139 && !(oldoldop->op_flags & OPf_SPECIAL)
11142 assert(oldoldop->op_next == oldop);
11143 assert( oldop->op_type == OP_NEXTSTATE
11144 || oldop->op_type == OP_DBSTATE);
11145 assert(oldop->op_next == o);
11148 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11150 /* Do not assume pad offsets for $c and $d are con-
11155 if ( oldoldop->op_targ + old_count == base
11156 && old_count < OPpPADRANGE_COUNTMASK - count) {
11157 base = oldoldop->op_targ;
11158 count += old_count;
11163 /* if there's any immediately following singleton
11164 * my var's; then swallow them and the associated
11166 * my ($a,$b); my $c; my $d;
11168 * my ($a,$b,$c,$d);
11171 while ( ((p = followop->op_next))
11172 && ( p->op_type == OP_PADSV
11173 || p->op_type == OP_PADAV
11174 || p->op_type == OP_PADHV)
11175 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11176 && (p->op_private & OPpLVAL_INTRO) == intro
11177 && !(p->op_private & ~OPpLVAL_INTRO)
11179 && ( p->op_next->op_type == OP_NEXTSTATE
11180 || p->op_next->op_type == OP_DBSTATE)
11181 && count < OPpPADRANGE_COUNTMASK
11182 && base + count == p->op_targ
11185 followop = p->op_next;
11193 assert(oldoldop->op_type == OP_PADRANGE);
11194 oldoldop->op_next = followop;
11195 oldoldop->op_private = (intro | count);
11201 /* Convert the pushmark into a padrange.
11202 * To make Deparse easier, we guarantee that a padrange was
11203 * *always* formerly a pushmark */
11204 assert(o->op_type == OP_PUSHMARK);
11205 o->op_next = followop;
11206 o->op_type = OP_PADRANGE;
11207 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11209 /* bit 7: INTRO; bit 6..0: count */
11210 o->op_private = (intro | count);
11211 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11212 | gimme | (defav ? OPf_SPECIAL : 0));
11219 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11220 OP* const pop = (o->op_type == OP_PADAV) ?
11221 o->op_next : o->op_next->op_next;
11223 if (pop && pop->op_type == OP_CONST &&
11224 ((PL_op = pop->op_next)) &&
11225 pop->op_next->op_type == OP_AELEM &&
11226 !(pop->op_next->op_private &
11227 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11228 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
11231 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11232 no_bareword_allowed(pop);
11233 if (o->op_type == OP_GV)
11234 op_null(o->op_next);
11235 op_null(pop->op_next);
11237 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11238 o->op_next = pop->op_next->op_next;
11239 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11240 o->op_private = (U8)i;
11241 if (o->op_type == OP_GV) {
11244 o->op_type = OP_AELEMFAST;
11247 o->op_type = OP_AELEMFAST_LEX;
11252 if (o->op_next->op_type == OP_RV2SV) {
11253 if (!(o->op_next->op_private & OPpDEREF)) {
11254 op_null(o->op_next);
11255 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11257 o->op_next = o->op_next->op_next;
11258 o->op_type = OP_GVSV;
11259 o->op_ppaddr = PL_ppaddr[OP_GVSV];
11262 else if (o->op_next->op_type == OP_READLINE
11263 && o->op_next->op_next->op_type == OP_CONCAT
11264 && (o->op_next->op_next->op_flags & OPf_STACKED))
11266 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11267 o->op_type = OP_RCATLINE;
11268 o->op_flags |= OPf_STACKED;
11269 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11270 op_null(o->op_next->op_next);
11271 op_null(o->op_next);
11276 #define HV_OR_SCALARHV(op) \
11277 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11279 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11280 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11281 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11282 ? cUNOPx(op)->op_first \
11286 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11287 fop->op_private |= OPpTRUEBOOL;
11293 fop = cLOGOP->op_first;
11294 sop = fop->op_sibling;
11295 while (cLOGOP->op_other->op_type == OP_NULL)
11296 cLOGOP->op_other = cLOGOP->op_other->op_next;
11297 while (o->op_next && ( o->op_type == o->op_next->op_type
11298 || o->op_next->op_type == OP_NULL))
11299 o->op_next = o->op_next->op_next;
11301 /* if we're an OR and our next is a AND in void context, we'll
11302 follow it's op_other on short circuit, same for reverse.
11303 We can't do this with OP_DOR since if it's true, its return
11304 value is the underlying value which must be evaluated
11308 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
11309 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
11311 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
11313 o->op_next = ((LOGOP*)o->op_next)->op_other;
11315 DEFER(cLOGOP->op_other);
11318 fop = HV_OR_SCALARHV(fop);
11319 if (sop) sop = HV_OR_SCALARHV(sop);
11324 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11325 while (nop && nop->op_next) {
11326 switch (nop->op_next->op_type) {
11331 lop = nop = nop->op_next;
11334 nop = nop->op_next;
11343 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11344 || o->op_type == OP_AND )
11345 fop->op_private |= OPpTRUEBOOL;
11346 else if (!(lop->op_flags & OPf_WANT))
11347 fop->op_private |= OPpMAYBE_TRUEBOOL;
11349 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11351 sop->op_private |= OPpTRUEBOOL;
11358 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11359 fop->op_private |= OPpTRUEBOOL;
11360 #undef HV_OR_SCALARHV
11361 /* GERONIMO! */ /* FALLTHROUGH */
11370 while (cLOGOP->op_other->op_type == OP_NULL)
11371 cLOGOP->op_other = cLOGOP->op_other->op_next;
11372 DEFER(cLOGOP->op_other);
11377 while (cLOOP->op_redoop->op_type == OP_NULL)
11378 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11379 while (cLOOP->op_nextop->op_type == OP_NULL)
11380 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11381 while (cLOOP->op_lastop->op_type == OP_NULL)
11382 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11383 /* a while(1) loop doesn't have an op_next that escapes the
11384 * loop, so we have to explicitly follow the op_lastop to
11385 * process the rest of the code */
11386 DEFER(cLOOP->op_lastop);
11390 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
11391 DEFER(cLOGOPo->op_other);
11395 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11396 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11397 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11398 cPMOP->op_pmstashstartu.op_pmreplstart
11399 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11400 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11406 if (o->op_flags & OPf_SPECIAL) {
11407 /* first arg is a code block */
11408 OP * const nullop = cLISTOP->op_first->op_sibling;
11409 OP * kid = cUNOPx(nullop)->op_first;
11411 assert(nullop->op_type == OP_NULL);
11412 assert(kid->op_type == OP_SCOPE
11413 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
11414 /* since OP_SORT doesn't have a handy op_other-style
11415 * field that can point directly to the start of the code
11416 * block, store it in the otherwise-unused op_next field
11417 * of the top-level OP_NULL. This will be quicker at
11418 * run-time, and it will also allow us to remove leading
11419 * OP_NULLs by just messing with op_nexts without
11420 * altering the basic op_first/op_sibling layout. */
11421 kid = kLISTOP->op_first;
11423 (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
11424 || kid->op_type == OP_STUB
11425 || kid->op_type == OP_ENTER);
11426 nullop->op_next = kLISTOP->op_next;
11427 DEFER(nullop->op_next);
11430 /* check that RHS of sort is a single plain array */
11431 oright = cUNOPo->op_first;
11432 if (!oright || oright->op_type != OP_PUSHMARK)
11435 if (o->op_private & OPpSORT_INPLACE)
11438 /* reverse sort ... can be optimised. */
11439 if (!cUNOPo->op_sibling) {
11440 /* Nothing follows us on the list. */
11441 OP * const reverse = o->op_next;
11443 if (reverse->op_type == OP_REVERSE &&
11444 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11445 OP * const pushmark = cUNOPx(reverse)->op_first;
11446 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11447 && (cUNOPx(pushmark)->op_sibling == o)) {
11448 /* reverse -> pushmark -> sort */
11449 o->op_private |= OPpSORT_REVERSE;
11451 pushmark->op_next = oright->op_next;
11461 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11463 LISTOP *enter, *exlist;
11465 if (o->op_private & OPpSORT_INPLACE)
11468 enter = (LISTOP *) o->op_next;
11471 if (enter->op_type == OP_NULL) {
11472 enter = (LISTOP *) enter->op_next;
11476 /* for $a (...) will have OP_GV then OP_RV2GV here.
11477 for (...) just has an OP_GV. */
11478 if (enter->op_type == OP_GV) {
11479 gvop = (OP *) enter;
11480 enter = (LISTOP *) enter->op_next;
11483 if (enter->op_type == OP_RV2GV) {
11484 enter = (LISTOP *) enter->op_next;
11490 if (enter->op_type != OP_ENTERITER)
11493 iter = enter->op_next;
11494 if (!iter || iter->op_type != OP_ITER)
11497 expushmark = enter->op_first;
11498 if (!expushmark || expushmark->op_type != OP_NULL
11499 || expushmark->op_targ != OP_PUSHMARK)
11502 exlist = (LISTOP *) expushmark->op_sibling;
11503 if (!exlist || exlist->op_type != OP_NULL
11504 || exlist->op_targ != OP_LIST)
11507 if (exlist->op_last != o) {
11508 /* Mmm. Was expecting to point back to this op. */
11511 theirmark = exlist->op_first;
11512 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11515 if (theirmark->op_sibling != o) {
11516 /* There's something between the mark and the reverse, eg
11517 for (1, reverse (...))
11522 ourmark = ((LISTOP *)o)->op_first;
11523 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11526 ourlast = ((LISTOP *)o)->op_last;
11527 if (!ourlast || ourlast->op_next != o)
11530 rv2av = ourmark->op_sibling;
11531 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11532 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11533 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11534 /* We're just reversing a single array. */
11535 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11536 enter->op_flags |= OPf_STACKED;
11539 /* We don't have control over who points to theirmark, so sacrifice
11541 theirmark->op_next = ourmark->op_next;
11542 theirmark->op_flags = ourmark->op_flags;
11543 ourlast->op_next = gvop ? gvop : (OP *) enter;
11546 enter->op_private |= OPpITER_REVERSED;
11547 iter->op_private |= OPpITER_REVERSED;
11554 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11555 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11560 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11562 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11564 sv = newRV((SV *)PL_compcv);
11568 o->op_type = OP_CONST;
11569 o->op_ppaddr = PL_ppaddr[OP_CONST];
11570 o->op_flags |= OPf_SPECIAL;
11571 cSVOPo->op_sv = sv;
11576 if (OP_GIMME(o,0) == G_VOID) {
11577 OP *right = cBINOP->op_first;
11596 OP *left = right->op_sibling;
11597 if (left->op_type == OP_SUBSTR
11598 && (left->op_private & 7) < 4) {
11600 cBINOP->op_first = left;
11601 right->op_sibling =
11602 cBINOPx(left)->op_first->op_sibling;
11603 cBINOPx(left)->op_first->op_sibling = right;
11604 left->op_private |= OPpSUBSTR_REPL_FIRST;
11606 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11613 Perl_cpeep_t cpeep =
11614 XopENTRYCUSTOM(o, xop_peep);
11616 cpeep(aTHX_ o, oldop);
11621 /* did we just null the current op? If so, re-process it to handle
11622 * eliding "empty" ops from the chain */
11623 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
11636 Perl_peep(pTHX_ OP *o)
11642 =head1 Custom Operators
11644 =for apidoc Ao||custom_op_xop
11645 Return the XOP structure for a given custom op. This macro should be
11646 considered internal to OP_NAME and the other access macros: use them instead.
11647 This macro does call a function. Prior
11648 to 5.19.6, this was implemented as a
11655 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
11661 static const XOP xop_null = { 0, 0, 0, 0, 0 };
11663 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
11664 assert(o->op_type == OP_CUSTOM);
11666 /* This is wrong. It assumes a function pointer can be cast to IV,
11667 * which isn't guaranteed, but this is what the old custom OP code
11668 * did. In principle it should be safer to Copy the bytes of the
11669 * pointer into a PV: since the new interface is hidden behind
11670 * functions, this can be changed later if necessary. */
11671 /* Change custom_op_xop if this ever happens */
11672 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
11675 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11677 /* assume noone will have just registered a desc */
11678 if (!he && PL_custom_op_names &&
11679 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11684 /* XXX does all this need to be shared mem? */
11685 Newxz(xop, 1, XOP);
11686 pv = SvPV(HeVAL(he), l);
11687 XopENTRY_set(xop, xop_name, savepvn(pv, l));
11688 if (PL_custom_op_descs &&
11689 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11691 pv = SvPV(HeVAL(he), l);
11692 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11694 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11698 xop = (XOP *)&xop_null;
11700 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11704 if(field == XOPe_xop_ptr) {
11707 const U32 flags = XopFLAGS(xop);
11708 if(flags & field) {
11710 case XOPe_xop_name:
11711 any.xop_name = xop->xop_name;
11713 case XOPe_xop_desc:
11714 any.xop_desc = xop->xop_desc;
11716 case XOPe_xop_class:
11717 any.xop_class = xop->xop_class;
11719 case XOPe_xop_peep:
11720 any.xop_peep = xop->xop_peep;
11728 case XOPe_xop_name:
11729 any.xop_name = XOPd_xop_name;
11731 case XOPe_xop_desc:
11732 any.xop_desc = XOPd_xop_desc;
11734 case XOPe_xop_class:
11735 any.xop_class = XOPd_xop_class;
11737 case XOPe_xop_peep:
11738 any.xop_peep = XOPd_xop_peep;
11746 /* Some gcc releases emit a warning for this function:
11747 * op.c: In function 'Perl_custom_op_get_field':
11748 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
11749 * Whether this is true, is currently unknown. */
11755 =for apidoc Ao||custom_op_register
11756 Register a custom op. See L<perlguts/"Custom Operators">.
11762 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11766 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
11768 /* see the comment in custom_op_xop */
11769 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
11771 if (!PL_custom_ops)
11772 PL_custom_ops = newHV();
11774 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11775 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
11780 =for apidoc core_prototype
11782 This function assigns the prototype of the named core function to C<sv>, or
11783 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
11784 NULL if the core function has no prototype. C<code> is a code as returned
11785 by C<keyword()>. It must not be equal to 0.
11791 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
11794 int i = 0, n = 0, seen_question = 0, defgv = 0;
11796 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11797 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
11798 bool nullret = FALSE;
11800 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11804 if (!sv) sv = sv_newmortal();
11806 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
11808 switch (code < 0 ? -code : code) {
11809 case KEY_and : case KEY_chop: case KEY_chomp:
11810 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
11811 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
11812 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
11813 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
11814 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
11815 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
11816 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
11817 case KEY_x : case KEY_xor :
11818 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
11819 case KEY_glob: retsetpvs("_;", OP_GLOB);
11820 case KEY_keys: retsetpvs("+", OP_KEYS);
11821 case KEY_values: retsetpvs("+", OP_VALUES);
11822 case KEY_each: retsetpvs("+", OP_EACH);
11823 case KEY_push: retsetpvs("+@", OP_PUSH);
11824 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11825 case KEY_pop: retsetpvs(";+", OP_POP);
11826 case KEY_shift: retsetpvs(";+", OP_SHIFT);
11827 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
11829 retsetpvs("+;$$@", OP_SPLICE);
11830 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
11832 case KEY_evalbytes:
11833 name = "entereval"; break;
11841 while (i < MAXO) { /* The slow way. */
11842 if (strEQ(name, PL_op_name[i])
11843 || strEQ(name, PL_op_desc[i]))
11845 if (nullret) { assert(opnum); *opnum = i; return NULL; }
11852 defgv = PL_opargs[i] & OA_DEFGV;
11853 oa = PL_opargs[i] >> OASHIFT;
11855 if (oa & OA_OPTIONAL && !seen_question && (
11856 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
11861 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11862 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11863 /* But globs are already references (kinda) */
11864 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11868 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11869 && !scalar_mod_type(NULL, i)) {
11874 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
11878 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
11879 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11880 str[n-1] = '_'; defgv = 0;
11884 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
11886 sv_setpvn(sv, str, n - 1);
11887 if (opnum) *opnum = i;
11892 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11895 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
11898 PERL_ARGS_ASSERT_CORESUB_OP;
11902 return op_append_elem(OP_LINESEQ,
11905 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
11909 case OP_SELECT: /* which represents OP_SSELECT as well */
11914 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11915 newSVOP(OP_CONST, 0, newSVuv(1))
11917 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11919 coresub_op(coreargssv, 0, OP_SELECT)
11923 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11925 return op_append_elem(
11928 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11929 ? OPpOFFBYONE << 8 : 0)
11931 case OA_BASEOP_OR_UNOP:
11932 if (opnum == OP_ENTEREVAL) {
11933 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11934 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11936 else o = newUNOP(opnum,0,argop);
11937 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11940 if (is_handle_constructor(o, 1))
11941 argop->op_private |= OPpCOREARGS_DEREF1;
11942 if (scalar_mod_type(NULL, opnum))
11943 argop->op_private |= OPpCOREARGS_SCALARMOD;
11947 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
11948 if (is_handle_constructor(o, 2))
11949 argop->op_private |= OPpCOREARGS_DEREF2;
11950 if (opnum == OP_SUBSTR) {
11951 o->op_private |= OPpMAYBE_LVSUB;
11960 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11961 SV * const *new_const_svp)
11963 const char *hvname;
11964 bool is_const = !!CvCONST(old_cv);
11965 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11967 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11969 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11971 /* They are 2 constant subroutines generated from
11972 the same constant. This probably means that
11973 they are really the "same" proxy subroutine
11974 instantiated in 2 places. Most likely this is
11975 when a constant is exported twice. Don't warn.
11978 (ckWARN(WARN_REDEFINE)
11980 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11981 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11982 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11983 strEQ(hvname, "autouse"))
11987 && ckWARN_d(WARN_REDEFINE)
11988 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11991 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11993 ? "Constant subroutine %"SVf" redefined"
11994 : "Subroutine %"SVf" redefined",
11999 =head1 Hook manipulation
12001 These functions provide convenient and thread-safe means of manipulating
12008 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12010 Puts a C function into the chain of check functions for a specified op
12011 type. This is the preferred way to manipulate the L</PL_check> array.
12012 I<opcode> specifies which type of op is to be affected. I<new_checker>
12013 is a pointer to the C function that is to be added to that opcode's
12014 check chain, and I<old_checker_p> points to the storage location where a
12015 pointer to the next function in the chain will be stored. The value of
12016 I<new_pointer> is written into the L</PL_check> array, while the value
12017 previously stored there is written to I<*old_checker_p>.
12019 The function should be defined like this:
12021 static OP *new_checker(pTHX_ OP *op) { ... }
12023 It is intended to be called in this manner:
12025 new_checker(aTHX_ op)
12027 I<old_checker_p> should be defined like this:
12029 static Perl_check_t old_checker_p;
12031 L</PL_check> is global to an entire process, and a module wishing to
12032 hook op checking may find itself invoked more than once per process,
12033 typically in different threads. To handle that situation, this function
12034 is idempotent. The location I<*old_checker_p> must initially (once
12035 per process) contain a null pointer. A C variable of static duration
12036 (declared at file scope, typically also marked C<static> to give
12037 it internal linkage) will be implicitly initialised appropriately,
12038 if it does not have an explicit initialiser. This function will only
12039 actually modify the check chain if it finds I<*old_checker_p> to be null.
12040 This function is also thread safe on the small scale. It uses appropriate
12041 locking to avoid race conditions in accessing L</PL_check>.
12043 When this function is called, the function referenced by I<new_checker>
12044 must be ready to be called, except for I<*old_checker_p> being unfilled.
12045 In a threading situation, I<new_checker> may be called immediately,
12046 even before this function has returned. I<*old_checker_p> will always
12047 be appropriately set before I<new_checker> is called. If I<new_checker>
12048 decides not to do anything special with an op that it is given (which
12049 is the usual case for most uses of op check hooking), it must chain the
12050 check function referenced by I<*old_checker_p>.
12052 If you want to influence compilation of calls to a specific subroutine,
12053 then use L</cv_set_call_checker> rather than hooking checking of all
12060 Perl_wrap_op_checker(pTHX_ Optype opcode,
12061 Perl_check_t new_checker, Perl_check_t *old_checker_p)
12065 PERL_UNUSED_CONTEXT;
12066 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12067 if (*old_checker_p) return;
12068 OP_CHECK_MUTEX_LOCK;
12069 if (!*old_checker_p) {
12070 *old_checker_p = PL_check[opcode];
12071 PL_check[opcode] = new_checker;
12073 OP_CHECK_MUTEX_UNLOCK;
12078 /* Efficient sub that returns a constant scalar value. */
12080 const_sv_xsub(pTHX_ CV* cv)
12084 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12085 PERL_UNUSED_ARG(items);
12095 const_av_xsub(pTHX_ CV* cv)
12099 AV * const av = MUTABLE_AV(XSANY.any_ptr);
12107 if (SvRMAGICAL(av))
12108 Perl_croak(aTHX_ "Magical list constants are not supported");
12109 if (GIMME_V != G_ARRAY) {
12111 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
12114 EXTEND(SP, AvFILLp(av)+1);
12115 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12116 XSRETURN(AvFILLp(av)+1);
12121 * c-indentation-style: bsd
12122 * c-basic-offset: 4
12123 * indent-tabs-mode: nil
12126 * ex: set ts=8 sts=4 sw=4 et: