4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
112 /* remove any leading "empty" ops from the op_next chain whose first
113 * node's address is stored in op_p. Store the updated address of the
114 * first node in op_p.
118 S_prune_chain_head(OP** op_p)
121 && ( (*op_p)->op_type == OP_NULL
122 || (*op_p)->op_type == OP_SCOPE
123 || (*op_p)->op_type == OP_SCALAR
124 || (*op_p)->op_type == OP_LINESEQ)
126 *op_p = (*op_p)->op_next;
130 /* See the explanatory comments above struct opslab in op.h. */
132 #ifdef PERL_DEBUG_READONLY_OPS
133 # define PERL_SLAB_SIZE 128
134 # define PERL_MAX_SLAB_SIZE 4096
135 # include <sys/mman.h>
138 #ifndef PERL_SLAB_SIZE
139 # define PERL_SLAB_SIZE 64
141 #ifndef PERL_MAX_SLAB_SIZE
142 # define PERL_MAX_SLAB_SIZE 2048
145 /* rounds up to nearest pointer */
146 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
147 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
150 S_new_slab(pTHX_ size_t sz)
152 #ifdef PERL_DEBUG_READONLY_OPS
153 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
154 PROT_READ|PROT_WRITE,
155 MAP_ANON|MAP_PRIVATE, -1, 0);
156 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
157 (unsigned long) sz, slab));
158 if (slab == MAP_FAILED) {
159 perror("mmap failed");
162 slab->opslab_size = (U16)sz;
164 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
167 /* The context is unused in non-Windows */
170 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
174 /* requires double parens and aTHX_ */
175 #define DEBUG_S_warn(args) \
177 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
181 Perl_Slab_Alloc(pTHX_ size_t sz)
189 /* We only allocate ops from the slab during subroutine compilation.
190 We find the slab via PL_compcv, hence that must be non-NULL. It could
191 also be pointing to a subroutine which is now fully set up (CvROOT()
192 pointing to the top of the optree for that sub), or a subroutine
193 which isn't using the slab allocator. If our sanity checks aren't met,
194 don't use a slab, but allocate the OP directly from the heap. */
195 if (!PL_compcv || CvROOT(PL_compcv)
196 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
198 o = (OP*)PerlMemShared_calloc(1, sz);
202 /* While the subroutine is under construction, the slabs are accessed via
203 CvSTART(), to avoid needing to expand PVCV by one pointer for something
204 unneeded at runtime. Once a subroutine is constructed, the slabs are
205 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
206 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
208 if (!CvSTART(PL_compcv)) {
210 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
211 CvSLABBED_on(PL_compcv);
212 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
214 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
216 opsz = SIZE_TO_PSIZE(sz);
217 sz = opsz + OPSLOT_HEADER_P;
219 /* The slabs maintain a free list of OPs. In particular, constant folding
220 will free up OPs, so it makes sense to re-use them where possible. A
221 freed up slot is used in preference to a new allocation. */
222 if (slab->opslab_freed) {
223 OP **too = &slab->opslab_freed;
225 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
226 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
227 DEBUG_S_warn((aTHX_ "Alas! too small"));
228 o = *(too = &o->op_next);
229 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
233 Zero(o, opsz, I32 *);
239 #define INIT_OPSLOT \
240 slot->opslot_slab = slab; \
241 slot->opslot_next = slab2->opslab_first; \
242 slab2->opslab_first = slot; \
243 o = &slot->opslot_op; \
246 /* The partially-filled slab is next in the chain. */
247 slab2 = slab->opslab_next ? slab->opslab_next : slab;
248 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
249 /* Remaining space is too small. */
251 /* If we can fit a BASEOP, add it to the free chain, so as not
253 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
254 slot = &slab2->opslab_slots;
256 o->op_type = OP_FREED;
257 o->op_next = slab->opslab_freed;
258 slab->opslab_freed = o;
261 /* Create a new slab. Make this one twice as big. */
262 slot = slab2->opslab_first;
263 while (slot->opslot_next) slot = slot->opslot_next;
264 slab2 = S_new_slab(aTHX_
265 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
267 : (DIFF(slab2, slot)+1)*2);
268 slab2->opslab_next = slab->opslab_next;
269 slab->opslab_next = slab2;
271 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
273 /* Create a new op slot */
274 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
275 assert(slot >= &slab2->opslab_slots);
276 if (DIFF(&slab2->opslab_slots, slot)
277 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
278 slot = &slab2->opslab_slots;
280 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
283 /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
285 assert(!o->op_sibling);
292 #ifdef PERL_DEBUG_READONLY_OPS
294 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
296 PERL_ARGS_ASSERT_SLAB_TO_RO;
298 if (slab->opslab_readonly) return;
299 slab->opslab_readonly = 1;
300 for (; slab; slab = slab->opslab_next) {
301 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
302 (unsigned long) slab->opslab_size, slab));*/
303 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
304 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
305 (unsigned long)slab->opslab_size, errno);
310 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
314 PERL_ARGS_ASSERT_SLAB_TO_RW;
316 if (!slab->opslab_readonly) return;
318 for (; slab2; slab2 = slab2->opslab_next) {
319 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
320 (unsigned long) size, slab2));*/
321 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
322 PROT_READ|PROT_WRITE)) {
323 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
324 (unsigned long)slab2->opslab_size, errno);
327 slab->opslab_readonly = 0;
331 # define Slab_to_rw(op) NOOP
334 /* This cannot possibly be right, but it was copied from the old slab
335 allocator, to which it was originally added, without explanation, in
338 # define PerlMemShared PerlMem
342 Perl_Slab_Free(pTHX_ void *op)
344 OP * const o = (OP *)op;
347 PERL_ARGS_ASSERT_SLAB_FREE;
349 if (!o->op_slabbed) {
351 PerlMemShared_free(op);
356 /* If this op is already freed, our refcount will get screwy. */
357 assert(o->op_type != OP_FREED);
358 o->op_type = OP_FREED;
359 o->op_next = slab->opslab_freed;
360 slab->opslab_freed = o;
361 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
362 OpslabREFCNT_dec_padok(slab);
366 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
368 const bool havepad = !!PL_comppad;
369 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
372 PAD_SAVE_SETNULLPAD();
379 Perl_opslab_free(pTHX_ OPSLAB *slab)
382 PERL_ARGS_ASSERT_OPSLAB_FREE;
384 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
385 assert(slab->opslab_refcnt == 1);
386 for (; slab; slab = slab2) {
387 slab2 = slab->opslab_next;
389 slab->opslab_refcnt = ~(size_t)0;
391 #ifdef PERL_DEBUG_READONLY_OPS
392 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
394 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
395 perror("munmap failed");
399 PerlMemShared_free(slab);
405 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
410 size_t savestack_count = 0;
412 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
415 for (slot = slab2->opslab_first;
417 slot = slot->opslot_next) {
418 if (slot->opslot_op.op_type != OP_FREED
419 && !(slot->opslot_op.op_savefree
425 assert(slot->opslot_op.op_slabbed);
426 op_free(&slot->opslot_op);
427 if (slab->opslab_refcnt == 1) goto free;
430 } while ((slab2 = slab2->opslab_next));
431 /* > 1 because the CV still holds a reference count. */
432 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
434 assert(savestack_count == slab->opslab_refcnt-1);
436 /* Remove the CV’s reference count. */
437 slab->opslab_refcnt--;
444 #ifdef PERL_DEBUG_READONLY_OPS
446 Perl_op_refcnt_inc(pTHX_ OP *o)
449 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
450 if (slab && slab->opslab_readonly) {
463 Perl_op_refcnt_dec(pTHX_ OP *o)
466 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
468 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
470 if (slab && slab->opslab_readonly) {
472 result = --o->op_targ;
475 result = --o->op_targ;
481 * In the following definition, the ", (OP*)0" is just to make the compiler
482 * think the expression is of the right type: croak actually does a Siglongjmp.
484 #define CHECKOP(type,o) \
485 ((PL_op_mask && PL_op_mask[type]) \
486 ? ( op_free((OP*)o), \
487 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
489 : PL_check[type](aTHX_ (OP*)o))
491 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
493 #define CHANGE_TYPE(o,type) \
495 o->op_type = (OPCODE)type; \
496 o->op_ppaddr = PL_ppaddr[type]; \
500 S_gv_ename(pTHX_ GV *gv)
502 SV* const tmpsv = sv_newmortal();
504 PERL_ARGS_ASSERT_GV_ENAME;
506 gv_efullname3(tmpsv, gv, NULL);
511 S_no_fh_allowed(pTHX_ OP *o)
513 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
515 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
521 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
523 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
524 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)),
525 SvUTF8(namesv) | flags);
530 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
532 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
533 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
538 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
540 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
542 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
547 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
549 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
551 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
552 SvUTF8(namesv) | flags);
557 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
559 PERL_ARGS_ASSERT_BAD_TYPE_PV;
561 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
562 (int)n, name, t, OP_DESC(kid)), flags);
566 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
568 SV * const namesv = gv_ename(gv);
569 PERL_ARGS_ASSERT_BAD_TYPE_GV;
571 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
572 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
576 S_no_bareword_allowed(pTHX_ OP *o)
578 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
580 qerror(Perl_mess(aTHX_
581 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
583 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
586 /* "register" allocation */
589 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
592 const bool is_our = (PL_parser->in_my == KEY_our);
594 PERL_ARGS_ASSERT_ALLOCMY;
596 if (flags & ~SVf_UTF8)
597 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
600 /* Until we're using the length for real, cross check that we're being
602 assert(strlen(name) == len);
604 /* complain about "my $<special_var>" etc etc */
608 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
609 (name[1] == '_' && (*name == '$' || len > 2))))
611 /* name[2] is true if strlen(name) > 2 */
612 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
613 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
614 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
615 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
616 PL_parser->in_my == KEY_state ? "state" : "my"));
618 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
619 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
622 else if (len == 2 && name[1] == '_' && !is_our)
623 /* diag_listed_as: Use of my $_ is experimental */
624 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
625 "Use of %s $_ is experimental",
626 PL_parser->in_my == KEY_state
630 /* allocate a spare slot and store the name in that slot */
632 off = pad_add_name_pvn(name, len,
633 (is_our ? padadd_OUR :
634 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
635 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
636 PL_parser->in_my_stash,
638 /* $_ is always in main::, even with our */
639 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
643 /* anon sub prototypes contains state vars should always be cloned,
644 * otherwise the state var would be shared between anon subs */
646 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
647 CvCLONE_on(PL_compcv);
653 =head1 Optree Manipulation Functions
655 =for apidoc alloccopstash
657 Available only under threaded builds, this function allocates an entry in
658 C<PL_stashpad> for the stash passed to it.
665 Perl_alloccopstash(pTHX_ HV *hv)
667 PADOFFSET off = 0, o = 1;
668 bool found_slot = FALSE;
670 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
672 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
674 for (; o < PL_stashpadmax; ++o) {
675 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
676 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
677 found_slot = TRUE, off = o;
680 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
681 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
682 off = PL_stashpadmax;
683 PL_stashpadmax += 10;
686 PL_stashpad[PL_stashpadix = off] = hv;
691 /* free the body of an op without examining its contents.
692 * Always use this rather than FreeOp directly */
695 S_op_destroy(pTHX_ OP *o)
703 =for apidoc Am|void|op_free|OP *o
705 Free an op. Only use this when an op is no longer linked to from any
712 Perl_op_free(pTHX_ OP *o)
719 /* Though ops may be freed twice, freeing the op after its slab is a
721 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
722 /* During the forced freeing of ops after compilation failure, kidops
723 may be freed before their parents. */
724 if (!o || o->op_type == OP_FREED)
728 if (o->op_private & OPpREFCOUNTED) {
739 refcnt = OpREFCNT_dec(o);
742 /* Need to find and remove any pattern match ops from the list
743 we maintain for reset(). */
744 find_and_forget_pmops(o);
754 /* Call the op_free hook if it has been set. Do it now so that it's called
755 * at the right time for refcounted ops, but still before all of the kids
759 if (o->op_flags & OPf_KIDS) {
761 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
762 nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
767 type = (OPCODE)o->op_targ;
770 Slab_to_rw(OpSLAB(o));
772 /* COP* is not cleared by op_clear() so that we may track line
773 * numbers etc even after null() */
774 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
780 #ifdef DEBUG_LEAKING_SCALARS
787 Perl_op_clear(pTHX_ OP *o)
792 PERL_ARGS_ASSERT_OP_CLEAR;
794 switch (o->op_type) {
795 case OP_NULL: /* Was holding old type, if any. */
798 case OP_ENTEREVAL: /* Was holding hints. */
802 if (!(o->op_flags & OPf_REF)
803 || (PL_check[o->op_type] != Perl_ck_ftst))
810 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
815 /* It's possible during global destruction that the GV is freed
816 before the optree. Whilst the SvREFCNT_inc is happy to bump from
817 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
818 will trigger an assertion failure, because the entry to sv_clear
819 checks that the scalar is not already freed. A check of for
820 !SvIS_FREED(gv) turns out to be invalid, because during global
821 destruction the reference count can be forced down to zero
822 (with SVf_BREAK set). In which case raising to 1 and then
823 dropping to 0 triggers cleanup before it should happen. I
824 *think* that this might actually be a general, systematic,
825 weakness of the whole idea of SVf_BREAK, in that code *is*
826 allowed to raise and lower references during global destruction,
827 so any *valid* code that happens to do this during global
828 destruction might well trigger premature cleanup. */
829 bool still_valid = gv && SvREFCNT(gv);
832 SvREFCNT_inc_simple_void(gv);
834 if (cPADOPo->op_padix > 0) {
835 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
836 * may still exist on the pad */
837 pad_swipe(cPADOPo->op_padix, TRUE);
838 cPADOPo->op_padix = 0;
841 SvREFCNT_dec(cSVOPo->op_sv);
842 cSVOPo->op_sv = NULL;
845 int try_downgrade = SvREFCNT(gv) == 2;
848 gv_try_downgrade(gv);
852 case OP_METHOD_NAMED:
855 SvREFCNT_dec(cSVOPo->op_sv);
856 cSVOPo->op_sv = NULL;
859 Even if op_clear does a pad_free for the target of the op,
860 pad_free doesn't actually remove the sv that exists in the pad;
861 instead it lives on. This results in that it could be reused as
862 a target later on when the pad was reallocated.
865 pad_swipe(o->op_targ,1);
875 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
880 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
881 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
883 if (cPADOPo->op_padix > 0) {
884 pad_swipe(cPADOPo->op_padix, TRUE);
885 cPADOPo->op_padix = 0;
888 SvREFCNT_dec(cSVOPo->op_sv);
889 cSVOPo->op_sv = NULL;
893 PerlMemShared_free(cPVOPo->op_pv);
894 cPVOPo->op_pv = NULL;
898 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
902 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
903 /* No GvIN_PAD_off here, because other references may still
904 * exist on the pad */
905 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
908 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
914 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
915 op_free(cPMOPo->op_code_list);
916 cPMOPo->op_code_list = NULL;
918 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
919 /* we use the same protection as the "SAFE" version of the PM_ macros
920 * here since sv_clean_all might release some PMOPs
921 * after PL_regex_padav has been cleared
922 * and the clearing of PL_regex_padav needs to
923 * happen before sv_clean_all
926 if(PL_regex_pad) { /* We could be in destruction */
927 const IV offset = (cPMOPo)->op_pmoffset;
928 ReREFCNT_dec(PM_GETRE(cPMOPo));
929 PL_regex_pad[offset] = &PL_sv_undef;
930 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
934 ReREFCNT_dec(PM_GETRE(cPMOPo));
935 PM_SETRE(cPMOPo, NULL);
941 if (o->op_targ > 0) {
942 pad_free(o->op_targ);
948 S_cop_free(pTHX_ COP* cop)
950 PERL_ARGS_ASSERT_COP_FREE;
953 if (! specialWARN(cop->cop_warnings))
954 PerlMemShared_free(cop->cop_warnings);
955 cophh_free(CopHINTHASH_get(cop));
956 if (PL_curcop == cop)
961 S_forget_pmop(pTHX_ PMOP *const o
964 HV * const pmstash = PmopSTASH(o);
966 PERL_ARGS_ASSERT_FORGET_PMOP;
968 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
969 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
971 PMOP **const array = (PMOP**) mg->mg_ptr;
972 U32 count = mg->mg_len / sizeof(PMOP**);
977 /* Found it. Move the entry at the end to overwrite it. */
978 array[i] = array[--count];
979 mg->mg_len = count * sizeof(PMOP**);
980 /* Could realloc smaller at this point always, but probably
981 not worth it. Probably worth free()ing if we're the
984 Safefree(mg->mg_ptr);
997 S_find_and_forget_pmops(pTHX_ OP *o)
999 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1001 if (o->op_flags & OPf_KIDS) {
1002 OP *kid = cUNOPo->op_first;
1004 switch (kid->op_type) {
1009 forget_pmop((PMOP*)kid);
1011 find_and_forget_pmops(kid);
1012 kid = OP_SIBLING(kid);
1018 =for apidoc Am|void|op_null|OP *o
1020 Neutralizes an op when it is no longer needed, but is still linked to from
1027 Perl_op_null(pTHX_ OP *o)
1031 PERL_ARGS_ASSERT_OP_NULL;
1033 if (o->op_type == OP_NULL)
1036 o->op_targ = o->op_type;
1037 o->op_type = OP_NULL;
1038 o->op_ppaddr = PL_ppaddr[OP_NULL];
1042 Perl_op_refcnt_lock(pTHX)
1047 PERL_UNUSED_CONTEXT;
1052 Perl_op_refcnt_unlock(pTHX)
1057 PERL_UNUSED_CONTEXT;
1063 =for apidoc op_sibling_splice
1065 A general function for editing the structure of an existing chain of
1066 op_sibling nodes. By analogy with the perl-level splice() function, allows
1067 you to delete zero or more sequential nodes, replacing them with zero or
1068 more different nodes. Performs the necessary op_first/op_last
1069 housekeeping on the parent node and op_sibling manipulation on the
1070 children. The last deleted node will be marked as as the last node by
1071 updating the op_sibling or op_lastsib field as appropriate.
1073 Note that op_next is not manipulated, and nodes are not freed; that is the
1074 responsibility of the caller. It also won't create a new list op for an
1075 empty list etc; use higher-level functions like op_append_elem() for that.
1077 parent is the parent node of the sibling chain.
1079 start is the node preceding the first node to be spliced. Node(s)
1080 following it will be deleted, and ops will be inserted after it. If it is
1081 NULL, the first node onwards is deleted, and nodes are inserted at the
1084 del_count is the number of nodes to delete. If zero, no nodes are deleted.
1085 If -1 or greater than or equal to the number of remaining kids, all
1086 remaining kids are deleted.
1088 insert is the first of a chain of nodes to be inserted in place of the nodes.
1089 If NULL, no nodes are inserted.
1091 The head of the chain of deleted ops is returned, or NULL if no ops were
1096 action before after returns
1097 ------ ----- ----- -------
1100 splice(P, A, 2, X-Y-Z) | | B-C
1104 splice(P, NULL, 1, X-Y) | | A
1108 splice(P, NULL, 3, NULL) | | A-B-C
1112 splice(P, B, 0, X-Y) | | NULL
1119 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1121 OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1123 OP *last_del = NULL;
1124 OP *last_ins = NULL;
1126 PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1128 assert(del_count >= -1);
1130 if (del_count && first) {
1132 while (--del_count && OP_HAS_SIBLING(last_del))
1133 last_del = OP_SIBLING(last_del);
1134 rest = OP_SIBLING(last_del);
1135 OP_SIBLING_set(last_del, NULL);
1136 last_del->op_lastsib = 1;
1143 while (OP_HAS_SIBLING(last_ins))
1144 last_ins = OP_SIBLING(last_ins);
1145 OP_SIBLING_set(last_ins, rest);
1146 last_ins->op_lastsib = rest ? 0 : 1;
1152 OP_SIBLING_set(start, insert);
1153 start->op_lastsib = insert ? 0 : 1;
1156 cLISTOPx(parent)->op_first = insert;
1159 /* update op_last etc */
1160 U32 type = parent->op_type;
1163 if (type == OP_NULL)
1164 type = parent->op_targ;
1165 type = PL_opargs[type] & OA_CLASS_MASK;
1167 lastop = last_ins ? last_ins : start ? start : NULL;
1168 if ( type == OA_BINOP
1169 || type == OA_LISTOP
1173 cLISTOPx(parent)->op_last = lastop;
1176 lastop->op_lastsib = 1;
1177 #ifdef PERL_OP_PARENT
1178 lastop->op_sibling = parent;
1182 return last_del ? first : NULL;
1186 =for apidoc op_parent
1188 returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1189 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1196 Perl_op_parent(OP *o)
1198 PERL_ARGS_ASSERT_OP_PARENT;
1199 #ifdef PERL_OP_PARENT
1200 while (OP_HAS_SIBLING(o))
1202 return o->op_sibling;
1210 /* replace the sibling following start with a new UNOP, which becomes
1211 * the parent of the original sibling; e.g.
1213 * op_sibling_newUNOP(P, A, unop-args...)
1221 * where U is the new UNOP.
1223 * parent and start args are the same as for op_sibling_splice();
1224 * type and flags args are as newUNOP().
1226 * Returns the new UNOP.
1230 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1234 kid = op_sibling_splice(parent, start, 1, NULL);
1235 newop = newUNOP(type, flags, kid);
1236 op_sibling_splice(parent, start, 0, newop);
1241 /* lowest-level newLOGOP-style function - just allocates and populates
1242 * the struct. Higher-level stuff should be done by S_new_logop() /
1243 * newLOGOP(). This function exists mainly to avoid op_first assignment
1244 * being spread throughout this file.
1248 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1252 NewOp(1101, logop, 1, LOGOP);
1253 logop->op_type = (OPCODE)type;
1254 logop->op_first = first;
1255 logop->op_other = other;
1256 logop->op_flags = OPf_KIDS;
1257 while (kid && OP_HAS_SIBLING(kid))
1258 kid = OP_SIBLING(kid);
1260 kid->op_lastsib = 1;
1261 #ifdef PERL_OP_PARENT
1262 kid->op_sibling = (OP*)logop;
1269 /* Contextualizers */
1272 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1274 Applies a syntactic context to an op tree representing an expression.
1275 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1276 or C<G_VOID> to specify the context to apply. The modified op tree
1283 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1285 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1287 case G_SCALAR: return scalar(o);
1288 case G_ARRAY: return list(o);
1289 case G_VOID: return scalarvoid(o);
1291 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1298 =for apidoc Am|OP*|op_linklist|OP *o
1299 This function is the implementation of the L</LINKLIST> macro. It should
1300 not be called directly.
1306 Perl_op_linklist(pTHX_ OP *o)
1310 PERL_ARGS_ASSERT_OP_LINKLIST;
1315 /* establish postfix order */
1316 first = cUNOPo->op_first;
1319 o->op_next = LINKLIST(first);
1322 OP *sibl = OP_SIBLING(kid);
1324 kid->op_next = LINKLIST(sibl);
1339 S_scalarkids(pTHX_ OP *o)
1341 if (o && o->op_flags & OPf_KIDS) {
1343 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1350 S_scalarboolean(pTHX_ OP *o)
1352 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1354 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1355 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1356 if (ckWARN(WARN_SYNTAX)) {
1357 const line_t oldline = CopLINE(PL_curcop);
1359 if (PL_parser && PL_parser->copline != NOLINE) {
1360 /* This ensures that warnings are reported at the first line
1361 of the conditional, not the last. */
1362 CopLINE_set(PL_curcop, PL_parser->copline);
1364 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1365 CopLINE_set(PL_curcop, oldline);
1372 S_op_varname(pTHX_ const OP *o)
1375 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1376 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1378 const char funny = o->op_type == OP_PADAV
1379 || o->op_type == OP_RV2AV ? '@' : '%';
1380 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1382 if (cUNOPo->op_first->op_type != OP_GV
1383 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1385 return varname(gv, funny, 0, NULL, 0, 1);
1388 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1393 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1394 { /* or not so pretty :-) */
1395 if (o->op_type == OP_CONST) {
1397 if (SvPOK(*retsv)) {
1399 *retsv = sv_newmortal();
1400 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1401 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1403 else if (!SvOK(*retsv))
1406 else *retpv = "...";
1410 S_scalar_slice_warning(pTHX_ const OP *o)
1414 o->op_type == OP_HSLICE ? '{' : '[';
1416 o->op_type == OP_HSLICE ? '}' : ']';
1418 SV *keysv = NULL; /* just to silence compiler warnings */
1419 const char *key = NULL;
1421 if (!(o->op_private & OPpSLICEWARNING))
1423 if (PL_parser && PL_parser->error_count)
1424 /* This warning can be nonsensical when there is a syntax error. */
1427 kid = cLISTOPo->op_first;
1428 kid = OP_SIBLING(kid); /* get past pushmark */
1429 /* weed out false positives: any ops that can return lists */
1430 switch (kid->op_type) {
1459 /* Don't warn if we have a nulled list either. */
1460 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1463 assert(OP_SIBLING(kid));
1464 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1465 if (!name) /* XS module fiddling with the op tree */
1467 S_op_pretty(aTHX_ kid, &keysv, &key);
1468 assert(SvPOK(name));
1469 sv_chop(name,SvPVX(name)+1);
1471 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1472 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1473 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1475 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1476 lbrack, key, rbrack);
1478 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1479 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1480 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1482 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1483 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1487 Perl_scalar(pTHX_ OP *o)
1491 /* assumes no premature commitment */
1492 if (!o || (PL_parser && PL_parser->error_count)
1493 || (o->op_flags & OPf_WANT)
1494 || o->op_type == OP_RETURN)
1499 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1501 switch (o->op_type) {
1503 scalar(cBINOPo->op_first);
1508 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1518 if (o->op_flags & OPf_KIDS) {
1519 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1525 kid = cLISTOPo->op_first;
1527 kid = OP_SIBLING(kid);
1530 OP *sib = OP_SIBLING(kid);
1531 if (sib && kid->op_type != OP_LEAVEWHEN)
1537 PL_curcop = &PL_compiling;
1542 kid = cLISTOPo->op_first;
1545 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1550 /* Warn about scalar context */
1551 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1552 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1555 const char *key = NULL;
1557 /* This warning can be nonsensical when there is a syntax error. */
1558 if (PL_parser && PL_parser->error_count)
1561 if (!ckWARN(WARN_SYNTAX)) break;
1563 kid = cLISTOPo->op_first;
1564 kid = OP_SIBLING(kid); /* get past pushmark */
1565 assert(OP_SIBLING(kid));
1566 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1567 if (!name) /* XS module fiddling with the op tree */
1569 S_op_pretty(aTHX_ kid, &keysv, &key);
1570 assert(SvPOK(name));
1571 sv_chop(name,SvPVX(name)+1);
1573 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1574 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1575 "%%%"SVf"%c%s%c in scalar context better written "
1577 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1578 lbrack, key, rbrack);
1580 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1581 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1582 "%%%"SVf"%c%"SVf"%c in scalar context better "
1583 "written as $%"SVf"%c%"SVf"%c",
1584 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1585 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1592 Perl_scalarvoid(pTHX_ OP *o)
1596 SV *useless_sv = NULL;
1597 const char* useless = NULL;
1601 PERL_ARGS_ASSERT_SCALARVOID;
1603 if (o->op_type == OP_NEXTSTATE
1604 || o->op_type == OP_DBSTATE
1605 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1606 || o->op_targ == OP_DBSTATE)))
1607 PL_curcop = (COP*)o; /* for warning below */
1609 /* assumes no premature commitment */
1610 want = o->op_flags & OPf_WANT;
1611 if ((want && want != OPf_WANT_SCALAR)
1612 || (PL_parser && PL_parser->error_count)
1613 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1618 if ((o->op_private & OPpTARGET_MY)
1619 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1621 return scalar(o); /* As if inside SASSIGN */
1624 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1626 switch (o->op_type) {
1628 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1632 if (o->op_flags & OPf_STACKED)
1636 if (o->op_private == 4)
1661 case OP_AELEMFAST_LEX:
1682 case OP_GETSOCKNAME:
1683 case OP_GETPEERNAME:
1688 case OP_GETPRIORITY:
1713 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1714 /* Otherwise it's "Useless use of grep iterator" */
1715 useless = OP_DESC(o);
1719 kid = cLISTOPo->op_first;
1720 if (kid && kid->op_type == OP_PUSHRE
1722 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1724 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1726 useless = OP_DESC(o);
1730 kid = cUNOPo->op_first;
1731 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1732 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1735 useless = "negative pattern binding (!~)";
1739 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1740 useless = "non-destructive substitution (s///r)";
1744 useless = "non-destructive transliteration (tr///r)";
1751 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1752 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1753 useless = "a variable";
1758 if (cSVOPo->op_private & OPpCONST_STRICT)
1759 no_bareword_allowed(o);
1761 if (ckWARN(WARN_VOID)) {
1762 /* don't warn on optimised away booleans, eg
1763 * use constant Foo, 5; Foo || print; */
1764 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1766 /* the constants 0 and 1 are permitted as they are
1767 conventionally used as dummies in constructs like
1768 1 while some_condition_with_side_effects; */
1769 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1771 else if (SvPOK(sv)) {
1772 SV * const dsv = newSVpvs("");
1774 = Perl_newSVpvf(aTHX_
1776 pv_pretty(dsv, SvPVX_const(sv),
1777 SvCUR(sv), 32, NULL, NULL,
1779 | PERL_PV_ESCAPE_NOCLEAR
1780 | PERL_PV_ESCAPE_UNI_DETECT));
1781 SvREFCNT_dec_NN(dsv);
1783 else if (SvOK(sv)) {
1784 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1787 useless = "a constant (undef)";
1790 op_null(o); /* don't execute or even remember it */
1794 o->op_type = OP_PREINC; /* pre-increment is faster */
1795 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1799 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1800 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1804 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1805 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1809 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1810 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1815 UNOP *refgen, *rv2cv;
1818 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1821 rv2gv = ((BINOP *)o)->op_last;
1822 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1825 refgen = (UNOP *)((BINOP *)o)->op_first;
1827 if (!refgen || refgen->op_type != OP_REFGEN)
1830 exlist = (LISTOP *)refgen->op_first;
1831 if (!exlist || exlist->op_type != OP_NULL
1832 || exlist->op_targ != OP_LIST)
1835 if (exlist->op_first->op_type != OP_PUSHMARK)
1838 rv2cv = (UNOP*)exlist->op_last;
1840 if (rv2cv->op_type != OP_RV2CV)
1843 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1844 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1845 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1847 o->op_private |= OPpASSIGN_CV_TO_GV;
1848 rv2gv->op_private |= OPpDONT_INIT_GV;
1849 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1861 kid = cLOGOPo->op_first;
1862 if (kid->op_type == OP_NOT
1863 && (kid->op_flags & OPf_KIDS)) {
1864 if (o->op_type == OP_AND) {
1866 o->op_ppaddr = PL_ppaddr[OP_OR];
1868 o->op_type = OP_AND;
1869 o->op_ppaddr = PL_ppaddr[OP_AND];
1879 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1884 if (o->op_flags & OPf_STACKED)
1891 if (!(o->op_flags & OPf_KIDS))
1902 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1913 /* mortalise it, in case warnings are fatal. */
1914 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1915 "Useless use of %"SVf" in void context",
1916 SVfARG(sv_2mortal(useless_sv)));
1919 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1920 "Useless use of %s in void context",
1927 S_listkids(pTHX_ OP *o)
1929 if (o && o->op_flags & OPf_KIDS) {
1931 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1938 Perl_list(pTHX_ OP *o)
1942 /* assumes no premature commitment */
1943 if (!o || (o->op_flags & OPf_WANT)
1944 || (PL_parser && PL_parser->error_count)
1945 || o->op_type == OP_RETURN)
1950 if ((o->op_private & OPpTARGET_MY)
1951 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1953 return o; /* As if inside SASSIGN */
1956 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1958 switch (o->op_type) {
1961 list(cBINOPo->op_first);
1966 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1974 if (!(o->op_flags & OPf_KIDS))
1976 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1977 list(cBINOPo->op_first);
1978 return gen_constant_list(o);
1985 kid = cLISTOPo->op_first;
1987 kid = OP_SIBLING(kid);
1990 OP *sib = OP_SIBLING(kid);
1991 if (sib && kid->op_type != OP_LEAVEWHEN)
1997 PL_curcop = &PL_compiling;
2001 kid = cLISTOPo->op_first;
2008 S_scalarseq(pTHX_ OP *o)
2011 const OPCODE type = o->op_type;
2013 if (type == OP_LINESEQ || type == OP_SCOPE ||
2014 type == OP_LEAVE || type == OP_LEAVETRY)
2017 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2018 if (OP_HAS_SIBLING(kid)) {
2022 PL_curcop = &PL_compiling;
2024 o->op_flags &= ~OPf_PARENS;
2025 if (PL_hints & HINT_BLOCK_SCOPE)
2026 o->op_flags |= OPf_PARENS;
2029 o = newOP(OP_STUB, 0);
2034 S_modkids(pTHX_ OP *o, I32 type)
2036 if (o && o->op_flags & OPf_KIDS) {
2038 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2039 op_lvalue(kid, type);
2045 =for apidoc finalize_optree
2047 This function finalizes the optree. Should be called directly after
2048 the complete optree is built. It does some additional
2049 checking which can't be done in the normal ck_xxx functions and makes
2050 the tree thread-safe.
2055 Perl_finalize_optree(pTHX_ OP* o)
2057 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2060 SAVEVPTR(PL_curcop);
2068 S_finalize_op(pTHX_ OP* o)
2070 PERL_ARGS_ASSERT_FINALIZE_OP;
2073 switch (o->op_type) {
2076 PL_curcop = ((COP*)o); /* for warnings */
2079 if (OP_HAS_SIBLING(o)) {
2080 OP *sib = OP_SIBLING(o);
2081 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2082 && ckWARN(WARN_EXEC)
2083 && OP_HAS_SIBLING(sib))
2085 const OPCODE type = OP_SIBLING(sib)->op_type;
2086 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2087 const line_t oldline = CopLINE(PL_curcop);
2088 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2089 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2090 "Statement unlikely to be reached");
2091 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2092 "\t(Maybe you meant system() when you said exec()?)\n");
2093 CopLINE_set(PL_curcop, oldline);
2100 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2101 GV * const gv = cGVOPo_gv;
2102 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2103 /* XXX could check prototype here instead of just carping */
2104 SV * const sv = sv_newmortal();
2105 gv_efullname3(sv, gv, NULL);
2106 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2107 "%"SVf"() called too early to check prototype",
2114 if (cSVOPo->op_private & OPpCONST_STRICT)
2115 no_bareword_allowed(o);
2119 case OP_METHOD_NAMED:
2120 /* Relocate sv to the pad for thread safety.
2121 * Despite being a "constant", the SV is written to,
2122 * for reference counts, sv_upgrade() etc. */
2123 if (cSVOPo->op_sv) {
2124 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
2125 SvREFCNT_dec(PAD_SVl(ix));
2126 PAD_SETSV(ix, cSVOPo->op_sv);
2127 /* XXX I don't know how this isn't readonly already. */
2128 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2129 cSVOPo->op_sv = NULL;
2143 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2146 rop = (UNOP*)((BINOP*)o)->op_first;
2151 S_scalar_slice_warning(aTHX_ o);
2155 kid = OP_SIBLING(cLISTOPo->op_first);
2156 if (/* I bet there's always a pushmark... */
2157 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2158 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2163 key_op = (SVOP*)(kid->op_type == OP_CONST
2165 : OP_SIBLING(kLISTOP->op_first));
2167 rop = (UNOP*)((LISTOP*)o)->op_last;
2170 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2172 else if (rop->op_first->op_type == OP_PADSV)
2173 /* @$hash{qw(keys here)} */
2174 rop = (UNOP*)rop->op_first;
2176 /* @{$hash}{qw(keys here)} */
2177 if (rop->op_first->op_type == OP_SCOPE
2178 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2180 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2186 lexname = NULL; /* just to silence compiler warnings */
2187 fields = NULL; /* just to silence compiler warnings */
2191 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2192 SvPAD_TYPED(lexname))
2193 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2194 && isGV(*fields) && GvHV(*fields);
2196 key_op = (SVOP*)OP_SIBLING(key_op)) {
2198 if (key_op->op_type != OP_CONST)
2200 svp = cSVOPx_svp(key_op);
2202 /* Make the CONST have a shared SV */
2203 if ((!SvIsCOW_shared_hash(sv = *svp))
2204 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2206 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2207 SV *nsv = newSVpvn_share(key,
2208 SvUTF8(sv) ? -keylen : keylen, 0);
2209 SvREFCNT_dec_NN(sv);
2214 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2215 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2216 "in variable %"SVf" of type %"HEKf,
2217 SVfARG(*svp), SVfARG(lexname),
2218 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2224 S_scalar_slice_warning(aTHX_ o);
2228 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2229 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2236 if (o->op_flags & OPf_KIDS) {
2240 /* check that op_last points to the last sibling, and that
2241 * the last op_sibling field points back to the parent, and
2242 * that the only ops with KIDS are those which are entitled to
2244 U32 type = o->op_type;
2248 if (type == OP_NULL) {
2250 /* ck_glob creates a null UNOP with ex-type GLOB
2251 * (which is a list op. So pretend it wasn't a listop */
2252 if (type == OP_GLOB)
2255 family = PL_opargs[type] & OA_CLASS_MASK;
2257 has_last = ( family == OA_BINOP
2258 || family == OA_LISTOP
2259 || family == OA_PMOP
2260 || family == OA_LOOP
2262 assert( has_last /* has op_first and op_last, or ...
2263 ... has (or may have) op_first: */
2264 || family == OA_UNOP
2265 || family == OA_LOGOP
2266 || family == OA_BASEOP_OR_UNOP
2267 || family == OA_FILESTATOP
2268 || family == OA_LOOPEXOP
2269 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2270 || type == OP_SASSIGN
2271 || type == OP_CUSTOM
2272 || type == OP_NULL /* new_logop does this */
2274 /* XXX list form of 'x' is has a null op_last. This is wrong,
2275 * but requires too much hacking (e.g. in Deparse) to fix for
2277 if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2282 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2283 # ifdef PERL_OP_PARENT
2284 if (!OP_HAS_SIBLING(kid)) {
2286 assert(kid == cLISTOPo->op_last);
2287 assert(kid->op_sibling == o);
2290 if (OP_HAS_SIBLING(kid)) {
2291 assert(!kid->op_lastsib);
2294 assert(kid->op_lastsib);
2296 assert(kid == cLISTOPo->op_last);
2302 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2308 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2310 Propagate lvalue ("modifiable") context to an op and its children.
2311 I<type> represents the context type, roughly based on the type of op that
2312 would do the modifying, although C<local()> is represented by OP_NULL,
2313 because it has no op type of its own (it is signalled by a flag on
2316 This function detects things that can't be modified, such as C<$x+1>, and
2317 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2318 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2320 It also flags things that need to behave specially in an lvalue context,
2321 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2327 S_vivifies(const OPCODE type)
2330 case OP_RV2AV: case OP_ASLICE:
2331 case OP_RV2HV: case OP_KVASLICE:
2332 case OP_RV2SV: case OP_HSLICE:
2333 case OP_AELEMFAST: case OP_KVHSLICE:
2342 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2346 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2349 if (!o || (PL_parser && PL_parser->error_count))
2352 if ((o->op_private & OPpTARGET_MY)
2353 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2358 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2360 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2362 switch (o->op_type) {
2367 if ((o->op_flags & OPf_PARENS))
2371 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2372 !(o->op_flags & OPf_STACKED)) {
2373 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2374 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2375 poses, so we need it clear. */
2376 o->op_private &= ~1;
2377 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2378 assert(cUNOPo->op_first->op_type == OP_NULL);
2379 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2382 else { /* lvalue subroutine call */
2383 o->op_private |= OPpLVAL_INTRO
2384 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2385 PL_modcount = RETURN_UNLIMITED_NUMBER;
2386 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2387 /* Potential lvalue context: */
2388 o->op_private |= OPpENTERSUB_INARGS;
2391 else { /* Compile-time error message: */
2392 OP *kid = cUNOPo->op_first;
2395 if (kid->op_type != OP_PUSHMARK) {
2396 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2398 "panic: unexpected lvalue entersub "
2399 "args: type/targ %ld:%"UVuf,
2400 (long)kid->op_type, (UV)kid->op_targ);
2401 kid = kLISTOP->op_first;
2403 while (OP_HAS_SIBLING(kid))
2404 kid = OP_SIBLING(kid);
2405 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2406 break; /* Postpone until runtime */
2409 kid = kUNOP->op_first;
2410 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2411 kid = kUNOP->op_first;
2412 if (kid->op_type == OP_NULL)
2414 "Unexpected constant lvalue entersub "
2415 "entry via type/targ %ld:%"UVuf,
2416 (long)kid->op_type, (UV)kid->op_targ);
2417 if (kid->op_type != OP_GV) {
2421 cv = GvCV(kGVOP_gv);
2431 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2432 /* grep, foreach, subcalls, refgen */
2433 if (type == OP_GREPSTART || type == OP_ENTERSUB
2434 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2436 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2437 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2439 : (o->op_type == OP_ENTERSUB
2440 ? "non-lvalue subroutine call"
2442 type ? PL_op_desc[type] : "local"));
2456 case OP_RIGHT_SHIFT:
2465 if (!(o->op_flags & OPf_STACKED))
2472 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2473 op_lvalue(kid, type);
2478 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2479 PL_modcount = RETURN_UNLIMITED_NUMBER;
2480 return o; /* Treat \(@foo) like ordinary list. */
2484 if (scalar_mod_type(o, type))
2486 ref(cUNOPo->op_first, o->op_type);
2493 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2494 if (type == OP_LEAVESUBLV && (
2495 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2496 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2498 o->op_private |= OPpMAYBE_LVSUB;
2502 PL_modcount = RETURN_UNLIMITED_NUMBER;
2506 if (type == OP_LEAVESUBLV)
2507 o->op_private |= OPpMAYBE_LVSUB;
2510 PL_hints |= HINT_BLOCK_SCOPE;
2511 if (type == OP_LEAVESUBLV)
2512 o->op_private |= OPpMAYBE_LVSUB;
2516 ref(cUNOPo->op_first, o->op_type);
2520 PL_hints |= HINT_BLOCK_SCOPE;
2530 case OP_AELEMFAST_LEX:
2537 PL_modcount = RETURN_UNLIMITED_NUMBER;
2538 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2539 return o; /* Treat \(@foo) like ordinary list. */
2540 if (scalar_mod_type(o, type))
2542 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2543 && type == OP_LEAVESUBLV)
2544 o->op_private |= OPpMAYBE_LVSUB;
2548 if (!type) /* local() */
2549 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2550 PAD_COMPNAME_SV(o->op_targ));
2559 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2563 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2569 if (type == OP_LEAVESUBLV)
2570 o->op_private |= OPpMAYBE_LVSUB;
2571 if (o->op_flags & OPf_KIDS)
2572 op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2577 ref(cBINOPo->op_first, o->op_type);
2578 if (type == OP_ENTERSUB &&
2579 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2580 o->op_private |= OPpLVAL_DEFER;
2581 if (type == OP_LEAVESUBLV)
2582 o->op_private |= OPpMAYBE_LVSUB;
2589 o->op_private |= OPpLVALUE;
2595 if (o->op_flags & OPf_KIDS)
2596 op_lvalue(cLISTOPo->op_last, type);
2601 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2603 else if (!(o->op_flags & OPf_KIDS))
2605 if (o->op_targ != OP_LIST) {
2606 op_lvalue(cBINOPo->op_first, type);
2612 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2613 /* elements might be in void context because the list is
2614 in scalar context or because they are attribute sub calls */
2615 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2616 op_lvalue(kid, type);
2620 if (type != OP_LEAVESUBLV)
2622 break; /* op_lvalue()ing was handled by ck_return() */
2629 if (type == OP_LEAVESUBLV
2630 || !S_vivifies(cLOGOPo->op_first->op_type))
2631 op_lvalue(cLOGOPo->op_first, type);
2632 if (type == OP_LEAVESUBLV
2633 || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2634 op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2638 /* [20011101.069] File test operators interpret OPf_REF to mean that
2639 their argument is a filehandle; thus \stat(".") should not set
2641 if (type == OP_REFGEN &&
2642 PL_check[o->op_type] == Perl_ck_ftst)
2645 if (type != OP_LEAVESUBLV)
2646 o->op_flags |= OPf_MOD;
2648 if (type == OP_AASSIGN || type == OP_SASSIGN)
2649 o->op_flags |= OPf_SPECIAL|OPf_REF;
2650 else if (!type) { /* local() */
2653 o->op_private |= OPpLVAL_INTRO;
2654 o->op_flags &= ~OPf_SPECIAL;
2655 PL_hints |= HINT_BLOCK_SCOPE;
2660 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2661 "Useless localization of %s", OP_DESC(o));
2664 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2665 && type != OP_LEAVESUBLV)
2666 o->op_flags |= OPf_REF;
2671 S_scalar_mod_type(const OP *o, I32 type)
2676 if (o && o->op_type == OP_RV2GV)
2700 case OP_RIGHT_SHIFT:
2721 S_is_handle_constructor(const OP *o, I32 numargs)
2723 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2725 switch (o->op_type) {
2733 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2746 S_refkids(pTHX_ OP *o, I32 type)
2748 if (o && o->op_flags & OPf_KIDS) {
2750 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2757 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2762 PERL_ARGS_ASSERT_DOREF;
2764 if (!o || (PL_parser && PL_parser->error_count))
2767 switch (o->op_type) {
2769 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2770 !(o->op_flags & OPf_STACKED)) {
2771 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2772 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2773 assert(cUNOPo->op_first->op_type == OP_NULL);
2774 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2775 o->op_flags |= OPf_SPECIAL;
2776 o->op_private &= ~1;
2778 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2779 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2780 : type == OP_RV2HV ? OPpDEREF_HV
2782 o->op_flags |= OPf_MOD;
2788 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2789 doref(kid, type, set_op_ref);
2792 if (type == OP_DEFINED)
2793 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2794 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2797 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2798 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2799 : type == OP_RV2HV ? OPpDEREF_HV
2801 o->op_flags |= OPf_MOD;
2808 o->op_flags |= OPf_REF;
2811 if (type == OP_DEFINED)
2812 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2813 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2819 o->op_flags |= OPf_REF;
2824 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2826 doref(cBINOPo->op_first, type, set_op_ref);
2830 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2831 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2832 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2833 : type == OP_RV2HV ? OPpDEREF_HV
2835 o->op_flags |= OPf_MOD;
2845 if (!(o->op_flags & OPf_KIDS))
2847 doref(cLISTOPo->op_last, type, set_op_ref);
2857 S_dup_attrlist(pTHX_ OP *o)
2861 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2863 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2864 * where the first kid is OP_PUSHMARK and the remaining ones
2865 * are OP_CONST. We need to push the OP_CONST values.
2867 if (o->op_type == OP_CONST)
2868 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2870 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2872 for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
2873 if (o->op_type == OP_CONST)
2874 rop = op_append_elem(OP_LIST, rop,
2875 newSVOP(OP_CONST, o->op_flags,
2876 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2883 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2885 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2887 PERL_ARGS_ASSERT_APPLY_ATTRS;
2889 /* fake up C<use attributes $pkg,$rv,@attrs> */
2891 #define ATTRSMODULE "attributes"
2892 #define ATTRSMODULE_PM "attributes.pm"
2894 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2895 newSVpvs(ATTRSMODULE),
2897 op_prepend_elem(OP_LIST,
2898 newSVOP(OP_CONST, 0, stashsv),
2899 op_prepend_elem(OP_LIST,
2900 newSVOP(OP_CONST, 0,
2902 dup_attrlist(attrs))));
2906 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2908 OP *pack, *imop, *arg;
2909 SV *meth, *stashsv, **svp;
2911 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2916 assert(target->op_type == OP_PADSV ||
2917 target->op_type == OP_PADHV ||
2918 target->op_type == OP_PADAV);
2920 /* Ensure that attributes.pm is loaded. */
2921 /* Don't force the C<use> if we don't need it. */
2922 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2923 if (svp && *svp != &PL_sv_undef)
2924 NOOP; /* already in %INC */
2926 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2927 newSVpvs(ATTRSMODULE), NULL);
2929 /* Need package name for method call. */
2930 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2932 /* Build up the real arg-list. */
2933 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2935 arg = newOP(OP_PADSV, 0);
2936 arg->op_targ = target->op_targ;
2937 arg = op_prepend_elem(OP_LIST,
2938 newSVOP(OP_CONST, 0, stashsv),
2939 op_prepend_elem(OP_LIST,
2940 newUNOP(OP_REFGEN, 0,
2941 op_lvalue(arg, OP_REFGEN)),
2942 dup_attrlist(attrs)));
2944 /* Fake up a method call to import */
2945 meth = newSVpvs_share("import");
2946 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2947 op_append_elem(OP_LIST,
2948 op_prepend_elem(OP_LIST, pack, list(arg)),
2949 newSVOP(OP_METHOD_NAMED, 0, meth)));
2951 /* Combine the ops. */
2952 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2956 =notfor apidoc apply_attrs_string
2958 Attempts to apply a list of attributes specified by the C<attrstr> and
2959 C<len> arguments to the subroutine identified by the C<cv> argument which
2960 is expected to be associated with the package identified by the C<stashpv>
2961 argument (see L<attributes>). It gets this wrong, though, in that it
2962 does not correctly identify the boundaries of the individual attribute
2963 specifications within C<attrstr>. This is not really intended for the
2964 public API, but has to be listed here for systems such as AIX which
2965 need an explicit export list for symbols. (It's called from XS code
2966 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2967 to respect attribute syntax properly would be welcome.
2973 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2974 const char *attrstr, STRLEN len)
2978 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2981 len = strlen(attrstr);
2985 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2987 const char * const sstr = attrstr;
2988 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2989 attrs = op_append_elem(OP_LIST, attrs,
2990 newSVOP(OP_CONST, 0,
2991 newSVpvn(sstr, attrstr-sstr)));
2995 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2996 newSVpvs(ATTRSMODULE),
2997 NULL, op_prepend_elem(OP_LIST,
2998 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2999 op_prepend_elem(OP_LIST,
3000 newSVOP(OP_CONST, 0,
3001 newRV(MUTABLE_SV(cv))),
3006 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3008 OP *new_proto = NULL;
3013 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3019 if (o->op_type == OP_CONST) {
3020 pv = SvPV(cSVOPo_sv, pvlen);
3021 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3022 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3023 SV ** const tmpo = cSVOPx_svp(o);
3024 SvREFCNT_dec(cSVOPo_sv);
3029 } else if (o->op_type == OP_LIST) {
3031 assert(o->op_flags & OPf_KIDS);
3032 lasto = cLISTOPo->op_first;
3033 assert(lasto->op_type == OP_PUSHMARK);
3034 for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3035 if (o->op_type == OP_CONST) {
3036 pv = SvPV(cSVOPo_sv, pvlen);
3037 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3038 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3039 SV ** const tmpo = cSVOPx_svp(o);
3040 SvREFCNT_dec(cSVOPo_sv);
3042 if (new_proto && ckWARN(WARN_MISC)) {
3044 const char * newp = SvPV(cSVOPo_sv, new_len);
3045 Perl_warner(aTHX_ packWARN(WARN_MISC),
3046 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3047 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3053 /* excise new_proto from the list */
3054 op_sibling_splice(*attrs, lasto, 1, NULL);
3061 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3062 would get pulled in with no real need */
3063 if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3072 svname = sv_newmortal();
3073 gv_efullname3(svname, name, NULL);
3075 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3076 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3078 svname = (SV *)name;
3079 if (ckWARN(WARN_ILLEGALPROTO))
3080 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3081 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3082 STRLEN old_len, new_len;
3083 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3084 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3086 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3087 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3089 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3090 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3100 S_cant_declare(pTHX_ OP *o)
3102 if (o->op_type == OP_NULL
3103 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3104 o = cUNOPo->op_first;
3105 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3106 o->op_type == OP_NULL
3107 && o->op_flags & OPf_SPECIAL
3110 PL_parser->in_my == KEY_our ? "our" :
3111 PL_parser->in_my == KEY_state ? "state" :
3116 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3119 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3121 PERL_ARGS_ASSERT_MY_KID;
3123 if (!o || (PL_parser && PL_parser->error_count))
3128 if (type == OP_LIST) {
3130 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3131 my_kid(kid, attrs, imopsp);
3133 } else if (type == OP_UNDEF || type == OP_STUB) {
3135 } else if (type == OP_RV2SV || /* "our" declaration */
3137 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3138 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3139 S_cant_declare(aTHX_ o);
3141 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3143 PL_parser->in_my = FALSE;
3144 PL_parser->in_my_stash = NULL;
3145 apply_attrs(GvSTASH(gv),
3146 (type == OP_RV2SV ? GvSV(gv) :
3147 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3148 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3151 o->op_private |= OPpOUR_INTRO;
3154 else if (type != OP_PADSV &&
3157 type != OP_PUSHMARK)
3159 S_cant_declare(aTHX_ o);
3162 else if (attrs && type != OP_PUSHMARK) {
3166 PL_parser->in_my = FALSE;
3167 PL_parser->in_my_stash = NULL;
3169 /* check for C<my Dog $spot> when deciding package */
3170 stash = PAD_COMPNAME_TYPE(o->op_targ);
3172 stash = PL_curstash;
3173 apply_attrs_my(stash, o, attrs, imopsp);
3175 o->op_flags |= OPf_MOD;
3176 o->op_private |= OPpLVAL_INTRO;
3178 o->op_private |= OPpPAD_STATE;
3183 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3186 int maybe_scalar = 0;
3188 PERL_ARGS_ASSERT_MY_ATTRS;
3190 /* [perl #17376]: this appears to be premature, and results in code such as
3191 C< our(%x); > executing in list mode rather than void mode */
3193 if (o->op_flags & OPf_PARENS)
3203 o = my_kid(o, attrs, &rops);
3205 if (maybe_scalar && o->op_type == OP_PADSV) {
3206 o = scalar(op_append_list(OP_LIST, rops, o));
3207 o->op_private |= OPpLVAL_INTRO;
3210 /* The listop in rops might have a pushmark at the beginning,
3211 which will mess up list assignment. */
3212 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3213 if (rops->op_type == OP_LIST &&
3214 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3216 OP * const pushmark = lrops->op_first;
3217 /* excise pushmark */
3218 op_sibling_splice(rops, NULL, 1, NULL);
3221 o = op_append_list(OP_LIST, o, rops);
3224 PL_parser->in_my = FALSE;
3225 PL_parser->in_my_stash = NULL;
3230 Perl_sawparens(pTHX_ OP *o)
3232 PERL_UNUSED_CONTEXT;
3234 o->op_flags |= OPf_PARENS;
3239 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3243 const OPCODE ltype = left->op_type;
3244 const OPCODE rtype = right->op_type;
3246 PERL_ARGS_ASSERT_BIND_MATCH;
3248 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3249 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3251 const char * const desc
3253 rtype == OP_SUBST || rtype == OP_TRANS
3254 || rtype == OP_TRANSR
3256 ? (int)rtype : OP_MATCH];
3257 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3259 S_op_varname(aTHX_ left);
3261 Perl_warner(aTHX_ packWARN(WARN_MISC),
3262 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3263 desc, SVfARG(name), SVfARG(name));
3265 const char * const sample = (isary
3266 ? "@array" : "%hash");
3267 Perl_warner(aTHX_ packWARN(WARN_MISC),
3268 "Applying %s to %s will act on scalar(%s)",
3269 desc, sample, sample);
3273 if (rtype == OP_CONST &&
3274 cSVOPx(right)->op_private & OPpCONST_BARE &&
3275 cSVOPx(right)->op_private & OPpCONST_STRICT)
3277 no_bareword_allowed(right);
3280 /* !~ doesn't make sense with /r, so error on it for now */
3281 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3283 /* diag_listed_as: Using !~ with %s doesn't make sense */
3284 yyerror("Using !~ with s///r doesn't make sense");
3285 if (rtype == OP_TRANSR && type == OP_NOT)
3286 /* diag_listed_as: Using !~ with %s doesn't make sense */
3287 yyerror("Using !~ with tr///r doesn't make sense");
3289 ismatchop = (rtype == OP_MATCH ||
3290 rtype == OP_SUBST ||
3291 rtype == OP_TRANS || rtype == OP_TRANSR)
3292 && !(right->op_flags & OPf_SPECIAL);
3293 if (ismatchop && right->op_private & OPpTARGET_MY) {
3295 right->op_private &= ~OPpTARGET_MY;
3297 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3300 right->op_flags |= OPf_STACKED;
3301 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3302 ! (rtype == OP_TRANS &&
3303 right->op_private & OPpTRANS_IDENTICAL) &&
3304 ! (rtype == OP_SUBST &&
3305 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3306 newleft = op_lvalue(left, rtype);
3309 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3310 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3312 o = op_prepend_elem(rtype, scalar(newleft), right);
3314 return newUNOP(OP_NOT, 0, scalar(o));
3318 return bind_match(type, left,
3319 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3323 Perl_invert(pTHX_ OP *o)
3327 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3331 =for apidoc Amx|OP *|op_scope|OP *o
3333 Wraps up an op tree with some additional ops so that at runtime a dynamic
3334 scope will be created. The original ops run in the new dynamic scope,
3335 and then, provided that they exit normally, the scope will be unwound.
3336 The additional ops used to create and unwind the dynamic scope will
3337 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3338 instead if the ops are simple enough to not need the full dynamic scope
3345 Perl_op_scope(pTHX_ OP *o)
3349 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3350 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3351 o->op_type = OP_LEAVE;
3352 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3354 else if (o->op_type == OP_LINESEQ) {
3356 o->op_type = OP_SCOPE;
3357 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3358 kid = ((LISTOP*)o)->op_first;
3359 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3362 /* The following deals with things like 'do {1 for 1}' */
3363 kid = OP_SIBLING(kid);
3365 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3370 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3376 Perl_op_unscope(pTHX_ OP *o)
3378 if (o && o->op_type == OP_LINESEQ) {
3379 OP *kid = cLISTOPo->op_first;
3380 for(; kid; kid = OP_SIBLING(kid))
3381 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3388 Perl_block_start(pTHX_ int full)
3390 const int retval = PL_savestack_ix;
3392 pad_block_start(full);
3394 PL_hints &= ~HINT_BLOCK_SCOPE;
3395 SAVECOMPILEWARNINGS();
3396 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3398 CALL_BLOCK_HOOKS(bhk_start, full);
3404 Perl_block_end(pTHX_ I32 floor, OP *seq)
3406 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3407 OP* retval = scalarseq(seq);
3410 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3414 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3418 /* pad_leavemy has created a sequence of introcv ops for all my
3419 subs declared in the block. We have to replicate that list with
3420 clonecv ops, to deal with this situation:
3425 sub s1 { state sub foo { \&s2 } }
3428 Originally, I was going to have introcv clone the CV and turn
3429 off the stale flag. Since &s1 is declared before &s2, the
3430 introcv op for &s1 is executed (on sub entry) before the one for
3431 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3432 cloned, since it is a state sub) closes over &s2 and expects
3433 to see it in its outer CV’s pad. If the introcv op clones &s1,
3434 then &s2 is still marked stale. Since &s1 is not active, and
3435 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3436 ble will not stay shared’ warning. Because it is the same stub
3437 that will be used when the introcv op for &s2 is executed, clos-
3438 ing over it is safe. Hence, we have to turn off the stale flag
3439 on all lexical subs in the block before we clone any of them.
3440 Hence, having introcv clone the sub cannot work. So we create a
3441 list of ops like this:
3465 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3466 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3467 for (;; kid = OP_SIBLING(kid)) {
3468 OP *newkid = newOP(OP_CLONECV, 0);
3469 newkid->op_targ = kid->op_targ;
3470 o = op_append_elem(OP_LINESEQ, o, newkid);
3471 if (kid == last) break;
3473 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3476 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3482 =head1 Compile-time scope hooks
3484 =for apidoc Aox||blockhook_register
3486 Register a set of hooks to be called when the Perl lexical scope changes
3487 at compile time. See L<perlguts/"Compile-time scope hooks">.
3493 Perl_blockhook_register(pTHX_ BHK *hk)
3495 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3497 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3503 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3504 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3505 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3508 OP * const o = newOP(OP_PADSV, 0);
3509 o->op_targ = offset;
3515 Perl_newPROG(pTHX_ OP *o)
3517 PERL_ARGS_ASSERT_NEWPROG;
3524 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3525 ((PL_in_eval & EVAL_KEEPERR)
3526 ? OPf_SPECIAL : 0), o);
3528 cx = &cxstack[cxstack_ix];
3529 assert(CxTYPE(cx) == CXt_EVAL);
3531 if ((cx->blk_gimme & G_WANT) == G_VOID)
3532 scalarvoid(PL_eval_root);
3533 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3536 scalar(PL_eval_root);
3538 PL_eval_start = op_linklist(PL_eval_root);
3539 PL_eval_root->op_private |= OPpREFCOUNTED;
3540 OpREFCNT_set(PL_eval_root, 1);
3541 PL_eval_root->op_next = 0;
3542 i = PL_savestack_ix;
3545 CALL_PEEP(PL_eval_start);
3546 finalize_optree(PL_eval_root);
3547 S_prune_chain_head(&PL_eval_start);
3549 PL_savestack_ix = i;
3552 if (o->op_type == OP_STUB) {
3553 /* This block is entered if nothing is compiled for the main
3554 program. This will be the case for an genuinely empty main
3555 program, or one which only has BEGIN blocks etc, so already
3558 Historically (5.000) the guard above was !o. However, commit
3559 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3560 c71fccf11fde0068, changed perly.y so that newPROG() is now
3561 called with the output of block_end(), which returns a new
3562 OP_STUB for the case of an empty optree. ByteLoader (and
3563 maybe other things) also take this path, because they set up
3564 PL_main_start and PL_main_root directly, without generating an
3567 If the parsing the main program aborts (due to parse errors,
3568 or due to BEGIN or similar calling exit), then newPROG()
3569 isn't even called, and hence this code path and its cleanups
3570 are skipped. This shouldn't make a make a difference:
3571 * a non-zero return from perl_parse is a failure, and
3572 perl_destruct() should be called immediately.
3573 * however, if exit(0) is called during the parse, then
3574 perl_parse() returns 0, and perl_run() is called. As
3575 PL_main_start will be NULL, perl_run() will return
3576 promptly, and the exit code will remain 0.
3579 PL_comppad_name = 0;
3581 S_op_destroy(aTHX_ o);
3584 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3585 PL_curcop = &PL_compiling;
3586 PL_main_start = LINKLIST(PL_main_root);
3587 PL_main_root->op_private |= OPpREFCOUNTED;
3588 OpREFCNT_set(PL_main_root, 1);
3589 PL_main_root->op_next = 0;
3590 CALL_PEEP(PL_main_start);
3591 finalize_optree(PL_main_root);
3592 S_prune_chain_head(&PL_main_start);
3593 cv_forget_slab(PL_compcv);
3596 /* Register with debugger */
3598 CV * const cv = get_cvs("DB::postponed", 0);
3602 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3604 call_sv(MUTABLE_SV(cv), G_DISCARD);
3611 Perl_localize(pTHX_ OP *o, I32 lex)
3613 PERL_ARGS_ASSERT_LOCALIZE;
3615 if (o->op_flags & OPf_PARENS)
3616 /* [perl #17376]: this appears to be premature, and results in code such as
3617 C< our(%x); > executing in list mode rather than void mode */
3624 if ( PL_parser->bufptr > PL_parser->oldbufptr
3625 && PL_parser->bufptr[-1] == ','
3626 && ckWARN(WARN_PARENTHESIS))
3628 char *s = PL_parser->bufptr;
3631 /* some heuristics to detect a potential error */
3632 while (*s && (strchr(", \t\n", *s)))
3636 if (*s && strchr("@$%*", *s) && *++s
3637 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3640 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3642 while (*s && (strchr(", \t\n", *s)))
3648 if (sigil && (*s == ';' || *s == '=')) {
3649 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3650 "Parentheses missing around \"%s\" list",
3652 ? (PL_parser->in_my == KEY_our
3654 : PL_parser->in_my == KEY_state
3664 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3665 PL_parser->in_my = FALSE;
3666 PL_parser->in_my_stash = NULL;
3671 Perl_jmaybe(pTHX_ OP *o)
3673 PERL_ARGS_ASSERT_JMAYBE;
3675 if (o->op_type == OP_LIST) {
3677 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3678 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3683 PERL_STATIC_INLINE OP *
3684 S_op_std_init(pTHX_ OP *o)
3686 I32 type = o->op_type;
3688 PERL_ARGS_ASSERT_OP_STD_INIT;
3690 if (PL_opargs[type] & OA_RETSCALAR)
3692 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3693 o->op_targ = pad_alloc(type, SVs_PADTMP);
3698 PERL_STATIC_INLINE OP *
3699 S_op_integerize(pTHX_ OP *o)
3701 I32 type = o->op_type;
3703 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3705 /* integerize op. */
3706 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3709 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3712 if (type == OP_NEGATE)
3713 /* XXX might want a ck_negate() for this */
3714 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3720 S_fold_constants(pTHX_ OP *o)
3725 VOL I32 type = o->op_type;
3730 SV * const oldwarnhook = PL_warnhook;
3731 SV * const olddiehook = PL_diehook;
3735 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3737 if (!(PL_opargs[type] & OA_FOLDCONST))
3746 #ifdef USE_LOCALE_CTYPE
3747 if (IN_LC_COMPILETIME(LC_CTYPE))
3756 #ifdef USE_LOCALE_COLLATE
3757 if (IN_LC_COMPILETIME(LC_COLLATE))
3762 /* XXX what about the numeric ops? */
3763 #ifdef USE_LOCALE_NUMERIC
3764 if (IN_LC_COMPILETIME(LC_NUMERIC))
3769 if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3770 || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3773 SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3774 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3776 const char *s = SvPVX_const(sv);
3777 while (s < SvEND(sv)) {
3778 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
3785 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3788 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3789 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3793 if (PL_parser && PL_parser->error_count)
3794 goto nope; /* Don't try to run w/ errors */
3796 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3797 const OPCODE type = curop->op_type;
3798 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3800 type != OP_SCALAR &&
3802 type != OP_PUSHMARK)
3808 curop = LINKLIST(o);
3809 old_next = o->op_next;
3813 oldscope = PL_scopestack_ix;
3814 create_eval_scope(G_FAKINGEVAL);
3816 /* Verify that we don't need to save it: */
3817 assert(PL_curcop == &PL_compiling);
3818 StructCopy(&PL_compiling, ¬_compiling, COP);
3819 PL_curcop = ¬_compiling;
3820 /* The above ensures that we run with all the correct hints of the
3821 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3822 assert(IN_PERL_RUNTIME);
3823 PL_warnhook = PERL_WARNHOOK_FATAL;
3830 sv = *(PL_stack_sp--);
3831 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3832 pad_swipe(o->op_targ, FALSE);
3834 else if (SvTEMP(sv)) { /* grab mortal temp? */
3835 SvREFCNT_inc_simple_void(sv);
3838 else { assert(SvIMMORTAL(sv)); }
3841 /* Something tried to die. Abandon constant folding. */
3842 /* Pretend the error never happened. */
3844 o->op_next = old_next;
3848 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3849 PL_warnhook = oldwarnhook;
3850 PL_diehook = olddiehook;
3851 /* XXX note that this croak may fail as we've already blown away
3852 * the stack - eg any nested evals */
3853 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3856 PL_warnhook = oldwarnhook;
3857 PL_diehook = olddiehook;
3858 PL_curcop = &PL_compiling;
3860 if (PL_scopestack_ix > oldscope)
3861 delete_eval_scope();
3868 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3869 else if (!SvIMMORTAL(sv)) {
3873 if (type == OP_RV2GV)
3874 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3877 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3878 if (type != OP_STRINGIFY) newop->op_folded = 1;
3887 S_gen_constant_list(pTHX_ OP *o)
3891 const SSize_t oldtmps_floor = PL_tmps_floor;
3896 if (PL_parser && PL_parser->error_count)
3897 return o; /* Don't attempt to run with errors */
3899 curop = LINKLIST(o);
3902 S_prune_chain_head(&curop);
3904 Perl_pp_pushmark(aTHX);
3907 assert (!(curop->op_flags & OPf_SPECIAL));
3908 assert(curop->op_type == OP_RANGE);
3909 Perl_pp_anonlist(aTHX);
3910 PL_tmps_floor = oldtmps_floor;
3912 o->op_type = OP_RV2AV;
3913 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3914 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3915 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3916 o->op_opt = 0; /* needs to be revisited in rpeep() */
3917 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3919 /* replace subtree with an OP_CONST */
3920 curop = ((UNOP*)o)->op_first;
3921 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
3924 if (AvFILLp(av) != -1)
3925 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3928 SvREADONLY_on(*svp);
3934 /* convert o (and any siblings) into a list if not already, then
3935 * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
3939 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3942 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3943 if (!o || o->op_type != OP_LIST)
3944 o = force_list(o, 0);
3946 o->op_flags &= ~OPf_WANT;
3948 if (!(PL_opargs[type] & OA_MARK))
3949 op_null(cLISTOPo->op_first);
3951 OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
3952 if (kid2 && kid2->op_type == OP_COREARGS) {
3953 op_null(cLISTOPo->op_first);
3954 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3958 o->op_type = (OPCODE)type;
3959 o->op_ppaddr = PL_ppaddr[type];
3960 o->op_flags |= flags;
3962 o = CHECKOP(type, o);
3963 if (o->op_type != (unsigned)type)
3966 return fold_constants(op_integerize(op_std_init(o)));
3970 =head1 Optree Manipulation Functions
3973 /* List constructors */
3976 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3978 Append an item to the list of ops contained directly within a list-type
3979 op, returning the lengthened list. I<first> is the list-type op,
3980 and I<last> is the op to append to the list. I<optype> specifies the
3981 intended opcode for the list. If I<first> is not already a list of the
3982 right type, it will be upgraded into one. If either I<first> or I<last>
3983 is null, the other is returned unchanged.
3989 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3997 if (first->op_type != (unsigned)type
3998 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4000 return newLISTOP(type, 0, first, last);
4003 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4004 first->op_flags |= OPf_KIDS;
4009 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4011 Concatenate the lists of ops contained directly within two list-type ops,
4012 returning the combined list. I<first> and I<last> are the list-type ops
4013 to concatenate. I<optype> specifies the intended opcode for the list.
4014 If either I<first> or I<last> is not already a list of the right type,
4015 it will be upgraded into one. If either I<first> or I<last> is null,
4016 the other is returned unchanged.
4022 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4030 if (first->op_type != (unsigned)type)
4031 return op_prepend_elem(type, first, last);
4033 if (last->op_type != (unsigned)type)
4034 return op_append_elem(type, first, last);
4036 ((LISTOP*)first)->op_last->op_lastsib = 0;
4037 OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4038 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4039 ((LISTOP*)first)->op_last->op_lastsib = 1;
4040 #ifdef PERL_OP_PARENT
4041 ((LISTOP*)first)->op_last->op_sibling = first;
4043 first->op_flags |= (last->op_flags & OPf_KIDS);
4046 S_op_destroy(aTHX_ last);
4052 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4054 Prepend an item to the list of ops contained directly within a list-type
4055 op, returning the lengthened list. I<first> is the op to prepend to the
4056 list, and I<last> is the list-type op. I<optype> specifies the intended
4057 opcode for the list. If I<last> is not already a list of the right type,
4058 it will be upgraded into one. If either I<first> or I<last> is null,
4059 the other is returned unchanged.
4065 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4073 if (last->op_type == (unsigned)type) {
4074 if (type == OP_LIST) { /* already a PUSHMARK there */
4075 /* insert 'first' after pushmark */
4076 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4077 if (!(first->op_flags & OPf_PARENS))
4078 last->op_flags &= ~OPf_PARENS;
4081 op_sibling_splice(last, NULL, 0, first);
4082 last->op_flags |= OPf_KIDS;
4086 return newLISTOP(type, 0, first, last);
4093 =head1 Optree construction
4095 =for apidoc Am|OP *|newNULLLIST
4097 Constructs, checks, and returns a new C<stub> op, which represents an
4098 empty list expression.
4104 Perl_newNULLLIST(pTHX)
4106 return newOP(OP_STUB, 0);
4109 /* promote o and any siblings to be a list if its not already; i.e.
4117 * pushmark - o - A - B
4119 * If nullit it true, the list op is nulled.
4123 S_force_list(pTHX_ OP *o, bool nullit)
4125 if (!o || o->op_type != OP_LIST) {
4128 /* manually detach any siblings then add them back later */
4129 rest = OP_SIBLING(o);
4130 OP_SIBLING_set(o, NULL);
4133 o = newLISTOP(OP_LIST, 0, o, NULL);
4135 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4143 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4145 Constructs, checks, and returns an op of any list type. I<type> is
4146 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4147 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4148 supply up to two ops to be direct children of the list op; they are
4149 consumed by this function and become part of the constructed op tree.
4155 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4160 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4162 NewOp(1101, listop, 1, LISTOP);
4164 listop->op_type = (OPCODE)type;
4165 listop->op_ppaddr = PL_ppaddr[type];
4168 listop->op_flags = (U8)flags;
4172 else if (!first && last)
4175 OP_SIBLING_set(first, last);
4176 listop->op_first = first;
4177 listop->op_last = last;
4178 if (type == OP_LIST) {
4179 OP* const pushop = newOP(OP_PUSHMARK, 0);
4180 pushop->op_lastsib = 0;
4181 OP_SIBLING_set(pushop, first);
4182 listop->op_first = pushop;
4183 listop->op_flags |= OPf_KIDS;
4185 listop->op_last = pushop;
4188 first->op_lastsib = 0;
4189 if (listop->op_last) {
4190 listop->op_last->op_lastsib = 1;
4191 #ifdef PERL_OP_PARENT
4192 listop->op_last->op_sibling = (OP*)listop;
4196 return CHECKOP(type, listop);
4200 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4202 Constructs, checks, and returns an op of any base type (any type that
4203 has no extra fields). I<type> is the opcode. I<flags> gives the
4204 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4211 Perl_newOP(pTHX_ I32 type, I32 flags)
4216 if (type == -OP_ENTEREVAL) {
4217 type = OP_ENTEREVAL;
4218 flags |= OPpEVAL_BYTES<<8;
4221 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4222 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4223 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4224 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4226 NewOp(1101, o, 1, OP);
4227 o->op_type = (OPCODE)type;
4228 o->op_ppaddr = PL_ppaddr[type];
4229 o->op_flags = (U8)flags;
4232 o->op_private = (U8)(0 | (flags >> 8));
4233 if (PL_opargs[type] & OA_RETSCALAR)
4235 if (PL_opargs[type] & OA_TARGET)
4236 o->op_targ = pad_alloc(type, SVs_PADTMP);
4237 return CHECKOP(type, o);
4241 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4243 Constructs, checks, and returns an op of any unary type. I<type> is
4244 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4245 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4246 bits, the eight bits of C<op_private>, except that the bit with value 1
4247 is automatically set. I<first> supplies an optional op to be the direct
4248 child of the unary op; it is consumed by this function and become part
4249 of the constructed op tree.
4255 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4260 if (type == -OP_ENTEREVAL) {
4261 type = OP_ENTEREVAL;
4262 flags |= OPpEVAL_BYTES<<8;
4265 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4266 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4267 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4268 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4269 || type == OP_SASSIGN
4270 || type == OP_ENTERTRY
4271 || type == OP_NULL );
4274 first = newOP(OP_STUB, 0);
4275 if (PL_opargs[type] & OA_MARK)
4276 first = force_list(first, 1);
4278 NewOp(1101, unop, 1, UNOP);
4279 unop->op_type = (OPCODE)type;
4280 unop->op_ppaddr = PL_ppaddr[type];
4281 unop->op_first = first;
4282 unop->op_flags = (U8)(flags | OPf_KIDS);
4283 unop->op_private = (U8)(1 | (flags >> 8));
4285 #ifdef PERL_OP_PARENT
4286 if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4287 first->op_sibling = (OP*)unop;
4290 unop = (UNOP*) CHECKOP(type, unop);
4294 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4298 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4300 Constructs, checks, and returns an op of any binary type. I<type>
4301 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4302 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4303 the eight bits of C<op_private>, except that the bit with value 1 or
4304 2 is automatically set as required. I<first> and I<last> supply up to
4305 two ops to be the direct children of the binary op; they are consumed
4306 by this function and become part of the constructed op tree.
4312 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4317 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4318 || type == OP_SASSIGN || type == OP_NULL );
4320 NewOp(1101, binop, 1, BINOP);
4323 first = newOP(OP_NULL, 0);
4325 binop->op_type = (OPCODE)type;
4326 binop->op_ppaddr = PL_ppaddr[type];
4327 binop->op_first = first;
4328 binop->op_flags = (U8)(flags | OPf_KIDS);
4331 binop->op_private = (U8)(1 | (flags >> 8));
4334 binop->op_private = (U8)(2 | (flags >> 8));
4335 OP_SIBLING_set(first, last);
4336 first->op_lastsib = 0;
4339 #ifdef PERL_OP_PARENT
4340 if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4341 last->op_sibling = (OP*)binop;
4344 binop = (BINOP*)CHECKOP(type, binop);
4345 if (binop->op_next || binop->op_type != (OPCODE)type)
4348 binop->op_last = OP_SIBLING(binop->op_first);
4349 #ifdef PERL_OP_PARENT
4351 binop->op_last->op_sibling = (OP*)binop;
4354 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4357 static int uvcompare(const void *a, const void *b)
4358 __attribute__nonnull__(1)
4359 __attribute__nonnull__(2)
4360 __attribute__pure__;
4361 static int uvcompare(const void *a, const void *b)
4363 if (*((const UV *)a) < (*(const UV *)b))
4365 if (*((const UV *)a) > (*(const UV *)b))
4367 if (*((const UV *)a+1) < (*(const UV *)b+1))
4369 if (*((const UV *)a+1) > (*(const UV *)b+1))
4375 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4377 SV * const tstr = ((SVOP*)expr)->op_sv;
4379 ((SVOP*)repl)->op_sv;
4382 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4383 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4389 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4390 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4391 I32 del = o->op_private & OPpTRANS_DELETE;
4394 PERL_ARGS_ASSERT_PMTRANS;
4396 PL_hints |= HINT_BLOCK_SCOPE;
4399 o->op_private |= OPpTRANS_FROM_UTF;
4402 o->op_private |= OPpTRANS_TO_UTF;
4404 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4405 SV* const listsv = newSVpvs("# comment\n");
4407 const U8* tend = t + tlen;
4408 const U8* rend = r + rlen;
4422 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4423 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4426 const U32 flags = UTF8_ALLOW_DEFAULT;
4430 t = tsave = bytes_to_utf8(t, &len);
4433 if (!to_utf && rlen) {
4435 r = rsave = bytes_to_utf8(r, &len);
4439 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4440 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4444 U8 tmpbuf[UTF8_MAXBYTES+1];
4447 Newx(cp, 2*tlen, UV);
4449 transv = newSVpvs("");
4451 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4453 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4455 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4459 cp[2*i+1] = cp[2*i];
4463 qsort(cp, i, 2*sizeof(UV), uvcompare);
4464 for (j = 0; j < i; j++) {
4466 diff = val - nextmin;
4468 t = uvchr_to_utf8(tmpbuf,nextmin);
4469 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4471 U8 range_mark = ILLEGAL_UTF8_BYTE;
4472 t = uvchr_to_utf8(tmpbuf, val - 1);
4473 sv_catpvn(transv, (char *)&range_mark, 1);
4474 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4481 t = uvchr_to_utf8(tmpbuf,nextmin);
4482 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4484 U8 range_mark = ILLEGAL_UTF8_BYTE;
4485 sv_catpvn(transv, (char *)&range_mark, 1);
4487 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4488 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4489 t = (const U8*)SvPVX_const(transv);
4490 tlen = SvCUR(transv);
4494 else if (!rlen && !del) {
4495 r = t; rlen = tlen; rend = tend;
4498 if ((!rlen && !del) || t == r ||
4499 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4501 o->op_private |= OPpTRANS_IDENTICAL;
4505 while (t < tend || tfirst <= tlast) {
4506 /* see if we need more "t" chars */
4507 if (tfirst > tlast) {
4508 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4510 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4512 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4519 /* now see if we need more "r" chars */
4520 if (rfirst > rlast) {
4522 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4524 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4526 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4535 rfirst = rlast = 0xffffffff;
4539 /* now see which range will peter our first, if either. */
4540 tdiff = tlast - tfirst;
4541 rdiff = rlast - rfirst;
4548 if (rfirst == 0xffffffff) {
4549 diff = tdiff; /* oops, pretend rdiff is infinite */
4551 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4552 (long)tfirst, (long)tlast);
4554 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4558 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4559 (long)tfirst, (long)(tfirst + diff),
4562 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4563 (long)tfirst, (long)rfirst);
4565 if (rfirst + diff > max)
4566 max = rfirst + diff;
4568 grows = (tfirst < rfirst &&
4569 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4581 else if (max > 0xff)
4586 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4588 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4589 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4590 PAD_SETSV(cPADOPo->op_padix, swash);
4592 SvREADONLY_on(swash);
4594 cSVOPo->op_sv = swash;
4596 SvREFCNT_dec(listsv);
4597 SvREFCNT_dec(transv);
4599 if (!del && havefinal && rlen)
4600 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4601 newSVuv((UV)final), 0);
4604 o->op_private |= OPpTRANS_GROWS;
4614 tbl = (short*)PerlMemShared_calloc(
4615 (o->op_private & OPpTRANS_COMPLEMENT) &&
4616 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4618 cPVOPo->op_pv = (char*)tbl;
4620 for (i = 0; i < (I32)tlen; i++)
4622 for (i = 0, j = 0; i < 256; i++) {
4624 if (j >= (I32)rlen) {
4633 if (i < 128 && r[j] >= 128)
4643 o->op_private |= OPpTRANS_IDENTICAL;
4645 else if (j >= (I32)rlen)
4650 PerlMemShared_realloc(tbl,
4651 (0x101+rlen-j) * sizeof(short));
4652 cPVOPo->op_pv = (char*)tbl;
4654 tbl[0x100] = (short)(rlen - j);
4655 for (i=0; i < (I32)rlen - j; i++)
4656 tbl[0x101+i] = r[j+i];
4660 if (!rlen && !del) {
4663 o->op_private |= OPpTRANS_IDENTICAL;
4665 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4666 o->op_private |= OPpTRANS_IDENTICAL;
4668 for (i = 0; i < 256; i++)
4670 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4671 if (j >= (I32)rlen) {
4673 if (tbl[t[i]] == -1)
4679 if (tbl[t[i]] == -1) {
4680 if (t[i] < 128 && r[j] >= 128)
4687 if(del && rlen == tlen) {
4688 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4689 } else if(rlen > tlen && !complement) {
4690 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4694 o->op_private |= OPpTRANS_GROWS;
4702 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4704 Constructs, checks, and returns an op of any pattern matching type.
4705 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4706 and, shifted up eight bits, the eight bits of C<op_private>.
4712 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4717 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4719 NewOp(1101, pmop, 1, PMOP);
4720 pmop->op_type = (OPCODE)type;
4721 pmop->op_ppaddr = PL_ppaddr[type];
4722 pmop->op_flags = (U8)flags;
4723 pmop->op_private = (U8)(0 | (flags >> 8));
4725 if (PL_hints & HINT_RE_TAINT)
4726 pmop->op_pmflags |= PMf_RETAINT;
4727 #ifdef USE_LOCALE_CTYPE
4728 if (IN_LC_COMPILETIME(LC_CTYPE)) {
4729 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4734 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4736 if (PL_hints & HINT_RE_FLAGS) {
4737 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4738 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4740 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4741 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4742 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4744 if (reflags && SvOK(reflags)) {
4745 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4751 assert(SvPOK(PL_regex_pad[0]));
4752 if (SvCUR(PL_regex_pad[0])) {
4753 /* Pop off the "packed" IV from the end. */
4754 SV *const repointer_list = PL_regex_pad[0];
4755 const char *p = SvEND(repointer_list) - sizeof(IV);
4756 const IV offset = *((IV*)p);
4758 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4760 SvEND_set(repointer_list, p);
4762 pmop->op_pmoffset = offset;
4763 /* This slot should be free, so assert this: */
4764 assert(PL_regex_pad[offset] == &PL_sv_undef);
4766 SV * const repointer = &PL_sv_undef;
4767 av_push(PL_regex_padav, repointer);
4768 pmop->op_pmoffset = av_tindex(PL_regex_padav);
4769 PL_regex_pad = AvARRAY(PL_regex_padav);
4773 return CHECKOP(type, pmop);
4776 /* Given some sort of match op o, and an expression expr containing a
4777 * pattern, either compile expr into a regex and attach it to o (if it's
4778 * constant), or convert expr into a runtime regcomp op sequence (if it's
4781 * isreg indicates that the pattern is part of a regex construct, eg
4782 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4783 * split "pattern", which aren't. In the former case, expr will be a list
4784 * if the pattern contains more than one term (eg /a$b/) or if it contains
4785 * a replacement, ie s/// or tr///.
4787 * When the pattern has been compiled within a new anon CV (for
4788 * qr/(?{...})/ ), then floor indicates the savestack level just before
4789 * the new sub was created
4793 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4798 I32 repl_has_vars = 0;
4800 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4801 bool is_compiletime;
4804 PERL_ARGS_ASSERT_PMRUNTIME;
4806 /* for s/// and tr///, last element in list is the replacement; pop it */
4808 if (is_trans || o->op_type == OP_SUBST) {
4810 repl = cLISTOPx(expr)->op_last;
4811 kid = cLISTOPx(expr)->op_first;
4812 while (OP_SIBLING(kid) != repl)
4813 kid = OP_SIBLING(kid);
4814 op_sibling_splice(expr, kid, 1, NULL);
4817 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4822 assert(expr->op_type == OP_LIST);
4823 first = cLISTOPx(expr)->op_first;
4824 last = cLISTOPx(expr)->op_last;
4825 assert(first->op_type == OP_PUSHMARK);
4826 assert(OP_SIBLING(first) == last);
4828 /* cut 'last' from sibling chain, then free everything else */
4829 op_sibling_splice(expr, first, 1, NULL);
4832 return pmtrans(o, last, repl);
4835 /* find whether we have any runtime or code elements;
4836 * at the same time, temporarily set the op_next of each DO block;
4837 * then when we LINKLIST, this will cause the DO blocks to be excluded
4838 * from the op_next chain (and from having LINKLIST recursively
4839 * applied to them). We fix up the DOs specially later */
4843 if (expr->op_type == OP_LIST) {
4845 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4846 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4848 assert(!o->op_next && OP_HAS_SIBLING(o));
4849 o->op_next = OP_SIBLING(o);
4851 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4855 else if (expr->op_type != OP_CONST)
4860 /* fix up DO blocks; treat each one as a separate little sub;
4861 * also, mark any arrays as LIST/REF */
4863 if (expr->op_type == OP_LIST) {
4865 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4867 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4868 assert( !(o->op_flags & OPf_WANT));
4869 /* push the array rather than its contents. The regex
4870 * engine will retrieve and join the elements later */
4871 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4875 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4877 o->op_next = NULL; /* undo temporary hack from above */
4880 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4881 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4883 assert(leaveop->op_first->op_type == OP_ENTER);
4884 assert(OP_HAS_SIBLING(leaveop->op_first));
4885 o->op_next = OP_SIBLING(leaveop->op_first);
4887 assert(leaveop->op_flags & OPf_KIDS);
4888 assert(leaveop->op_last->op_next == (OP*)leaveop);
4889 leaveop->op_next = NULL; /* stop on last op */
4890 op_null((OP*)leaveop);
4894 OP *scope = cLISTOPo->op_first;
4895 assert(scope->op_type == OP_SCOPE);
4896 assert(scope->op_flags & OPf_KIDS);
4897 scope->op_next = NULL; /* stop on last op */
4900 /* have to peep the DOs individually as we've removed it from
4901 * the op_next chain */
4903 S_prune_chain_head(&(o->op_next));
4905 /* runtime finalizes as part of finalizing whole tree */
4909 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4910 assert( !(expr->op_flags & OPf_WANT));
4911 /* push the array rather than its contents. The regex
4912 * engine will retrieve and join the elements later */
4913 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4916 PL_hints |= HINT_BLOCK_SCOPE;
4918 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4920 if (is_compiletime) {
4921 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4922 regexp_engine const *eng = current_re_engine();
4924 if (o->op_flags & OPf_SPECIAL)
4925 rx_flags |= RXf_SPLIT;
4927 if (!has_code || !eng->op_comp) {
4928 /* compile-time simple constant pattern */
4930 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4931 /* whoops! we guessed that a qr// had a code block, but we
4932 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4933 * that isn't required now. Note that we have to be pretty
4934 * confident that nothing used that CV's pad while the
4935 * regex was parsed */
4936 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4937 /* But we know that one op is using this CV's slab. */
4938 cv_forget_slab(PL_compcv);
4940 pm->op_pmflags &= ~PMf_HAS_CV;
4945 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4946 rx_flags, pm->op_pmflags)
4947 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4948 rx_flags, pm->op_pmflags)
4953 /* compile-time pattern that includes literal code blocks */
4954 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4957 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4960 if (pm->op_pmflags & PMf_HAS_CV) {
4962 /* this QR op (and the anon sub we embed it in) is never
4963 * actually executed. It's just a placeholder where we can
4964 * squirrel away expr in op_code_list without the peephole
4965 * optimiser etc processing it for a second time */
4966 OP *qr = newPMOP(OP_QR, 0);
4967 ((PMOP*)qr)->op_code_list = expr;
4969 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4970 SvREFCNT_inc_simple_void(PL_compcv);
4971 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4972 ReANY(re)->qr_anoncv = cv;
4974 /* attach the anon CV to the pad so that
4975 * pad_fixup_inner_anons() can find it */
4976 (void)pad_add_anon(cv, o->op_type);
4977 SvREFCNT_inc_simple_void(cv);
4980 pm->op_code_list = expr;
4985 /* runtime pattern: build chain of regcomp etc ops */
4987 PADOFFSET cv_targ = 0;
4989 reglist = isreg && expr->op_type == OP_LIST;
4994 pm->op_code_list = expr;
4995 /* don't free op_code_list; its ops are embedded elsewhere too */
4996 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4999 if (o->op_flags & OPf_SPECIAL)
5000 pm->op_pmflags |= PMf_SPLIT;
5002 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5003 * to allow its op_next to be pointed past the regcomp and
5004 * preceding stacking ops;
5005 * OP_REGCRESET is there to reset taint before executing the
5007 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5008 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5010 if (pm->op_pmflags & PMf_HAS_CV) {
5011 /* we have a runtime qr with literal code. This means
5012 * that the qr// has been wrapped in a new CV, which
5013 * means that runtime consts, vars etc will have been compiled
5014 * against a new pad. So... we need to execute those ops
5015 * within the environment of the new CV. So wrap them in a call
5016 * to a new anon sub. i.e. for
5020 * we build an anon sub that looks like
5022 * sub { "a", $b, '(?{...})' }
5024 * and call it, passing the returned list to regcomp.
5025 * Or to put it another way, the list of ops that get executed
5029 * ------ -------------------
5030 * pushmark (for regcomp)
5031 * pushmark (for entersub)
5032 * pushmark (for refgen)
5036 * regcreset regcreset
5038 * const("a") const("a")
5040 * const("(?{...})") const("(?{...})")
5045 SvREFCNT_inc_simple_void(PL_compcv);
5046 /* these lines are just an unrolled newANONATTRSUB */
5047 expr = newSVOP(OP_ANONCODE, 0,
5048 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5049 cv_targ = expr->op_targ;
5050 expr = newUNOP(OP_REFGEN, 0, expr);
5052 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5055 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5056 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
5057 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5058 | (reglist ? OPf_STACKED : 0);
5059 rcop->op_targ = cv_targ;
5061 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5062 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
5064 /* establish postfix order */
5065 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5067 rcop->op_next = expr;
5068 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5071 rcop->op_next = LINKLIST(expr);
5072 expr->op_next = (OP*)rcop;
5075 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5081 /* If we are looking at s//.../e with a single statement, get past
5082 the implicit do{}. */
5083 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5084 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5085 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5088 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5089 if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
5090 && !OP_HAS_SIBLING(sib))
5093 if (curop->op_type == OP_CONST)
5095 else if (( (curop->op_type == OP_RV2SV ||
5096 curop->op_type == OP_RV2AV ||
5097 curop->op_type == OP_RV2HV ||
5098 curop->op_type == OP_RV2GV)
5099 && cUNOPx(curop)->op_first
5100 && cUNOPx(curop)->op_first->op_type == OP_GV )
5101 || curop->op_type == OP_PADSV
5102 || curop->op_type == OP_PADAV
5103 || curop->op_type == OP_PADHV
5104 || curop->op_type == OP_PADANY) {
5112 || !RX_PRELEN(PM_GETRE(pm))
5113 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5115 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5116 op_prepend_elem(o->op_type, scalar(repl), o);
5119 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5120 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
5121 rcop->op_private = 1;
5123 /* establish postfix order */
5124 rcop->op_next = LINKLIST(repl);
5125 repl->op_next = (OP*)rcop;
5127 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5128 assert(!(pm->op_pmflags & PMf_ONCE));
5129 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5138 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5140 Constructs, checks, and returns an op of any type that involves an
5141 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
5142 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
5143 takes ownership of one reference to it.
5149 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5154 PERL_ARGS_ASSERT_NEWSVOP;
5156 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5157 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5158 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5160 NewOp(1101, svop, 1, SVOP);
5161 svop->op_type = (OPCODE)type;
5162 svop->op_ppaddr = PL_ppaddr[type];
5164 svop->op_next = (OP*)svop;
5165 svop->op_flags = (U8)flags;
5166 svop->op_private = (U8)(0 | (flags >> 8));
5167 if (PL_opargs[type] & OA_RETSCALAR)
5169 if (PL_opargs[type] & OA_TARGET)
5170 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5171 return CHECKOP(type, svop);
5177 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5179 Constructs, checks, and returns an op of any type that involves a
5180 reference to a pad element. I<type> is the opcode. I<flags> gives the
5181 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5182 is populated with I<sv>; this function takes ownership of one reference
5185 This function only exists if Perl has been compiled to use ithreads.
5191 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5196 PERL_ARGS_ASSERT_NEWPADOP;
5198 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5199 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5200 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5202 NewOp(1101, padop, 1, PADOP);
5203 padop->op_type = (OPCODE)type;
5204 padop->op_ppaddr = PL_ppaddr[type];
5206 pad_alloc(type, IS_PADGV(sv) ? SVf_READONLY : SVs_PADTMP);
5207 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5208 PAD_SETSV(padop->op_padix, sv);
5210 padop->op_next = (OP*)padop;
5211 padop->op_flags = (U8)flags;
5212 if (PL_opargs[type] & OA_RETSCALAR)
5214 if (PL_opargs[type] & OA_TARGET)
5215 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5216 return CHECKOP(type, padop);
5219 #endif /* USE_ITHREADS */
5222 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5224 Constructs, checks, and returns an op of any type that involves an
5225 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5226 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5227 reference; calling this function does not transfer ownership of any
5234 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5236 PERL_ARGS_ASSERT_NEWGVOP;
5240 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5242 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5247 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5249 Constructs, checks, and returns an op of any type that involves an
5250 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5251 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
5252 must have been allocated using C<PerlMemShared_malloc>; the memory will
5253 be freed when the op is destroyed.
5259 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5262 const bool utf8 = cBOOL(flags & SVf_UTF8);
5267 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5269 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5271 NewOp(1101, pvop, 1, PVOP);
5272 pvop->op_type = (OPCODE)type;
5273 pvop->op_ppaddr = PL_ppaddr[type];
5275 pvop->op_next = (OP*)pvop;
5276 pvop->op_flags = (U8)flags;
5277 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5278 if (PL_opargs[type] & OA_RETSCALAR)
5280 if (PL_opargs[type] & OA_TARGET)
5281 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5282 return CHECKOP(type, pvop);
5286 Perl_package(pTHX_ OP *o)
5288 SV *const sv = cSVOPo->op_sv;
5290 PERL_ARGS_ASSERT_PACKAGE;
5292 SAVEGENERICSV(PL_curstash);
5293 save_item(PL_curstname);
5295 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5297 sv_setsv(PL_curstname, sv);
5299 PL_hints |= HINT_BLOCK_SCOPE;
5300 PL_parser->copline = NOLINE;
5306 Perl_package_version( pTHX_ OP *v )
5308 U32 savehints = PL_hints;
5309 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5310 PL_hints &= ~HINT_STRICT_VARS;
5311 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5312 PL_hints = savehints;
5317 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5322 SV *use_version = NULL;
5324 PERL_ARGS_ASSERT_UTILIZE;
5326 if (idop->op_type != OP_CONST)
5327 Perl_croak(aTHX_ "Module name must be constant");
5332 SV * const vesv = ((SVOP*)version)->op_sv;
5334 if (!arg && !SvNIOKp(vesv)) {
5341 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5342 Perl_croak(aTHX_ "Version number must be a constant number");
5344 /* Make copy of idop so we don't free it twice */
5345 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5347 /* Fake up a method call to VERSION */
5348 meth = newSVpvs_share("VERSION");
5349 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5350 op_append_elem(OP_LIST,
5351 op_prepend_elem(OP_LIST, pack, list(version)),
5352 newSVOP(OP_METHOD_NAMED, 0, meth)));
5356 /* Fake up an import/unimport */
5357 if (arg && arg->op_type == OP_STUB) {
5358 imop = arg; /* no import on explicit () */
5360 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5361 imop = NULL; /* use 5.0; */
5363 use_version = ((SVOP*)idop)->op_sv;
5365 idop->op_private |= OPpCONST_NOVER;
5370 /* Make copy of idop so we don't free it twice */
5371 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5373 /* Fake up a method call to import/unimport */
5375 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5376 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5377 op_append_elem(OP_LIST,
5378 op_prepend_elem(OP_LIST, pack, list(arg)),
5379 newSVOP(OP_METHOD_NAMED, 0, meth)));
5382 /* Fake up the BEGIN {}, which does its thing immediately. */
5384 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5387 op_append_elem(OP_LINESEQ,
5388 op_append_elem(OP_LINESEQ,
5389 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5390 newSTATEOP(0, NULL, veop)),
5391 newSTATEOP(0, NULL, imop) ));
5395 * feature bundle that corresponds to the required version. */
5396 use_version = sv_2mortal(new_version(use_version));
5397 S_enable_feature_bundle(aTHX_ use_version);
5399 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5400 if (vcmp(use_version,
5401 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5402 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5403 PL_hints |= HINT_STRICT_REFS;
5404 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5405 PL_hints |= HINT_STRICT_SUBS;
5406 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5407 PL_hints |= HINT_STRICT_VARS;
5409 /* otherwise they are off */
5411 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5412 PL_hints &= ~HINT_STRICT_REFS;
5413 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5414 PL_hints &= ~HINT_STRICT_SUBS;
5415 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5416 PL_hints &= ~HINT_STRICT_VARS;
5420 /* The "did you use incorrect case?" warning used to be here.
5421 * The problem is that on case-insensitive filesystems one
5422 * might get false positives for "use" (and "require"):
5423 * "use Strict" or "require CARP" will work. This causes
5424 * portability problems for the script: in case-strict
5425 * filesystems the script will stop working.
5427 * The "incorrect case" warning checked whether "use Foo"
5428 * imported "Foo" to your namespace, but that is wrong, too:
5429 * there is no requirement nor promise in the language that
5430 * a Foo.pm should or would contain anything in package "Foo".
5432 * There is very little Configure-wise that can be done, either:
5433 * the case-sensitivity of the build filesystem of Perl does not
5434 * help in guessing the case-sensitivity of the runtime environment.
5437 PL_hints |= HINT_BLOCK_SCOPE;
5438 PL_parser->copline = NOLINE;
5439 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5440 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5446 =head1 Embedding Functions
5448 =for apidoc load_module
5450 Loads the module whose name is pointed to by the string part of name.
5451 Note that the actual module name, not its filename, should be given.
5452 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5453 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5454 (or 0 for no flags). ver, if specified
5455 and not NULL, provides version semantics
5456 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5457 arguments can be used to specify arguments to the module's import()
5458 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5459 terminated with a final NULL pointer. Note that this list can only
5460 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5461 Otherwise at least a single NULL pointer to designate the default
5462 import list is required.
5464 The reference count for each specified C<SV*> parameter is decremented.
5469 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5473 PERL_ARGS_ASSERT_LOAD_MODULE;
5475 va_start(args, ver);
5476 vload_module(flags, name, ver, &args);
5480 #ifdef PERL_IMPLICIT_CONTEXT
5482 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5486 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5487 va_start(args, ver);
5488 vload_module(flags, name, ver, &args);
5494 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5497 OP * const modname = newSVOP(OP_CONST, 0, name);
5499 PERL_ARGS_ASSERT_VLOAD_MODULE;
5501 modname->op_private |= OPpCONST_BARE;
5503 veop = newSVOP(OP_CONST, 0, ver);
5507 if (flags & PERL_LOADMOD_NOIMPORT) {
5508 imop = sawparens(newNULLLIST());
5510 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5511 imop = va_arg(*args, OP*);
5516 sv = va_arg(*args, SV*);
5518 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5519 sv = va_arg(*args, SV*);
5523 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5524 * that it has a PL_parser to play with while doing that, and also
5525 * that it doesn't mess with any existing parser, by creating a tmp
5526 * new parser with lex_start(). This won't actually be used for much,
5527 * since pp_require() will create another parser for the real work.
5528 * The ENTER/LEAVE pair protect callers from any side effects of use. */
5531 SAVEVPTR(PL_curcop);
5532 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5533 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5534 veop, modname, imop);
5538 PERL_STATIC_INLINE OP *
5539 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5541 return newUNOP(OP_ENTERSUB, OPf_STACKED,
5542 newLISTOP(OP_LIST, 0, arg,
5543 newUNOP(OP_RV2CV, 0,
5544 newGVOP(OP_GV, 0, gv))));
5548 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5553 PERL_ARGS_ASSERT_DOFILE;
5555 if (!force_builtin && (gv = gv_override("do", 2))) {
5556 doop = S_new_entersubop(aTHX_ gv, term);
5559 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5565 =head1 Optree construction
5567 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5569 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5570 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5571 be set automatically, and, shifted up eight bits, the eight bits of
5572 C<op_private>, except that the bit with value 1 or 2 is automatically
5573 set as required. I<listval> and I<subscript> supply the parameters of
5574 the slice; they are consumed by this function and become part of the
5575 constructed op tree.
5581 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5583 return newBINOP(OP_LSLICE, flags,
5584 list(force_list(subscript, 1)),
5585 list(force_list(listval, 1)) );
5589 S_is_list_assignment(pTHX_ const OP *o)
5597 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5598 o = cUNOPo->op_first;
5600 flags = o->op_flags;
5602 if (type == OP_COND_EXPR) {
5603 OP * const sib = OP_SIBLING(cLOGOPo->op_first);
5604 const I32 t = is_list_assignment(sib);
5605 const I32 f = is_list_assignment(OP_SIBLING(sib));
5610 yyerror("Assignment to both a list and a scalar");
5614 if (type == OP_LIST &&
5615 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5616 o->op_private & OPpLVAL_INTRO)
5619 if (type == OP_LIST || flags & OPf_PARENS ||
5620 type == OP_RV2AV || type == OP_RV2HV ||
5621 type == OP_ASLICE || type == OP_HSLICE ||
5622 type == OP_KVASLICE || type == OP_KVHSLICE)
5625 if (type == OP_PADAV || type == OP_PADHV)
5628 if (type == OP_RV2SV)
5635 Helper function for newASSIGNOP to detection commonality between the
5636 lhs and the rhs. Marks all variables with PL_generation. If it
5637 returns TRUE the assignment must be able to handle common variables.
5639 PERL_STATIC_INLINE bool
5640 S_aassign_common_vars(pTHX_ OP* o)
5643 for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
5644 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5645 if (curop->op_type == OP_GV) {
5646 GV *gv = cGVOPx_gv(curop);
5648 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5650 GvASSIGN_GENERATION_set(gv, PL_generation);
5652 else if (curop->op_type == OP_PADSV ||
5653 curop->op_type == OP_PADAV ||
5654 curop->op_type == OP_PADHV ||
5655 curop->op_type == OP_PADANY)
5657 if (PAD_COMPNAME_GEN(curop->op_targ)
5658 == (STRLEN)PL_generation)
5660 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5663 else if (curop->op_type == OP_RV2CV)
5665 else if (curop->op_type == OP_RV2SV ||
5666 curop->op_type == OP_RV2AV ||
5667 curop->op_type == OP_RV2HV ||
5668 curop->op_type == OP_RV2GV) {
5669 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5672 else if (curop->op_type == OP_PUSHRE) {
5675 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5676 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5679 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5683 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5685 GvASSIGN_GENERATION_set(gv, PL_generation);
5692 if (curop->op_flags & OPf_KIDS) {
5693 if (aassign_common_vars(curop))
5701 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5703 Constructs, checks, and returns an assignment op. I<left> and I<right>
5704 supply the parameters of the assignment; they are consumed by this
5705 function and become part of the constructed op tree.
5707 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5708 a suitable conditional optree is constructed. If I<optype> is the opcode
5709 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5710 performs the binary operation and assigns the result to the left argument.
5711 Either way, if I<optype> is non-zero then I<flags> has no effect.
5713 If I<optype> is zero, then a plain scalar or list assignment is
5714 constructed. Which type of assignment it is is automatically determined.
5715 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5716 will be set automatically, and, shifted up eight bits, the eight bits
5717 of C<op_private>, except that the bit with value 1 or 2 is automatically
5724 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5729 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5730 return newLOGOP(optype, 0,
5731 op_lvalue(scalar(left), optype),
5732 newUNOP(OP_SASSIGN, 0, scalar(right)));
5735 return newBINOP(optype, OPf_STACKED,
5736 op_lvalue(scalar(left), optype), scalar(right));
5740 if (is_list_assignment(left)) {
5741 static const char no_list_state[] = "Initialization of state variables"
5742 " in list context currently forbidden";
5744 bool maybe_common_vars = TRUE;
5746 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5747 left->op_private &= ~ OPpSLICEWARNING;
5750 left = op_lvalue(left, OP_AASSIGN);
5751 curop = list(force_list(left, 1));
5752 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
5753 o->op_private = (U8)(0 | (flags >> 8));
5755 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
5757 OP* lop = ((LISTOP*)left)->op_first;
5758 maybe_common_vars = FALSE;
5760 if (lop->op_type == OP_PADSV ||
5761 lop->op_type == OP_PADAV ||
5762 lop->op_type == OP_PADHV ||
5763 lop->op_type == OP_PADANY) {
5764 if (!(lop->op_private & OPpLVAL_INTRO))
5765 maybe_common_vars = TRUE;
5767 if (lop->op_private & OPpPAD_STATE) {
5768 if (left->op_private & OPpLVAL_INTRO) {
5769 /* Each variable in state($a, $b, $c) = ... */
5772 /* Each state variable in
5773 (state $a, my $b, our $c, $d, undef) = ... */
5775 yyerror(no_list_state);
5777 /* Each my variable in
5778 (state $a, my $b, our $c, $d, undef) = ... */
5780 } else if (lop->op_type == OP_UNDEF ||
5781 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
5782 /* undef may be interesting in
5783 (state $a, undef, state $c) */
5785 /* Other ops in the list. */
5786 maybe_common_vars = TRUE;
5788 lop = OP_SIBLING(lop);
5791 else if ((left->op_private & OPpLVAL_INTRO)
5792 && ( left->op_type == OP_PADSV
5793 || left->op_type == OP_PADAV
5794 || left->op_type == OP_PADHV
5795 || left->op_type == OP_PADANY))
5797 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5798 if (left->op_private & OPpPAD_STATE) {
5799 /* All single variable list context state assignments, hence
5809 yyerror(no_list_state);
5813 /* PL_generation sorcery:
5814 * an assignment like ($a,$b) = ($c,$d) is easier than
5815 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5816 * To detect whether there are common vars, the global var
5817 * PL_generation is incremented for each assign op we compile.
5818 * Then, while compiling the assign op, we run through all the
5819 * variables on both sides of the assignment, setting a spare slot
5820 * in each of them to PL_generation. If any of them already have
5821 * that value, we know we've got commonality. We could use a
5822 * single bit marker, but then we'd have to make 2 passes, first
5823 * to clear the flag, then to test and set it. To find somewhere
5824 * to store these values, evil chicanery is done with SvUVX().
5827 if (maybe_common_vars) {
5829 if (aassign_common_vars(o))
5830 o->op_private |= OPpASSIGN_COMMON;
5834 if (right && right->op_type == OP_SPLIT) {
5835 OP* tmpop = ((LISTOP*)right)->op_first;
5836 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5837 PMOP * const pm = (PMOP*)tmpop;
5838 if (left->op_type == OP_RV2AV &&
5839 !(left->op_private & OPpLVAL_INTRO) &&
5840 !(o->op_private & OPpASSIGN_COMMON) )
5842 tmpop = ((UNOP*)left)->op_first;
5843 if (tmpop->op_type == OP_GV
5845 && !pm->op_pmreplrootu.op_pmtargetoff
5847 && !pm->op_pmreplrootu.op_pmtargetgv
5851 pm->op_pmreplrootu.op_pmtargetoff
5852 = cPADOPx(tmpop)->op_padix;
5853 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5855 pm->op_pmreplrootu.op_pmtargetgv
5856 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5857 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5859 tmpop = cUNOPo->op_first; /* to list (nulled) */
5860 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5861 /* detach rest of siblings from o subtree,
5862 * and free subtree */
5863 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
5864 right->op_next = tmpop->op_next; /* fix starting loc */
5865 op_free(o); /* blow off assign */
5866 right->op_flags &= ~OPf_WANT;
5867 /* "I don't know and I don't care." */
5872 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5873 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5876 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5877 SV * const sv = *svp;
5878 if (SvIOK(sv) && SvIVX(sv) == 0)
5880 if (right->op_private & OPpSPLIT_IMPLIM) {
5881 /* our own SV, created in ck_split */
5883 sv_setiv(sv, PL_modcount+1);
5886 /* SV may belong to someone else */
5888 *svp = newSViv(PL_modcount+1);
5898 right = newOP(OP_UNDEF, 0);
5899 if (right->op_type == OP_READLINE) {
5900 right->op_flags |= OPf_STACKED;
5901 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5905 o = newBINOP(OP_SASSIGN, flags,
5906 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5912 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5914 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5915 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5916 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5917 If I<label> is non-null, it supplies the name of a label to attach to
5918 the state op; this function takes ownership of the memory pointed at by
5919 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5922 If I<o> is null, the state op is returned. Otherwise the state op is
5923 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5924 is consumed by this function and becomes part of the returned op tree.
5930 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5933 const U32 seq = intro_my();
5934 const U32 utf8 = flags & SVf_UTF8;
5939 NewOp(1101, cop, 1, COP);
5940 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5941 cop->op_type = OP_DBSTATE;
5942 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5945 cop->op_type = OP_NEXTSTATE;
5946 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5948 cop->op_flags = (U8)flags;
5949 CopHINTS_set(cop, PL_hints);
5951 cop->op_private |= NATIVE_HINTS;
5954 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
5956 cop->op_next = (OP*)cop;
5959 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5960 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5962 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5964 PL_hints |= HINT_BLOCK_SCOPE;
5965 /* It seems that we need to defer freeing this pointer, as other parts
5966 of the grammar end up wanting to copy it after this op has been
5971 if (PL_parser->preambling != NOLINE) {
5972 CopLINE_set(cop, PL_parser->preambling);
5973 PL_parser->copline = NOLINE;
5975 else if (PL_parser->copline == NOLINE)
5976 CopLINE_set(cop, CopLINE(PL_curcop));
5978 CopLINE_set(cop, PL_parser->copline);
5979 PL_parser->copline = NOLINE;
5982 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5984 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5986 CopSTASH_set(cop, PL_curstash);
5988 if (cop->op_type == OP_DBSTATE) {
5989 /* this line can have a breakpoint - store the cop in IV */
5990 AV *av = CopFILEAVx(PL_curcop);
5992 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
5993 if (svp && *svp != &PL_sv_undef ) {
5994 (void)SvIOK_on(*svp);
5995 SvIV_set(*svp, PTR2IV(cop));
6000 if (flags & OPf_SPECIAL)
6002 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6006 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6008 Constructs, checks, and returns a logical (flow control) op. I<type>
6009 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
6010 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6011 the eight bits of C<op_private>, except that the bit with value 1 is
6012 automatically set. I<first> supplies the expression controlling the
6013 flow, and I<other> supplies the side (alternate) chain of ops; they are
6014 consumed by this function and become part of the constructed op tree.
6020 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6022 PERL_ARGS_ASSERT_NEWLOGOP;
6024 return new_logop(type, flags, &first, &other);
6028 S_search_const(pTHX_ OP *o)
6030 PERL_ARGS_ASSERT_SEARCH_CONST;
6032 switch (o->op_type) {
6036 if (o->op_flags & OPf_KIDS)
6037 return search_const(cUNOPo->op_first);
6044 if (!(o->op_flags & OPf_KIDS))
6046 kid = cLISTOPo->op_first;
6048 switch (kid->op_type) {
6052 kid = OP_SIBLING(kid);
6055 if (kid != cLISTOPo->op_last)
6061 kid = cLISTOPo->op_last;
6063 return search_const(kid);
6071 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6079 int prepend_not = 0;
6081 PERL_ARGS_ASSERT_NEW_LOGOP;
6086 /* [perl #59802]: Warn about things like "return $a or $b", which
6087 is parsed as "(return $a) or $b" rather than "return ($a or
6088 $b)". NB: This also applies to xor, which is why we do it
6091 switch (first->op_type) {
6095 /* XXX: Perhaps we should emit a stronger warning for these.
6096 Even with the high-precedence operator they don't seem to do
6099 But until we do, fall through here.
6105 /* XXX: Currently we allow people to "shoot themselves in the
6106 foot" by explicitly writing "(return $a) or $b".
6108 Warn unless we are looking at the result from folding or if
6109 the programmer explicitly grouped the operators like this.
6110 The former can occur with e.g.
6112 use constant FEATURE => ( $] >= ... );
6113 sub { not FEATURE and return or do_stuff(); }
6115 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6116 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6117 "Possible precedence issue with control flow operator");
6118 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6124 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6125 return newBINOP(type, flags, scalar(first), scalar(other));
6127 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6129 scalarboolean(first);
6130 /* optimize AND and OR ops that have NOTs as children */
6131 if (first->op_type == OP_NOT
6132 && (first->op_flags & OPf_KIDS)
6133 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6134 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6136 if (type == OP_AND || type == OP_OR) {
6142 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6144 prepend_not = 1; /* prepend a NOT op later */
6148 /* search for a constant op that could let us fold the test */
6149 if ((cstop = search_const(first))) {
6150 if (cstop->op_private & OPpCONST_STRICT)
6151 no_bareword_allowed(cstop);
6152 else if ((cstop->op_private & OPpCONST_BARE))
6153 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6154 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6155 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6156 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6158 if (other->op_type == OP_CONST)
6159 other->op_private |= OPpCONST_SHORTCIRCUIT;
6161 if (other->op_type == OP_LEAVE)
6162 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6163 else if (other->op_type == OP_MATCH
6164 || other->op_type == OP_SUBST
6165 || other->op_type == OP_TRANSR
6166 || other->op_type == OP_TRANS)
6167 /* Mark the op as being unbindable with =~ */
6168 other->op_flags |= OPf_SPECIAL;
6170 other->op_folded = 1;
6174 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6175 const OP *o2 = other;
6176 if ( ! (o2->op_type == OP_LIST
6177 && (( o2 = cUNOPx(o2)->op_first))
6178 && o2->op_type == OP_PUSHMARK
6179 && (( o2 = OP_SIBLING(o2))) )
6182 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6183 || o2->op_type == OP_PADHV)
6184 && o2->op_private & OPpLVAL_INTRO
6185 && !(o2->op_private & OPpPAD_STATE))
6187 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6188 "Deprecated use of my() in false conditional");
6192 if (cstop->op_type == OP_CONST)
6193 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6198 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6199 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6201 const OP * const k1 = ((UNOP*)first)->op_first;
6202 const OP * const k2 = OP_SIBLING(k1);
6204 switch (first->op_type)
6207 if (k2 && k2->op_type == OP_READLINE
6208 && (k2->op_flags & OPf_STACKED)
6209 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6211 warnop = k2->op_type;
6216 if (k1->op_type == OP_READDIR
6217 || k1->op_type == OP_GLOB
6218 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6219 || k1->op_type == OP_EACH
6220 || k1->op_type == OP_AEACH)
6222 warnop = ((k1->op_type == OP_NULL)
6223 ? (OPCODE)k1->op_targ : k1->op_type);
6228 const line_t oldline = CopLINE(PL_curcop);
6229 /* This ensures that warnings are reported at the first line
6230 of the construction, not the last. */
6231 CopLINE_set(PL_curcop, PL_parser->copline);
6232 Perl_warner(aTHX_ packWARN(WARN_MISC),
6233 "Value of %s%s can be \"0\"; test with defined()",
6235 ((warnop == OP_READLINE || warnop == OP_GLOB)
6236 ? " construct" : "() operator"));
6237 CopLINE_set(PL_curcop, oldline);
6244 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6245 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6247 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6248 logop->op_ppaddr = PL_ppaddr[type];
6249 logop->op_flags |= (U8)flags;
6250 logop->op_private = (U8)(1 | (flags >> 8));
6252 /* establish postfix order */
6253 logop->op_next = LINKLIST(first);
6254 first->op_next = (OP*)logop;
6255 assert(!OP_HAS_SIBLING(first));
6256 op_sibling_splice((OP*)logop, first, 0, other);
6258 CHECKOP(type,logop);
6260 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6267 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6269 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6270 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6271 will be set automatically, and, shifted up eight bits, the eight bits of
6272 C<op_private>, except that the bit with value 1 is automatically set.
6273 I<first> supplies the expression selecting between the two branches,
6274 and I<trueop> and I<falseop> supply the branches; they are consumed by
6275 this function and become part of the constructed op tree.
6281 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6289 PERL_ARGS_ASSERT_NEWCONDOP;
6292 return newLOGOP(OP_AND, 0, first, trueop);
6294 return newLOGOP(OP_OR, 0, first, falseop);
6296 scalarboolean(first);
6297 if ((cstop = search_const(first))) {
6298 /* Left or right arm of the conditional? */
6299 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6300 OP *live = left ? trueop : falseop;
6301 OP *const dead = left ? falseop : trueop;
6302 if (cstop->op_private & OPpCONST_BARE &&
6303 cstop->op_private & OPpCONST_STRICT) {
6304 no_bareword_allowed(cstop);
6308 if (live->op_type == OP_LEAVE)
6309 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6310 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6311 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6312 /* Mark the op as being unbindable with =~ */
6313 live->op_flags |= OPf_SPECIAL;
6314 live->op_folded = 1;
6317 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6318 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6319 logop->op_flags |= (U8)flags;
6320 logop->op_private = (U8)(1 | (flags >> 8));
6321 logop->op_next = LINKLIST(falseop);
6323 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6326 /* establish postfix order */
6327 start = LINKLIST(first);
6328 first->op_next = (OP*)logop;
6330 /* make first, trueop, falseop siblings */
6331 op_sibling_splice((OP*)logop, first, 0, trueop);
6332 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6334 o = newUNOP(OP_NULL, 0, (OP*)logop);
6336 trueop->op_next = falseop->op_next = o;
6343 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6345 Constructs and returns a C<range> op, with subordinate C<flip> and
6346 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6347 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6348 for both the C<flip> and C<range> ops, except that the bit with value
6349 1 is automatically set. I<left> and I<right> supply the expressions
6350 controlling the endpoints of the range; they are consumed by this function
6351 and become part of the constructed op tree.
6357 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6366 PERL_ARGS_ASSERT_NEWRANGE;
6368 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6369 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6370 range->op_flags = OPf_KIDS;
6371 leftstart = LINKLIST(left);
6372 range->op_private = (U8)(1 | (flags >> 8));
6374 /* make left and right siblings */
6375 op_sibling_splice((OP*)range, left, 0, right);
6377 range->op_next = (OP*)range;
6378 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6379 flop = newUNOP(OP_FLOP, 0, flip);
6380 o = newUNOP(OP_NULL, 0, flop);
6382 range->op_next = leftstart;
6384 left->op_next = flip;
6385 right->op_next = flop;
6387 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6388 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6389 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6390 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6392 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6393 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6395 /* check barewords before they might be optimized aways */
6396 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6397 no_bareword_allowed(left);
6398 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6399 no_bareword_allowed(right);
6402 if (!flip->op_private || !flop->op_private)
6403 LINKLIST(o); /* blow off optimizer unless constant */
6409 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6411 Constructs, checks, and returns an op tree expressing a loop. This is
6412 only a loop in the control flow through the op tree; it does not have
6413 the heavyweight loop structure that allows exiting the loop by C<last>
6414 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6415 top-level op, except that some bits will be set automatically as required.
6416 I<expr> supplies the expression controlling loop iteration, and I<block>
6417 supplies the body of the loop; they are consumed by this function and
6418 become part of the constructed op tree. I<debuggable> is currently
6419 unused and should always be 1.
6425 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6429 const bool once = block && block->op_flags & OPf_SPECIAL &&
6430 block->op_type == OP_NULL;
6432 PERL_UNUSED_ARG(debuggable);
6436 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6437 || ( expr->op_type == OP_NOT
6438 && cUNOPx(expr)->op_first->op_type == OP_CONST
6439 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6442 /* Return the block now, so that S_new_logop does not try to
6444 return block; /* do {} while 0 does once */
6445 if (expr->op_type == OP_READLINE
6446 || expr->op_type == OP_READDIR
6447 || expr->op_type == OP_GLOB
6448 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6449 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6450 expr = newUNOP(OP_DEFINED, 0,
6451 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6452 } else if (expr->op_flags & OPf_KIDS) {
6453 const OP * const k1 = ((UNOP*)expr)->op_first;
6454 const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL;
6455 switch (expr->op_type) {
6457 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6458 && (k2->op_flags & OPf_STACKED)
6459 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6460 expr = newUNOP(OP_DEFINED, 0, expr);
6464 if (k1 && (k1->op_type == OP_READDIR
6465 || k1->op_type == OP_GLOB
6466 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6467 || k1->op_type == OP_EACH
6468 || k1->op_type == OP_AEACH))
6469 expr = newUNOP(OP_DEFINED, 0, expr);
6475 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6476 * op, in listop. This is wrong. [perl #27024] */
6478 block = newOP(OP_NULL, 0);
6479 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6480 o = new_logop(OP_AND, 0, &expr, &listop);
6487 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6489 if (once && o != listop)
6491 assert(cUNOPo->op_first->op_type == OP_AND
6492 || cUNOPo->op_first->op_type == OP_OR);
6493 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6497 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6499 o->op_flags |= flags;
6501 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6506 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6508 Constructs, checks, and returns an op tree expressing a C<while> loop.
6509 This is a heavyweight loop, with structure that allows exiting the loop
6510 by C<last> and suchlike.
6512 I<loop> is an optional preconstructed C<enterloop> op to use in the
6513 loop; if it is null then a suitable op will be constructed automatically.
6514 I<expr> supplies the loop's controlling expression. I<block> supplies the
6515 main body of the loop, and I<cont> optionally supplies a C<continue> block
6516 that operates as a second half of the body. All of these optree inputs
6517 are consumed by this function and become part of the constructed op tree.
6519 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6520 op and, shifted up eight bits, the eight bits of C<op_private> for
6521 the C<leaveloop> op, except that (in both cases) some bits will be set
6522 automatically. I<debuggable> is currently unused and should always be 1.
6523 I<has_my> can be supplied as true to force the
6524 loop body to be enclosed in its own scope.
6530 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6531 OP *expr, OP *block, OP *cont, I32 has_my)
6540 PERL_UNUSED_ARG(debuggable);
6543 if (expr->op_type == OP_READLINE
6544 || expr->op_type == OP_READDIR
6545 || expr->op_type == OP_GLOB
6546 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6547 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6548 expr = newUNOP(OP_DEFINED, 0,
6549 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6550 } else if (expr->op_flags & OPf_KIDS) {
6551 const OP * const k1 = ((UNOP*)expr)->op_first;
6552 const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL;
6553 switch (expr->op_type) {
6555 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6556 && (k2->op_flags & OPf_STACKED)
6557 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6558 expr = newUNOP(OP_DEFINED, 0, expr);
6562 if (k1 && (k1->op_type == OP_READDIR
6563 || k1->op_type == OP_GLOB
6564 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6565 || k1->op_type == OP_EACH
6566 || k1->op_type == OP_AEACH))
6567 expr = newUNOP(OP_DEFINED, 0, expr);
6574 block = newOP(OP_NULL, 0);
6575 else if (cont || has_my) {
6576 block = op_scope(block);
6580 next = LINKLIST(cont);
6583 OP * const unstack = newOP(OP_UNSTACK, 0);
6586 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6590 listop = op_append_list(OP_LINESEQ, block, cont);
6592 redo = LINKLIST(listop);
6596 o = new_logop(OP_AND, 0, &expr, &listop);
6597 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6599 return expr; /* listop already freed by new_logop */
6602 ((LISTOP*)listop)->op_last->op_next =
6603 (o == listop ? redo : LINKLIST(o));
6609 NewOp(1101,loop,1,LOOP);
6610 loop->op_type = OP_ENTERLOOP;
6611 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6612 loop->op_private = 0;
6613 loop->op_next = (OP*)loop;
6616 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6618 loop->op_redoop = redo;
6619 loop->op_lastop = o;
6620 o->op_private |= loopflags;
6623 loop->op_nextop = next;
6625 loop->op_nextop = o;
6627 o->op_flags |= flags;
6628 o->op_private |= (flags >> 8);
6633 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6635 Constructs, checks, and returns an op tree expressing a C<foreach>
6636 loop (iteration through a list of values). This is a heavyweight loop,
6637 with structure that allows exiting the loop by C<last> and suchlike.
6639 I<sv> optionally supplies the variable that will be aliased to each
6640 item in turn; if null, it defaults to C<$_> (either lexical or global).
6641 I<expr> supplies the list of values to iterate over. I<block> supplies
6642 the main body of the loop, and I<cont> optionally supplies a C<continue>
6643 block that operates as a second half of the body. All of these optree
6644 inputs are consumed by this function and become part of the constructed
6647 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6648 op and, shifted up eight bits, the eight bits of C<op_private> for
6649 the C<leaveloop> op, except that (in both cases) some bits will be set
6656 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6661 PADOFFSET padoff = 0;
6665 PERL_ARGS_ASSERT_NEWFOROP;
6668 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6669 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6670 sv->op_type = OP_RV2GV;
6671 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6673 /* The op_type check is needed to prevent a possible segfault
6674 * if the loop variable is undeclared and 'strict vars' is in
6675 * effect. This is illegal but is nonetheless parsed, so we
6676 * may reach this point with an OP_CONST where we're expecting
6679 if (cUNOPx(sv)->op_first->op_type == OP_GV
6680 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6681 iterpflags |= OPpITER_DEF;
6683 else if (sv->op_type == OP_PADSV) { /* private variable */
6684 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6685 padoff = sv->op_targ;
6691 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6693 SV *const namesv = PAD_COMPNAME_SV(padoff);
6695 const char *const name = SvPV_const(namesv, len);
6697 if (len == 2 && name[0] == '$' && name[1] == '_')
6698 iterpflags |= OPpITER_DEF;
6702 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6703 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6704 sv = newGVOP(OP_GV, 0, PL_defgv);
6709 iterpflags |= OPpITER_DEF;
6712 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6713 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
6714 iterflags |= OPf_STACKED;
6716 else if (expr->op_type == OP_NULL &&
6717 (expr->op_flags & OPf_KIDS) &&
6718 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6720 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6721 * set the STACKED flag to indicate that these values are to be
6722 * treated as min/max values by 'pp_enteriter'.
6724 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6725 LOGOP* const range = (LOGOP*) flip->op_first;
6726 OP* const left = range->op_first;
6727 OP* const right = OP_SIBLING(left);
6730 range->op_flags &= ~OPf_KIDS;
6731 /* detach range's children */
6732 op_sibling_splice((OP*)range, NULL, -1, NULL);
6734 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6735 listop->op_first->op_next = range->op_next;
6736 left->op_next = range->op_other;
6737 right->op_next = (OP*)listop;
6738 listop->op_next = listop->op_first;
6741 expr = (OP*)(listop);
6743 iterflags |= OPf_STACKED;
6746 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
6749 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6750 op_append_elem(OP_LIST, expr, scalar(sv))));
6751 assert(!loop->op_next);
6752 /* for my $x () sets OPpLVAL_INTRO;
6753 * for our $x () sets OPpOUR_INTRO */
6754 loop->op_private = (U8)iterpflags;
6755 if (loop->op_slabbed
6756 && DIFF(loop, OpSLOT(loop)->opslot_next)
6757 < SIZE_TO_PSIZE(sizeof(LOOP)))
6760 NewOp(1234,tmp,1,LOOP);
6761 Copy(loop,tmp,1,LISTOP);
6762 #ifdef PERL_OP_PARENT
6763 assert(loop->op_last->op_sibling == (OP*)loop);
6764 loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
6766 S_op_destroy(aTHX_ (OP*)loop);
6769 else if (!loop->op_slabbed)
6770 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6771 loop->op_targ = padoff;
6772 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6777 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6779 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6780 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6781 determining the target of the op; it is consumed by this function and
6782 becomes part of the constructed op tree.
6788 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6792 PERL_ARGS_ASSERT_NEWLOOPEX;
6794 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6796 if (type != OP_GOTO) {
6797 /* "last()" means "last" */
6798 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6799 o = newOP(type, OPf_SPECIAL);
6803 /* Check whether it's going to be a goto &function */
6804 if (label->op_type == OP_ENTERSUB
6805 && !(label->op_flags & OPf_STACKED))
6806 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6809 /* Check for a constant argument */
6810 if (label->op_type == OP_CONST) {
6811 SV * const sv = ((SVOP *)label)->op_sv;
6813 const char *s = SvPV_const(sv,l);
6814 if (l == strlen(s)) {
6816 SvUTF8(((SVOP*)label)->op_sv),
6818 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6822 /* If we have already created an op, we do not need the label. */
6825 else o = newUNOP(type, OPf_STACKED, label);
6827 PL_hints |= HINT_BLOCK_SCOPE;
6831 /* if the condition is a literal array or hash
6832 (or @{ ... } etc), make a reference to it.
6835 S_ref_array_or_hash(pTHX_ OP *cond)
6838 && (cond->op_type == OP_RV2AV
6839 || cond->op_type == OP_PADAV
6840 || cond->op_type == OP_RV2HV
6841 || cond->op_type == OP_PADHV))
6843 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6846 && (cond->op_type == OP_ASLICE
6847 || cond->op_type == OP_KVASLICE
6848 || cond->op_type == OP_HSLICE
6849 || cond->op_type == OP_KVHSLICE)) {
6851 /* anonlist now needs a list from this op, was previously used in
6853 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6854 cond->op_flags |= OPf_WANT_LIST;
6856 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6863 /* These construct the optree fragments representing given()
6866 entergiven and enterwhen are LOGOPs; the op_other pointer
6867 points up to the associated leave op. We need this so we
6868 can put it in the context and make break/continue work.
6869 (Also, of course, pp_enterwhen will jump straight to
6870 op_other if the match fails.)
6874 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6875 I32 enter_opcode, I32 leave_opcode,
6876 PADOFFSET entertarg)
6882 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6884 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
6885 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6886 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6887 enterop->op_private = 0;
6889 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6892 /* prepend cond if we have one */
6893 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
6895 o->op_next = LINKLIST(cond);
6896 cond->op_next = (OP *) enterop;
6899 /* This is a default {} block */
6900 enterop->op_flags |= OPf_SPECIAL;
6901 o ->op_flags |= OPf_SPECIAL;
6903 o->op_next = (OP *) enterop;
6906 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6907 entergiven and enterwhen both
6910 enterop->op_next = LINKLIST(block);
6911 block->op_next = enterop->op_other = o;
6916 /* Does this look like a boolean operation? For these purposes
6917 a boolean operation is:
6918 - a subroutine call [*]
6919 - a logical connective
6920 - a comparison operator
6921 - a filetest operator, with the exception of -s -M -A -C
6922 - defined(), exists() or eof()
6923 - /$re/ or $foo =~ /$re/
6925 [*] possibly surprising
6928 S_looks_like_bool(pTHX_ const OP *o)
6930 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6932 switch(o->op_type) {
6935 return looks_like_bool(cLOGOPo->op_first);
6939 OP* sibl = OP_SIBLING(cLOGOPo->op_first);
6942 looks_like_bool(cLOGOPo->op_first)
6943 && looks_like_bool(sibl));
6949 o->op_flags & OPf_KIDS
6950 && looks_like_bool(cUNOPo->op_first));
6954 case OP_NOT: case OP_XOR:
6956 case OP_EQ: case OP_NE: case OP_LT:
6957 case OP_GT: case OP_LE: case OP_GE:
6959 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6960 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6962 case OP_SEQ: case OP_SNE: case OP_SLT:
6963 case OP_SGT: case OP_SLE: case OP_SGE:
6967 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6968 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6969 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6970 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6971 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6972 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6973 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6974 case OP_FTTEXT: case OP_FTBINARY:
6976 case OP_DEFINED: case OP_EXISTS:
6977 case OP_MATCH: case OP_EOF:
6984 /* Detect comparisons that have been optimized away */
6985 if (cSVOPo->op_sv == &PL_sv_yes
6986 || cSVOPo->op_sv == &PL_sv_no)
6999 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7001 Constructs, checks, and returns an op tree expressing a C<given> block.
7002 I<cond> supplies the expression that will be locally assigned to a lexical
7003 variable, and I<block> supplies the body of the C<given> construct; they
7004 are consumed by this function and become part of the constructed op tree.
7005 I<defsv_off> is the pad offset of the scalar lexical variable that will
7006 be affected. If it is 0, the global $_ will be used.
7012 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7014 PERL_ARGS_ASSERT_NEWGIVENOP;
7015 return newGIVWHENOP(
7016 ref_array_or_hash(cond),
7018 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7023 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7025 Constructs, checks, and returns an op tree expressing a C<when> block.
7026 I<cond> supplies the test expression, and I<block> supplies the block
7027 that will be executed if the test evaluates to true; they are consumed
7028 by this function and become part of the constructed op tree. I<cond>
7029 will be interpreted DWIMically, often as a comparison against C<$_>,
7030 and may be null to generate a C<default> block.
7036 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7038 const bool cond_llb = (!cond || looks_like_bool(cond));
7041 PERL_ARGS_ASSERT_NEWWHENOP;
7046 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7048 scalar(ref_array_or_hash(cond)));
7051 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7055 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7056 const STRLEN len, const U32 flags)
7058 SV *name = NULL, *msg;
7059 const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
7060 STRLEN clen = CvPROTOLEN(cv), plen = len;
7062 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7064 if (p == NULL && cvp == NULL)
7067 if (!ckWARN_d(WARN_PROTOTYPE))
7071 p = S_strip_spaces(aTHX_ p, &plen);
7072 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7073 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7074 if (plen == clen && memEQ(cvp, p, plen))
7077 if (flags & SVf_UTF8) {
7078 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7082 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7088 msg = sv_newmortal();
7093 gv_efullname3(name = sv_newmortal(), gv, NULL);
7094 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7095 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7096 else name = (SV *)gv;
7098 sv_setpvs(msg, "Prototype mismatch:");
7100 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7102 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7103 UTF8fARG(SvUTF8(cv),clen,cvp)
7106 sv_catpvs(msg, ": none");
7107 sv_catpvs(msg, " vs ");
7109 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7111 sv_catpvs(msg, "none");
7112 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7115 static void const_sv_xsub(pTHX_ CV* cv);
7116 static void const_av_xsub(pTHX_ CV* cv);
7120 =head1 Optree Manipulation Functions
7122 =for apidoc cv_const_sv
7124 If C<cv> is a constant sub eligible for inlining, returns the constant
7125 value returned by the sub. Otherwise, returns NULL.
7127 Constant subs can be created with C<newCONSTSUB> or as described in
7128 L<perlsub/"Constant Functions">.
7133 Perl_cv_const_sv(const CV *const cv)
7138 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7140 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7141 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7146 Perl_cv_const_sv_or_av(const CV * const cv)
7150 if (SvROK(cv)) return SvRV((SV *)cv);
7151 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7152 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7155 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7156 * Can be called in 3 ways:
7159 * look for a single OP_CONST with attached value: return the value
7161 * cv && CvCLONE(cv) && !CvCONST(cv)
7163 * examine the clone prototype, and if contains only a single
7164 * OP_CONST referencing a pad const, or a single PADSV referencing
7165 * an outer lexical, return a non-zero value to indicate the CV is
7166 * a candidate for "constizing" at clone time
7170 * We have just cloned an anon prototype that was marked as a const
7171 * candidate. Try to grab the current value, and in the case of
7172 * PADSV, ignore it if it has multiple references. In this case we
7173 * return a newly created *copy* of the value.
7177 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
7184 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
7185 o = OP_SIBLING(cLISTOPo->op_first);
7187 for (; o; o = o->op_next) {
7188 const OPCODE type = o->op_type;
7190 if (sv && o->op_next == o)
7192 if (o->op_next != o) {
7193 if (type == OP_NEXTSTATE
7194 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7195 || type == OP_PUSHMARK)
7197 if (type == OP_DBSTATE)
7200 if (type == OP_LEAVESUB || type == OP_RETURN)
7204 if (type == OP_CONST && cSVOPo->op_sv)
7206 else if (cv && type == OP_CONST) {
7207 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7211 else if (cv && type == OP_PADSV) {
7212 if (CvCONST(cv)) { /* newly cloned anon */
7213 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7214 /* the candidate should have 1 ref from this pad and 1 ref
7215 * from the parent */
7216 if (!sv || SvREFCNT(sv) != 2)
7223 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
7224 sv = &PL_sv_undef; /* an arbitrary non-null value */
7235 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7236 PADNAME * const name, SV ** const const_svp)
7243 if (CvFLAGS(PL_compcv)) {
7244 /* might have had built-in attrs applied */
7245 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7246 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7247 && ckWARN(WARN_MISC))
7249 /* protect against fatal warnings leaking compcv */
7250 SAVEFREESV(PL_compcv);
7251 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7252 SvREFCNT_inc_simple_void_NN(PL_compcv);
7255 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7256 & ~(CVf_LVALUE * pureperl));
7261 /* redundant check for speed: */
7262 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7263 const line_t oldline = CopLINE(PL_curcop);
7266 : sv_2mortal(newSVpvn_utf8(
7267 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7269 if (PL_parser && PL_parser->copline != NOLINE)
7270 /* This ensures that warnings are reported at the first
7271 line of a redefinition, not the last. */
7272 CopLINE_set(PL_curcop, PL_parser->copline);
7273 /* protect against fatal warnings leaking compcv */
7274 SAVEFREESV(PL_compcv);
7275 report_redefined_cv(namesv, cv, const_svp);
7276 SvREFCNT_inc_simple_void_NN(PL_compcv);
7277 CopLINE_set(PL_curcop, oldline);
7284 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7289 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7292 CV *compcv = PL_compcv;
7295 PADOFFSET pax = o->op_targ;
7296 CV *outcv = CvOUTSIDE(PL_compcv);
7299 bool reusable = FALSE;
7301 PERL_ARGS_ASSERT_NEWMYSUB;
7303 /* Find the pad slot for storing the new sub.
7304 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7305 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7306 ing sub. And then we need to dig deeper if this is a lexical from
7308 my sub foo; sub { sub foo { } }
7311 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7312 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7313 pax = PARENT_PAD_INDEX(name);
7314 outcv = CvOUTSIDE(outcv);
7319 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7320 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7321 spot = (CV **)svspot;
7323 if (!(PL_parser && PL_parser->error_count))
7324 move_proto_attr(&proto, &attrs, (GV *)name);
7327 assert(proto->op_type == OP_CONST);
7328 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7329 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7339 if (PL_parser && PL_parser->error_count) {
7341 SvREFCNT_dec(PL_compcv);
7346 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7348 svspot = (SV **)(spot = &clonee);
7350 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7354 SvUPGRADE(name, SVt_PVMG);
7355 mg = mg_find(name, PERL_MAGIC_proto);
7356 assert (SvTYPE(*spot) == SVt_PVCV);
7358 hek = CvNAME_HEK(*spot);
7360 CvNAME_HEK_set(*spot, hek =
7363 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
7369 cv = (CV *)mg->mg_obj;
7372 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7373 mg = mg_find(name, PERL_MAGIC_proto);
7375 spot = (CV **)(svspot = &mg->mg_obj);
7378 if (!block || !ps || *ps || attrs
7379 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7383 const_sv = op_const_sv(block, NULL);
7386 const bool exists = CvROOT(cv) || CvXSUB(cv);
7388 /* if the subroutine doesn't exist and wasn't pre-declared
7389 * with a prototype, assume it will be AUTOLOADed,
7390 * skipping the prototype check
7392 if (exists || SvPOK(cv))
7393 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7394 /* already defined? */
7396 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7399 if (attrs) goto attrs;
7400 /* just a "sub foo;" when &foo is already defined */
7405 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7411 SvREFCNT_inc_simple_void_NN(const_sv);
7412 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7414 assert(!CvROOT(cv) && !CvCONST(cv));
7418 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7419 CvFILE_set_from_cop(cv, PL_curcop);
7420 CvSTASH_set(cv, PL_curstash);
7423 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7424 CvXSUBANY(cv).any_ptr = const_sv;
7425 CvXSUB(cv) = const_sv_xsub;
7429 SvREFCNT_dec(compcv);
7433 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7434 determine whether this sub definition is in the same scope as its
7435 declaration. If this sub definition is inside an inner named pack-
7436 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7437 the package sub. So check PadnameOUTER(name) too.
7439 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7440 assert(!CvWEAKOUTSIDE(compcv));
7441 SvREFCNT_dec(CvOUTSIDE(compcv));
7442 CvWEAKOUTSIDE_on(compcv);
7444 /* XXX else do we have a circular reference? */
7445 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7446 /* transfer PL_compcv to cv */
7449 cv_flags_t preserved_flags =
7450 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7451 PADLIST *const temp_padl = CvPADLIST(cv);
7452 CV *const temp_cv = CvOUTSIDE(cv);
7453 const cv_flags_t other_flags =
7454 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7455 OP * const cvstart = CvSTART(cv);
7459 CvFLAGS(compcv) | preserved_flags;
7460 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7461 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7462 CvPADLIST(cv) = CvPADLIST(compcv);
7463 CvOUTSIDE(compcv) = temp_cv;
7464 CvPADLIST(compcv) = temp_padl;
7465 CvSTART(cv) = CvSTART(compcv);
7466 CvSTART(compcv) = cvstart;
7467 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7468 CvFLAGS(compcv) |= other_flags;
7470 if (CvFILE(cv) && CvDYNFILE(cv)) {
7471 Safefree(CvFILE(cv));
7474 /* inner references to compcv must be fixed up ... */
7475 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7476 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7477 ++PL_sub_generation;
7480 /* Might have had built-in attributes applied -- propagate them. */
7481 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7483 /* ... before we throw it away */
7484 SvREFCNT_dec(compcv);
7485 PL_compcv = compcv = cv;
7492 if (!CvNAME_HEK(cv)) {
7495 ? share_hek_hek(hek)
7496 : share_hek(PadnamePV(name)+1,
7497 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7501 if (const_sv) goto clone;
7503 CvFILE_set_from_cop(cv, PL_curcop);
7504 CvSTASH_set(cv, PL_curstash);
7507 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7508 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7514 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7515 the debugger could be able to set a breakpoint in, so signal to
7516 pp_entereval that it should not throw away any saved lines at scope
7519 PL_breakable_sub_gen++;
7520 /* This makes sub {}; work as expected. */
7521 if (block->op_type == OP_STUB) {
7522 OP* const newblock = newSTATEOP(0, NULL, 0);
7526 CvROOT(cv) = CvLVALUE(cv)
7527 ? newUNOP(OP_LEAVESUBLV, 0,
7528 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7529 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7530 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7531 OpREFCNT_set(CvROOT(cv), 1);
7532 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7533 itself has a refcount. */
7535 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7536 CvSTART(cv) = LINKLIST(CvROOT(cv));
7537 CvROOT(cv)->op_next = 0;
7538 CALL_PEEP(CvSTART(cv));
7539 finalize_optree(CvROOT(cv));
7540 S_prune_chain_head(&CvSTART(cv));
7542 /* now that optimizer has done its work, adjust pad values */
7544 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7547 assert(!CvCONST(cv));
7548 if (ps && !*ps && op_const_sv(block, cv))
7554 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7555 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7559 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7560 SV * const tmpstr = sv_newmortal();
7561 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7562 GV_ADDMULTI, SVt_PVHV);
7564 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7567 (long)CopLINE(PL_curcop));
7568 if (HvNAME_HEK(PL_curstash)) {
7569 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7570 sv_catpvs(tmpstr, "::");
7572 else sv_setpvs(tmpstr, "__ANON__::");
7573 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7574 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7575 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7576 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7577 hv = GvHVn(db_postponed);
7578 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7579 CV * const pcv = GvCV(db_postponed);
7585 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7593 assert(CvDEPTH(outcv));
7595 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7596 if (reusable) cv_clone_into(clonee, *spot);
7597 else *spot = cv_clone(clonee);
7598 SvREFCNT_dec_NN(clonee);
7602 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7603 PADOFFSET depth = CvDEPTH(outcv);
7606 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7608 *svspot = SvREFCNT_inc_simple_NN(cv);
7609 SvREFCNT_dec(oldcv);
7615 PL_parser->copline = NOLINE;
7623 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7624 OP *block, bool o_is_gv)
7628 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7632 const bool ec = PL_parser && PL_parser->error_count;
7633 /* If the subroutine has no body, no attributes, and no builtin attributes
7634 then it's just a sub declaration, and we may be able to get away with
7635 storing with a placeholder scalar in the symbol table, rather than a
7636 full GV and CV. If anything is present then it will take a full CV to
7638 const I32 gv_fetch_flags
7639 = ec ? GV_NOADD_NOINIT :
7640 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
7641 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7643 const char * const name =
7644 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7646 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7647 #ifdef PERL_DEBUG_READONLY_OPS
7648 OPSLAB *slab = NULL;
7656 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7658 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7659 SV * const sv = sv_newmortal();
7660 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7661 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7662 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7663 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7665 } else if (PL_curstash) {
7666 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7669 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7673 move_proto_attr(&proto, &attrs, gv);
7676 assert(proto->op_type == OP_CONST);
7677 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7678 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7692 if (name) SvREFCNT_dec(PL_compcv);
7693 else cv = PL_compcv;
7695 if (name && block) {
7696 const char *s = strrchr(name, ':');
7698 if (strEQ(s, "BEGIN")) {
7699 if (PL_in_eval & EVAL_KEEPERR)
7700 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7702 SV * const errsv = ERRSV;
7703 /* force display of errors found but not reported */
7704 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7705 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7712 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
7713 maximum a prototype before. */
7714 if (SvTYPE(gv) > SVt_NULL) {
7715 cv_ckproto_len_flags((const CV *)gv,
7716 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7720 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7721 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7724 sv_setiv(MUTABLE_SV(gv), -1);
7726 SvREFCNT_dec(PL_compcv);
7727 cv = PL_compcv = NULL;
7731 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7733 if (!block || !ps || *ps || attrs
7734 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7738 const_sv = op_const_sv(block, NULL);
7741 const bool exists = CvROOT(cv) || CvXSUB(cv);
7743 /* if the subroutine doesn't exist and wasn't pre-declared
7744 * with a prototype, assume it will be AUTOLOADed,
7745 * skipping the prototype check
7747 if (exists || SvPOK(cv))
7748 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7749 /* already defined (or promised)? */
7750 if (exists || GvASSUMECV(gv)) {
7751 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7754 if (attrs) goto attrs;
7755 /* just a "sub foo;" when &foo is already defined */
7756 SAVEFREESV(PL_compcv);
7762 SvREFCNT_inc_simple_void_NN(const_sv);
7763 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7765 assert(!CvROOT(cv) && !CvCONST(cv));
7767 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7768 CvXSUBANY(cv).any_ptr = const_sv;
7769 CvXSUB(cv) = const_sv_xsub;
7775 cv = newCONSTSUB_flags(
7776 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7781 SvREFCNT_dec(PL_compcv);
7785 if (cv) { /* must reuse cv if autoloaded */
7786 /* transfer PL_compcv to cv */
7789 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7790 PADLIST *const temp_av = CvPADLIST(cv);
7791 CV *const temp_cv = CvOUTSIDE(cv);
7792 const cv_flags_t other_flags =
7793 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7794 OP * const cvstart = CvSTART(cv);
7797 assert(!CvCVGV_RC(cv));
7798 assert(CvGV(cv) == gv);
7801 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7802 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7803 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7804 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7805 CvOUTSIDE(PL_compcv) = temp_cv;
7806 CvPADLIST(PL_compcv) = temp_av;
7807 CvSTART(cv) = CvSTART(PL_compcv);
7808 CvSTART(PL_compcv) = cvstart;
7809 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7810 CvFLAGS(PL_compcv) |= other_flags;
7812 if (CvFILE(cv) && CvDYNFILE(cv)) {
7813 Safefree(CvFILE(cv));
7815 CvFILE_set_from_cop(cv, PL_curcop);
7816 CvSTASH_set(cv, PL_curstash);
7818 /* inner references to PL_compcv must be fixed up ... */
7819 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7820 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7821 ++PL_sub_generation;
7824 /* Might have had built-in attributes applied -- propagate them. */
7825 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7827 /* ... before we throw it away */
7828 SvREFCNT_dec(PL_compcv);
7836 if (HvENAME_HEK(GvSTASH(gv)))
7837 /* sub Foo::bar { (shift)+1 } */
7838 gv_method_changed(gv);
7843 CvFILE_set_from_cop(cv, PL_curcop);
7844 CvSTASH_set(cv, PL_curstash);
7848 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7849 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7855 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7856 the debugger could be able to set a breakpoint in, so signal to
7857 pp_entereval that it should not throw away any saved lines at scope
7860 PL_breakable_sub_gen++;
7861 /* This makes sub {}; work as expected. */
7862 if (block->op_type == OP_STUB) {
7863 OP* const newblock = newSTATEOP(0, NULL, 0);
7867 CvROOT(cv) = CvLVALUE(cv)
7868 ? newUNOP(OP_LEAVESUBLV, 0,
7869 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7870 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7871 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7872 OpREFCNT_set(CvROOT(cv), 1);
7873 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7874 itself has a refcount. */
7876 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7877 #ifdef PERL_DEBUG_READONLY_OPS
7878 slab = (OPSLAB *)CvSTART(cv);
7880 CvSTART(cv) = LINKLIST(CvROOT(cv));
7881 CvROOT(cv)->op_next = 0;
7882 CALL_PEEP(CvSTART(cv));
7883 finalize_optree(CvROOT(cv));
7884 S_prune_chain_head(&CvSTART(cv));
7886 /* now that optimizer has done its work, adjust pad values */
7888 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7891 assert(!CvCONST(cv));
7892 if (ps && !*ps && op_const_sv(block, cv))
7898 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7899 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7900 if (!name) SAVEFREESV(cv);
7901 apply_attrs(stash, MUTABLE_SV(cv), attrs);
7902 if (!name) SvREFCNT_inc_simple_void_NN(cv);
7905 if (block && has_name) {
7906 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7907 SV * const tmpstr = sv_newmortal();
7908 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7909 GV_ADDMULTI, SVt_PVHV);
7911 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7914 (long)CopLINE(PL_curcop));
7915 gv_efullname3(tmpstr, gv, NULL);
7916 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7917 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7918 hv = GvHVn(db_postponed);
7919 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7920 CV * const pcv = GvCV(db_postponed);
7926 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7932 if (PL_parser && PL_parser->error_count)
7933 clear_special_blocks(name, gv, cv);
7935 process_special_blocks(floor, name, gv, cv);
7941 PL_parser->copline = NOLINE;
7943 #ifdef PERL_DEBUG_READONLY_OPS
7944 /* Watch out for BEGIN blocks */
7945 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7951 S_clear_special_blocks(pTHX_ const char *const fullname,
7952 GV *const gv, CV *const cv) {
7956 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
7958 colon = strrchr(fullname,':');
7959 name = colon ? colon + 1 : fullname;
7961 if ((*name == 'B' && strEQ(name, "BEGIN"))
7962 || (*name == 'E' && strEQ(name, "END"))
7963 || (*name == 'U' && strEQ(name, "UNITCHECK"))
7964 || (*name == 'C' && strEQ(name, "CHECK"))
7965 || (*name == 'I' && strEQ(name, "INIT"))) {
7967 SvREFCNT_dec_NN(MUTABLE_SV(cv));
7972 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7976 const char *const colon = strrchr(fullname,':');
7977 const char *const name = colon ? colon + 1 : fullname;
7979 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7982 if (strEQ(name, "BEGIN")) {
7983 const I32 oldscope = PL_scopestack_ix;
7985 if (floor) LEAVE_SCOPE(floor);
7987 PUSHSTACKi(PERLSI_REQUIRE);
7988 SAVECOPFILE(&PL_compiling);
7989 SAVECOPLINE(&PL_compiling);
7990 SAVEVPTR(PL_curcop);
7992 DEBUG_x( dump_sub(gv) );
7993 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7994 GvCV_set(gv,0); /* cv has been hijacked */
7995 call_list(oldscope, PL_beginav);
8004 if strEQ(name, "END") {
8005 DEBUG_x( dump_sub(gv) );
8006 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8009 } else if (*name == 'U') {
8010 if (strEQ(name, "UNITCHECK")) {
8011 /* It's never too late to run a unitcheck block */
8012 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8016 } else if (*name == 'C') {
8017 if (strEQ(name, "CHECK")) {
8019 /* diag_listed_as: Too late to run %s block */
8020 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8021 "Too late to run CHECK block");
8022 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8026 } else if (*name == 'I') {
8027 if (strEQ(name, "INIT")) {
8029 /* diag_listed_as: Too late to run %s block */
8030 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8031 "Too late to run INIT block");
8032 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8038 DEBUG_x( dump_sub(gv) );
8039 GvCV_set(gv,0); /* cv has been hijacked */
8044 =for apidoc newCONSTSUB
8046 See L</newCONSTSUB_flags>.
8052 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8054 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8058 =for apidoc newCONSTSUB_flags
8060 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8061 eligible for inlining at compile-time.
8063 Currently, the only useful value for C<flags> is SVf_UTF8.
8065 The newly created subroutine takes ownership of a reference to the passed in
8068 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8069 which won't be called if used as a destructor, but will suppress the overhead
8070 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8077 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8081 const char *const file = CopFILE(PL_curcop);
8085 if (IN_PERL_RUNTIME) {
8086 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8087 * an op shared between threads. Use a non-shared COP for our
8089 SAVEVPTR(PL_curcop);
8090 SAVECOMPILEWARNINGS();
8091 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8092 PL_curcop = &PL_compiling;
8094 SAVECOPLINE(PL_curcop);
8095 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8098 PL_hints &= ~HINT_BLOCK_SCOPE;
8101 SAVEGENERICSV(PL_curstash);
8102 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8105 /* Protect sv against leakage caused by fatal warnings. */
8106 if (sv) SAVEFREESV(sv);
8108 /* file becomes the CvFILE. For an XS, it's usually static storage,
8109 and so doesn't get free()d. (It's expected to be from the C pre-
8110 processor __FILE__ directive). But we need a dynamically allocated one,
8111 and we need it to get freed. */
8112 cv = newXS_len_flags(name, len,
8113 sv && SvTYPE(sv) == SVt_PVAV
8116 file ? file : "", "",
8117 &sv, XS_DYNAMIC_FILENAME | flags);
8118 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8127 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8128 const char *const filename, const char *const proto,
8131 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8132 return newXS_len_flags(
8133 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8138 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8139 XSUBADDR_t subaddr, const char *const filename,
8140 const char *const proto, SV **const_svp,
8144 bool interleave = FALSE;
8146 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8149 GV * const gv = gv_fetchpvn(
8150 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8151 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8152 sizeof("__ANON__::__ANON__") - 1,
8153 GV_ADDMULTI | flags, SVt_PVCV);
8156 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8158 if ((cv = (name ? GvCV(gv) : NULL))) {
8160 /* just a cached method */
8164 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8165 /* already defined (or promised) */
8166 /* Redundant check that allows us to avoid creating an SV
8167 most of the time: */
8168 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8169 report_redefined_cv(newSVpvn_flags(
8170 name,len,(flags&SVf_UTF8)|SVs_TEMP
8181 if (cv) /* must reuse cv if autoloaded */
8184 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8188 if (HvENAME_HEK(GvSTASH(gv)))
8189 gv_method_changed(gv); /* newXS */
8195 (void)gv_fetchfile(filename);
8196 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8197 an external constant string */
8198 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8200 CvXSUB(cv) = subaddr;
8203 process_special_blocks(0, name, gv, cv);
8206 if (flags & XS_DYNAMIC_FILENAME) {
8207 CvFILE(cv) = savepv(filename);
8210 sv_setpv(MUTABLE_SV(cv), proto);
8211 if (interleave) LEAVE;
8216 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8218 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8220 PERL_ARGS_ASSERT_NEWSTUB;
8224 if (!fake && HvENAME_HEK(GvSTASH(gv)))
8225 gv_method_changed(gv);
8227 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8232 CvFILE_set_from_cop(cv, PL_curcop);
8233 CvSTASH_set(cv, PL_curstash);
8239 =for apidoc U||newXS
8241 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
8242 static storage, as it is used directly as CvFILE(), without a copy being made.
8248 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8250 PERL_ARGS_ASSERT_NEWXS;
8251 return newXS_len_flags(
8252 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8257 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8263 if (PL_parser && PL_parser->error_count) {
8269 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8270 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8273 if ((cv = GvFORM(gv))) {
8274 if (ckWARN(WARN_REDEFINE)) {
8275 const line_t oldline = CopLINE(PL_curcop);
8276 if (PL_parser && PL_parser->copline != NOLINE)
8277 CopLINE_set(PL_curcop, PL_parser->copline);
8279 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8280 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8282 /* diag_listed_as: Format %s redefined */
8283 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8284 "Format STDOUT redefined");
8286 CopLINE_set(PL_curcop, oldline);
8291 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8293 CvFILE_set_from_cop(cv, PL_curcop);
8296 pad_tidy(padtidy_FORMAT);
8297 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8298 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8299 OpREFCNT_set(CvROOT(cv), 1);
8300 CvSTART(cv) = LINKLIST(CvROOT(cv));
8301 CvROOT(cv)->op_next = 0;
8302 CALL_PEEP(CvSTART(cv));
8303 finalize_optree(CvROOT(cv));
8304 S_prune_chain_head(&CvSTART(cv));
8310 PL_parser->copline = NOLINE;
8315 Perl_newANONLIST(pTHX_ OP *o)
8317 return convert(OP_ANONLIST, OPf_SPECIAL, o);
8321 Perl_newANONHASH(pTHX_ OP *o)
8323 return convert(OP_ANONHASH, OPf_SPECIAL, o);
8327 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8329 return newANONATTRSUB(floor, proto, NULL, block);
8333 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8335 return newUNOP(OP_REFGEN, 0,
8336 newSVOP(OP_ANONCODE, 0,
8337 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8341 Perl_oopsAV(pTHX_ OP *o)
8345 PERL_ARGS_ASSERT_OOPSAV;
8347 switch (o->op_type) {
8350 o->op_type = OP_PADAV;
8351 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8352 return ref(o, OP_RV2AV);
8356 o->op_type = OP_RV2AV;
8357 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8362 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8369 Perl_oopsHV(pTHX_ OP *o)
8373 PERL_ARGS_ASSERT_OOPSHV;
8375 switch (o->op_type) {
8378 o->op_type = OP_PADHV;
8379 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8380 return ref(o, OP_RV2HV);
8384 o->op_type = OP_RV2HV;
8385 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8390 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8397 Perl_newAVREF(pTHX_ OP *o)
8401 PERL_ARGS_ASSERT_NEWAVREF;
8403 if (o->op_type == OP_PADANY) {
8404 o->op_type = OP_PADAV;
8405 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8408 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8409 Perl_croak(aTHX_ "Can't use an array as a reference");
8411 return newUNOP(OP_RV2AV, 0, scalar(o));
8415 Perl_newGVREF(pTHX_ I32 type, OP *o)
8417 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8418 return newUNOP(OP_NULL, 0, o);
8419 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8423 Perl_newHVREF(pTHX_ OP *o)
8427 PERL_ARGS_ASSERT_NEWHVREF;
8429 if (o->op_type == OP_PADANY) {
8430 o->op_type = OP_PADHV;
8431 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8434 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8435 Perl_croak(aTHX_ "Can't use a hash as a reference");
8437 return newUNOP(OP_RV2HV, 0, scalar(o));
8441 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8443 if (o->op_type == OP_PADANY) {
8445 o->op_type = OP_PADCV;
8446 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8448 return newUNOP(OP_RV2CV, flags, scalar(o));
8452 Perl_newSVREF(pTHX_ OP *o)
8456 PERL_ARGS_ASSERT_NEWSVREF;
8458 if (o->op_type == OP_PADANY) {
8459 o->op_type = OP_PADSV;
8460 o->op_ppaddr = PL_ppaddr[OP_PADSV];
8463 return newUNOP(OP_RV2SV, 0, scalar(o));
8466 /* Check routines. See the comments at the top of this file for details
8467 * on when these are called */
8470 Perl_ck_anoncode(pTHX_ OP *o)
8472 PERL_ARGS_ASSERT_CK_ANONCODE;
8474 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8475 cSVOPo->op_sv = NULL;
8480 S_io_hints(pTHX_ OP *o)
8482 #if O_BINARY != 0 || O_TEXT != 0
8484 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8486 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8489 const char *d = SvPV_const(*svp, len);
8490 const I32 mode = mode_from_discipline(d, len);
8491 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8493 if (mode & O_BINARY)
8494 o->op_private |= OPpOPEN_IN_RAW;
8498 o->op_private |= OPpOPEN_IN_CRLF;
8502 svp = hv_fetchs(table, "open_OUT", FALSE);
8505 const char *d = SvPV_const(*svp, len);
8506 const I32 mode = mode_from_discipline(d, len);
8507 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8509 if (mode & O_BINARY)
8510 o->op_private |= OPpOPEN_OUT_RAW;
8514 o->op_private |= OPpOPEN_OUT_CRLF;
8519 PERL_UNUSED_CONTEXT;
8525 Perl_ck_backtick(pTHX_ OP *o)
8530 PERL_ARGS_ASSERT_CK_BACKTICK;
8531 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8532 if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
8533 && (gv = gv_override("readpipe",8)))
8535 /* detach rest of siblings from o and its first child */
8536 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
8537 newop = S_new_entersubop(aTHX_ gv, sibl);
8539 else if (!(o->op_flags & OPf_KIDS))
8540 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8545 S_io_hints(aTHX_ o);
8550 Perl_ck_bitop(pTHX_ OP *o)
8552 PERL_ARGS_ASSERT_CK_BITOP;
8554 o->op_private = (U8)(PL_hints & HINT_INTEGER);
8555 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8556 && (o->op_type == OP_BIT_OR
8557 || o->op_type == OP_BIT_AND
8558 || o->op_type == OP_BIT_XOR))
8560 const OP * const left = cBINOPo->op_first;
8561 const OP * const right = OP_SIBLING(left);
8562 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8563 (left->op_flags & OPf_PARENS) == 0) ||
8564 (OP_IS_NUMCOMPARE(right->op_type) &&
8565 (right->op_flags & OPf_PARENS) == 0))
8566 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8567 "Possible precedence problem on bitwise %c operator",
8568 o->op_type == OP_BIT_OR ? '|'
8569 : o->op_type == OP_BIT_AND ? '&' : '^'
8575 PERL_STATIC_INLINE bool
8576 is_dollar_bracket(pTHX_ const OP * const o)
8579 PERL_UNUSED_CONTEXT;
8580 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8581 && (kid = cUNOPx(o)->op_first)
8582 && kid->op_type == OP_GV
8583 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8587 Perl_ck_cmp(pTHX_ OP *o)
8589 PERL_ARGS_ASSERT_CK_CMP;
8590 if (ckWARN(WARN_SYNTAX)) {
8591 const OP *kid = cUNOPo->op_first;
8594 ( is_dollar_bracket(aTHX_ kid)
8595 && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
8597 || ( kid->op_type == OP_CONST
8598 && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
8602 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8603 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8609 Perl_ck_concat(pTHX_ OP *o)
8611 const OP * const kid = cUNOPo->op_first;
8613 PERL_ARGS_ASSERT_CK_CONCAT;
8614 PERL_UNUSED_CONTEXT;
8616 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8617 !(kUNOP->op_first->op_flags & OPf_MOD))
8618 o->op_flags |= OPf_STACKED;
8623 Perl_ck_spair(pTHX_ OP *o)
8627 PERL_ARGS_ASSERT_CK_SPAIR;
8629 if (o->op_flags & OPf_KIDS) {
8633 const OPCODE type = o->op_type;
8634 o = modkids(ck_fun(o), type);
8635 kid = cUNOPo->op_first;
8636 kidkid = kUNOP->op_first;
8637 newop = OP_SIBLING(kidkid);
8639 const OPCODE type = newop->op_type;
8640 if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) ||
8641 type == OP_PADAV || type == OP_PADHV ||
8642 type == OP_RV2AV || type == OP_RV2HV)
8645 /* excise first sibling */
8646 op_sibling_splice(kid, NULL, 1, NULL);
8649 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8650 * and OP_CHOMP into OP_SCHOMP */
8651 o->op_ppaddr = PL_ppaddr[++o->op_type];
8656 Perl_ck_delete(pTHX_ OP *o)
8658 PERL_ARGS_ASSERT_CK_DELETE;
8662 if (o->op_flags & OPf_KIDS) {
8663 OP * const kid = cUNOPo->op_first;
8664 switch (kid->op_type) {
8666 o->op_flags |= OPf_SPECIAL;
8669 o->op_private |= OPpSLICE;
8672 o->op_flags |= OPf_SPECIAL;
8677 Perl_croak(aTHX_ "delete argument is index/value array slice,"
8678 " use array slice");
8680 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8683 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8684 "element or slice");
8686 if (kid->op_private & OPpLVAL_INTRO)
8687 o->op_private |= OPpLVAL_INTRO;
8694 Perl_ck_eof(pTHX_ OP *o)
8696 PERL_ARGS_ASSERT_CK_EOF;
8698 if (o->op_flags & OPf_KIDS) {
8700 if (cLISTOPo->op_first->op_type == OP_STUB) {
8702 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8707 kid = cLISTOPo->op_first;
8708 if (kid->op_type == OP_RV2GV)
8709 kid->op_private |= OPpALLOW_FAKE;
8715 Perl_ck_eval(pTHX_ OP *o)
8719 PERL_ARGS_ASSERT_CK_EVAL;
8721 PL_hints |= HINT_BLOCK_SCOPE;
8722 if (o->op_flags & OPf_KIDS) {
8723 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8726 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8729 /* cut whole sibling chain free from o */
8730 op_sibling_splice(o, NULL, -1, NULL);
8733 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
8734 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8736 /* establish postfix order */
8737 enter->op_next = (OP*)enter;
8739 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8740 o->op_type = OP_LEAVETRY;
8741 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8742 enter->op_other = o;
8751 const U8 priv = o->op_private;
8753 /* the newUNOP will recursively call ck_eval(), which will handle
8754 * all the stuff at the end of this function, like adding
8757 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8759 o->op_targ = (PADOFFSET)PL_hints;
8760 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8761 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8762 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8763 /* Store a copy of %^H that pp_entereval can pick up. */
8764 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8765 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8766 /* append hhop to only child */
8767 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
8769 o->op_private |= OPpEVAL_HAS_HH;
8771 if (!(o->op_private & OPpEVAL_BYTES)
8772 && FEATURE_UNIEVAL_IS_ENABLED)
8773 o->op_private |= OPpEVAL_UNICODE;
8778 Perl_ck_exec(pTHX_ OP *o)
8780 PERL_ARGS_ASSERT_CK_EXEC;
8782 if (o->op_flags & OPf_STACKED) {
8785 kid = OP_SIBLING(cUNOPo->op_first);
8786 if (kid->op_type == OP_RV2GV)
8795 Perl_ck_exists(pTHX_ OP *o)
8797 PERL_ARGS_ASSERT_CK_EXISTS;
8800 if (o->op_flags & OPf_KIDS) {
8801 OP * const kid = cUNOPo->op_first;
8802 if (kid->op_type == OP_ENTERSUB) {
8803 (void) ref(kid, o->op_type);
8804 if (kid->op_type != OP_RV2CV
8805 && !(PL_parser && PL_parser->error_count))
8807 "exists argument is not a subroutine name");
8808 o->op_private |= OPpEXISTS_SUB;
8810 else if (kid->op_type == OP_AELEM)
8811 o->op_flags |= OPf_SPECIAL;
8812 else if (kid->op_type != OP_HELEM)
8813 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8814 "element or a subroutine");
8821 Perl_ck_rvconst(pTHX_ OP *o)
8824 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8826 PERL_ARGS_ASSERT_CK_RVCONST;
8828 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8829 if (o->op_type == OP_RV2CV)
8830 o->op_private &= ~1;
8832 if (kid->op_type == OP_CONST) {
8834 const int noexpand = o->op_type == OP_RV2CV
8835 && o->op_private & OPpMAY_RETURN_CONSTANT
8839 SV * const kidsv = kid->op_sv;
8841 /* Is it a constant from cv_const_sv()? */
8842 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
8845 if (SvTYPE(kidsv) == SVt_PVAV) return o;
8846 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8847 const char *badthing;
8848 switch (o->op_type) {
8850 badthing = "a SCALAR";
8853 badthing = "an ARRAY";
8856 badthing = "a HASH";
8864 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8865 SVfARG(kidsv), badthing);
8868 * This is a little tricky. We only want to add the symbol if we
8869 * didn't add it in the lexer. Otherwise we get duplicate strict
8870 * warnings. But if we didn't add it in the lexer, we must at
8871 * least pretend like we wanted to add it even if it existed before,
8872 * or we get possible typo warnings. OPpCONST_ENTERED says
8873 * whether the lexer already added THIS instance of this symbol.
8875 iscv = (o->op_type == OP_RV2CV) * 2;
8877 gv = gv_fetchsv(kidsv,
8880 : iscv | !(kid->op_private & OPpCONST_ENTERED),
8883 : o->op_type == OP_RV2SV
8885 : o->op_type == OP_RV2AV
8887 : o->op_type == OP_RV2HV
8890 } while (!noexpand && !gv && !(kid->op_private & OPpCONST_ENTERED)
8893 kid->op_type = OP_GV;
8894 SvREFCNT_dec(kid->op_sv);
8896 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8897 assert (sizeof(PADOP) <= sizeof(SVOP));
8898 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
8899 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8900 if (isGV(gv)) GvIN_PAD_on(gv);
8901 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8903 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8905 kid->op_private = 0;
8906 kid->op_ppaddr = PL_ppaddr[OP_GV];
8907 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8915 Perl_ck_ftst(pTHX_ OP *o)
8918 const I32 type = o->op_type;
8920 PERL_ARGS_ASSERT_CK_FTST;
8922 if (o->op_flags & OPf_REF) {
8925 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8926 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8927 const OPCODE kidtype = kid->op_type;
8929 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8930 && !kid->op_folded) {
8931 OP * const newop = newGVOP(type, OPf_REF,
8932 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8936 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8937 o->op_private |= OPpFT_ACCESS;
8938 if (PL_check[kidtype] == Perl_ck_ftst
8939 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8940 o->op_private |= OPpFT_STACKED;
8941 kid->op_private |= OPpFT_STACKING;
8942 if (kidtype == OP_FTTTY && (
8943 !(kid->op_private & OPpFT_STACKED)
8944 || kid->op_private & OPpFT_AFTER_t
8946 o->op_private |= OPpFT_AFTER_t;
8951 if (type == OP_FTTTY)
8952 o = newGVOP(type, OPf_REF, PL_stdingv);
8954 o = newUNOP(type, 0, newDEFSVOP());
8960 Perl_ck_fun(pTHX_ OP *o)
8962 const int type = o->op_type;
8963 I32 oa = PL_opargs[type] >> OASHIFT;
8965 PERL_ARGS_ASSERT_CK_FUN;
8967 if (o->op_flags & OPf_STACKED) {
8968 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8971 return no_fh_allowed(o);
8974 if (o->op_flags & OPf_KIDS) {
8975 OP *prev_kid = NULL;
8976 OP *kid = cLISTOPo->op_first;
8978 bool seen_optional = FALSE;
8980 if (kid->op_type == OP_PUSHMARK ||
8981 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8984 kid = OP_SIBLING(kid);
8986 if (kid && kid->op_type == OP_COREARGS) {
8987 bool optional = FALSE;
8990 if (oa & OA_OPTIONAL) optional = TRUE;
8993 if (optional) o->op_private |= numargs;
8998 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8999 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9001 /* append kid to chain */
9002 op_sibling_splice(o, prev_kid, 0, kid);
9004 seen_optional = TRUE;
9011 /* list seen where single (scalar) arg expected? */
9012 if (numargs == 1 && !(oa >> 4)
9013 && kid->op_type == OP_LIST && type != OP_SCALAR)
9015 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9017 if (type != OP_DELETE) scalar(kid);
9028 if ((type == OP_PUSH || type == OP_UNSHIFT)
9029 && !OP_HAS_SIBLING(kid))
9030 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9031 "Useless use of %s with no values",
9034 if (kid->op_type == OP_CONST
9035 && ( !SvROK(cSVOPx_sv(kid))
9036 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9038 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9039 /* Defer checks to run-time if we have a scalar arg */
9040 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9041 op_lvalue(kid, type);
9044 /* diag_listed_as: push on reference is experimental */
9045 Perl_ck_warner_d(aTHX_
9046 packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9047 "%s on reference is experimental",
9052 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9053 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9054 op_lvalue(kid, type);
9058 /* replace kid with newop in chain */
9060 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9061 newop->op_next = newop;
9066 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9067 if (kid->op_type == OP_CONST &&
9068 (kid->op_private & OPpCONST_BARE))
9070 OP * const newop = newGVOP(OP_GV, 0,
9071 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9072 /* replace kid with newop in chain */
9073 op_sibling_splice(o, prev_kid, 1, newop);
9077 else if (kid->op_type == OP_READLINE) {
9078 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9079 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9082 I32 flags = OPf_SPECIAL;
9086 /* is this op a FH constructor? */
9087 if (is_handle_constructor(o,numargs)) {
9088 const char *name = NULL;
9091 bool want_dollar = TRUE;
9094 /* Set a flag to tell rv2gv to vivify
9095 * need to "prove" flag does not mean something
9096 * else already - NI-S 1999/05/07
9099 if (kid->op_type == OP_PADSV) {
9101 = PAD_COMPNAME_SV(kid->op_targ);
9102 name = SvPV_const(namesv, len);
9103 name_utf8 = SvUTF8(namesv);
9105 else if (kid->op_type == OP_RV2SV
9106 && kUNOP->op_first->op_type == OP_GV)
9108 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9110 len = GvNAMELEN(gv);
9111 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9113 else if (kid->op_type == OP_AELEM
9114 || kid->op_type == OP_HELEM)
9117 OP *op = ((BINOP*)kid)->op_first;
9121 const char * const a =
9122 kid->op_type == OP_AELEM ?
9124 if (((op->op_type == OP_RV2AV) ||
9125 (op->op_type == OP_RV2HV)) &&
9126 (firstop = ((UNOP*)op)->op_first) &&
9127 (firstop->op_type == OP_GV)) {
9128 /* packagevar $a[] or $h{} */
9129 GV * const gv = cGVOPx_gv(firstop);
9137 else if (op->op_type == OP_PADAV
9138 || op->op_type == OP_PADHV) {
9139 /* lexicalvar $a[] or $h{} */
9140 const char * const padname =
9141 PAD_COMPNAME_PV(op->op_targ);
9150 name = SvPV_const(tmpstr, len);
9151 name_utf8 = SvUTF8(tmpstr);
9156 name = "__ANONIO__";
9158 want_dollar = FALSE;
9160 op_lvalue(kid, type);
9164 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9165 namesv = PAD_SVl(targ);
9166 if (want_dollar && *name != '$')
9167 sv_setpvs(namesv, "$");
9169 sv_setpvs(namesv, "");
9170 sv_catpvn(namesv, name, len);
9171 if ( name_utf8 ) SvUTF8_on(namesv);
9175 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9177 kid->op_targ = targ;
9178 kid->op_private |= priv;
9184 if ((type == OP_UNDEF || type == OP_POS)
9185 && numargs == 1 && !(oa >> 4)
9186 && kid->op_type == OP_LIST)
9187 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9188 op_lvalue(scalar(kid), type);
9193 kid = OP_SIBLING(kid);
9195 /* FIXME - should the numargs or-ing move after the too many
9196 * arguments check? */
9197 o->op_private |= numargs;
9199 return too_many_arguments_pv(o,OP_DESC(o), 0);
9202 else if (PL_opargs[type] & OA_DEFGV) {
9203 /* Ordering of these two is important to keep f_map.t passing. */
9205 return newUNOP(type, 0, newDEFSVOP());
9209 while (oa & OA_OPTIONAL)
9211 if (oa && oa != OA_LIST)
9212 return too_few_arguments_pv(o,OP_DESC(o), 0);
9218 Perl_ck_glob(pTHX_ OP *o)
9222 PERL_ARGS_ASSERT_CK_GLOB;
9225 if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
9226 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9228 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9232 * \ null - const(wildcard)
9237 * \ mark - glob - rv2cv
9238 * | \ gv(CORE::GLOBAL::glob)
9240 * \ null - const(wildcard)
9242 o->op_flags |= OPf_SPECIAL;
9243 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9244 o = S_new_entersubop(aTHX_ gv, o);
9245 o = newUNOP(OP_NULL, 0, o);
9246 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9249 else o->op_flags &= ~OPf_SPECIAL;
9250 #if !defined(PERL_EXTERNAL_GLOB)
9253 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9254 newSVpvs("File::Glob"), NULL, NULL, NULL);
9257 #endif /* !PERL_EXTERNAL_GLOB */
9258 gv = (GV *)newSV(0);
9259 gv_init(gv, 0, "", 0, 0);
9261 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9262 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9268 Perl_ck_grep(pTHX_ OP *o)
9273 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9276 PERL_ARGS_ASSERT_CK_GREP;
9278 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9279 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9281 if (o->op_flags & OPf_STACKED) {
9282 kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
9283 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9284 return no_fh_allowed(o);
9285 o->op_flags &= ~OPf_STACKED;
9287 kid = OP_SIBLING(cLISTOPo->op_first);
9288 if (type == OP_MAPWHILE)
9293 if (PL_parser && PL_parser->error_count)
9295 kid = OP_SIBLING(cLISTOPo->op_first);
9296 if (kid->op_type != OP_NULL)
9297 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9298 kid = kUNOP->op_first;
9300 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
9301 gwop->op_ppaddr = PL_ppaddr[type];
9302 kid->op_next = (OP*)gwop;
9303 offset = pad_findmy_pvs("$_", 0);
9304 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9305 o->op_private = gwop->op_private = 0;
9306 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9309 o->op_private = gwop->op_private = OPpGREP_LEX;
9310 gwop->op_targ = o->op_targ = offset;
9313 kid = OP_SIBLING(cLISTOPo->op_first);
9314 for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
9315 op_lvalue(kid, OP_GREPSTART);
9321 Perl_ck_index(pTHX_ OP *o)
9323 PERL_ARGS_ASSERT_CK_INDEX;
9325 if (o->op_flags & OPf_KIDS) {
9326 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9328 kid = OP_SIBLING(kid); /* get past "big" */
9329 if (kid && kid->op_type == OP_CONST) {
9330 const bool save_taint = TAINT_get;
9331 SV *sv = kSVOP->op_sv;
9332 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9334 sv_copypv(sv, kSVOP->op_sv);
9335 SvREFCNT_dec_NN(kSVOP->op_sv);
9338 if (SvOK(sv)) fbm_compile(sv, 0);
9339 TAINT_set(save_taint);
9340 #ifdef NO_TAINT_SUPPORT
9341 PERL_UNUSED_VAR(save_taint);
9349 Perl_ck_lfun(pTHX_ OP *o)
9351 const OPCODE type = o->op_type;
9353 PERL_ARGS_ASSERT_CK_LFUN;
9355 return modkids(ck_fun(o), type);
9359 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
9361 PERL_ARGS_ASSERT_CK_DEFINED;
9363 if ((o->op_flags & OPf_KIDS)) {
9364 switch (cUNOPo->op_first->op_type) {
9367 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
9368 " (Maybe you should just omit the defined()?)");
9372 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
9373 " (Maybe you should just omit the defined()?)");
9384 Perl_ck_readline(pTHX_ OP *o)
9386 PERL_ARGS_ASSERT_CK_READLINE;
9388 if (o->op_flags & OPf_KIDS) {
9389 OP *kid = cLISTOPo->op_first;
9390 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9394 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9402 Perl_ck_rfun(pTHX_ OP *o)
9404 const OPCODE type = o->op_type;
9406 PERL_ARGS_ASSERT_CK_RFUN;
9408 return refkids(ck_fun(o), type);
9412 Perl_ck_listiob(pTHX_ OP *o)
9416 PERL_ARGS_ASSERT_CK_LISTIOB;
9418 kid = cLISTOPo->op_first;
9420 o = force_list(o, 1);
9421 kid = cLISTOPo->op_first;
9423 if (kid->op_type == OP_PUSHMARK)
9424 kid = OP_SIBLING(kid);
9425 if (kid && o->op_flags & OPf_STACKED)
9426 kid = OP_SIBLING(kid);
9427 else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */
9428 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9429 && !kid->op_folded) {
9430 o->op_flags |= OPf_STACKED; /* make it a filehandle */
9432 /* replace old const op with new OP_RV2GV parent */
9433 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
9435 kid = OP_SIBLING(kid);
9440 op_append_elem(o->op_type, o, newDEFSVOP());
9442 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9447 Perl_ck_smartmatch(pTHX_ OP *o)
9450 PERL_ARGS_ASSERT_CK_SMARTMATCH;
9451 if (0 == (o->op_flags & OPf_SPECIAL)) {
9452 OP *first = cBINOPo->op_first;
9453 OP *second = OP_SIBLING(first);
9455 /* Implicitly take a reference to an array or hash */
9457 /* remove the original two siblings, then add back the
9458 * (possibly different) first and second sibs.
9460 op_sibling_splice(o, NULL, 1, NULL);
9461 op_sibling_splice(o, NULL, 1, NULL);
9462 first = ref_array_or_hash(first);
9463 second = ref_array_or_hash(second);
9464 op_sibling_splice(o, NULL, 0, second);
9465 op_sibling_splice(o, NULL, 0, first);
9467 /* Implicitly take a reference to a regular expression */
9468 if (first->op_type == OP_MATCH) {
9469 first->op_type = OP_QR;
9470 first->op_ppaddr = PL_ppaddr[OP_QR];
9472 if (second->op_type == OP_MATCH) {
9473 second->op_type = OP_QR;
9474 second->op_ppaddr = PL_ppaddr[OP_QR];
9483 Perl_ck_sassign(pTHX_ OP *o)
9486 OP * const kid = cLISTOPo->op_first;
9488 PERL_ARGS_ASSERT_CK_SASSIGN;
9490 /* has a disposable target? */
9491 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9492 && !(kid->op_flags & OPf_STACKED)
9493 /* Cannot steal the second time! */
9494 && !(kid->op_private & OPpTARGET_MY)
9497 OP * const kkid = OP_SIBLING(kid);
9499 /* Can just relocate the target. */
9500 if (kkid && kkid->op_type == OP_PADSV
9501 && !(kkid->op_private & OPpLVAL_INTRO))
9503 kid->op_targ = kkid->op_targ;
9505 /* Now we do not need PADSV and SASSIGN.
9506 * first replace the PADSV with OP_SIBLING(o), then
9507 * detach kid and OP_SIBLING(o) from o */
9508 op_sibling_splice(o, kid, 1, OP_SIBLING(o));
9509 op_sibling_splice(o, NULL, -1, NULL);
9512 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9516 if (OP_HAS_SIBLING(kid)) {
9517 OP *kkid = OP_SIBLING(kid);
9518 /* For state variable assignment, kkid is a list op whose op_last
9520 if ((kkid->op_type == OP_PADSV ||
9521 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
9522 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9525 && (kkid->op_private & OPpLVAL_INTRO)
9526 && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
9527 const PADOFFSET target = kkid->op_targ;
9528 OP *const other = newOP(OP_PADSV,
9530 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9531 OP *const first = newOP(OP_NULL, 0);
9532 OP *const nullop = newCONDOP(0, first, o, other);
9533 OP *const condop = first->op_next;
9534 /* hijacking PADSTALE for uninitialized state variables */
9535 SvPADSTALE_on(PAD_SVl(target));
9537 condop->op_type = OP_ONCE;
9538 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9539 condop->op_targ = target;
9540 other->op_targ = target;
9542 /* Because we change the type of the op here, we will skip the
9543 assignment binop->op_last = OP_SIBLING(binop->op_first); at the
9544 end of Perl_newBINOP(). So need to do it here. */
9545 cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first);
9546 cBINOPo->op_first->op_lastsib = 0;
9547 cBINOPo->op_last ->op_lastsib = 1;
9548 #ifdef PERL_OP_PARENT
9549 cBINOPo->op_last->op_sibling = o;
9558 Perl_ck_match(pTHX_ OP *o)
9560 PERL_ARGS_ASSERT_CK_MATCH;
9562 if (o->op_type != OP_QR && PL_compcv) {
9563 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9564 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9565 o->op_targ = offset;
9566 o->op_private |= OPpTARGET_MY;
9569 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9570 o->op_private |= OPpRUNTIME;
9575 Perl_ck_method(pTHX_ OP *o)
9577 OP * const kid = cUNOPo->op_first;
9579 PERL_ARGS_ASSERT_CK_METHOD;
9581 if (kid->op_type == OP_CONST) {
9582 SV* sv = kSVOP->op_sv;
9583 const char * const method = SvPVX_const(sv);
9584 if (!(strchr(method, ':') || strchr(method, '\''))) {
9586 if (!SvIsCOW_shared_hash(sv)) {
9587 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9590 kSVOP->op_sv = NULL;
9592 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9601 Perl_ck_null(pTHX_ OP *o)
9603 PERL_ARGS_ASSERT_CK_NULL;
9604 PERL_UNUSED_CONTEXT;
9609 Perl_ck_open(pTHX_ OP *o)
9611 PERL_ARGS_ASSERT_CK_OPEN;
9613 S_io_hints(aTHX_ o);
9615 /* In case of three-arg dup open remove strictness
9616 * from the last arg if it is a bareword. */
9617 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9618 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
9622 if ((last->op_type == OP_CONST) && /* The bareword. */
9623 (last->op_private & OPpCONST_BARE) &&
9624 (last->op_private & OPpCONST_STRICT) &&
9625 (oa = OP_SIBLING(first)) && /* The fh. */
9626 (oa = OP_SIBLING(oa)) && /* The mode. */
9627 (oa->op_type == OP_CONST) &&
9628 SvPOK(((SVOP*)oa)->op_sv) &&
9629 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9630 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9631 (last == OP_SIBLING(oa))) /* The bareword. */
9632 last->op_private &= ~OPpCONST_STRICT;
9638 Perl_ck_repeat(pTHX_ OP *o)
9640 PERL_ARGS_ASSERT_CK_REPEAT;
9642 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9644 o->op_private |= OPpREPEAT_DOLIST;
9645 kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
9646 kids = force_list(kids, 1); /* promote them to a list */
9647 op_sibling_splice(o, NULL, 0, kids); /* and add back */
9655 Perl_ck_require(pTHX_ OP *o)
9659 PERL_ARGS_ASSERT_CK_REQUIRE;
9661 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9662 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9664 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9665 SV * const sv = kid->op_sv;
9666 U32 was_readonly = SvREADONLY(sv);
9674 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9679 for (; s < end; s++) {
9680 if (*s == ':' && s[1] == ':') {
9682 Move(s+2, s+1, end - s - 1, char);
9687 sv_catpvs(sv, ".pm");
9688 SvFLAGS(sv) |= was_readonly;
9692 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9693 /* handle override, if any */
9694 && (gv = gv_override("require", 7))) {
9696 if (o->op_flags & OPf_KIDS) {
9697 kid = cUNOPo->op_first;
9698 op_sibling_splice(o, NULL, -1, NULL);
9704 newop = S_new_entersubop(aTHX_ gv, kid);
9708 return scalar(ck_fun(o));
9712 Perl_ck_return(pTHX_ OP *o)
9716 PERL_ARGS_ASSERT_CK_RETURN;
9718 kid = OP_SIBLING(cLISTOPo->op_first);
9719 if (CvLVALUE(PL_compcv)) {
9720 for (; kid; kid = OP_SIBLING(kid))
9721 op_lvalue(kid, OP_LEAVESUBLV);
9728 Perl_ck_select(pTHX_ OP *o)
9733 PERL_ARGS_ASSERT_CK_SELECT;
9735 if (o->op_flags & OPf_KIDS) {
9736 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9737 if (kid && OP_HAS_SIBLING(kid)) {
9738 o->op_type = OP_SSELECT;
9739 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9741 return fold_constants(op_integerize(op_std_init(o)));
9745 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9746 if (kid && kid->op_type == OP_RV2GV)
9747 kid->op_private &= ~HINT_STRICT_REFS;
9752 Perl_ck_shift(pTHX_ OP *o)
9754 const I32 type = o->op_type;
9756 PERL_ARGS_ASSERT_CK_SHIFT;
9758 if (!(o->op_flags & OPf_KIDS)) {
9761 if (!CvUNIQUE(PL_compcv)) {
9762 o->op_flags |= OPf_SPECIAL;
9766 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9768 return newUNOP(type, 0, scalar(argop));
9770 return scalar(ck_fun(o));
9774 Perl_ck_sort(pTHX_ OP *o)
9779 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9782 PERL_ARGS_ASSERT_CK_SORT;
9785 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9787 const I32 sorthints = (I32)SvIV(*svp);
9788 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9789 o->op_private |= OPpSORT_QSORT;
9790 if ((sorthints & HINT_SORT_STABLE) != 0)
9791 o->op_private |= OPpSORT_STABLE;
9795 if (o->op_flags & OPf_STACKED)
9797 firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9799 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
9800 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9802 /* if the first arg is a code block, process it and mark sort as
9804 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9806 if (kid->op_type == OP_LEAVE)
9807 op_null(kid); /* wipe out leave */
9808 /* Prevent execution from escaping out of the sort block. */
9811 /* provide scalar context for comparison function/block */
9812 kid = scalar(firstkid);
9814 o->op_flags |= OPf_SPECIAL;
9817 firstkid = OP_SIBLING(firstkid);
9820 for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
9821 /* provide list context for arguments */
9824 op_lvalue(kid, OP_GREPSTART);
9830 /* for sort { X } ..., where X is one of
9831 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
9832 * elide the second child of the sort (the one containing X),
9833 * and set these flags as appropriate
9837 * Also, check and warn on lexical $a, $b.
9841 S_simplify_sort(pTHX_ OP *o)
9843 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9850 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9852 kid = kUNOP->op_first; /* get past null */
9853 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9854 && kid->op_type != OP_LEAVE)
9856 kid = kLISTOP->op_last; /* get past scope */
9857 switch(kid->op_type) {
9861 if (!have_scopeop) goto padkids;
9866 k = kid; /* remember this node*/
9867 if (kBINOP->op_first->op_type != OP_RV2SV
9868 || kBINOP->op_last ->op_type != OP_RV2SV)
9871 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9872 then used in a comparison. This catches most, but not
9873 all cases. For instance, it catches
9874 sort { my($a); $a <=> $b }
9876 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9877 (although why you'd do that is anyone's guess).
9881 if (!ckWARN(WARN_SYNTAX)) return;
9882 kid = kBINOP->op_first;
9884 if (kid->op_type == OP_PADSV) {
9885 SV * const name = PAD_COMPNAME_SV(kid->op_targ);
9886 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9887 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9888 /* diag_listed_as: "my %s" used in sort comparison */
9889 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9890 "\"%s %s\" used in sort comparison",
9891 SvPAD_STATE(name) ? "state" : "my",
9894 } while ((kid = OP_SIBLING(kid)));
9897 kid = kBINOP->op_first; /* get past cmp */
9898 if (kUNOP->op_first->op_type != OP_GV)
9900 kid = kUNOP->op_first; /* get past rv2sv */
9902 if (GvSTASH(gv) != PL_curstash)
9904 gvname = GvNAME(gv);
9905 if (*gvname == 'a' && gvname[1] == '\0')
9907 else if (*gvname == 'b' && gvname[1] == '\0')
9912 kid = k; /* back to cmp */
9913 /* already checked above that it is rv2sv */
9914 kid = kBINOP->op_last; /* down to 2nd arg */
9915 if (kUNOP->op_first->op_type != OP_GV)
9917 kid = kUNOP->op_first; /* get past rv2sv */
9919 if (GvSTASH(gv) != PL_curstash)
9921 gvname = GvNAME(gv);
9923 ? !(*gvname == 'a' && gvname[1] == '\0')
9924 : !(*gvname == 'b' && gvname[1] == '\0'))
9926 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9928 o->op_private |= OPpSORT_DESCEND;
9929 if (k->op_type == OP_NCMP)
9930 o->op_private |= OPpSORT_NUMERIC;
9931 if (k->op_type == OP_I_NCMP)
9932 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9933 kid = OP_SIBLING(cLISTOPo->op_first);
9934 /* cut out and delete old block (second sibling) */
9935 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
9940 Perl_ck_split(pTHX_ OP *o)
9945 PERL_ARGS_ASSERT_CK_SPLIT;
9947 if (o->op_flags & OPf_STACKED)
9948 return no_fh_allowed(o);
9950 kid = cLISTOPo->op_first;
9951 if (kid->op_type != OP_NULL)
9952 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9953 /* delete leading NULL node, then add a CONST if no other nodes */
9954 op_sibling_splice(o, NULL, 1,
9955 OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
9957 kid = cLISTOPo->op_first;
9959 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9960 /* remove kid, and replace with new optree */
9961 op_sibling_splice(o, NULL, 1, NULL);
9962 /* OPf_SPECIAL is used to trigger split " " behavior */
9963 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
9964 op_sibling_splice(o, NULL, 0, kid);
9967 kid->op_type = OP_PUSHRE;
9968 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9970 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9971 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9972 "Use of /g modifier is meaningless in split");
9975 if (!OP_HAS_SIBLING(kid))
9976 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9978 kid = OP_SIBLING(kid);
9982 if (!OP_HAS_SIBLING(kid))
9984 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9985 o->op_private |= OPpSPLIT_IMPLIM;
9987 assert(OP_HAS_SIBLING(kid));
9989 kid = OP_SIBLING(kid);
9992 if (OP_HAS_SIBLING(kid))
9993 return too_many_arguments_pv(o,OP_DESC(o), 0);
9999 Perl_ck_join(pTHX_ OP *o)
10001 const OP * const kid = OP_SIBLING(cLISTOPo->op_first);
10003 PERL_ARGS_ASSERT_CK_JOIN;
10005 if (kid && kid->op_type == OP_MATCH) {
10006 if (ckWARN(WARN_SYNTAX)) {
10007 const REGEXP *re = PM_GETRE(kPMOP);
10009 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10010 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10011 : newSVpvs_flags( "STRING", SVs_TEMP );
10012 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10013 "/%"SVf"/ should probably be written as \"%"SVf"\"",
10014 SVfARG(msg), SVfARG(msg));
10021 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10023 Examines an op, which is expected to identify a subroutine at runtime,
10024 and attempts to determine at compile time which subroutine it identifies.
10025 This is normally used during Perl compilation to determine whether
10026 a prototype can be applied to a function call. I<cvop> is the op
10027 being considered, normally an C<rv2cv> op. A pointer to the identified
10028 subroutine is returned, if it could be determined statically, and a null
10029 pointer is returned if it was not possible to determine statically.
10031 Currently, the subroutine can be identified statically if the RV that the
10032 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10033 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
10034 suitable if the constant value must be an RV pointing to a CV. Details of
10035 this process may change in future versions of Perl. If the C<rv2cv> op
10036 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10037 the subroutine statically: this flag is used to suppress compile-time
10038 magic on a subroutine call, forcing it to use default runtime behaviour.
10040 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10041 of a GV reference is modified. If a GV was examined and its CV slot was
10042 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10043 If the op is not optimised away, and the CV slot is later populated with
10044 a subroutine having a prototype, that flag eventually triggers the warning
10045 "called too early to check prototype".
10047 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10048 of returning a pointer to the subroutine it returns a pointer to the
10049 GV giving the most appropriate name for the subroutine in this context.
10050 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10051 (C<CvANON>) subroutine that is referenced through a GV it will be the
10052 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
10053 A null pointer is returned as usual if there is no statically-determinable
10059 /* shared by toke.c:yylex */
10061 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10063 PADNAME *name = PAD_COMPNAME(off);
10064 CV *compcv = PL_compcv;
10065 while (PadnameOUTER(name)) {
10066 assert(PARENT_PAD_INDEX(name));
10067 compcv = CvOUTSIDE(PL_compcv);
10068 name = PadlistNAMESARRAY(CvPADLIST(compcv))
10069 [off = PARENT_PAD_INDEX(name)];
10071 assert(!PadnameIsOUR(name));
10072 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10073 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10075 assert(mg->mg_obj);
10076 return (CV *)mg->mg_obj;
10078 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10082 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10087 PERL_ARGS_ASSERT_RV2CV_OP_CV;
10088 if (flags & ~RV2CVOPCV_FLAG_MASK)
10089 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10090 if (cvop->op_type != OP_RV2CV)
10092 if (cvop->op_private & OPpENTERSUB_AMPER)
10094 if (!(cvop->op_flags & OPf_KIDS))
10096 rvop = cUNOPx(cvop)->op_first;
10097 switch (rvop->op_type) {
10099 gv = cGVOPx_gv(rvop);
10101 if (flags & RV2CVOPCV_RETURN_STUB)
10107 if (flags & RV2CVOPCV_MARK_EARLY)
10108 rvop->op_private |= OPpEARLY_CV;
10113 SV *rv = cSVOPx_sv(rvop);
10116 cv = (CV*)SvRV(rv);
10120 cv = find_lexical_cv(rvop->op_targ);
10125 } NOT_REACHED; /* NOTREACHED */
10127 if (SvTYPE((SV*)cv) != SVt_PVCV)
10129 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10130 if (!CvANON(cv) || !gv)
10139 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10141 Performs the default fixup of the arguments part of an C<entersub>
10142 op tree. This consists of applying list context to each of the
10143 argument ops. This is the standard treatment used on a call marked
10144 with C<&>, or a method call, or a call through a subroutine reference,
10145 or any other call where the callee can't be identified at compile time,
10146 or a call where the callee has no prototype.
10152 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10155 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10156 aop = cUNOPx(entersubop)->op_first;
10157 if (!OP_HAS_SIBLING(aop))
10158 aop = cUNOPx(aop)->op_first;
10159 for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
10161 op_lvalue(aop, OP_ENTERSUB);
10167 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10169 Performs the fixup of the arguments part of an C<entersub> op tree
10170 based on a subroutine prototype. This makes various modifications to
10171 the argument ops, from applying context up to inserting C<refgen> ops,
10172 and checking the number and syntactic types of arguments, as directed by
10173 the prototype. This is the standard treatment used on a subroutine call,
10174 not marked with C<&>, where the callee can be identified at compile time
10175 and has a prototype.
10177 I<protosv> supplies the subroutine prototype to be applied to the call.
10178 It may be a normal defined scalar, of which the string value will be used.
10179 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10180 that has been cast to C<SV*>) which has a prototype. The prototype
10181 supplied, in whichever form, does not need to match the actual callee
10182 referenced by the op tree.
10184 If the argument ops disagree with the prototype, for example by having
10185 an unacceptable number of arguments, a valid op tree is returned anyway.
10186 The error is reflected in the parser state, normally resulting in a single
10187 exception at the top level of parsing which covers all the compilation
10188 errors that occurred. In the error message, the callee is referred to
10189 by the name defined by the I<namegv> parameter.
10195 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10198 const char *proto, *proto_end;
10199 OP *aop, *prev, *cvop, *parent;
10202 I32 contextclass = 0;
10203 const char *e = NULL;
10204 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10205 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10206 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10207 "flags=%lx", (unsigned long) SvFLAGS(protosv));
10208 if (SvTYPE(protosv) == SVt_PVCV)
10209 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10210 else proto = SvPV(protosv, proto_len);
10211 proto = S_strip_spaces(aTHX_ proto, &proto_len);
10212 proto_end = proto + proto_len;
10213 parent = entersubop;
10214 aop = cUNOPx(entersubop)->op_first;
10215 if (!OP_HAS_SIBLING(aop)) {
10217 aop = cUNOPx(aop)->op_first;
10220 aop = OP_SIBLING(aop);
10221 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10222 while (aop != cvop) {
10225 if (proto >= proto_end)
10226 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10234 /* _ must be at the end */
10235 if (proto[1] && !strchr(";@%", proto[1]))
10251 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10253 arg == 1 ? "block or sub {}" : "sub {}",
10257 /* '*' allows any scalar type, including bareword */
10260 if (o3->op_type == OP_RV2GV)
10261 goto wrapref; /* autoconvert GLOB -> GLOBref */
10262 else if (o3->op_type == OP_CONST)
10263 o3->op_private &= ~OPpCONST_STRICT;
10264 else if (o3->op_type == OP_ENTERSUB) {
10265 /* accidental subroutine, revert to bareword */
10266 OP *gvop = ((UNOP*)o3)->op_first;
10267 if (gvop && gvop->op_type == OP_NULL) {
10268 gvop = ((UNOP*)gvop)->op_first;
10270 for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop))
10273 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10274 (gvop = ((UNOP*)gvop)->op_first) &&
10275 gvop->op_type == OP_GV)
10278 GV * const gv = cGVOPx_gv(gvop);
10279 SV * const n = newSVpvs("");
10280 gv_fullname4(n, gv, "", FALSE);
10281 /* replace the aop subtree with a const op */
10282 newop = newSVOP(OP_CONST, 0, n);
10283 op_sibling_splice(parent, prev, 1, newop);
10295 if (o3->op_type == OP_RV2AV ||
10296 o3->op_type == OP_PADAV ||
10297 o3->op_type == OP_RV2HV ||
10298 o3->op_type == OP_PADHV
10304 case '[': case ']':
10311 switch (*proto++) {
10313 if (contextclass++ == 0) {
10314 e = strchr(proto, ']');
10315 if (!e || e == proto)
10323 if (contextclass) {
10324 const char *p = proto;
10325 const char *const end = proto;
10327 while (*--p != '[')
10328 /* \[$] accepts any scalar lvalue */
10330 && Perl_op_lvalue_flags(aTHX_
10332 OP_READ, /* not entersub */
10335 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10336 (int)(end - p), p),
10342 if (o3->op_type == OP_RV2GV)
10345 bad_type_gv(arg, "symbol", namegv, 0, o3);
10348 if (o3->op_type == OP_ENTERSUB)
10351 bad_type_gv(arg, "subroutine entry", namegv, 0,
10355 if (o3->op_type == OP_RV2SV ||
10356 o3->op_type == OP_PADSV ||
10357 o3->op_type == OP_HELEM ||
10358 o3->op_type == OP_AELEM)
10360 if (!contextclass) {
10361 /* \$ accepts any scalar lvalue */
10362 if (Perl_op_lvalue_flags(aTHX_
10364 OP_READ, /* not entersub */
10367 bad_type_gv(arg, "scalar", namegv, 0, o3);
10371 if (o3->op_type == OP_RV2AV ||
10372 o3->op_type == OP_PADAV)
10375 bad_type_gv(arg, "array", namegv, 0, o3);
10378 if (o3->op_type == OP_RV2HV ||
10379 o3->op_type == OP_PADHV)
10382 bad_type_gv(arg, "hash", namegv, 0, o3);
10385 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
10387 if (contextclass && e) {
10392 default: goto oops;
10402 SV* const tmpsv = sv_newmortal();
10403 gv_efullname3(tmpsv, namegv, NULL);
10404 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10405 SVfARG(tmpsv), SVfARG(protosv));
10409 op_lvalue(aop, OP_ENTERSUB);
10411 aop = OP_SIBLING(aop);
10413 if (aop == cvop && *proto == '_') {
10414 /* generate an access to $_ */
10415 op_sibling_splice(parent, prev, 0, newDEFSVOP());
10417 if (!optional && proto_end > proto &&
10418 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10419 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10424 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10426 Performs the fixup of the arguments part of an C<entersub> op tree either
10427 based on a subroutine prototype or using default list-context processing.
10428 This is the standard treatment used on a subroutine call, not marked
10429 with C<&>, where the callee can be identified at compile time.
10431 I<protosv> supplies the subroutine prototype to be applied to the call,
10432 or indicates that there is no prototype. It may be a normal scalar,
10433 in which case if it is defined then the string value will be used
10434 as a prototype, and if it is undefined then there is no prototype.
10435 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10436 that has been cast to C<SV*>), of which the prototype will be used if it
10437 has one. The prototype (or lack thereof) supplied, in whichever form,
10438 does not need to match the actual callee referenced by the op tree.
10440 If the argument ops disagree with the prototype, for example by having
10441 an unacceptable number of arguments, a valid op tree is returned anyway.
10442 The error is reflected in the parser state, normally resulting in a single
10443 exception at the top level of parsing which covers all the compilation
10444 errors that occurred. In the error message, the callee is referred to
10445 by the name defined by the I<namegv> parameter.
10451 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10452 GV *namegv, SV *protosv)
10454 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10455 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10456 return ck_entersub_args_proto(entersubop, namegv, protosv);
10458 return ck_entersub_args_list(entersubop);
10462 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10464 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10465 OP *aop = cUNOPx(entersubop)->op_first;
10467 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10471 if (!OP_HAS_SIBLING(aop))
10472 aop = cUNOPx(aop)->op_first;
10473 aop = OP_SIBLING(aop);
10474 for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10476 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10478 op_free(entersubop);
10479 switch(GvNAME(namegv)[2]) {
10480 case 'F': return newSVOP(OP_CONST, 0,
10481 newSVpv(CopFILE(PL_curcop),0));
10482 case 'L': return newSVOP(
10484 Perl_newSVpvf(aTHX_
10485 "%"IVdf, (IV)CopLINE(PL_curcop)
10488 case 'P': return newSVOP(OP_CONST, 0,
10490 ? newSVhek(HvNAME_HEK(PL_curstash))
10498 OP *prev, *cvop, *first, *parent;
10501 parent = entersubop;
10502 if (!OP_HAS_SIBLING(aop)) {
10504 aop = cUNOPx(aop)->op_first;
10507 first = prev = aop;
10508 aop = OP_SIBLING(aop);
10509 /* find last sibling */
10511 OP_HAS_SIBLING(cvop);
10512 prev = cvop, cvop = OP_SIBLING(cvop))
10514 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
10515 /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
10516 * parens, but these have their own meaning for that flag: */
10517 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
10518 && opnum != OP_DELETE && opnum != OP_EXISTS)
10519 flags |= OPf_SPECIAL;
10520 /* excise cvop from end of sibling chain */
10521 op_sibling_splice(parent, prev, 1, NULL);
10523 if (aop == cvop) aop = NULL;
10525 /* detach remaining siblings from the first sibling, then
10526 * dispose of original optree */
10529 op_sibling_splice(parent, first, -1, NULL);
10530 op_free(entersubop);
10532 if (opnum == OP_ENTEREVAL
10533 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10534 flags |= OPpEVAL_BYTES <<8;
10536 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10538 case OA_BASEOP_OR_UNOP:
10539 case OA_FILESTATOP:
10540 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10543 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10546 return opnum == OP_RUNCV
10547 ? newPVOP(OP_RUNCV,0,NULL)
10550 return convert(opnum,0,aop);
10558 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10560 Retrieves the function that will be used to fix up a call to I<cv>.
10561 Specifically, the function is applied to an C<entersub> op tree for a
10562 subroutine call, not marked with C<&>, where the callee can be identified
10563 at compile time as I<cv>.
10565 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10566 argument for it is returned in I<*ckobj_p>. The function is intended
10567 to be called in this manner:
10569 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10571 In this call, I<entersubop> is a pointer to the C<entersub> op,
10572 which may be replaced by the check function, and I<namegv> is a GV
10573 supplying the name that should be used by the check function to refer
10574 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10575 It is permitted to apply the check function in non-standard situations,
10576 such as to a call to a different subroutine or to a method call.
10578 By default, the function is
10579 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10580 and the SV parameter is I<cv> itself. This implements standard
10581 prototype processing. It can be changed, for a particular subroutine,
10582 by L</cv_set_call_checker>.
10588 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10591 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10592 PERL_UNUSED_CONTEXT;
10593 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10595 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10596 *ckobj_p = callmg->mg_obj;
10598 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10599 *ckobj_p = (SV*)cv;
10604 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10606 Sets the function that will be used to fix up a call to I<cv>.
10607 Specifically, the function is applied to an C<entersub> op tree for a
10608 subroutine call, not marked with C<&>, where the callee can be identified
10609 at compile time as I<cv>.
10611 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10612 for it is supplied in I<ckobj>. The function should be defined like this:
10614 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
10616 It is intended to be called in this manner:
10618 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10620 In this call, I<entersubop> is a pointer to the C<entersub> op,
10621 which may be replaced by the check function, and I<namegv> is a GV
10622 supplying the name that should be used by the check function to refer
10623 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10624 It is permitted to apply the check function in non-standard situations,
10625 such as to a call to a different subroutine or to a method call.
10627 The current setting for a particular CV can be retrieved by
10628 L</cv_get_call_checker>.
10634 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10636 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10637 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10638 if (SvMAGICAL((SV*)cv))
10639 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10642 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10643 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10645 if (callmg->mg_flags & MGf_REFCOUNTED) {
10646 SvREFCNT_dec(callmg->mg_obj);
10647 callmg->mg_flags &= ~MGf_REFCOUNTED;
10649 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10650 callmg->mg_obj = ckobj;
10651 if (ckobj != (SV*)cv) {
10652 SvREFCNT_inc_simple_void_NN(ckobj);
10653 callmg->mg_flags |= MGf_REFCOUNTED;
10655 callmg->mg_flags |= MGf_COPY;
10660 Perl_ck_subr(pTHX_ OP *o)
10666 PERL_ARGS_ASSERT_CK_SUBR;
10668 aop = cUNOPx(o)->op_first;
10669 if (!OP_HAS_SIBLING(aop))
10670 aop = cUNOPx(aop)->op_first;
10671 aop = OP_SIBLING(aop);
10672 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10673 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10674 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10676 o->op_private &= ~1;
10677 o->op_private |= OPpENTERSUB_HASTARG;
10678 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10679 if (PERLDB_SUB && PL_curstash != PL_debstash)
10680 o->op_private |= OPpENTERSUB_DB;
10681 if (cvop->op_type == OP_RV2CV) {
10682 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10684 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10685 if (aop->op_type == OP_CONST)
10686 aop->op_private &= ~OPpCONST_STRICT;
10687 else if (aop->op_type == OP_LIST) {
10688 OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
10689 if (sib && sib->op_type == OP_CONST)
10690 sib->op_private &= ~OPpCONST_STRICT;
10695 return ck_entersub_args_list(o);
10697 Perl_call_checker ckfun;
10699 cv_get_call_checker(cv, &ckfun, &ckobj);
10700 if (!namegv) { /* expletive! */
10701 /* XXX The call checker API is public. And it guarantees that
10702 a GV will be provided with the right name. So we have
10703 to create a GV. But it is still not correct, as its
10704 stringification will include the package. What we
10705 really need is a new call checker API that accepts a
10706 GV or string (or GV or CV). */
10707 HEK * const hek = CvNAME_HEK(cv);
10708 /* After a syntax error in a lexical sub, the cv that
10709 rv2cv_op_cv returns may be a nameless stub. */
10710 if (!hek) return ck_entersub_args_list(o);;
10711 namegv = (GV *)sv_newmortal();
10712 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10713 SVf_UTF8 * !!HEK_UTF8(hek));
10715 return ckfun(aTHX_ o, namegv, ckobj);
10720 Perl_ck_svconst(pTHX_ OP *o)
10722 SV * const sv = cSVOPo->op_sv;
10723 PERL_ARGS_ASSERT_CK_SVCONST;
10724 PERL_UNUSED_CONTEXT;
10725 #ifdef PERL_OLD_COPY_ON_WRITE
10726 if (SvIsCOW(sv)) sv_force_normal(sv);
10727 #elif defined(PERL_NEW_COPY_ON_WRITE)
10728 /* Since the read-only flag may be used to protect a string buffer, we
10729 cannot do copy-on-write with existing read-only scalars that are not
10730 already copy-on-write scalars. To allow $_ = "hello" to do COW with
10731 that constant, mark the constant as COWable here, if it is not
10732 already read-only. */
10733 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10736 # ifdef PERL_DEBUG_READONLY_COW
10746 Perl_ck_trunc(pTHX_ OP *o)
10748 PERL_ARGS_ASSERT_CK_TRUNC;
10750 if (o->op_flags & OPf_KIDS) {
10751 SVOP *kid = (SVOP*)cUNOPo->op_first;
10753 if (kid->op_type == OP_NULL)
10754 kid = (SVOP*)OP_SIBLING(kid);
10755 if (kid && kid->op_type == OP_CONST &&
10756 (kid->op_private & OPpCONST_BARE) &&
10759 o->op_flags |= OPf_SPECIAL;
10760 kid->op_private &= ~OPpCONST_STRICT;
10767 Perl_ck_substr(pTHX_ OP *o)
10769 PERL_ARGS_ASSERT_CK_SUBSTR;
10772 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10773 OP *kid = cLISTOPo->op_first;
10775 if (kid->op_type == OP_NULL)
10776 kid = OP_SIBLING(kid);
10778 kid->op_flags |= OPf_MOD;
10785 Perl_ck_tell(pTHX_ OP *o)
10787 PERL_ARGS_ASSERT_CK_TELL;
10789 if (o->op_flags & OPf_KIDS) {
10790 OP *kid = cLISTOPo->op_first;
10791 if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
10792 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10798 Perl_ck_each(pTHX_ OP *o)
10801 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10802 const unsigned orig_type = o->op_type;
10803 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10804 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10805 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10806 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10808 PERL_ARGS_ASSERT_CK_EACH;
10811 switch (kid->op_type) {
10817 CHANGE_TYPE(o, array_type);
10820 if (kid->op_private == OPpCONST_BARE
10821 || !SvROK(cSVOPx_sv(kid))
10822 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10823 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10825 /* we let ck_fun handle it */
10828 CHANGE_TYPE(o, ref_type);
10832 /* if treating as a reference, defer additional checks to runtime */
10833 if (o->op_type == ref_type) {
10834 /* diag_listed_as: keys on reference is experimental */
10835 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
10836 "%s is experimental", PL_op_desc[ref_type]);
10843 Perl_ck_length(pTHX_ OP *o)
10845 PERL_ARGS_ASSERT_CK_LENGTH;
10849 if (ckWARN(WARN_SYNTAX)) {
10850 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10854 const bool hash = kid->op_type == OP_PADHV
10855 || kid->op_type == OP_RV2HV;
10856 switch (kid->op_type) {
10861 name = S_op_varname(aTHX_ kid);
10867 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10868 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10870 SVfARG(name), hash ? "keys " : "", SVfARG(name)
10873 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10874 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10875 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10877 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10878 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10879 "length() used on @array (did you mean \"scalar(@array)\"?)");
10886 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10887 and modify the optree to make them work inplace */
10890 S_inplace_aassign(pTHX_ OP *o) {
10892 OP *modop, *modop_pushmark;
10894 OP *oleft, *oleft_pushmark;
10896 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10898 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10900 assert(cUNOPo->op_first->op_type == OP_NULL);
10901 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10902 assert(modop_pushmark->op_type == OP_PUSHMARK);
10903 modop = OP_SIBLING(modop_pushmark);
10905 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10908 /* no other operation except sort/reverse */
10909 if (OP_HAS_SIBLING(modop))
10912 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10913 if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
10915 if (modop->op_flags & OPf_STACKED) {
10916 /* skip sort subroutine/block */
10917 assert(oright->op_type == OP_NULL);
10918 oright = OP_SIBLING(oright);
10921 assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
10922 oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
10923 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10924 oleft = OP_SIBLING(oleft_pushmark);
10926 /* Check the lhs is an array */
10928 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10929 || OP_HAS_SIBLING(oleft)
10930 || (oleft->op_private & OPpLVAL_INTRO)
10934 /* Only one thing on the rhs */
10935 if (OP_HAS_SIBLING(oright))
10938 /* check the array is the same on both sides */
10939 if (oleft->op_type == OP_RV2AV) {
10940 if (oright->op_type != OP_RV2AV
10941 || !cUNOPx(oright)->op_first
10942 || cUNOPx(oright)->op_first->op_type != OP_GV
10943 || cUNOPx(oleft )->op_first->op_type != OP_GV
10944 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10945 cGVOPx_gv(cUNOPx(oright)->op_first)
10949 else if (oright->op_type != OP_PADAV
10950 || oright->op_targ != oleft->op_targ
10954 /* This actually is an inplace assignment */
10956 modop->op_private |= OPpSORT_INPLACE;
10958 /* transfer MODishness etc from LHS arg to RHS arg */
10959 oright->op_flags = oleft->op_flags;
10961 /* remove the aassign op and the lhs */
10963 op_null(oleft_pushmark);
10964 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10965 op_null(cUNOPx(oleft)->op_first);
10971 /* mechanism for deferring recursion in rpeep() */
10973 #define MAX_DEFERRED 4
10977 if (defer_ix == (MAX_DEFERRED-1)) { \
10978 OP **defer = defer_queue[defer_base]; \
10979 CALL_RPEEP(*defer); \
10980 S_prune_chain_head(defer); \
10981 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10984 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
10987 #define IS_AND_OP(o) (o->op_type == OP_AND)
10988 #define IS_OR_OP(o) (o->op_type == OP_OR)
10992 S_null_listop_in_list_context(pTHX_ OP *o)
10996 PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
10998 /* This is an OP_LIST in list context. That means we
10999 * can ditch the OP_LIST and the OP_PUSHMARK within. */
11001 kid = cLISTOPo->op_first;
11002 /* Find the end of the chain of OPs executed within the OP_LIST. */
11003 while (kid->op_next != o)
11004 kid = kid->op_next;
11006 kid->op_next = o->op_next; /* patch list out of exec chain */
11007 op_null(cUNOPo->op_first); /* NULL the pushmark */
11008 op_null(o); /* NULL the list */
11011 /* A peephole optimizer. We visit the ops in the order they're to execute.
11012 * See the comments at the top of this file for more details about when
11013 * peep() is called */
11016 Perl_rpeep(pTHX_ OP *o)
11020 OP* oldoldop = NULL;
11021 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11022 int defer_base = 0;
11027 if (!o || o->op_opt)
11031 SAVEVPTR(PL_curcop);
11032 for (;; o = o->op_next) {
11033 if (o && o->op_opt)
11036 while (defer_ix >= 0) {
11038 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
11039 CALL_RPEEP(*defer);
11040 S_prune_chain_head(defer);
11045 /* By default, this op has now been optimised. A couple of cases below
11046 clear this again. */
11051 /* The following will have the OP_LIST and OP_PUSHMARK
11052 * patched out later IF the OP_LIST is in list context.
11053 * So in that case, we can set the this OP's op_next
11054 * to skip to after the OP_PUSHMARK:
11060 * will eventually become:
11063 * - ex-pushmark -> -
11069 OP *other_pushmark;
11070 if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
11071 && (sibling = OP_SIBLING(o))
11072 && sibling->op_type == OP_LIST
11073 /* This KIDS check is likely superfluous since OP_LIST
11074 * would otherwise be an OP_STUB. */
11075 && sibling->op_flags & OPf_KIDS
11076 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
11077 && (other_pushmark = cLISTOPx(sibling)->op_first)
11078 /* Pointer equality also effectively checks that it's a
11080 && other_pushmark == o->op_next)
11082 o->op_next = other_pushmark->op_next;
11083 null_listop_in_list_context(sibling);
11087 switch (o->op_type) {
11089 PL_curcop = ((COP*)o); /* for warnings */
11092 PL_curcop = ((COP*)o); /* for warnings */
11094 /* Optimise a "return ..." at the end of a sub to just be "...".
11095 * This saves 2 ops. Before:
11096 * 1 <;> nextstate(main 1 -e:1) v ->2
11097 * 4 <@> return K ->5
11098 * 2 <0> pushmark s ->3
11099 * - <1> ex-rv2sv sK/1 ->4
11100 * 3 <#> gvsv[*cat] s ->4
11103 * - <@> return K ->-
11104 * - <0> pushmark s ->2
11105 * - <1> ex-rv2sv sK/1 ->-
11106 * 2 <$> gvsv(*cat) s ->3
11109 OP *next = o->op_next;
11110 OP *sibling = OP_SIBLING(o);
11111 if ( OP_TYPE_IS(next, OP_PUSHMARK)
11112 && OP_TYPE_IS(sibling, OP_RETURN)
11113 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
11114 && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
11115 && cUNOPx(sibling)->op_first == next
11116 && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
11119 /* Look through the PUSHMARK's siblings for one that
11120 * points to the RETURN */
11121 OP *top = OP_SIBLING(next);
11122 while (top && top->op_next) {
11123 if (top->op_next == sibling) {
11124 top->op_next = sibling->op_next;
11125 o->op_next = next->op_next;
11128 top = OP_SIBLING(top);
11133 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
11135 * This latter form is then suitable for conversion into padrange
11136 * later on. Convert:
11138 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
11142 * nextstate1 -> listop -> nextstate3
11144 * pushmark -> padop1 -> padop2
11146 if (o->op_next && (
11147 o->op_next->op_type == OP_PADSV
11148 || o->op_next->op_type == OP_PADAV
11149 || o->op_next->op_type == OP_PADHV
11151 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
11152 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
11153 && o->op_next->op_next->op_next && (
11154 o->op_next->op_next->op_next->op_type == OP_PADSV
11155 || o->op_next->op_next->op_next->op_type == OP_PADAV
11156 || o->op_next->op_next->op_next->op_type == OP_PADHV
11158 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
11159 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
11160 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
11161 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
11163 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
11166 ns2 = pad1->op_next;
11167 pad2 = ns2->op_next;
11168 ns3 = pad2->op_next;
11170 /* we assume here that the op_next chain is the same as
11171 * the op_sibling chain */
11172 assert(OP_SIBLING(o) == pad1);
11173 assert(OP_SIBLING(pad1) == ns2);
11174 assert(OP_SIBLING(ns2) == pad2);
11175 assert(OP_SIBLING(pad2) == ns3);
11177 /* create new listop, with children consisting of:
11178 * a new pushmark, pad1, pad2. */
11179 OP_SIBLING_set(pad2, NULL);
11180 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
11181 newop->op_flags |= OPf_PARENS;
11182 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11183 newpm = cUNOPx(newop)->op_first; /* pushmark */
11185 /* Kill nextstate2 between padop1/padop2 */
11188 o ->op_next = newpm;
11189 newpm->op_next = pad1;
11190 pad1 ->op_next = pad2;
11191 pad2 ->op_next = newop; /* listop */
11192 newop->op_next = ns3;
11194 OP_SIBLING_set(o, newop);
11195 OP_SIBLING_set(newop, ns3);
11196 newop->op_lastsib = 0;
11198 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11200 /* Ensure pushmark has this flag if padops do */
11201 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
11202 o->op_next->op_flags |= OPf_MOD;
11208 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11209 to carry two labels. For now, take the easier option, and skip
11210 this optimisation if the first NEXTSTATE has a label. */
11211 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
11212 OP *nextop = o->op_next;
11213 while (nextop && nextop->op_type == OP_NULL)
11214 nextop = nextop->op_next;
11216 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11217 COP *firstcop = (COP *)o;
11218 COP *secondcop = (COP *)nextop;
11219 /* We want the COP pointed to by o (and anything else) to
11220 become the next COP down the line. */
11221 cop_free(firstcop);
11223 firstcop->op_next = secondcop->op_next;
11225 /* Now steal all its pointers, and duplicate the other
11227 firstcop->cop_line = secondcop->cop_line;
11228 #ifdef USE_ITHREADS
11229 firstcop->cop_stashoff = secondcop->cop_stashoff;
11230 firstcop->cop_file = secondcop->cop_file;
11232 firstcop->cop_stash = secondcop->cop_stash;
11233 firstcop->cop_filegv = secondcop->cop_filegv;
11235 firstcop->cop_hints = secondcop->cop_hints;
11236 firstcop->cop_seq = secondcop->cop_seq;
11237 firstcop->cop_warnings = secondcop->cop_warnings;
11238 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11240 #ifdef USE_ITHREADS
11241 secondcop->cop_stashoff = 0;
11242 secondcop->cop_file = NULL;
11244 secondcop->cop_stash = NULL;
11245 secondcop->cop_filegv = NULL;
11247 secondcop->cop_warnings = NULL;
11248 secondcop->cop_hints_hash = NULL;
11250 /* If we use op_null(), and hence leave an ex-COP, some
11251 warnings are misreported. For example, the compile-time
11252 error in 'use strict; no strict refs;' */
11253 secondcop->op_type = OP_NULL;
11254 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11260 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11261 if (o->op_next->op_private & OPpTARGET_MY) {
11262 if (o->op_flags & OPf_STACKED) /* chained concats */
11263 break; /* ignore_optimization */
11265 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11266 o->op_targ = o->op_next->op_targ;
11267 o->op_next->op_targ = 0;
11268 o->op_private |= OPpTARGET_MY;
11271 op_null(o->op_next);
11275 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11276 break; /* Scalar stub must produce undef. List stub is noop */
11280 if (o->op_targ == OP_NEXTSTATE
11281 || o->op_targ == OP_DBSTATE)
11283 PL_curcop = ((COP*)o);
11285 /* XXX: We avoid setting op_seq here to prevent later calls
11286 to rpeep() from mistakenly concluding that optimisation
11287 has already occurred. This doesn't fix the real problem,
11288 though (See 20010220.007). AMS 20010719 */
11289 /* op_seq functionality is now replaced by op_opt */
11297 oldop->op_next = o->op_next;
11305 /* Convert a series of PAD ops for my vars plus support into a
11306 * single padrange op. Basically
11308 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11310 * becomes, depending on circumstances, one of
11312 * padrange ----------------------------------> (list) -> rest
11313 * padrange --------------------------------------------> rest
11315 * where all the pad indexes are sequential and of the same type
11317 * We convert the pushmark into a padrange op, then skip
11318 * any other pad ops, and possibly some trailing ops.
11319 * Note that we don't null() the skipped ops, to make it
11320 * easier for Deparse to undo this optimisation (and none of
11321 * the skipped ops are holding any resourses). It also makes
11322 * it easier for find_uninit_var(), as it can just ignore
11323 * padrange, and examine the original pad ops.
11327 OP *followop = NULL; /* the op that will follow the padrange op */
11330 PADOFFSET base = 0; /* init only to stop compiler whining */
11331 U8 gimme = 0; /* init only to stop compiler whining */
11332 bool defav = 0; /* seen (...) = @_ */
11333 bool reuse = 0; /* reuse an existing padrange op */
11335 /* look for a pushmark -> gv[_] -> rv2av */
11341 if ( p->op_type == OP_GV
11342 && (gv = cGVOPx_gv(p))
11343 && GvNAMELEN_get(gv) == 1
11344 && *GvNAME_get(gv) == '_'
11345 && GvSTASH(gv) == PL_defstash
11346 && (rv2av = p->op_next)
11347 && rv2av->op_type == OP_RV2AV
11348 && !(rv2av->op_flags & OPf_REF)
11349 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11350 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11351 && OP_SIBLING(o) == rv2av /* these two for Deparse */
11352 && cUNOPx(rv2av)->op_first == p
11354 q = rv2av->op_next;
11355 if (q->op_type == OP_NULL)
11357 if (q->op_type == OP_PUSHMARK) {
11364 /* To allow Deparse to pessimise this, it needs to be able
11365 * to restore the pushmark's original op_next, which it
11366 * will assume to be the same as OP_SIBLING. */
11367 if (o->op_next != OP_SIBLING(o))
11372 /* scan for PAD ops */
11374 for (p = p->op_next; p; p = p->op_next) {
11375 if (p->op_type == OP_NULL)
11378 if (( p->op_type != OP_PADSV
11379 && p->op_type != OP_PADAV
11380 && p->op_type != OP_PADHV
11382 /* any private flag other than INTRO? e.g. STATE */
11383 || (p->op_private & ~OPpLVAL_INTRO)
11387 /* let $a[N] potentially be optimised into AELEMFAST_LEX
11389 if ( p->op_type == OP_PADAV
11391 && p->op_next->op_type == OP_CONST
11392 && p->op_next->op_next
11393 && p->op_next->op_next->op_type == OP_AELEM
11397 /* for 1st padop, note what type it is and the range
11398 * start; for the others, check that it's the same type
11399 * and that the targs are contiguous */
11401 intro = (p->op_private & OPpLVAL_INTRO);
11403 gimme = (p->op_flags & OPf_WANT);
11406 if ((p->op_private & OPpLVAL_INTRO) != intro)
11408 /* Note that you'd normally expect targs to be
11409 * contiguous in my($a,$b,$c), but that's not the case
11410 * when external modules start doing things, e.g.
11411 i* Function::Parameters */
11412 if (p->op_targ != base + count)
11414 assert(p->op_targ == base + count);
11415 /* all the padops should be in the same context */
11416 if (gimme != (p->op_flags & OPf_WANT))
11420 /* for AV, HV, only when we're not flattening */
11421 if ( p->op_type != OP_PADSV
11422 && gimme != OPf_WANT_VOID
11423 && !(p->op_flags & OPf_REF)
11427 if (count >= OPpPADRANGE_COUNTMASK)
11430 /* there's a biggest base we can fit into a
11431 * SAVEt_CLEARPADRANGE in pp_padrange */
11432 if (intro && base >
11433 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11436 /* Success! We've got another valid pad op to optimise away */
11438 followop = p->op_next;
11444 /* pp_padrange in specifically compile-time void context
11445 * skips pushing a mark and lexicals; in all other contexts
11446 * (including unknown till runtime) it pushes a mark and the
11447 * lexicals. We must be very careful then, that the ops we
11448 * optimise away would have exactly the same effect as the
11450 * In particular in void context, we can only optimise to
11451 * a padrange if see see the complete sequence
11452 * pushmark, pad*v, ...., list, nextstate
11453 * which has the net effect of of leaving the stack empty
11454 * (for now we leave the nextstate in the execution chain, for
11455 * its other side-effects).
11458 if (gimme == OPf_WANT_VOID) {
11459 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
11460 && gimme == (followop->op_flags & OPf_WANT)
11461 && ( followop->op_next->op_type == OP_NEXTSTATE
11462 || followop->op_next->op_type == OP_DBSTATE))
11464 followop = followop->op_next; /* skip OP_LIST */
11466 /* consolidate two successive my(...);'s */
11469 && oldoldop->op_type == OP_PADRANGE
11470 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11471 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11472 && !(oldoldop->op_flags & OPf_SPECIAL)
11475 assert(oldoldop->op_next == oldop);
11476 assert( oldop->op_type == OP_NEXTSTATE
11477 || oldop->op_type == OP_DBSTATE);
11478 assert(oldop->op_next == o);
11481 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11483 /* Do not assume pad offsets for $c and $d are con-
11488 if ( oldoldop->op_targ + old_count == base
11489 && old_count < OPpPADRANGE_COUNTMASK - count) {
11490 base = oldoldop->op_targ;
11491 count += old_count;
11496 /* if there's any immediately following singleton
11497 * my var's; then swallow them and the associated
11499 * my ($a,$b); my $c; my $d;
11501 * my ($a,$b,$c,$d);
11504 while ( ((p = followop->op_next))
11505 && ( p->op_type == OP_PADSV
11506 || p->op_type == OP_PADAV
11507 || p->op_type == OP_PADHV)
11508 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11509 && (p->op_private & OPpLVAL_INTRO) == intro
11510 && !(p->op_private & ~OPpLVAL_INTRO)
11512 && ( p->op_next->op_type == OP_NEXTSTATE
11513 || p->op_next->op_type == OP_DBSTATE)
11514 && count < OPpPADRANGE_COUNTMASK
11515 && base + count == p->op_targ
11518 followop = p->op_next;
11526 assert(oldoldop->op_type == OP_PADRANGE);
11527 oldoldop->op_next = followop;
11528 oldoldop->op_private = (intro | count);
11534 /* Convert the pushmark into a padrange.
11535 * To make Deparse easier, we guarantee that a padrange was
11536 * *always* formerly a pushmark */
11537 assert(o->op_type == OP_PUSHMARK);
11538 o->op_next = followop;
11539 o->op_type = OP_PADRANGE;
11540 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11542 /* bit 7: INTRO; bit 6..0: count */
11543 o->op_private = (intro | count);
11544 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11545 | gimme | (defav ? OPf_SPECIAL : 0));
11552 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11553 OP* const pop = (o->op_type == OP_PADAV) ?
11554 o->op_next : o->op_next->op_next;
11556 if (pop && pop->op_type == OP_CONST &&
11557 ((PL_op = pop->op_next)) &&
11558 pop->op_next->op_type == OP_AELEM &&
11559 !(pop->op_next->op_private &
11560 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11561 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
11564 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11565 no_bareword_allowed(pop);
11566 if (o->op_type == OP_GV)
11567 op_null(o->op_next);
11568 op_null(pop->op_next);
11570 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11571 o->op_next = pop->op_next->op_next;
11572 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11573 o->op_private = (U8)i;
11574 if (o->op_type == OP_GV) {
11577 o->op_type = OP_AELEMFAST;
11580 o->op_type = OP_AELEMFAST_LEX;
11585 if (o->op_next->op_type == OP_RV2SV) {
11586 if (!(o->op_next->op_private & OPpDEREF)) {
11587 op_null(o->op_next);
11588 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11590 o->op_next = o->op_next->op_next;
11591 o->op_type = OP_GVSV;
11592 o->op_ppaddr = PL_ppaddr[OP_GVSV];
11595 else if (o->op_next->op_type == OP_READLINE
11596 && o->op_next->op_next->op_type == OP_CONCAT
11597 && (o->op_next->op_next->op_flags & OPf_STACKED))
11599 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11600 o->op_type = OP_RCATLINE;
11601 o->op_flags |= OPf_STACKED;
11602 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11603 op_null(o->op_next->op_next);
11604 op_null(o->op_next);
11609 #define HV_OR_SCALARHV(op) \
11610 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11612 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11613 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11614 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11615 ? cUNOPx(op)->op_first \
11619 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11620 fop->op_private |= OPpTRUEBOOL;
11626 fop = cLOGOP->op_first;
11627 sop = OP_SIBLING(fop);
11628 while (cLOGOP->op_other->op_type == OP_NULL)
11629 cLOGOP->op_other = cLOGOP->op_other->op_next;
11630 while (o->op_next && ( o->op_type == o->op_next->op_type
11631 || o->op_next->op_type == OP_NULL))
11632 o->op_next = o->op_next->op_next;
11634 /* if we're an OR and our next is a AND in void context, we'll
11635 follow it's op_other on short circuit, same for reverse.
11636 We can't do this with OP_DOR since if it's true, its return
11637 value is the underlying value which must be evaluated
11641 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
11642 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
11644 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
11646 o->op_next = ((LOGOP*)o->op_next)->op_other;
11648 DEFER(cLOGOP->op_other);
11651 fop = HV_OR_SCALARHV(fop);
11652 if (sop) sop = HV_OR_SCALARHV(sop);
11657 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11658 while (nop && nop->op_next) {
11659 switch (nop->op_next->op_type) {
11664 lop = nop = nop->op_next;
11667 nop = nop->op_next;
11676 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11677 || o->op_type == OP_AND )
11678 fop->op_private |= OPpTRUEBOOL;
11679 else if (!(lop->op_flags & OPf_WANT))
11680 fop->op_private |= OPpMAYBE_TRUEBOOL;
11682 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11684 sop->op_private |= OPpTRUEBOOL;
11691 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11692 fop->op_private |= OPpTRUEBOOL;
11693 #undef HV_OR_SCALARHV
11694 /* GERONIMO! */ /* FALLTHROUGH */
11703 while (cLOGOP->op_other->op_type == OP_NULL)
11704 cLOGOP->op_other = cLOGOP->op_other->op_next;
11705 DEFER(cLOGOP->op_other);
11710 while (cLOOP->op_redoop->op_type == OP_NULL)
11711 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11712 while (cLOOP->op_nextop->op_type == OP_NULL)
11713 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11714 while (cLOOP->op_lastop->op_type == OP_NULL)
11715 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11716 /* a while(1) loop doesn't have an op_next that escapes the
11717 * loop, so we have to explicitly follow the op_lastop to
11718 * process the rest of the code */
11719 DEFER(cLOOP->op_lastop);
11723 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
11724 DEFER(cLOGOPo->op_other);
11728 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11729 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11730 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11731 cPMOP->op_pmstashstartu.op_pmreplstart
11732 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11733 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11739 if (o->op_flags & OPf_SPECIAL) {
11740 /* first arg is a code block */
11741 OP * const nullop = OP_SIBLING(cLISTOP->op_first);
11742 OP * kid = cUNOPx(nullop)->op_first;
11744 assert(nullop->op_type == OP_NULL);
11745 assert(kid->op_type == OP_SCOPE
11746 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
11747 /* since OP_SORT doesn't have a handy op_other-style
11748 * field that can point directly to the start of the code
11749 * block, store it in the otherwise-unused op_next field
11750 * of the top-level OP_NULL. This will be quicker at
11751 * run-time, and it will also allow us to remove leading
11752 * OP_NULLs by just messing with op_nexts without
11753 * altering the basic op_first/op_sibling layout. */
11754 kid = kLISTOP->op_first;
11756 (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
11757 || kid->op_type == OP_STUB
11758 || kid->op_type == OP_ENTER);
11759 nullop->op_next = kLISTOP->op_next;
11760 DEFER(nullop->op_next);
11763 /* check that RHS of sort is a single plain array */
11764 oright = cUNOPo->op_first;
11765 if (!oright || oright->op_type != OP_PUSHMARK)
11768 if (o->op_private & OPpSORT_INPLACE)
11771 /* reverse sort ... can be optimised. */
11772 if (!OP_HAS_SIBLING(cUNOPo)) {
11773 /* Nothing follows us on the list. */
11774 OP * const reverse = o->op_next;
11776 if (reverse->op_type == OP_REVERSE &&
11777 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11778 OP * const pushmark = cUNOPx(reverse)->op_first;
11779 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11780 && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
11781 /* reverse -> pushmark -> sort */
11782 o->op_private |= OPpSORT_REVERSE;
11784 pushmark->op_next = oright->op_next;
11794 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11796 LISTOP *enter, *exlist;
11798 if (o->op_private & OPpSORT_INPLACE)
11801 enter = (LISTOP *) o->op_next;
11804 if (enter->op_type == OP_NULL) {
11805 enter = (LISTOP *) enter->op_next;
11809 /* for $a (...) will have OP_GV then OP_RV2GV here.
11810 for (...) just has an OP_GV. */
11811 if (enter->op_type == OP_GV) {
11812 gvop = (OP *) enter;
11813 enter = (LISTOP *) enter->op_next;
11816 if (enter->op_type == OP_RV2GV) {
11817 enter = (LISTOP *) enter->op_next;
11823 if (enter->op_type != OP_ENTERITER)
11826 iter = enter->op_next;
11827 if (!iter || iter->op_type != OP_ITER)
11830 expushmark = enter->op_first;
11831 if (!expushmark || expushmark->op_type != OP_NULL
11832 || expushmark->op_targ != OP_PUSHMARK)
11835 exlist = (LISTOP *) OP_SIBLING(expushmark);
11836 if (!exlist || exlist->op_type != OP_NULL
11837 || exlist->op_targ != OP_LIST)
11840 if (exlist->op_last != o) {
11841 /* Mmm. Was expecting to point back to this op. */
11844 theirmark = exlist->op_first;
11845 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11848 if (OP_SIBLING(theirmark) != o) {
11849 /* There's something between the mark and the reverse, eg
11850 for (1, reverse (...))
11855 ourmark = ((LISTOP *)o)->op_first;
11856 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11859 ourlast = ((LISTOP *)o)->op_last;
11860 if (!ourlast || ourlast->op_next != o)
11863 rv2av = OP_SIBLING(ourmark);
11864 if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av)
11865 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11866 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11867 /* We're just reversing a single array. */
11868 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11869 enter->op_flags |= OPf_STACKED;
11872 /* We don't have control over who points to theirmark, so sacrifice
11874 theirmark->op_next = ourmark->op_next;
11875 theirmark->op_flags = ourmark->op_flags;
11876 ourlast->op_next = gvop ? gvop : (OP *) enter;
11879 enter->op_private |= OPpITER_REVERSED;
11880 iter->op_private |= OPpITER_REVERSED;
11887 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11888 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11893 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11895 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11897 sv = newRV((SV *)PL_compcv);
11901 o->op_type = OP_CONST;
11902 o->op_ppaddr = PL_ppaddr[OP_CONST];
11903 o->op_flags |= OPf_SPECIAL;
11904 cSVOPo->op_sv = sv;
11909 if (OP_GIMME(o,0) == G_VOID) {
11910 OP *right = cBINOP->op_first;
11929 OP *left = OP_SIBLING(right);
11930 if (left->op_type == OP_SUBSTR
11931 && (left->op_private & 7) < 4) {
11933 /* cut out right */
11934 op_sibling_splice(o, NULL, 1, NULL);
11935 /* and insert it as second child of OP_SUBSTR */
11936 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
11938 left->op_private |= OPpSUBSTR_REPL_FIRST;
11940 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11947 Perl_cpeep_t cpeep =
11948 XopENTRYCUSTOM(o, xop_peep);
11950 cpeep(aTHX_ o, oldop);
11955 /* did we just null the current op? If so, re-process it to handle
11956 * eliding "empty" ops from the chain */
11957 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
11970 Perl_peep(pTHX_ OP *o)
11976 =head1 Custom Operators
11978 =for apidoc Ao||custom_op_xop
11979 Return the XOP structure for a given custom op. This macro should be
11980 considered internal to OP_NAME and the other access macros: use them instead.
11981 This macro does call a function. Prior
11982 to 5.19.6, this was implemented as a
11989 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
11995 static const XOP xop_null = { 0, 0, 0, 0, 0 };
11997 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
11998 assert(o->op_type == OP_CUSTOM);
12000 /* This is wrong. It assumes a function pointer can be cast to IV,
12001 * which isn't guaranteed, but this is what the old custom OP code
12002 * did. In principle it should be safer to Copy the bytes of the
12003 * pointer into a PV: since the new interface is hidden behind
12004 * functions, this can be changed later if necessary. */
12005 /* Change custom_op_xop if this ever happens */
12006 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
12009 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12011 /* assume noone will have just registered a desc */
12012 if (!he && PL_custom_op_names &&
12013 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
12018 /* XXX does all this need to be shared mem? */
12019 Newxz(xop, 1, XOP);
12020 pv = SvPV(HeVAL(he), l);
12021 XopENTRY_set(xop, xop_name, savepvn(pv, l));
12022 if (PL_custom_op_descs &&
12023 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
12025 pv = SvPV(HeVAL(he), l);
12026 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
12028 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
12032 xop = (XOP *)&xop_null;
12034 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
12038 if(field == XOPe_xop_ptr) {
12041 const U32 flags = XopFLAGS(xop);
12042 if(flags & field) {
12044 case XOPe_xop_name:
12045 any.xop_name = xop->xop_name;
12047 case XOPe_xop_desc:
12048 any.xop_desc = xop->xop_desc;
12050 case XOPe_xop_class:
12051 any.xop_class = xop->xop_class;
12053 case XOPe_xop_peep:
12054 any.xop_peep = xop->xop_peep;
12062 case XOPe_xop_name:
12063 any.xop_name = XOPd_xop_name;
12065 case XOPe_xop_desc:
12066 any.xop_desc = XOPd_xop_desc;
12068 case XOPe_xop_class:
12069 any.xop_class = XOPd_xop_class;
12071 case XOPe_xop_peep:
12072 any.xop_peep = XOPd_xop_peep;
12080 /* Some gcc releases emit a warning for this function:
12081 * op.c: In function 'Perl_custom_op_get_field':
12082 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
12083 * Whether this is true, is currently unknown. */
12089 =for apidoc Ao||custom_op_register
12090 Register a custom op. See L<perlguts/"Custom Operators">.
12096 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
12100 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
12102 /* see the comment in custom_op_xop */
12103 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
12105 if (!PL_custom_ops)
12106 PL_custom_ops = newHV();
12108 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
12109 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
12114 =for apidoc core_prototype
12116 This function assigns the prototype of the named core function to C<sv>, or
12117 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
12118 NULL if the core function has no prototype. C<code> is a code as returned
12119 by C<keyword()>. It must not be equal to 0.
12125 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
12128 int i = 0, n = 0, seen_question = 0, defgv = 0;
12130 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
12131 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
12132 bool nullret = FALSE;
12134 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
12138 if (!sv) sv = sv_newmortal();
12140 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
12142 switch (code < 0 ? -code : code) {
12143 case KEY_and : case KEY_chop: case KEY_chomp:
12144 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
12145 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
12146 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
12147 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
12148 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
12149 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
12150 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
12151 case KEY_x : case KEY_xor :
12152 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
12153 case KEY_glob: retsetpvs("_;", OP_GLOB);
12154 case KEY_keys: retsetpvs("+", OP_KEYS);
12155 case KEY_values: retsetpvs("+", OP_VALUES);
12156 case KEY_each: retsetpvs("+", OP_EACH);
12157 case KEY_push: retsetpvs("+@", OP_PUSH);
12158 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
12159 case KEY_pop: retsetpvs(";+", OP_POP);
12160 case KEY_shift: retsetpvs(";+", OP_SHIFT);
12161 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
12163 retsetpvs("+;$$@", OP_SPLICE);
12164 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
12166 case KEY_evalbytes:
12167 name = "entereval"; break;
12175 while (i < MAXO) { /* The slow way. */
12176 if (strEQ(name, PL_op_name[i])
12177 || strEQ(name, PL_op_desc[i]))
12179 if (nullret) { assert(opnum); *opnum = i; return NULL; }
12186 defgv = PL_opargs[i] & OA_DEFGV;
12187 oa = PL_opargs[i] >> OASHIFT;
12189 if (oa & OA_OPTIONAL && !seen_question && (
12190 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
12195 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
12196 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
12197 /* But globs are already references (kinda) */
12198 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
12202 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
12203 && !scalar_mod_type(NULL, i)) {
12208 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
12212 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
12213 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
12214 str[n-1] = '_'; defgv = 0;
12218 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
12220 sv_setpvn(sv, str, n - 1);
12221 if (opnum) *opnum = i;
12226 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
12229 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
12232 PERL_ARGS_ASSERT_CORESUB_OP;
12236 return op_append_elem(OP_LINESEQ,
12239 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
12243 case OP_SELECT: /* which represents OP_SSELECT as well */
12248 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12249 newSVOP(OP_CONST, 0, newSVuv(1))
12251 coresub_op(newSVuv((UV)OP_SSELECT), 0,
12253 coresub_op(coreargssv, 0, OP_SELECT)
12257 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12259 return op_append_elem(
12262 opnum == OP_WANTARRAY || opnum == OP_RUNCV
12263 ? OPpOFFBYONE << 8 : 0)
12265 case OA_BASEOP_OR_UNOP:
12266 if (opnum == OP_ENTEREVAL) {
12267 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12268 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12270 else o = newUNOP(opnum,0,argop);
12271 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12274 if (is_handle_constructor(o, 1))
12275 argop->op_private |= OPpCOREARGS_DEREF1;
12276 if (scalar_mod_type(NULL, opnum))
12277 argop->op_private |= OPpCOREARGS_SCALARMOD;
12281 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
12282 if (is_handle_constructor(o, 2))
12283 argop->op_private |= OPpCOREARGS_DEREF2;
12284 if (opnum == OP_SUBSTR) {
12285 o->op_private |= OPpMAYBE_LVSUB;
12294 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12295 SV * const *new_const_svp)
12297 const char *hvname;
12298 bool is_const = !!CvCONST(old_cv);
12299 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12301 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12303 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12305 /* They are 2 constant subroutines generated from
12306 the same constant. This probably means that
12307 they are really the "same" proxy subroutine
12308 instantiated in 2 places. Most likely this is
12309 when a constant is exported twice. Don't warn.
12312 (ckWARN(WARN_REDEFINE)
12314 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12315 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12316 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12317 strEQ(hvname, "autouse"))
12321 && ckWARN_d(WARN_REDEFINE)
12322 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
12325 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12327 ? "Constant subroutine %"SVf" redefined"
12328 : "Subroutine %"SVf" redefined",
12333 =head1 Hook manipulation
12335 These functions provide convenient and thread-safe means of manipulating
12342 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12344 Puts a C function into the chain of check functions for a specified op
12345 type. This is the preferred way to manipulate the L</PL_check> array.
12346 I<opcode> specifies which type of op is to be affected. I<new_checker>
12347 is a pointer to the C function that is to be added to that opcode's
12348 check chain, and I<old_checker_p> points to the storage location where a
12349 pointer to the next function in the chain will be stored. The value of
12350 I<new_pointer> is written into the L</PL_check> array, while the value
12351 previously stored there is written to I<*old_checker_p>.
12353 The function should be defined like this:
12355 static OP *new_checker(pTHX_ OP *op) { ... }
12357 It is intended to be called in this manner:
12359 new_checker(aTHX_ op)
12361 I<old_checker_p> should be defined like this:
12363 static Perl_check_t old_checker_p;
12365 L</PL_check> is global to an entire process, and a module wishing to
12366 hook op checking may find itself invoked more than once per process,
12367 typically in different threads. To handle that situation, this function
12368 is idempotent. The location I<*old_checker_p> must initially (once
12369 per process) contain a null pointer. A C variable of static duration
12370 (declared at file scope, typically also marked C<static> to give
12371 it internal linkage) will be implicitly initialised appropriately,
12372 if it does not have an explicit initialiser. This function will only
12373 actually modify the check chain if it finds I<*old_checker_p> to be null.
12374 This function is also thread safe on the small scale. It uses appropriate
12375 locking to avoid race conditions in accessing L</PL_check>.
12377 When this function is called, the function referenced by I<new_checker>
12378 must be ready to be called, except for I<*old_checker_p> being unfilled.
12379 In a threading situation, I<new_checker> may be called immediately,
12380 even before this function has returned. I<*old_checker_p> will always
12381 be appropriately set before I<new_checker> is called. If I<new_checker>
12382 decides not to do anything special with an op that it is given (which
12383 is the usual case for most uses of op check hooking), it must chain the
12384 check function referenced by I<*old_checker_p>.
12386 If you want to influence compilation of calls to a specific subroutine,
12387 then use L</cv_set_call_checker> rather than hooking checking of all
12394 Perl_wrap_op_checker(pTHX_ Optype opcode,
12395 Perl_check_t new_checker, Perl_check_t *old_checker_p)
12399 PERL_UNUSED_CONTEXT;
12400 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12401 if (*old_checker_p) return;
12402 OP_CHECK_MUTEX_LOCK;
12403 if (!*old_checker_p) {
12404 *old_checker_p = PL_check[opcode];
12405 PL_check[opcode] = new_checker;
12407 OP_CHECK_MUTEX_UNLOCK;
12412 /* Efficient sub that returns a constant scalar value. */
12414 const_sv_xsub(pTHX_ CV* cv)
12417 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12418 PERL_UNUSED_ARG(items);
12428 const_av_xsub(pTHX_ CV* cv)
12431 AV * const av = MUTABLE_AV(XSANY.any_ptr);
12439 if (SvRMAGICAL(av))
12440 Perl_croak(aTHX_ "Magical list constants are not supported");
12441 if (GIMME_V != G_ARRAY) {
12443 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
12446 EXTEND(SP, AvFILLp(av)+1);
12447 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12448 XSRETURN(AvFILLp(av)+1);
12453 * c-indentation-style: bsd
12454 * c-basic-offset: 4
12455 * indent-tabs-mode: nil
12458 * ex: set ts=8 sts=4 sw=4 et: