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 (*s == 'p' || *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];
5205 padop->op_padix = pad_alloc(type, SVs_PADTMP);
5206 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5207 PAD_SETSV(padop->op_padix, sv);
5209 padop->op_next = (OP*)padop;
5210 padop->op_flags = (U8)flags;
5211 if (PL_opargs[type] & OA_RETSCALAR)
5213 if (PL_opargs[type] & OA_TARGET)
5214 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5215 return CHECKOP(type, padop);
5218 #endif /* USE_ITHREADS */
5221 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5223 Constructs, checks, and returns an op of any type that involves an
5224 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5225 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5226 reference; calling this function does not transfer ownership of any
5233 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5235 PERL_ARGS_ASSERT_NEWGVOP;
5239 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5241 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5246 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5248 Constructs, checks, and returns an op of any type that involves an
5249 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5250 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
5251 must have been allocated using C<PerlMemShared_malloc>; the memory will
5252 be freed when the op is destroyed.
5258 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5261 const bool utf8 = cBOOL(flags & SVf_UTF8);
5266 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5268 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5270 NewOp(1101, pvop, 1, PVOP);
5271 pvop->op_type = (OPCODE)type;
5272 pvop->op_ppaddr = PL_ppaddr[type];
5274 pvop->op_next = (OP*)pvop;
5275 pvop->op_flags = (U8)flags;
5276 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5277 if (PL_opargs[type] & OA_RETSCALAR)
5279 if (PL_opargs[type] & OA_TARGET)
5280 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5281 return CHECKOP(type, pvop);
5285 Perl_package(pTHX_ OP *o)
5287 SV *const sv = cSVOPo->op_sv;
5289 PERL_ARGS_ASSERT_PACKAGE;
5291 SAVEGENERICSV(PL_curstash);
5292 save_item(PL_curstname);
5294 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5296 sv_setsv(PL_curstname, sv);
5298 PL_hints |= HINT_BLOCK_SCOPE;
5299 PL_parser->copline = NOLINE;
5300 PL_parser->expect = XSTATE;
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_parser->expect = XSTATE;
5440 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5441 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5447 =head1 Embedding Functions
5449 =for apidoc load_module
5451 Loads the module whose name is pointed to by the string part of name.
5452 Note that the actual module name, not its filename, should be given.
5453 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5454 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5455 (or 0 for no flags). ver, if specified
5456 and not NULL, provides version semantics
5457 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5458 arguments can be used to specify arguments to the module's import()
5459 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5460 terminated with a final NULL pointer. Note that this list can only
5461 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5462 Otherwise at least a single NULL pointer to designate the default
5463 import list is required.
5465 The reference count for each specified C<SV*> parameter is decremented.
5470 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5474 PERL_ARGS_ASSERT_LOAD_MODULE;
5476 va_start(args, ver);
5477 vload_module(flags, name, ver, &args);
5481 #ifdef PERL_IMPLICIT_CONTEXT
5483 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5487 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5488 va_start(args, ver);
5489 vload_module(flags, name, ver, &args);
5495 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5498 OP * const modname = newSVOP(OP_CONST, 0, name);
5500 PERL_ARGS_ASSERT_VLOAD_MODULE;
5502 modname->op_private |= OPpCONST_BARE;
5504 veop = newSVOP(OP_CONST, 0, ver);
5508 if (flags & PERL_LOADMOD_NOIMPORT) {
5509 imop = sawparens(newNULLLIST());
5511 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5512 imop = va_arg(*args, OP*);
5517 sv = va_arg(*args, SV*);
5519 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5520 sv = va_arg(*args, SV*);
5524 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5525 * that it has a PL_parser to play with while doing that, and also
5526 * that it doesn't mess with any existing parser, by creating a tmp
5527 * new parser with lex_start(). This won't actually be used for much,
5528 * since pp_require() will create another parser for the real work.
5529 * The ENTER/LEAVE pair protect callers from any side effects of use. */
5532 SAVEVPTR(PL_curcop);
5533 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5534 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5535 veop, modname, imop);
5539 PERL_STATIC_INLINE OP *
5540 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5542 return newUNOP(OP_ENTERSUB, OPf_STACKED,
5543 newLISTOP(OP_LIST, 0, arg,
5544 newUNOP(OP_RV2CV, 0,
5545 newGVOP(OP_GV, 0, gv))));
5549 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5554 PERL_ARGS_ASSERT_DOFILE;
5556 if (!force_builtin && (gv = gv_override("do", 2))) {
5557 doop = S_new_entersubop(aTHX_ gv, term);
5560 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5566 =head1 Optree construction
5568 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5570 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5571 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5572 be set automatically, and, shifted up eight bits, the eight bits of
5573 C<op_private>, except that the bit with value 1 or 2 is automatically
5574 set as required. I<listval> and I<subscript> supply the parameters of
5575 the slice; they are consumed by this function and become part of the
5576 constructed op tree.
5582 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5584 return newBINOP(OP_LSLICE, flags,
5585 list(force_list(subscript, 1)),
5586 list(force_list(listval, 1)) );
5590 S_is_list_assignment(pTHX_ const OP *o)
5598 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5599 o = cUNOPo->op_first;
5601 flags = o->op_flags;
5603 if (type == OP_COND_EXPR) {
5604 OP * const sib = OP_SIBLING(cLOGOPo->op_first);
5605 const I32 t = is_list_assignment(sib);
5606 const I32 f = is_list_assignment(OP_SIBLING(sib));
5611 yyerror("Assignment to both a list and a scalar");
5615 if (type == OP_LIST &&
5616 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5617 o->op_private & OPpLVAL_INTRO)
5620 if (type == OP_LIST || flags & OPf_PARENS ||
5621 type == OP_RV2AV || type == OP_RV2HV ||
5622 type == OP_ASLICE || type == OP_HSLICE ||
5623 type == OP_KVASLICE || type == OP_KVHSLICE)
5626 if (type == OP_PADAV || type == OP_PADHV)
5629 if (type == OP_RV2SV)
5636 Helper function for newASSIGNOP to detection commonality between the
5637 lhs and the rhs. Marks all variables with PL_generation. If it
5638 returns TRUE the assignment must be able to handle common variables.
5640 PERL_STATIC_INLINE bool
5641 S_aassign_common_vars(pTHX_ OP* o)
5644 for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
5645 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5646 if (curop->op_type == OP_GV) {
5647 GV *gv = cGVOPx_gv(curop);
5649 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5651 GvASSIGN_GENERATION_set(gv, PL_generation);
5653 else if (curop->op_type == OP_PADSV ||
5654 curop->op_type == OP_PADAV ||
5655 curop->op_type == OP_PADHV ||
5656 curop->op_type == OP_PADANY)
5658 if (PAD_COMPNAME_GEN(curop->op_targ)
5659 == (STRLEN)PL_generation)
5661 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5664 else if (curop->op_type == OP_RV2CV)
5666 else if (curop->op_type == OP_RV2SV ||
5667 curop->op_type == OP_RV2AV ||
5668 curop->op_type == OP_RV2HV ||
5669 curop->op_type == OP_RV2GV) {
5670 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5673 else if (curop->op_type == OP_PUSHRE) {
5676 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5677 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5680 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5684 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5686 GvASSIGN_GENERATION_set(gv, PL_generation);
5693 if (curop->op_flags & OPf_KIDS) {
5694 if (aassign_common_vars(curop))
5702 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5704 Constructs, checks, and returns an assignment op. I<left> and I<right>
5705 supply the parameters of the assignment; they are consumed by this
5706 function and become part of the constructed op tree.
5708 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5709 a suitable conditional optree is constructed. If I<optype> is the opcode
5710 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5711 performs the binary operation and assigns the result to the left argument.
5712 Either way, if I<optype> is non-zero then I<flags> has no effect.
5714 If I<optype> is zero, then a plain scalar or list assignment is
5715 constructed. Which type of assignment it is is automatically determined.
5716 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5717 will be set automatically, and, shifted up eight bits, the eight bits
5718 of C<op_private>, except that the bit with value 1 or 2 is automatically
5725 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5730 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5731 return newLOGOP(optype, 0,
5732 op_lvalue(scalar(left), optype),
5733 newUNOP(OP_SASSIGN, 0, scalar(right)));
5736 return newBINOP(optype, OPf_STACKED,
5737 op_lvalue(scalar(left), optype), scalar(right));
5741 if (is_list_assignment(left)) {
5742 static const char no_list_state[] = "Initialization of state variables"
5743 " in list context currently forbidden";
5745 bool maybe_common_vars = TRUE;
5747 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5748 left->op_private &= ~ OPpSLICEWARNING;
5751 left = op_lvalue(left, OP_AASSIGN);
5752 curop = list(force_list(left, 1));
5753 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
5754 o->op_private = (U8)(0 | (flags >> 8));
5756 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
5758 OP* lop = ((LISTOP*)left)->op_first;
5759 maybe_common_vars = FALSE;
5761 if (lop->op_type == OP_PADSV ||
5762 lop->op_type == OP_PADAV ||
5763 lop->op_type == OP_PADHV ||
5764 lop->op_type == OP_PADANY) {
5765 if (!(lop->op_private & OPpLVAL_INTRO))
5766 maybe_common_vars = TRUE;
5768 if (lop->op_private & OPpPAD_STATE) {
5769 if (left->op_private & OPpLVAL_INTRO) {
5770 /* Each variable in state($a, $b, $c) = ... */
5773 /* Each state variable in
5774 (state $a, my $b, our $c, $d, undef) = ... */
5776 yyerror(no_list_state);
5778 /* Each my variable in
5779 (state $a, my $b, our $c, $d, undef) = ... */
5781 } else if (lop->op_type == OP_UNDEF ||
5782 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
5783 /* undef may be interesting in
5784 (state $a, undef, state $c) */
5786 /* Other ops in the list. */
5787 maybe_common_vars = TRUE;
5789 lop = OP_SIBLING(lop);
5792 else if ((left->op_private & OPpLVAL_INTRO)
5793 && ( left->op_type == OP_PADSV
5794 || left->op_type == OP_PADAV
5795 || left->op_type == OP_PADHV
5796 || left->op_type == OP_PADANY))
5798 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5799 if (left->op_private & OPpPAD_STATE) {
5800 /* All single variable list context state assignments, hence
5810 yyerror(no_list_state);
5814 /* PL_generation sorcery:
5815 * an assignment like ($a,$b) = ($c,$d) is easier than
5816 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5817 * To detect whether there are common vars, the global var
5818 * PL_generation is incremented for each assign op we compile.
5819 * Then, while compiling the assign op, we run through all the
5820 * variables on both sides of the assignment, setting a spare slot
5821 * in each of them to PL_generation. If any of them already have
5822 * that value, we know we've got commonality. We could use a
5823 * single bit marker, but then we'd have to make 2 passes, first
5824 * to clear the flag, then to test and set it. To find somewhere
5825 * to store these values, evil chicanery is done with SvUVX().
5828 if (maybe_common_vars) {
5830 if (aassign_common_vars(o))
5831 o->op_private |= OPpASSIGN_COMMON;
5835 if (right && right->op_type == OP_SPLIT) {
5836 OP* tmpop = ((LISTOP*)right)->op_first;
5837 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5838 PMOP * const pm = (PMOP*)tmpop;
5839 if (left->op_type == OP_RV2AV &&
5840 !(left->op_private & OPpLVAL_INTRO) &&
5841 !(o->op_private & OPpASSIGN_COMMON) )
5843 tmpop = ((UNOP*)left)->op_first;
5844 if (tmpop->op_type == OP_GV
5846 && !pm->op_pmreplrootu.op_pmtargetoff
5848 && !pm->op_pmreplrootu.op_pmtargetgv
5852 pm->op_pmreplrootu.op_pmtargetoff
5853 = cPADOPx(tmpop)->op_padix;
5854 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5856 pm->op_pmreplrootu.op_pmtargetgv
5857 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5858 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5860 tmpop = cUNOPo->op_first; /* to list (nulled) */
5861 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5862 /* detach rest of siblings from o subtree,
5863 * and free subtree */
5864 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
5865 right->op_next = tmpop->op_next; /* fix starting loc */
5866 op_free(o); /* blow off assign */
5867 right->op_flags &= ~OPf_WANT;
5868 /* "I don't know and I don't care." */
5873 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5874 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5877 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5878 SV * const sv = *svp;
5879 if (SvIOK(sv) && SvIVX(sv) == 0)
5881 if (right->op_private & OPpSPLIT_IMPLIM) {
5882 /* our own SV, created in ck_split */
5884 sv_setiv(sv, PL_modcount+1);
5887 /* SV may belong to someone else */
5889 *svp = newSViv(PL_modcount+1);
5899 right = newOP(OP_UNDEF, 0);
5900 if (right->op_type == OP_READLINE) {
5901 right->op_flags |= OPf_STACKED;
5902 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5906 o = newBINOP(OP_SASSIGN, flags,
5907 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5913 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5915 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5916 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5917 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5918 If I<label> is non-null, it supplies the name of a label to attach to
5919 the state op; this function takes ownership of the memory pointed at by
5920 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5923 If I<o> is null, the state op is returned. Otherwise the state op is
5924 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5925 is consumed by this function and becomes part of the returned op tree.
5931 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5934 const U32 seq = intro_my();
5935 const U32 utf8 = flags & SVf_UTF8;
5940 NewOp(1101, cop, 1, COP);
5941 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5942 cop->op_type = OP_DBSTATE;
5943 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5946 cop->op_type = OP_NEXTSTATE;
5947 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5949 cop->op_flags = (U8)flags;
5950 CopHINTS_set(cop, PL_hints);
5952 cop->op_private |= NATIVE_HINTS;
5955 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
5957 cop->op_next = (OP*)cop;
5960 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5961 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5963 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5965 PL_hints |= HINT_BLOCK_SCOPE;
5966 /* It seems that we need to defer freeing this pointer, as other parts
5967 of the grammar end up wanting to copy it after this op has been
5972 if (PL_parser->preambling != NOLINE) {
5973 CopLINE_set(cop, PL_parser->preambling);
5974 PL_parser->copline = NOLINE;
5976 else if (PL_parser->copline == NOLINE)
5977 CopLINE_set(cop, CopLINE(PL_curcop));
5979 CopLINE_set(cop, PL_parser->copline);
5980 PL_parser->copline = NOLINE;
5983 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5985 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5987 CopSTASH_set(cop, PL_curstash);
5989 if (cop->op_type == OP_DBSTATE) {
5990 /* this line can have a breakpoint - store the cop in IV */
5991 AV *av = CopFILEAVx(PL_curcop);
5993 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
5994 if (svp && *svp != &PL_sv_undef ) {
5995 (void)SvIOK_on(*svp);
5996 SvIV_set(*svp, PTR2IV(cop));
6001 if (flags & OPf_SPECIAL)
6003 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6007 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6009 Constructs, checks, and returns a logical (flow control) op. I<type>
6010 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
6011 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6012 the eight bits of C<op_private>, except that the bit with value 1 is
6013 automatically set. I<first> supplies the expression controlling the
6014 flow, and I<other> supplies the side (alternate) chain of ops; they are
6015 consumed by this function and become part of the constructed op tree.
6021 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6023 PERL_ARGS_ASSERT_NEWLOGOP;
6025 return new_logop(type, flags, &first, &other);
6029 S_search_const(pTHX_ OP *o)
6031 PERL_ARGS_ASSERT_SEARCH_CONST;
6033 switch (o->op_type) {
6037 if (o->op_flags & OPf_KIDS)
6038 return search_const(cUNOPo->op_first);
6045 if (!(o->op_flags & OPf_KIDS))
6047 kid = cLISTOPo->op_first;
6049 switch (kid->op_type) {
6053 kid = OP_SIBLING(kid);
6056 if (kid != cLISTOPo->op_last)
6062 kid = cLISTOPo->op_last;
6064 return search_const(kid);
6072 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6080 int prepend_not = 0;
6082 PERL_ARGS_ASSERT_NEW_LOGOP;
6087 /* [perl #59802]: Warn about things like "return $a or $b", which
6088 is parsed as "(return $a) or $b" rather than "return ($a or
6089 $b)". NB: This also applies to xor, which is why we do it
6092 switch (first->op_type) {
6096 /* XXX: Perhaps we should emit a stronger warning for these.
6097 Even with the high-precedence operator they don't seem to do
6100 But until we do, fall through here.
6106 /* XXX: Currently we allow people to "shoot themselves in the
6107 foot" by explicitly writing "(return $a) or $b".
6109 Warn unless we are looking at the result from folding or if
6110 the programmer explicitly grouped the operators like this.
6111 The former can occur with e.g.
6113 use constant FEATURE => ( $] >= ... );
6114 sub { not FEATURE and return or do_stuff(); }
6116 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6117 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6118 "Possible precedence issue with control flow operator");
6119 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6125 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6126 return newBINOP(type, flags, scalar(first), scalar(other));
6128 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6130 scalarboolean(first);
6131 /* optimize AND and OR ops that have NOTs as children */
6132 if (first->op_type == OP_NOT
6133 && (first->op_flags & OPf_KIDS)
6134 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6135 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6137 if (type == OP_AND || type == OP_OR) {
6143 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6145 prepend_not = 1; /* prepend a NOT op later */
6149 /* search for a constant op that could let us fold the test */
6150 if ((cstop = search_const(first))) {
6151 if (cstop->op_private & OPpCONST_STRICT)
6152 no_bareword_allowed(cstop);
6153 else if ((cstop->op_private & OPpCONST_BARE))
6154 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6155 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6156 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6157 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6159 if (other->op_type == OP_CONST)
6160 other->op_private |= OPpCONST_SHORTCIRCUIT;
6162 if (other->op_type == OP_LEAVE)
6163 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6164 else if (other->op_type == OP_MATCH
6165 || other->op_type == OP_SUBST
6166 || other->op_type == OP_TRANSR
6167 || other->op_type == OP_TRANS)
6168 /* Mark the op as being unbindable with =~ */
6169 other->op_flags |= OPf_SPECIAL;
6171 other->op_folded = 1;
6175 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6176 const OP *o2 = other;
6177 if ( ! (o2->op_type == OP_LIST
6178 && (( o2 = cUNOPx(o2)->op_first))
6179 && o2->op_type == OP_PUSHMARK
6180 && (( o2 = OP_SIBLING(o2))) )
6183 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6184 || o2->op_type == OP_PADHV)
6185 && o2->op_private & OPpLVAL_INTRO
6186 && !(o2->op_private & OPpPAD_STATE))
6188 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6189 "Deprecated use of my() in false conditional");
6193 if (cstop->op_type == OP_CONST)
6194 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6199 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6200 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6202 const OP * const k1 = ((UNOP*)first)->op_first;
6203 const OP * const k2 = OP_SIBLING(k1);
6205 switch (first->op_type)
6208 if (k2 && k2->op_type == OP_READLINE
6209 && (k2->op_flags & OPf_STACKED)
6210 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6212 warnop = k2->op_type;
6217 if (k1->op_type == OP_READDIR
6218 || k1->op_type == OP_GLOB
6219 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6220 || k1->op_type == OP_EACH
6221 || k1->op_type == OP_AEACH)
6223 warnop = ((k1->op_type == OP_NULL)
6224 ? (OPCODE)k1->op_targ : k1->op_type);
6229 const line_t oldline = CopLINE(PL_curcop);
6230 /* This ensures that warnings are reported at the first line
6231 of the construction, not the last. */
6232 CopLINE_set(PL_curcop, PL_parser->copline);
6233 Perl_warner(aTHX_ packWARN(WARN_MISC),
6234 "Value of %s%s can be \"0\"; test with defined()",
6236 ((warnop == OP_READLINE || warnop == OP_GLOB)
6237 ? " construct" : "() operator"));
6238 CopLINE_set(PL_curcop, oldline);
6245 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6246 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6248 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6249 logop->op_ppaddr = PL_ppaddr[type];
6250 logop->op_flags |= (U8)flags;
6251 logop->op_private = (U8)(1 | (flags >> 8));
6253 /* establish postfix order */
6254 logop->op_next = LINKLIST(first);
6255 first->op_next = (OP*)logop;
6256 assert(!OP_HAS_SIBLING(first));
6257 op_sibling_splice((OP*)logop, first, 0, other);
6259 CHECKOP(type,logop);
6261 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6268 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6270 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6271 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6272 will be set automatically, and, shifted up eight bits, the eight bits of
6273 C<op_private>, except that the bit with value 1 is automatically set.
6274 I<first> supplies the expression selecting between the two branches,
6275 and I<trueop> and I<falseop> supply the branches; they are consumed by
6276 this function and become part of the constructed op tree.
6282 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6290 PERL_ARGS_ASSERT_NEWCONDOP;
6293 return newLOGOP(OP_AND, 0, first, trueop);
6295 return newLOGOP(OP_OR, 0, first, falseop);
6297 scalarboolean(first);
6298 if ((cstop = search_const(first))) {
6299 /* Left or right arm of the conditional? */
6300 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6301 OP *live = left ? trueop : falseop;
6302 OP *const dead = left ? falseop : trueop;
6303 if (cstop->op_private & OPpCONST_BARE &&
6304 cstop->op_private & OPpCONST_STRICT) {
6305 no_bareword_allowed(cstop);
6309 if (live->op_type == OP_LEAVE)
6310 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6311 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6312 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6313 /* Mark the op as being unbindable with =~ */
6314 live->op_flags |= OPf_SPECIAL;
6315 live->op_folded = 1;
6318 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6319 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6320 logop->op_flags |= (U8)flags;
6321 logop->op_private = (U8)(1 | (flags >> 8));
6322 logop->op_next = LINKLIST(falseop);
6324 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6327 /* establish postfix order */
6328 start = LINKLIST(first);
6329 first->op_next = (OP*)logop;
6331 /* make first, trueop, falseop siblings */
6332 op_sibling_splice((OP*)logop, first, 0, trueop);
6333 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6335 o = newUNOP(OP_NULL, 0, (OP*)logop);
6337 trueop->op_next = falseop->op_next = o;
6344 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6346 Constructs and returns a C<range> op, with subordinate C<flip> and
6347 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6348 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6349 for both the C<flip> and C<range> ops, except that the bit with value
6350 1 is automatically set. I<left> and I<right> supply the expressions
6351 controlling the endpoints of the range; they are consumed by this function
6352 and become part of the constructed op tree.
6358 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6367 PERL_ARGS_ASSERT_NEWRANGE;
6369 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6370 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6371 range->op_flags = OPf_KIDS;
6372 leftstart = LINKLIST(left);
6373 range->op_private = (U8)(1 | (flags >> 8));
6375 /* make left and right siblings */
6376 op_sibling_splice((OP*)range, left, 0, right);
6378 range->op_next = (OP*)range;
6379 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6380 flop = newUNOP(OP_FLOP, 0, flip);
6381 o = newUNOP(OP_NULL, 0, flop);
6383 range->op_next = leftstart;
6385 left->op_next = flip;
6386 right->op_next = flop;
6388 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6389 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6390 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6391 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6393 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6394 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6396 /* check barewords before they might be optimized aways */
6397 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6398 no_bareword_allowed(left);
6399 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6400 no_bareword_allowed(right);
6403 if (!flip->op_private || !flop->op_private)
6404 LINKLIST(o); /* blow off optimizer unless constant */
6410 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6412 Constructs, checks, and returns an op tree expressing a loop. This is
6413 only a loop in the control flow through the op tree; it does not have
6414 the heavyweight loop structure that allows exiting the loop by C<last>
6415 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6416 top-level op, except that some bits will be set automatically as required.
6417 I<expr> supplies the expression controlling loop iteration, and I<block>
6418 supplies the body of the loop; they are consumed by this function and
6419 become part of the constructed op tree. I<debuggable> is currently
6420 unused and should always be 1.
6426 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6430 const bool once = block && block->op_flags & OPf_SPECIAL &&
6431 block->op_type == OP_NULL;
6433 PERL_UNUSED_ARG(debuggable);
6437 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6438 || ( expr->op_type == OP_NOT
6439 && cUNOPx(expr)->op_first->op_type == OP_CONST
6440 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6443 /* Return the block now, so that S_new_logop does not try to
6445 return block; /* do {} while 0 does once */
6446 if (expr->op_type == OP_READLINE
6447 || expr->op_type == OP_READDIR
6448 || expr->op_type == OP_GLOB
6449 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6450 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6451 expr = newUNOP(OP_DEFINED, 0,
6452 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6453 } else if (expr->op_flags & OPf_KIDS) {
6454 const OP * const k1 = ((UNOP*)expr)->op_first;
6455 const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL;
6456 switch (expr->op_type) {
6458 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6459 && (k2->op_flags & OPf_STACKED)
6460 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6461 expr = newUNOP(OP_DEFINED, 0, expr);
6465 if (k1 && (k1->op_type == OP_READDIR
6466 || k1->op_type == OP_GLOB
6467 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6468 || k1->op_type == OP_EACH
6469 || k1->op_type == OP_AEACH))
6470 expr = newUNOP(OP_DEFINED, 0, expr);
6476 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6477 * op, in listop. This is wrong. [perl #27024] */
6479 block = newOP(OP_NULL, 0);
6480 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6481 o = new_logop(OP_AND, 0, &expr, &listop);
6488 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6490 if (once && o != listop)
6492 assert(cUNOPo->op_first->op_type == OP_AND
6493 || cUNOPo->op_first->op_type == OP_OR);
6494 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6498 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6500 o->op_flags |= flags;
6502 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6507 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6509 Constructs, checks, and returns an op tree expressing a C<while> loop.
6510 This is a heavyweight loop, with structure that allows exiting the loop
6511 by C<last> and suchlike.
6513 I<loop> is an optional preconstructed C<enterloop> op to use in the
6514 loop; if it is null then a suitable op will be constructed automatically.
6515 I<expr> supplies the loop's controlling expression. I<block> supplies the
6516 main body of the loop, and I<cont> optionally supplies a C<continue> block
6517 that operates as a second half of the body. All of these optree inputs
6518 are consumed by this function and become part of the constructed op tree.
6520 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6521 op and, shifted up eight bits, the eight bits of C<op_private> for
6522 the C<leaveloop> op, except that (in both cases) some bits will be set
6523 automatically. I<debuggable> is currently unused and should always be 1.
6524 I<has_my> can be supplied as true to force the
6525 loop body to be enclosed in its own scope.
6531 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6532 OP *expr, OP *block, OP *cont, I32 has_my)
6541 PERL_UNUSED_ARG(debuggable);
6544 if (expr->op_type == OP_READLINE
6545 || expr->op_type == OP_READDIR
6546 || expr->op_type == OP_GLOB
6547 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6548 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6549 expr = newUNOP(OP_DEFINED, 0,
6550 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6551 } else if (expr->op_flags & OPf_KIDS) {
6552 const OP * const k1 = ((UNOP*)expr)->op_first;
6553 const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL;
6554 switch (expr->op_type) {
6556 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6557 && (k2->op_flags & OPf_STACKED)
6558 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6559 expr = newUNOP(OP_DEFINED, 0, expr);
6563 if (k1 && (k1->op_type == OP_READDIR
6564 || k1->op_type == OP_GLOB
6565 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6566 || k1->op_type == OP_EACH
6567 || k1->op_type == OP_AEACH))
6568 expr = newUNOP(OP_DEFINED, 0, expr);
6575 block = newOP(OP_NULL, 0);
6576 else if (cont || has_my) {
6577 block = op_scope(block);
6581 next = LINKLIST(cont);
6584 OP * const unstack = newOP(OP_UNSTACK, 0);
6587 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6591 listop = op_append_list(OP_LINESEQ, block, cont);
6593 redo = LINKLIST(listop);
6597 o = new_logop(OP_AND, 0, &expr, &listop);
6598 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6600 return expr; /* listop already freed by new_logop */
6603 ((LISTOP*)listop)->op_last->op_next =
6604 (o == listop ? redo : LINKLIST(o));
6610 NewOp(1101,loop,1,LOOP);
6611 loop->op_type = OP_ENTERLOOP;
6612 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6613 loop->op_private = 0;
6614 loop->op_next = (OP*)loop;
6617 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6619 loop->op_redoop = redo;
6620 loop->op_lastop = o;
6621 o->op_private |= loopflags;
6624 loop->op_nextop = next;
6626 loop->op_nextop = o;
6628 o->op_flags |= flags;
6629 o->op_private |= (flags >> 8);
6634 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6636 Constructs, checks, and returns an op tree expressing a C<foreach>
6637 loop (iteration through a list of values). This is a heavyweight loop,
6638 with structure that allows exiting the loop by C<last> and suchlike.
6640 I<sv> optionally supplies the variable that will be aliased to each
6641 item in turn; if null, it defaults to C<$_> (either lexical or global).
6642 I<expr> supplies the list of values to iterate over. I<block> supplies
6643 the main body of the loop, and I<cont> optionally supplies a C<continue>
6644 block that operates as a second half of the body. All of these optree
6645 inputs are consumed by this function and become part of the constructed
6648 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6649 op and, shifted up eight bits, the eight bits of C<op_private> for
6650 the C<leaveloop> op, except that (in both cases) some bits will be set
6657 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6662 PADOFFSET padoff = 0;
6666 PERL_ARGS_ASSERT_NEWFOROP;
6669 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6670 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6671 sv->op_type = OP_RV2GV;
6672 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6674 /* The op_type check is needed to prevent a possible segfault
6675 * if the loop variable is undeclared and 'strict vars' is in
6676 * effect. This is illegal but is nonetheless parsed, so we
6677 * may reach this point with an OP_CONST where we're expecting
6680 if (cUNOPx(sv)->op_first->op_type == OP_GV
6681 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6682 iterpflags |= OPpITER_DEF;
6684 else if (sv->op_type == OP_PADSV) { /* private variable */
6685 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6686 padoff = sv->op_targ;
6692 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6694 SV *const namesv = PAD_COMPNAME_SV(padoff);
6696 const char *const name = SvPV_const(namesv, len);
6698 if (len == 2 && name[0] == '$' && name[1] == '_')
6699 iterpflags |= OPpITER_DEF;
6703 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6704 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6705 sv = newGVOP(OP_GV, 0, PL_defgv);
6710 iterpflags |= OPpITER_DEF;
6713 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6714 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
6715 iterflags |= OPf_STACKED;
6717 else if (expr->op_type == OP_NULL &&
6718 (expr->op_flags & OPf_KIDS) &&
6719 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6721 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6722 * set the STACKED flag to indicate that these values are to be
6723 * treated as min/max values by 'pp_enteriter'.
6725 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6726 LOGOP* const range = (LOGOP*) flip->op_first;
6727 OP* const left = range->op_first;
6728 OP* const right = OP_SIBLING(left);
6731 range->op_flags &= ~OPf_KIDS;
6732 /* detach range's children */
6733 op_sibling_splice((OP*)range, NULL, -1, NULL);
6735 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6736 listop->op_first->op_next = range->op_next;
6737 left->op_next = range->op_other;
6738 right->op_next = (OP*)listop;
6739 listop->op_next = listop->op_first;
6742 expr = (OP*)(listop);
6744 iterflags |= OPf_STACKED;
6747 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
6750 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6751 op_append_elem(OP_LIST, expr, scalar(sv))));
6752 assert(!loop->op_next);
6753 /* for my $x () sets OPpLVAL_INTRO;
6754 * for our $x () sets OPpOUR_INTRO */
6755 loop->op_private = (U8)iterpflags;
6756 if (loop->op_slabbed
6757 && DIFF(loop, OpSLOT(loop)->opslot_next)
6758 < SIZE_TO_PSIZE(sizeof(LOOP)))
6761 NewOp(1234,tmp,1,LOOP);
6762 Copy(loop,tmp,1,LISTOP);
6763 #ifdef PERL_OP_PARENT
6764 assert(loop->op_last->op_sibling == (OP*)loop);
6765 loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
6767 S_op_destroy(aTHX_ (OP*)loop);
6770 else if (!loop->op_slabbed)
6771 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6772 loop->op_targ = padoff;
6773 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6778 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6780 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6781 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6782 determining the target of the op; it is consumed by this function and
6783 becomes part of the constructed op tree.
6789 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6793 PERL_ARGS_ASSERT_NEWLOOPEX;
6795 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6797 if (type != OP_GOTO) {
6798 /* "last()" means "last" */
6799 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6800 o = newOP(type, OPf_SPECIAL);
6804 /* Check whether it's going to be a goto &function */
6805 if (label->op_type == OP_ENTERSUB
6806 && !(label->op_flags & OPf_STACKED))
6807 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6810 /* Check for a constant argument */
6811 if (label->op_type == OP_CONST) {
6812 SV * const sv = ((SVOP *)label)->op_sv;
6814 const char *s = SvPV_const(sv,l);
6815 if (l == strlen(s)) {
6817 SvUTF8(((SVOP*)label)->op_sv),
6819 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6823 /* If we have already created an op, we do not need the label. */
6826 else o = newUNOP(type, OPf_STACKED, label);
6828 PL_hints |= HINT_BLOCK_SCOPE;
6832 /* if the condition is a literal array or hash
6833 (or @{ ... } etc), make a reference to it.
6836 S_ref_array_or_hash(pTHX_ OP *cond)
6839 && (cond->op_type == OP_RV2AV
6840 || cond->op_type == OP_PADAV
6841 || cond->op_type == OP_RV2HV
6842 || cond->op_type == OP_PADHV))
6844 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6847 && (cond->op_type == OP_ASLICE
6848 || cond->op_type == OP_KVASLICE
6849 || cond->op_type == OP_HSLICE
6850 || cond->op_type == OP_KVHSLICE)) {
6852 /* anonlist now needs a list from this op, was previously used in
6854 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6855 cond->op_flags |= OPf_WANT_LIST;
6857 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6864 /* These construct the optree fragments representing given()
6867 entergiven and enterwhen are LOGOPs; the op_other pointer
6868 points up to the associated leave op. We need this so we
6869 can put it in the context and make break/continue work.
6870 (Also, of course, pp_enterwhen will jump straight to
6871 op_other if the match fails.)
6875 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6876 I32 enter_opcode, I32 leave_opcode,
6877 PADOFFSET entertarg)
6883 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6885 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
6886 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6887 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6888 enterop->op_private = 0;
6890 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6893 /* prepend cond if we have one */
6894 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
6896 o->op_next = LINKLIST(cond);
6897 cond->op_next = (OP *) enterop;
6900 /* This is a default {} block */
6901 enterop->op_flags |= OPf_SPECIAL;
6902 o ->op_flags |= OPf_SPECIAL;
6904 o->op_next = (OP *) enterop;
6907 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6908 entergiven and enterwhen both
6911 enterop->op_next = LINKLIST(block);
6912 block->op_next = enterop->op_other = o;
6917 /* Does this look like a boolean operation? For these purposes
6918 a boolean operation is:
6919 - a subroutine call [*]
6920 - a logical connective
6921 - a comparison operator
6922 - a filetest operator, with the exception of -s -M -A -C
6923 - defined(), exists() or eof()
6924 - /$re/ or $foo =~ /$re/
6926 [*] possibly surprising
6929 S_looks_like_bool(pTHX_ const OP *o)
6931 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6933 switch(o->op_type) {
6936 return looks_like_bool(cLOGOPo->op_first);
6940 OP* sibl = OP_SIBLING(cLOGOPo->op_first);
6943 looks_like_bool(cLOGOPo->op_first)
6944 && looks_like_bool(sibl));
6950 o->op_flags & OPf_KIDS
6951 && looks_like_bool(cUNOPo->op_first));
6955 case OP_NOT: case OP_XOR:
6957 case OP_EQ: case OP_NE: case OP_LT:
6958 case OP_GT: case OP_LE: case OP_GE:
6960 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6961 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6963 case OP_SEQ: case OP_SNE: case OP_SLT:
6964 case OP_SGT: case OP_SLE: case OP_SGE:
6968 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6969 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6970 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6971 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6972 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6973 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6974 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6975 case OP_FTTEXT: case OP_FTBINARY:
6977 case OP_DEFINED: case OP_EXISTS:
6978 case OP_MATCH: case OP_EOF:
6985 /* Detect comparisons that have been optimized away */
6986 if (cSVOPo->op_sv == &PL_sv_yes
6987 || cSVOPo->op_sv == &PL_sv_no)
7000 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7002 Constructs, checks, and returns an op tree expressing a C<given> block.
7003 I<cond> supplies the expression that will be locally assigned to a lexical
7004 variable, and I<block> supplies the body of the C<given> construct; they
7005 are consumed by this function and become part of the constructed op tree.
7006 I<defsv_off> is the pad offset of the scalar lexical variable that will
7007 be affected. If it is 0, the global $_ will be used.
7013 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7015 PERL_ARGS_ASSERT_NEWGIVENOP;
7016 return newGIVWHENOP(
7017 ref_array_or_hash(cond),
7019 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7024 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7026 Constructs, checks, and returns an op tree expressing a C<when> block.
7027 I<cond> supplies the test expression, and I<block> supplies the block
7028 that will be executed if the test evaluates to true; they are consumed
7029 by this function and become part of the constructed op tree. I<cond>
7030 will be interpreted DWIMically, often as a comparison against C<$_>,
7031 and may be null to generate a C<default> block.
7037 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7039 const bool cond_llb = (!cond || looks_like_bool(cond));
7042 PERL_ARGS_ASSERT_NEWWHENOP;
7047 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7049 scalar(ref_array_or_hash(cond)));
7052 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7056 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7057 const STRLEN len, const U32 flags)
7059 SV *name = NULL, *msg;
7060 const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
7061 STRLEN clen = CvPROTOLEN(cv), plen = len;
7063 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7065 if (p == NULL && cvp == NULL)
7068 if (!ckWARN_d(WARN_PROTOTYPE))
7072 p = S_strip_spaces(aTHX_ p, &plen);
7073 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7074 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7075 if (plen == clen && memEQ(cvp, p, plen))
7078 if (flags & SVf_UTF8) {
7079 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7083 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7089 msg = sv_newmortal();
7094 gv_efullname3(name = sv_newmortal(), gv, NULL);
7095 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7096 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7097 else name = (SV *)gv;
7099 sv_setpvs(msg, "Prototype mismatch:");
7101 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7103 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7104 UTF8fARG(SvUTF8(cv),clen,cvp)
7107 sv_catpvs(msg, ": none");
7108 sv_catpvs(msg, " vs ");
7110 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7112 sv_catpvs(msg, "none");
7113 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7116 static void const_sv_xsub(pTHX_ CV* cv);
7117 static void const_av_xsub(pTHX_ CV* cv);
7121 =head1 Optree Manipulation Functions
7123 =for apidoc cv_const_sv
7125 If C<cv> is a constant sub eligible for inlining, returns the constant
7126 value returned by the sub. Otherwise, returns NULL.
7128 Constant subs can be created with C<newCONSTSUB> or as described in
7129 L<perlsub/"Constant Functions">.
7134 Perl_cv_const_sv(const CV *const cv)
7139 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7141 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7142 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7147 Perl_cv_const_sv_or_av(const CV * const 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);
7674 move_proto_attr(&proto, &attrs, gv);
7677 assert(proto->op_type == OP_CONST);
7678 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7679 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7693 if (name) SvREFCNT_dec(PL_compcv);
7694 else cv = PL_compcv;
7696 if (name && block) {
7697 const char *s = strrchr(name, ':');
7699 if (strEQ(s, "BEGIN")) {
7700 if (PL_in_eval & EVAL_KEEPERR)
7701 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7703 SV * const errsv = ERRSV;
7704 /* force display of errors found but not reported */
7705 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7706 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7713 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
7714 maximum a prototype before. */
7715 if (SvTYPE(gv) > SVt_NULL) {
7716 cv_ckproto_len_flags((const CV *)gv,
7717 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7721 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7722 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7725 sv_setiv(MUTABLE_SV(gv), -1);
7727 SvREFCNT_dec(PL_compcv);
7728 cv = PL_compcv = NULL;
7732 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7734 if (!block || !ps || *ps || attrs
7735 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7739 const_sv = op_const_sv(block, NULL);
7742 const bool exists = CvROOT(cv) || CvXSUB(cv);
7744 /* if the subroutine doesn't exist and wasn't pre-declared
7745 * with a prototype, assume it will be AUTOLOADed,
7746 * skipping the prototype check
7748 if (exists || SvPOK(cv))
7749 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7750 /* already defined (or promised)? */
7751 if (exists || GvASSUMECV(gv)) {
7752 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7755 if (attrs) goto attrs;
7756 /* just a "sub foo;" when &foo is already defined */
7757 SAVEFREESV(PL_compcv);
7763 SvREFCNT_inc_simple_void_NN(const_sv);
7764 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7766 assert(!CvROOT(cv) && !CvCONST(cv));
7768 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7769 CvXSUBANY(cv).any_ptr = const_sv;
7770 CvXSUB(cv) = const_sv_xsub;
7776 cv = newCONSTSUB_flags(
7777 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7782 SvREFCNT_dec(PL_compcv);
7786 if (cv) { /* must reuse cv if autoloaded */
7787 /* transfer PL_compcv to cv */
7790 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7791 PADLIST *const temp_av = CvPADLIST(cv);
7792 CV *const temp_cv = CvOUTSIDE(cv);
7793 const cv_flags_t other_flags =
7794 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7795 OP * const cvstart = CvSTART(cv);
7798 assert(!CvCVGV_RC(cv));
7799 assert(CvGV(cv) == gv);
7802 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7803 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7804 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7805 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7806 CvOUTSIDE(PL_compcv) = temp_cv;
7807 CvPADLIST(PL_compcv) = temp_av;
7808 CvSTART(cv) = CvSTART(PL_compcv);
7809 CvSTART(PL_compcv) = cvstart;
7810 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7811 CvFLAGS(PL_compcv) |= other_flags;
7813 if (CvFILE(cv) && CvDYNFILE(cv)) {
7814 Safefree(CvFILE(cv));
7816 CvFILE_set_from_cop(cv, PL_curcop);
7817 CvSTASH_set(cv, PL_curstash);
7819 /* inner references to PL_compcv must be fixed up ... */
7820 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7821 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7822 ++PL_sub_generation;
7825 /* Might have had built-in attributes applied -- propagate them. */
7826 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7828 /* ... before we throw it away */
7829 SvREFCNT_dec(PL_compcv);
7837 if (HvENAME_HEK(GvSTASH(gv)))
7838 /* sub Foo::bar { (shift)+1 } */
7839 gv_method_changed(gv);
7844 CvFILE_set_from_cop(cv, PL_curcop);
7845 CvSTASH_set(cv, PL_curstash);
7849 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7850 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7856 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7857 the debugger could be able to set a breakpoint in, so signal to
7858 pp_entereval that it should not throw away any saved lines at scope
7861 PL_breakable_sub_gen++;
7862 /* This makes sub {}; work as expected. */
7863 if (block->op_type == OP_STUB) {
7864 OP* const newblock = newSTATEOP(0, NULL, 0);
7868 CvROOT(cv) = CvLVALUE(cv)
7869 ? newUNOP(OP_LEAVESUBLV, 0,
7870 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7871 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7872 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7873 OpREFCNT_set(CvROOT(cv), 1);
7874 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7875 itself has a refcount. */
7877 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7878 #ifdef PERL_DEBUG_READONLY_OPS
7879 slab = (OPSLAB *)CvSTART(cv);
7881 CvSTART(cv) = LINKLIST(CvROOT(cv));
7882 CvROOT(cv)->op_next = 0;
7883 CALL_PEEP(CvSTART(cv));
7884 finalize_optree(CvROOT(cv));
7885 S_prune_chain_head(&CvSTART(cv));
7887 /* now that optimizer has done its work, adjust pad values */
7889 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7892 assert(!CvCONST(cv));
7893 if (ps && !*ps && op_const_sv(block, cv))
7899 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7900 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7901 if (!name) SAVEFREESV(cv);
7902 apply_attrs(stash, MUTABLE_SV(cv), attrs);
7903 if (!name) SvREFCNT_inc_simple_void_NN(cv);
7906 if (block && has_name) {
7907 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7908 SV * const tmpstr = sv_newmortal();
7909 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7910 GV_ADDMULTI, SVt_PVHV);
7912 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7915 (long)CopLINE(PL_curcop));
7916 gv_efullname3(tmpstr, gv, NULL);
7917 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7918 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7919 hv = GvHVn(db_postponed);
7920 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7921 CV * const pcv = GvCV(db_postponed);
7927 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7932 if (name && ! (PL_parser && PL_parser->error_count))
7933 process_special_blocks(floor, name, gv, cv);
7938 PL_parser->copline = NOLINE;
7940 #ifdef PERL_DEBUG_READONLY_OPS
7941 /* Watch out for BEGIN blocks */
7942 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7948 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7952 const char *const colon = strrchr(fullname,':');
7953 const char *const name = colon ? colon + 1 : fullname;
7955 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7958 if (strEQ(name, "BEGIN")) {
7959 const I32 oldscope = PL_scopestack_ix;
7961 if (floor) LEAVE_SCOPE(floor);
7963 PUSHSTACKi(PERLSI_REQUIRE);
7964 SAVECOPFILE(&PL_compiling);
7965 SAVECOPLINE(&PL_compiling);
7966 SAVEVPTR(PL_curcop);
7968 DEBUG_x( dump_sub(gv) );
7969 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7970 GvCV_set(gv,0); /* cv has been hijacked */
7971 call_list(oldscope, PL_beginav);
7980 if strEQ(name, "END") {
7981 DEBUG_x( dump_sub(gv) );
7982 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7985 } else if (*name == 'U') {
7986 if (strEQ(name, "UNITCHECK")) {
7987 /* It's never too late to run a unitcheck block */
7988 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7992 } else if (*name == 'C') {
7993 if (strEQ(name, "CHECK")) {
7995 /* diag_listed_as: Too late to run %s block */
7996 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7997 "Too late to run CHECK block");
7998 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8002 } else if (*name == 'I') {
8003 if (strEQ(name, "INIT")) {
8005 /* diag_listed_as: Too late to run %s block */
8006 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8007 "Too late to run INIT block");
8008 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8014 DEBUG_x( dump_sub(gv) );
8015 GvCV_set(gv,0); /* cv has been hijacked */
8020 =for apidoc newCONSTSUB
8022 See L</newCONSTSUB_flags>.
8028 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8030 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8034 =for apidoc newCONSTSUB_flags
8036 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8037 eligible for inlining at compile-time.
8039 Currently, the only useful value for C<flags> is SVf_UTF8.
8041 The newly created subroutine takes ownership of a reference to the passed in
8044 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8045 which won't be called if used as a destructor, but will suppress the overhead
8046 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8053 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8057 const char *const file = CopFILE(PL_curcop);
8061 if (IN_PERL_RUNTIME) {
8062 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8063 * an op shared between threads. Use a non-shared COP for our
8065 SAVEVPTR(PL_curcop);
8066 SAVECOMPILEWARNINGS();
8067 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8068 PL_curcop = &PL_compiling;
8070 SAVECOPLINE(PL_curcop);
8071 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8074 PL_hints &= ~HINT_BLOCK_SCOPE;
8077 SAVEGENERICSV(PL_curstash);
8078 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8081 /* Protect sv against leakage caused by fatal warnings. */
8082 if (sv) SAVEFREESV(sv);
8084 /* file becomes the CvFILE. For an XS, it's usually static storage,
8085 and so doesn't get free()d. (It's expected to be from the C pre-
8086 processor __FILE__ directive). But we need a dynamically allocated one,
8087 and we need it to get freed. */
8088 cv = newXS_len_flags(name, len,
8089 sv && SvTYPE(sv) == SVt_PVAV
8092 file ? file : "", "",
8093 &sv, XS_DYNAMIC_FILENAME | flags);
8094 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8103 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8104 const char *const filename, const char *const proto,
8107 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8108 return newXS_len_flags(
8109 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8114 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8115 XSUBADDR_t subaddr, const char *const filename,
8116 const char *const proto, SV **const_svp,
8120 bool interleave = FALSE;
8122 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8125 GV * const gv = gv_fetchpvn(
8126 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8127 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8128 sizeof("__ANON__::__ANON__") - 1,
8129 GV_ADDMULTI | flags, SVt_PVCV);
8132 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8134 if ((cv = (name ? GvCV(gv) : NULL))) {
8136 /* just a cached method */
8140 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8141 /* already defined (or promised) */
8142 /* Redundant check that allows us to avoid creating an SV
8143 most of the time: */
8144 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8145 report_redefined_cv(newSVpvn_flags(
8146 name,len,(flags&SVf_UTF8)|SVs_TEMP
8157 if (cv) /* must reuse cv if autoloaded */
8160 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8164 if (HvENAME_HEK(GvSTASH(gv)))
8165 gv_method_changed(gv); /* newXS */
8171 (void)gv_fetchfile(filename);
8172 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8173 an external constant string */
8174 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8176 CvXSUB(cv) = subaddr;
8179 process_special_blocks(0, name, gv, cv);
8182 if (flags & XS_DYNAMIC_FILENAME) {
8183 CvFILE(cv) = savepv(filename);
8186 sv_setpv(MUTABLE_SV(cv), proto);
8187 if (interleave) LEAVE;
8192 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8194 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8196 PERL_ARGS_ASSERT_NEWSTUB;
8200 if (!fake && HvENAME_HEK(GvSTASH(gv)))
8201 gv_method_changed(gv);
8203 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8208 CvFILE_set_from_cop(cv, PL_curcop);
8209 CvSTASH_set(cv, PL_curstash);
8215 =for apidoc U||newXS
8217 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
8218 static storage, as it is used directly as CvFILE(), without a copy being made.
8224 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8226 PERL_ARGS_ASSERT_NEWXS;
8227 return newXS_len_flags(
8228 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8233 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8239 if (PL_parser && PL_parser->error_count) {
8245 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8246 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8249 if ((cv = GvFORM(gv))) {
8250 if (ckWARN(WARN_REDEFINE)) {
8251 const line_t oldline = CopLINE(PL_curcop);
8252 if (PL_parser && PL_parser->copline != NOLINE)
8253 CopLINE_set(PL_curcop, PL_parser->copline);
8255 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8256 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8258 /* diag_listed_as: Format %s redefined */
8259 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8260 "Format STDOUT redefined");
8262 CopLINE_set(PL_curcop, oldline);
8267 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8269 CvFILE_set_from_cop(cv, PL_curcop);
8272 pad_tidy(padtidy_FORMAT);
8273 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8274 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8275 OpREFCNT_set(CvROOT(cv), 1);
8276 CvSTART(cv) = LINKLIST(CvROOT(cv));
8277 CvROOT(cv)->op_next = 0;
8278 CALL_PEEP(CvSTART(cv));
8279 finalize_optree(CvROOT(cv));
8280 S_prune_chain_head(&CvSTART(cv));
8286 PL_parser->copline = NOLINE;
8291 Perl_newANONLIST(pTHX_ OP *o)
8293 return convert(OP_ANONLIST, OPf_SPECIAL, o);
8297 Perl_newANONHASH(pTHX_ OP *o)
8299 return convert(OP_ANONHASH, OPf_SPECIAL, o);
8303 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8305 return newANONATTRSUB(floor, proto, NULL, block);
8309 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8311 return newUNOP(OP_REFGEN, 0,
8312 newSVOP(OP_ANONCODE, 0,
8313 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8317 Perl_oopsAV(pTHX_ OP *o)
8321 PERL_ARGS_ASSERT_OOPSAV;
8323 switch (o->op_type) {
8326 o->op_type = OP_PADAV;
8327 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8328 return ref(o, OP_RV2AV);
8332 o->op_type = OP_RV2AV;
8333 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8338 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8345 Perl_oopsHV(pTHX_ OP *o)
8349 PERL_ARGS_ASSERT_OOPSHV;
8351 switch (o->op_type) {
8354 o->op_type = OP_PADHV;
8355 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8356 return ref(o, OP_RV2HV);
8360 o->op_type = OP_RV2HV;
8361 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8366 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8373 Perl_newAVREF(pTHX_ OP *o)
8377 PERL_ARGS_ASSERT_NEWAVREF;
8379 if (o->op_type == OP_PADANY) {
8380 o->op_type = OP_PADAV;
8381 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8384 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8385 Perl_croak(aTHX_ "Can't use an array as a reference");
8387 return newUNOP(OP_RV2AV, 0, scalar(o));
8391 Perl_newGVREF(pTHX_ I32 type, OP *o)
8393 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8394 return newUNOP(OP_NULL, 0, o);
8395 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8399 Perl_newHVREF(pTHX_ OP *o)
8403 PERL_ARGS_ASSERT_NEWHVREF;
8405 if (o->op_type == OP_PADANY) {
8406 o->op_type = OP_PADHV;
8407 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8410 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8411 Perl_croak(aTHX_ "Can't use a hash as a reference");
8413 return newUNOP(OP_RV2HV, 0, scalar(o));
8417 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8419 if (o->op_type == OP_PADANY) {
8421 o->op_type = OP_PADCV;
8422 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8424 return newUNOP(OP_RV2CV, flags, scalar(o));
8428 Perl_newSVREF(pTHX_ OP *o)
8432 PERL_ARGS_ASSERT_NEWSVREF;
8434 if (o->op_type == OP_PADANY) {
8435 o->op_type = OP_PADSV;
8436 o->op_ppaddr = PL_ppaddr[OP_PADSV];
8439 return newUNOP(OP_RV2SV, 0, scalar(o));
8442 /* Check routines. See the comments at the top of this file for details
8443 * on when these are called */
8446 Perl_ck_anoncode(pTHX_ OP *o)
8448 PERL_ARGS_ASSERT_CK_ANONCODE;
8450 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8451 cSVOPo->op_sv = NULL;
8456 S_io_hints(pTHX_ OP *o)
8458 #if O_BINARY != 0 || O_TEXT != 0
8460 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8462 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8465 const char *d = SvPV_const(*svp, len);
8466 const I32 mode = mode_from_discipline(d, len);
8467 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8469 if (mode & O_BINARY)
8470 o->op_private |= OPpOPEN_IN_RAW;
8474 o->op_private |= OPpOPEN_IN_CRLF;
8478 svp = hv_fetchs(table, "open_OUT", FALSE);
8481 const char *d = SvPV_const(*svp, len);
8482 const I32 mode = mode_from_discipline(d, len);
8483 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8485 if (mode & O_BINARY)
8486 o->op_private |= OPpOPEN_OUT_RAW;
8490 o->op_private |= OPpOPEN_OUT_CRLF;
8495 PERL_UNUSED_CONTEXT;
8501 Perl_ck_backtick(pTHX_ OP *o)
8506 PERL_ARGS_ASSERT_CK_BACKTICK;
8507 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8508 if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
8509 && (gv = gv_override("readpipe",8)))
8511 /* detach rest of siblings from o and its first child */
8512 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
8513 newop = S_new_entersubop(aTHX_ gv, sibl);
8515 else if (!(o->op_flags & OPf_KIDS))
8516 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8521 S_io_hints(aTHX_ o);
8526 Perl_ck_bitop(pTHX_ OP *o)
8528 PERL_ARGS_ASSERT_CK_BITOP;
8530 o->op_private = (U8)(PL_hints & HINT_INTEGER);
8531 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8532 && (o->op_type == OP_BIT_OR
8533 || o->op_type == OP_BIT_AND
8534 || o->op_type == OP_BIT_XOR))
8536 const OP * const left = cBINOPo->op_first;
8537 const OP * const right = OP_SIBLING(left);
8538 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8539 (left->op_flags & OPf_PARENS) == 0) ||
8540 (OP_IS_NUMCOMPARE(right->op_type) &&
8541 (right->op_flags & OPf_PARENS) == 0))
8542 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8543 "Possible precedence problem on bitwise %c operator",
8544 o->op_type == OP_BIT_OR ? '|'
8545 : o->op_type == OP_BIT_AND ? '&' : '^'
8551 PERL_STATIC_INLINE bool
8552 is_dollar_bracket(pTHX_ const OP * const o)
8555 PERL_UNUSED_CONTEXT;
8556 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8557 && (kid = cUNOPx(o)->op_first)
8558 && kid->op_type == OP_GV
8559 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8563 Perl_ck_cmp(pTHX_ OP *o)
8565 PERL_ARGS_ASSERT_CK_CMP;
8566 if (ckWARN(WARN_SYNTAX)) {
8567 const OP *kid = cUNOPo->op_first;
8570 ( is_dollar_bracket(aTHX_ kid)
8571 && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
8573 || ( kid->op_type == OP_CONST
8574 && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
8578 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8579 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8585 Perl_ck_concat(pTHX_ OP *o)
8587 const OP * const kid = cUNOPo->op_first;
8589 PERL_ARGS_ASSERT_CK_CONCAT;
8590 PERL_UNUSED_CONTEXT;
8592 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8593 !(kUNOP->op_first->op_flags & OPf_MOD))
8594 o->op_flags |= OPf_STACKED;
8599 Perl_ck_spair(pTHX_ OP *o)
8603 PERL_ARGS_ASSERT_CK_SPAIR;
8605 if (o->op_flags & OPf_KIDS) {
8609 const OPCODE type = o->op_type;
8610 o = modkids(ck_fun(o), type);
8611 kid = cUNOPo->op_first;
8612 kidkid = kUNOP->op_first;
8613 newop = OP_SIBLING(kidkid);
8615 const OPCODE type = newop->op_type;
8616 if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) ||
8617 type == OP_PADAV || type == OP_PADHV ||
8618 type == OP_RV2AV || type == OP_RV2HV)
8621 /* excise first sibling */
8622 op_sibling_splice(kid, NULL, 1, NULL);
8625 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8626 * and OP_CHOMP into OP_SCHOMP */
8627 o->op_ppaddr = PL_ppaddr[++o->op_type];
8632 Perl_ck_delete(pTHX_ OP *o)
8634 PERL_ARGS_ASSERT_CK_DELETE;
8638 if (o->op_flags & OPf_KIDS) {
8639 OP * const kid = cUNOPo->op_first;
8640 switch (kid->op_type) {
8642 o->op_flags |= OPf_SPECIAL;
8645 o->op_private |= OPpSLICE;
8648 o->op_flags |= OPf_SPECIAL;
8653 Perl_croak(aTHX_ "delete argument is index/value array slice,"
8654 " use array slice");
8656 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8659 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8660 "element or slice");
8662 if (kid->op_private & OPpLVAL_INTRO)
8663 o->op_private |= OPpLVAL_INTRO;
8670 Perl_ck_eof(pTHX_ OP *o)
8672 PERL_ARGS_ASSERT_CK_EOF;
8674 if (o->op_flags & OPf_KIDS) {
8676 if (cLISTOPo->op_first->op_type == OP_STUB) {
8678 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8683 kid = cLISTOPo->op_first;
8684 if (kid->op_type == OP_RV2GV)
8685 kid->op_private |= OPpALLOW_FAKE;
8691 Perl_ck_eval(pTHX_ OP *o)
8695 PERL_ARGS_ASSERT_CK_EVAL;
8697 PL_hints |= HINT_BLOCK_SCOPE;
8698 if (o->op_flags & OPf_KIDS) {
8699 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8702 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8705 /* cut whole sibling chain free from o */
8706 op_sibling_splice(o, NULL, -1, NULL);
8709 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
8710 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8712 /* establish postfix order */
8713 enter->op_next = (OP*)enter;
8715 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8716 o->op_type = OP_LEAVETRY;
8717 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8718 enter->op_other = o;
8727 const U8 priv = o->op_private;
8729 /* the newUNOP will recursively call ck_eval(), which will handle
8730 * all the stuff at the end of this function, like adding
8733 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8735 o->op_targ = (PADOFFSET)PL_hints;
8736 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8737 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8738 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8739 /* Store a copy of %^H that pp_entereval can pick up. */
8740 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8741 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8742 /* append hhop to only child */
8743 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
8745 o->op_private |= OPpEVAL_HAS_HH;
8747 if (!(o->op_private & OPpEVAL_BYTES)
8748 && FEATURE_UNIEVAL_IS_ENABLED)
8749 o->op_private |= OPpEVAL_UNICODE;
8754 Perl_ck_exec(pTHX_ OP *o)
8756 PERL_ARGS_ASSERT_CK_EXEC;
8758 if (o->op_flags & OPf_STACKED) {
8761 kid = OP_SIBLING(cUNOPo->op_first);
8762 if (kid->op_type == OP_RV2GV)
8771 Perl_ck_exists(pTHX_ OP *o)
8773 PERL_ARGS_ASSERT_CK_EXISTS;
8776 if (o->op_flags & OPf_KIDS) {
8777 OP * const kid = cUNOPo->op_first;
8778 if (kid->op_type == OP_ENTERSUB) {
8779 (void) ref(kid, o->op_type);
8780 if (kid->op_type != OP_RV2CV
8781 && !(PL_parser && PL_parser->error_count))
8783 "exists argument is not a subroutine name");
8784 o->op_private |= OPpEXISTS_SUB;
8786 else if (kid->op_type == OP_AELEM)
8787 o->op_flags |= OPf_SPECIAL;
8788 else if (kid->op_type != OP_HELEM)
8789 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8790 "element or a subroutine");
8797 Perl_ck_rvconst(pTHX_ OP *o)
8800 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8802 PERL_ARGS_ASSERT_CK_RVCONST;
8804 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8805 if (o->op_type == OP_RV2CV)
8806 o->op_private &= ~1;
8808 if (kid->op_type == OP_CONST) {
8811 SV * const kidsv = kid->op_sv;
8813 /* Is it a constant from cv_const_sv()? */
8814 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8815 SV * const rsv = SvRV(kidsv);
8816 const svtype type = SvTYPE(rsv);
8817 const char *badtype = NULL;
8819 switch (o->op_type) {
8821 if (type > SVt_PVMG)
8822 badtype = "a SCALAR";
8825 if (type != SVt_PVAV)
8826 badtype = "an ARRAY";
8829 if (type != SVt_PVHV)
8833 if (type != SVt_PVCV)
8838 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8841 if (SvTYPE(kidsv) == SVt_PVAV) return o;
8842 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8843 const char *badthing;
8844 switch (o->op_type) {
8846 badthing = "a SCALAR";
8849 badthing = "an ARRAY";
8852 badthing = "a HASH";
8860 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8861 SVfARG(kidsv), badthing);
8864 * This is a little tricky. We only want to add the symbol if we
8865 * didn't add it in the lexer. Otherwise we get duplicate strict
8866 * warnings. But if we didn't add it in the lexer, we must at
8867 * least pretend like we wanted to add it even if it existed before,
8868 * or we get possible typo warnings. OPpCONST_ENTERED says
8869 * whether the lexer already added THIS instance of this symbol.
8871 iscv = (o->op_type == OP_RV2CV) * 2;
8873 gv = gv_fetchsv(kidsv,
8874 iscv | !(kid->op_private & OPpCONST_ENTERED),
8877 : o->op_type == OP_RV2SV
8879 : o->op_type == OP_RV2AV
8881 : o->op_type == OP_RV2HV
8884 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8886 kid->op_type = OP_GV;
8887 SvREFCNT_dec(kid->op_sv);
8889 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8890 assert (sizeof(PADOP) <= sizeof(SVOP));
8891 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8892 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8894 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8896 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8898 kid->op_private = 0;
8899 kid->op_ppaddr = PL_ppaddr[OP_GV];
8900 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8908 Perl_ck_ftst(pTHX_ OP *o)
8911 const I32 type = o->op_type;
8913 PERL_ARGS_ASSERT_CK_FTST;
8915 if (o->op_flags & OPf_REF) {
8918 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8919 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8920 const OPCODE kidtype = kid->op_type;
8922 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8923 && !kid->op_folded) {
8924 OP * const newop = newGVOP(type, OPf_REF,
8925 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8929 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8930 o->op_private |= OPpFT_ACCESS;
8931 if (PL_check[kidtype] == Perl_ck_ftst
8932 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8933 o->op_private |= OPpFT_STACKED;
8934 kid->op_private |= OPpFT_STACKING;
8935 if (kidtype == OP_FTTTY && (
8936 !(kid->op_private & OPpFT_STACKED)
8937 || kid->op_private & OPpFT_AFTER_t
8939 o->op_private |= OPpFT_AFTER_t;
8944 if (type == OP_FTTTY)
8945 o = newGVOP(type, OPf_REF, PL_stdingv);
8947 o = newUNOP(type, 0, newDEFSVOP());
8953 Perl_ck_fun(pTHX_ OP *o)
8955 const int type = o->op_type;
8956 I32 oa = PL_opargs[type] >> OASHIFT;
8958 PERL_ARGS_ASSERT_CK_FUN;
8960 if (o->op_flags & OPf_STACKED) {
8961 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8964 return no_fh_allowed(o);
8967 if (o->op_flags & OPf_KIDS) {
8968 OP *prev_kid = NULL;
8969 OP *kid = cLISTOPo->op_first;
8971 bool seen_optional = FALSE;
8973 if (kid->op_type == OP_PUSHMARK ||
8974 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8977 kid = OP_SIBLING(kid);
8979 if (kid && kid->op_type == OP_COREARGS) {
8980 bool optional = FALSE;
8983 if (oa & OA_OPTIONAL) optional = TRUE;
8986 if (optional) o->op_private |= numargs;
8991 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8992 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
8994 /* append kid to chain */
8995 op_sibling_splice(o, prev_kid, 0, kid);
8997 seen_optional = TRUE;
9004 /* list seen where single (scalar) arg expected? */
9005 if (numargs == 1 && !(oa >> 4)
9006 && kid->op_type == OP_LIST && type != OP_SCALAR)
9008 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9010 if (type != OP_DELETE) scalar(kid);
9021 if ((type == OP_PUSH || type == OP_UNSHIFT)
9022 && !OP_HAS_SIBLING(kid))
9023 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9024 "Useless use of %s with no values",
9027 if (kid->op_type == OP_CONST
9028 && ( !SvROK(cSVOPx_sv(kid))
9029 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9031 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9032 /* Defer checks to run-time if we have a scalar arg */
9033 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9034 op_lvalue(kid, type);
9037 /* diag_listed_as: push on reference is experimental */
9038 Perl_ck_warner_d(aTHX_
9039 packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9040 "%s on reference is experimental",
9045 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9046 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9047 op_lvalue(kid, type);
9051 /* replace kid with newop in chain */
9053 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9054 newop->op_next = newop;
9059 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9060 if (kid->op_type == OP_CONST &&
9061 (kid->op_private & OPpCONST_BARE))
9063 OP * const newop = newGVOP(OP_GV, 0,
9064 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9065 /* replace kid with newop in chain */
9066 op_sibling_splice(o, prev_kid, 1, newop);
9070 else if (kid->op_type == OP_READLINE) {
9071 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9072 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9075 I32 flags = OPf_SPECIAL;
9079 /* is this op a FH constructor? */
9080 if (is_handle_constructor(o,numargs)) {
9081 const char *name = NULL;
9084 bool want_dollar = TRUE;
9087 /* Set a flag to tell rv2gv to vivify
9088 * need to "prove" flag does not mean something
9089 * else already - NI-S 1999/05/07
9092 if (kid->op_type == OP_PADSV) {
9094 = PAD_COMPNAME_SV(kid->op_targ);
9095 name = SvPV_const(namesv, len);
9096 name_utf8 = SvUTF8(namesv);
9098 else if (kid->op_type == OP_RV2SV
9099 && kUNOP->op_first->op_type == OP_GV)
9101 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9103 len = GvNAMELEN(gv);
9104 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9106 else if (kid->op_type == OP_AELEM
9107 || kid->op_type == OP_HELEM)
9110 OP *op = ((BINOP*)kid)->op_first;
9114 const char * const a =
9115 kid->op_type == OP_AELEM ?
9117 if (((op->op_type == OP_RV2AV) ||
9118 (op->op_type == OP_RV2HV)) &&
9119 (firstop = ((UNOP*)op)->op_first) &&
9120 (firstop->op_type == OP_GV)) {
9121 /* packagevar $a[] or $h{} */
9122 GV * const gv = cGVOPx_gv(firstop);
9130 else if (op->op_type == OP_PADAV
9131 || op->op_type == OP_PADHV) {
9132 /* lexicalvar $a[] or $h{} */
9133 const char * const padname =
9134 PAD_COMPNAME_PV(op->op_targ);
9143 name = SvPV_const(tmpstr, len);
9144 name_utf8 = SvUTF8(tmpstr);
9149 name = "__ANONIO__";
9151 want_dollar = FALSE;
9153 op_lvalue(kid, type);
9157 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9158 namesv = PAD_SVl(targ);
9159 if (want_dollar && *name != '$')
9160 sv_setpvs(namesv, "$");
9162 sv_setpvs(namesv, "");
9163 sv_catpvn(namesv, name, len);
9164 if ( name_utf8 ) SvUTF8_on(namesv);
9168 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9170 kid->op_targ = targ;
9171 kid->op_private |= priv;
9177 if ((type == OP_UNDEF || type == OP_POS)
9178 && numargs == 1 && !(oa >> 4)
9179 && kid->op_type == OP_LIST)
9180 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9181 op_lvalue(scalar(kid), type);
9186 kid = OP_SIBLING(kid);
9188 /* FIXME - should the numargs or-ing move after the too many
9189 * arguments check? */
9190 o->op_private |= numargs;
9192 return too_many_arguments_pv(o,OP_DESC(o), 0);
9195 else if (PL_opargs[type] & OA_DEFGV) {
9196 /* Ordering of these two is important to keep f_map.t passing. */
9198 return newUNOP(type, 0, newDEFSVOP());
9202 while (oa & OA_OPTIONAL)
9204 if (oa && oa != OA_LIST)
9205 return too_few_arguments_pv(o,OP_DESC(o), 0);
9211 Perl_ck_glob(pTHX_ OP *o)
9215 PERL_ARGS_ASSERT_CK_GLOB;
9218 if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
9219 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9221 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9225 * \ null - const(wildcard)
9230 * \ mark - glob - rv2cv
9231 * | \ gv(CORE::GLOBAL::glob)
9233 * \ null - const(wildcard)
9235 o->op_flags |= OPf_SPECIAL;
9236 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9237 o = S_new_entersubop(aTHX_ gv, o);
9238 o = newUNOP(OP_NULL, 0, o);
9239 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9242 else o->op_flags &= ~OPf_SPECIAL;
9243 #if !defined(PERL_EXTERNAL_GLOB)
9246 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9247 newSVpvs("File::Glob"), NULL, NULL, NULL);
9250 #endif /* !PERL_EXTERNAL_GLOB */
9251 gv = (GV *)newSV(0);
9252 gv_init(gv, 0, "", 0, 0);
9254 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9255 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9261 Perl_ck_grep(pTHX_ OP *o)
9266 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9269 PERL_ARGS_ASSERT_CK_GREP;
9271 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9272 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9274 if (o->op_flags & OPf_STACKED) {
9275 kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
9276 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9277 return no_fh_allowed(o);
9278 o->op_flags &= ~OPf_STACKED;
9280 kid = OP_SIBLING(cLISTOPo->op_first);
9281 if (type == OP_MAPWHILE)
9286 if (PL_parser && PL_parser->error_count)
9288 kid = OP_SIBLING(cLISTOPo->op_first);
9289 if (kid->op_type != OP_NULL)
9290 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9291 kid = kUNOP->op_first;
9293 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
9294 gwop->op_ppaddr = PL_ppaddr[type];
9295 kid->op_next = (OP*)gwop;
9296 offset = pad_findmy_pvs("$_", 0);
9297 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9298 o->op_private = gwop->op_private = 0;
9299 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9302 o->op_private = gwop->op_private = OPpGREP_LEX;
9303 gwop->op_targ = o->op_targ = offset;
9306 kid = OP_SIBLING(cLISTOPo->op_first);
9307 for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
9308 op_lvalue(kid, OP_GREPSTART);
9314 Perl_ck_index(pTHX_ OP *o)
9316 PERL_ARGS_ASSERT_CK_INDEX;
9318 if (o->op_flags & OPf_KIDS) {
9319 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9321 kid = OP_SIBLING(kid); /* get past "big" */
9322 if (kid && kid->op_type == OP_CONST) {
9323 const bool save_taint = TAINT_get;
9324 SV *sv = kSVOP->op_sv;
9325 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9327 sv_copypv(sv, kSVOP->op_sv);
9328 SvREFCNT_dec_NN(kSVOP->op_sv);
9331 if (SvOK(sv)) fbm_compile(sv, 0);
9332 TAINT_set(save_taint);
9333 #ifdef NO_TAINT_SUPPORT
9334 PERL_UNUSED_VAR(save_taint);
9342 Perl_ck_lfun(pTHX_ OP *o)
9344 const OPCODE type = o->op_type;
9346 PERL_ARGS_ASSERT_CK_LFUN;
9348 return modkids(ck_fun(o), type);
9352 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
9354 PERL_ARGS_ASSERT_CK_DEFINED;
9356 if ((o->op_flags & OPf_KIDS)) {
9357 switch (cUNOPo->op_first->op_type) {
9360 case OP_AASSIGN: /* Is this a good idea? */
9361 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
9362 " (Maybe you should just omit the defined()?)");
9366 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
9367 " (Maybe you should just omit the defined()?)");
9378 Perl_ck_readline(pTHX_ OP *o)
9380 PERL_ARGS_ASSERT_CK_READLINE;
9382 if (o->op_flags & OPf_KIDS) {
9383 OP *kid = cLISTOPo->op_first;
9384 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9388 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9396 Perl_ck_rfun(pTHX_ OP *o)
9398 const OPCODE type = o->op_type;
9400 PERL_ARGS_ASSERT_CK_RFUN;
9402 return refkids(ck_fun(o), type);
9406 Perl_ck_listiob(pTHX_ OP *o)
9410 PERL_ARGS_ASSERT_CK_LISTIOB;
9412 kid = cLISTOPo->op_first;
9414 o = force_list(o, 1);
9415 kid = cLISTOPo->op_first;
9417 if (kid->op_type == OP_PUSHMARK)
9418 kid = OP_SIBLING(kid);
9419 if (kid && o->op_flags & OPf_STACKED)
9420 kid = OP_SIBLING(kid);
9421 else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */
9422 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9423 && !kid->op_folded) {
9424 o->op_flags |= OPf_STACKED; /* make it a filehandle */
9426 /* replace old const op with new OP_RV2GV parent */
9427 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
9429 kid = OP_SIBLING(kid);
9434 op_append_elem(o->op_type, o, newDEFSVOP());
9436 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9441 Perl_ck_smartmatch(pTHX_ OP *o)
9444 PERL_ARGS_ASSERT_CK_SMARTMATCH;
9445 if (0 == (o->op_flags & OPf_SPECIAL)) {
9446 OP *first = cBINOPo->op_first;
9447 OP *second = OP_SIBLING(first);
9449 /* Implicitly take a reference to an array or hash */
9451 /* remove the original two siblings, then add back the
9452 * (possibly different) first and second sibs.
9454 op_sibling_splice(o, NULL, 1, NULL);
9455 op_sibling_splice(o, NULL, 1, NULL);
9456 first = ref_array_or_hash(first);
9457 second = ref_array_or_hash(second);
9458 op_sibling_splice(o, NULL, 0, second);
9459 op_sibling_splice(o, NULL, 0, first);
9461 /* Implicitly take a reference to a regular expression */
9462 if (first->op_type == OP_MATCH) {
9463 first->op_type = OP_QR;
9464 first->op_ppaddr = PL_ppaddr[OP_QR];
9466 if (second->op_type == OP_MATCH) {
9467 second->op_type = OP_QR;
9468 second->op_ppaddr = PL_ppaddr[OP_QR];
9477 Perl_ck_sassign(pTHX_ OP *o)
9480 OP * const kid = cLISTOPo->op_first;
9482 PERL_ARGS_ASSERT_CK_SASSIGN;
9484 /* has a disposable target? */
9485 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9486 && !(kid->op_flags & OPf_STACKED)
9487 /* Cannot steal the second time! */
9488 && !(kid->op_private & OPpTARGET_MY)
9491 OP * const kkid = OP_SIBLING(kid);
9493 /* Can just relocate the target. */
9494 if (kkid && kkid->op_type == OP_PADSV
9495 && !(kkid->op_private & OPpLVAL_INTRO))
9497 kid->op_targ = kkid->op_targ;
9499 /* Now we do not need PADSV and SASSIGN.
9500 * first replace the PADSV with OP_SIBLING(o), then
9501 * detach kid and OP_SIBLING(o) from o */
9502 op_sibling_splice(o, kid, 1, OP_SIBLING(o));
9503 op_sibling_splice(o, NULL, -1, NULL);
9506 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9510 if (OP_HAS_SIBLING(kid)) {
9511 OP *kkid = OP_SIBLING(kid);
9512 /* For state variable assignment, kkid is a list op whose op_last
9514 if ((kkid->op_type == OP_PADSV ||
9515 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
9516 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9519 && (kkid->op_private & OPpLVAL_INTRO)
9520 && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
9521 const PADOFFSET target = kkid->op_targ;
9522 OP *const other = newOP(OP_PADSV,
9524 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9525 OP *const first = newOP(OP_NULL, 0);
9526 OP *const nullop = newCONDOP(0, first, o, other);
9527 OP *const condop = first->op_next;
9528 /* hijacking PADSTALE for uninitialized state variables */
9529 SvPADSTALE_on(PAD_SVl(target));
9531 condop->op_type = OP_ONCE;
9532 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9533 condop->op_targ = target;
9534 other->op_targ = target;
9536 /* Because we change the type of the op here, we will skip the
9537 assignment binop->op_last = OP_SIBLING(binop->op_first); at the
9538 end of Perl_newBINOP(). So need to do it here. */
9539 cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first);
9540 cBINOPo->op_first->op_lastsib = 0;
9541 cBINOPo->op_last ->op_lastsib = 1;
9542 #ifdef PERL_OP_PARENT
9543 cBINOPo->op_last->op_sibling = o;
9552 Perl_ck_match(pTHX_ OP *o)
9554 PERL_ARGS_ASSERT_CK_MATCH;
9556 if (o->op_type != OP_QR && PL_compcv) {
9557 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9558 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9559 o->op_targ = offset;
9560 o->op_private |= OPpTARGET_MY;
9563 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9564 o->op_private |= OPpRUNTIME;
9569 Perl_ck_method(pTHX_ OP *o)
9571 OP * const kid = cUNOPo->op_first;
9573 PERL_ARGS_ASSERT_CK_METHOD;
9575 if (kid->op_type == OP_CONST) {
9576 SV* sv = kSVOP->op_sv;
9577 const char * const method = SvPVX_const(sv);
9578 if (!(strchr(method, ':') || strchr(method, '\''))) {
9580 if (!SvIsCOW_shared_hash(sv)) {
9581 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9584 kSVOP->op_sv = NULL;
9586 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9595 Perl_ck_null(pTHX_ OP *o)
9597 PERL_ARGS_ASSERT_CK_NULL;
9598 PERL_UNUSED_CONTEXT;
9603 Perl_ck_open(pTHX_ OP *o)
9605 PERL_ARGS_ASSERT_CK_OPEN;
9607 S_io_hints(aTHX_ o);
9609 /* In case of three-arg dup open remove strictness
9610 * from the last arg if it is a bareword. */
9611 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9612 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
9616 if ((last->op_type == OP_CONST) && /* The bareword. */
9617 (last->op_private & OPpCONST_BARE) &&
9618 (last->op_private & OPpCONST_STRICT) &&
9619 (oa = OP_SIBLING(first)) && /* The fh. */
9620 (oa = OP_SIBLING(oa)) && /* The mode. */
9621 (oa->op_type == OP_CONST) &&
9622 SvPOK(((SVOP*)oa)->op_sv) &&
9623 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9624 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9625 (last == OP_SIBLING(oa))) /* The bareword. */
9626 last->op_private &= ~OPpCONST_STRICT;
9632 Perl_ck_repeat(pTHX_ OP *o)
9634 PERL_ARGS_ASSERT_CK_REPEAT;
9636 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9638 o->op_private |= OPpREPEAT_DOLIST;
9639 kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
9640 kids = force_list(kids, 1); /* promote them to a list */
9641 op_sibling_splice(o, NULL, 0, kids); /* and add back */
9649 Perl_ck_require(pTHX_ OP *o)
9653 PERL_ARGS_ASSERT_CK_REQUIRE;
9655 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9656 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9658 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9659 SV * const sv = kid->op_sv;
9660 U32 was_readonly = SvREADONLY(sv);
9668 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9673 for (; s < end; s++) {
9674 if (*s == ':' && s[1] == ':') {
9676 Move(s+2, s+1, end - s - 1, char);
9681 sv_catpvs(sv, ".pm");
9682 SvFLAGS(sv) |= was_readonly;
9686 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9687 /* handle override, if any */
9688 && (gv = gv_override("require", 7))) {
9690 if (o->op_flags & OPf_KIDS) {
9691 kid = cUNOPo->op_first;
9692 op_sibling_splice(o, NULL, -1, NULL);
9698 newop = S_new_entersubop(aTHX_ gv, kid);
9702 return scalar(ck_fun(o));
9706 Perl_ck_return(pTHX_ OP *o)
9710 PERL_ARGS_ASSERT_CK_RETURN;
9712 kid = OP_SIBLING(cLISTOPo->op_first);
9713 if (CvLVALUE(PL_compcv)) {
9714 for (; kid; kid = OP_SIBLING(kid))
9715 op_lvalue(kid, OP_LEAVESUBLV);
9722 Perl_ck_select(pTHX_ OP *o)
9727 PERL_ARGS_ASSERT_CK_SELECT;
9729 if (o->op_flags & OPf_KIDS) {
9730 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9731 if (kid && OP_HAS_SIBLING(kid)) {
9732 o->op_type = OP_SSELECT;
9733 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9735 return fold_constants(op_integerize(op_std_init(o)));
9739 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9740 if (kid && kid->op_type == OP_RV2GV)
9741 kid->op_private &= ~HINT_STRICT_REFS;
9746 Perl_ck_shift(pTHX_ OP *o)
9748 const I32 type = o->op_type;
9750 PERL_ARGS_ASSERT_CK_SHIFT;
9752 if (!(o->op_flags & OPf_KIDS)) {
9755 if (!CvUNIQUE(PL_compcv)) {
9756 o->op_flags |= OPf_SPECIAL;
9760 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9762 return newUNOP(type, 0, scalar(argop));
9764 return scalar(ck_fun(o));
9768 Perl_ck_sort(pTHX_ OP *o)
9773 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9776 PERL_ARGS_ASSERT_CK_SORT;
9779 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9781 const I32 sorthints = (I32)SvIV(*svp);
9782 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9783 o->op_private |= OPpSORT_QSORT;
9784 if ((sorthints & HINT_SORT_STABLE) != 0)
9785 o->op_private |= OPpSORT_STABLE;
9789 if (o->op_flags & OPf_STACKED)
9791 firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9793 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
9794 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9796 /* if the first arg is a code block, process it and mark sort as
9798 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9800 if (kid->op_type == OP_LEAVE)
9801 op_null(kid); /* wipe out leave */
9802 /* Prevent execution from escaping out of the sort block. */
9805 /* provide scalar context for comparison function/block */
9806 kid = scalar(firstkid);
9808 o->op_flags |= OPf_SPECIAL;
9811 firstkid = OP_SIBLING(firstkid);
9814 for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
9815 /* provide list context for arguments */
9818 op_lvalue(kid, OP_GREPSTART);
9824 /* for sort { X } ..., where X is one of
9825 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
9826 * elide the second child of the sort (the one containing X),
9827 * and set these flags as appropriate
9831 * Also, check and warn on lexical $a, $b.
9835 S_simplify_sort(pTHX_ OP *o)
9837 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9844 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9846 kid = kUNOP->op_first; /* get past null */
9847 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9848 && kid->op_type != OP_LEAVE)
9850 kid = kLISTOP->op_last; /* get past scope */
9851 switch(kid->op_type) {
9855 if (!have_scopeop) goto padkids;
9860 k = kid; /* remember this node*/
9861 if (kBINOP->op_first->op_type != OP_RV2SV
9862 || kBINOP->op_last ->op_type != OP_RV2SV)
9865 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9866 then used in a comparison. This catches most, but not
9867 all cases. For instance, it catches
9868 sort { my($a); $a <=> $b }
9870 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9871 (although why you'd do that is anyone's guess).
9875 if (!ckWARN(WARN_SYNTAX)) return;
9876 kid = kBINOP->op_first;
9878 if (kid->op_type == OP_PADSV) {
9879 SV * const name = PAD_COMPNAME_SV(kid->op_targ);
9880 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9881 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9882 /* diag_listed_as: "my %s" used in sort comparison */
9883 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9884 "\"%s %s\" used in sort comparison",
9885 SvPAD_STATE(name) ? "state" : "my",
9888 } while ((kid = OP_SIBLING(kid)));
9891 kid = kBINOP->op_first; /* get past cmp */
9892 if (kUNOP->op_first->op_type != OP_GV)
9894 kid = kUNOP->op_first; /* get past rv2sv */
9896 if (GvSTASH(gv) != PL_curstash)
9898 gvname = GvNAME(gv);
9899 if (*gvname == 'a' && gvname[1] == '\0')
9901 else if (*gvname == 'b' && gvname[1] == '\0')
9906 kid = k; /* back to cmp */
9907 /* already checked above that it is rv2sv */
9908 kid = kBINOP->op_last; /* down to 2nd arg */
9909 if (kUNOP->op_first->op_type != OP_GV)
9911 kid = kUNOP->op_first; /* get past rv2sv */
9913 if (GvSTASH(gv) != PL_curstash)
9915 gvname = GvNAME(gv);
9917 ? !(*gvname == 'a' && gvname[1] == '\0')
9918 : !(*gvname == 'b' && gvname[1] == '\0'))
9920 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9922 o->op_private |= OPpSORT_DESCEND;
9923 if (k->op_type == OP_NCMP)
9924 o->op_private |= OPpSORT_NUMERIC;
9925 if (k->op_type == OP_I_NCMP)
9926 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9927 kid = OP_SIBLING(cLISTOPo->op_first);
9928 /* cut out and delete old block (second sibling) */
9929 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
9934 Perl_ck_split(pTHX_ OP *o)
9939 PERL_ARGS_ASSERT_CK_SPLIT;
9941 if (o->op_flags & OPf_STACKED)
9942 return no_fh_allowed(o);
9944 kid = cLISTOPo->op_first;
9945 if (kid->op_type != OP_NULL)
9946 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9947 /* delete leading NULL node, then add a CONST if no other nodes */
9948 op_sibling_splice(o, NULL, 1,
9949 OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
9951 kid = cLISTOPo->op_first;
9953 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9954 /* remove kid, and replace with new optree */
9955 op_sibling_splice(o, NULL, 1, NULL);
9956 /* OPf_SPECIAL is used to trigger split " " behavior */
9957 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
9958 op_sibling_splice(o, NULL, 0, kid);
9961 kid->op_type = OP_PUSHRE;
9962 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9964 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9965 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9966 "Use of /g modifier is meaningless in split");
9969 if (!OP_HAS_SIBLING(kid))
9970 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9972 kid = OP_SIBLING(kid);
9976 if (!OP_HAS_SIBLING(kid))
9978 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9979 o->op_private |= OPpSPLIT_IMPLIM;
9981 assert(OP_HAS_SIBLING(kid));
9983 kid = OP_SIBLING(kid);
9986 if (OP_HAS_SIBLING(kid))
9987 return too_many_arguments_pv(o,OP_DESC(o), 0);
9993 Perl_ck_join(pTHX_ OP *o)
9995 const OP * const kid = OP_SIBLING(cLISTOPo->op_first);
9997 PERL_ARGS_ASSERT_CK_JOIN;
9999 if (kid && kid->op_type == OP_MATCH) {
10000 if (ckWARN(WARN_SYNTAX)) {
10001 const REGEXP *re = PM_GETRE(kPMOP);
10003 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10004 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10005 : newSVpvs_flags( "STRING", SVs_TEMP );
10006 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10007 "/%"SVf"/ should probably be written as \"%"SVf"\"",
10008 SVfARG(msg), SVfARG(msg));
10015 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10017 Examines an op, which is expected to identify a subroutine at runtime,
10018 and attempts to determine at compile time which subroutine it identifies.
10019 This is normally used during Perl compilation to determine whether
10020 a prototype can be applied to a function call. I<cvop> is the op
10021 being considered, normally an C<rv2cv> op. A pointer to the identified
10022 subroutine is returned, if it could be determined statically, and a null
10023 pointer is returned if it was not possible to determine statically.
10025 Currently, the subroutine can be identified statically if the RV that the
10026 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10027 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
10028 suitable if the constant value must be an RV pointing to a CV. Details of
10029 this process may change in future versions of Perl. If the C<rv2cv> op
10030 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10031 the subroutine statically: this flag is used to suppress compile-time
10032 magic on a subroutine call, forcing it to use default runtime behaviour.
10034 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10035 of a GV reference is modified. If a GV was examined and its CV slot was
10036 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10037 If the op is not optimised away, and the CV slot is later populated with
10038 a subroutine having a prototype, that flag eventually triggers the warning
10039 "called too early to check prototype".
10041 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10042 of returning a pointer to the subroutine it returns a pointer to the
10043 GV giving the most appropriate name for the subroutine in this context.
10044 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10045 (C<CvANON>) subroutine that is referenced through a GV it will be the
10046 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
10047 A null pointer is returned as usual if there is no statically-determinable
10053 /* shared by toke.c:yylex */
10055 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10057 PADNAME *name = PAD_COMPNAME(off);
10058 CV *compcv = PL_compcv;
10059 while (PadnameOUTER(name)) {
10060 assert(PARENT_PAD_INDEX(name));
10061 compcv = CvOUTSIDE(PL_compcv);
10062 name = PadlistNAMESARRAY(CvPADLIST(compcv))
10063 [off = PARENT_PAD_INDEX(name)];
10065 assert(!PadnameIsOUR(name));
10066 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10067 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10069 assert(mg->mg_obj);
10070 return (CV *)mg->mg_obj;
10072 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10076 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10081 PERL_ARGS_ASSERT_RV2CV_OP_CV;
10082 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
10083 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10084 if (cvop->op_type != OP_RV2CV)
10086 if (cvop->op_private & OPpENTERSUB_AMPER)
10088 if (!(cvop->op_flags & OPf_KIDS))
10090 rvop = cUNOPx(cvop)->op_first;
10091 switch (rvop->op_type) {
10093 gv = cGVOPx_gv(rvop);
10096 if (flags & RV2CVOPCV_MARK_EARLY)
10097 rvop->op_private |= OPpEARLY_CV;
10102 SV *rv = cSVOPx_sv(rvop);
10105 cv = (CV*)SvRV(rv);
10109 cv = find_lexical_cv(rvop->op_targ);
10114 } NOT_REACHED; /* NOTREACHED */
10116 if (SvTYPE((SV*)cv) != SVt_PVCV)
10118 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10119 if (!CvANON(cv) || !gv)
10128 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10130 Performs the default fixup of the arguments part of an C<entersub>
10131 op tree. This consists of applying list context to each of the
10132 argument ops. This is the standard treatment used on a call marked
10133 with C<&>, or a method call, or a call through a subroutine reference,
10134 or any other call where the callee can't be identified at compile time,
10135 or a call where the callee has no prototype.
10141 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10144 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10145 aop = cUNOPx(entersubop)->op_first;
10146 if (!OP_HAS_SIBLING(aop))
10147 aop = cUNOPx(aop)->op_first;
10148 for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
10150 op_lvalue(aop, OP_ENTERSUB);
10156 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10158 Performs the fixup of the arguments part of an C<entersub> op tree
10159 based on a subroutine prototype. This makes various modifications to
10160 the argument ops, from applying context up to inserting C<refgen> ops,
10161 and checking the number and syntactic types of arguments, as directed by
10162 the prototype. This is the standard treatment used on a subroutine call,
10163 not marked with C<&>, where the callee can be identified at compile time
10164 and has a prototype.
10166 I<protosv> supplies the subroutine prototype to be applied to the call.
10167 It may be a normal defined scalar, of which the string value will be used.
10168 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10169 that has been cast to C<SV*>) which has a prototype. The prototype
10170 supplied, in whichever form, does not need to match the actual callee
10171 referenced by the op tree.
10173 If the argument ops disagree with the prototype, for example by having
10174 an unacceptable number of arguments, a valid op tree is returned anyway.
10175 The error is reflected in the parser state, normally resulting in a single
10176 exception at the top level of parsing which covers all the compilation
10177 errors that occurred. In the error message, the callee is referred to
10178 by the name defined by the I<namegv> parameter.
10184 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10187 const char *proto, *proto_end;
10188 OP *aop, *prev, *cvop, *parent;
10191 I32 contextclass = 0;
10192 const char *e = NULL;
10193 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10194 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10195 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10196 "flags=%lx", (unsigned long) SvFLAGS(protosv));
10197 if (SvTYPE(protosv) == SVt_PVCV)
10198 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10199 else proto = SvPV(protosv, proto_len);
10200 proto = S_strip_spaces(aTHX_ proto, &proto_len);
10201 proto_end = proto + proto_len;
10202 parent = entersubop;
10203 aop = cUNOPx(entersubop)->op_first;
10204 if (!OP_HAS_SIBLING(aop)) {
10206 aop = cUNOPx(aop)->op_first;
10209 aop = OP_SIBLING(aop);
10210 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10211 while (aop != cvop) {
10214 if (proto >= proto_end)
10215 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10223 /* _ must be at the end */
10224 if (proto[1] && !strchr(";@%", proto[1]))
10240 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10242 arg == 1 ? "block or sub {}" : "sub {}",
10246 /* '*' allows any scalar type, including bareword */
10249 if (o3->op_type == OP_RV2GV)
10250 goto wrapref; /* autoconvert GLOB -> GLOBref */
10251 else if (o3->op_type == OP_CONST)
10252 o3->op_private &= ~OPpCONST_STRICT;
10253 else if (o3->op_type == OP_ENTERSUB) {
10254 /* accidental subroutine, revert to bareword */
10255 OP *gvop = ((UNOP*)o3)->op_first;
10256 if (gvop && gvop->op_type == OP_NULL) {
10257 gvop = ((UNOP*)gvop)->op_first;
10259 for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop))
10262 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10263 (gvop = ((UNOP*)gvop)->op_first) &&
10264 gvop->op_type == OP_GV)
10267 GV * const gv = cGVOPx_gv(gvop);
10268 SV * const n = newSVpvs("");
10269 gv_fullname4(n, gv, "", FALSE);
10270 /* replace the aop subtree with a const op */
10271 newop = newSVOP(OP_CONST, 0, n);
10272 op_sibling_splice(parent, prev, 1, newop);
10284 if (o3->op_type == OP_RV2AV ||
10285 o3->op_type == OP_PADAV ||
10286 o3->op_type == OP_RV2HV ||
10287 o3->op_type == OP_PADHV
10293 case '[': case ']':
10300 switch (*proto++) {
10302 if (contextclass++ == 0) {
10303 e = strchr(proto, ']');
10304 if (!e || e == proto)
10312 if (contextclass) {
10313 const char *p = proto;
10314 const char *const end = proto;
10316 while (*--p != '[')
10317 /* \[$] accepts any scalar lvalue */
10319 && Perl_op_lvalue_flags(aTHX_
10321 OP_READ, /* not entersub */
10324 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10325 (int)(end - p), p),
10331 if (o3->op_type == OP_RV2GV)
10334 bad_type_gv(arg, "symbol", namegv, 0, o3);
10337 if (o3->op_type == OP_ENTERSUB)
10340 bad_type_gv(arg, "subroutine entry", namegv, 0,
10344 if (o3->op_type == OP_RV2SV ||
10345 o3->op_type == OP_PADSV ||
10346 o3->op_type == OP_HELEM ||
10347 o3->op_type == OP_AELEM)
10349 if (!contextclass) {
10350 /* \$ accepts any scalar lvalue */
10351 if (Perl_op_lvalue_flags(aTHX_
10353 OP_READ, /* not entersub */
10356 bad_type_gv(arg, "scalar", namegv, 0, o3);
10360 if (o3->op_type == OP_RV2AV ||
10361 o3->op_type == OP_PADAV)
10364 bad_type_gv(arg, "array", namegv, 0, o3);
10367 if (o3->op_type == OP_RV2HV ||
10368 o3->op_type == OP_PADHV)
10371 bad_type_gv(arg, "hash", namegv, 0, o3);
10374 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
10376 if (contextclass && e) {
10381 default: goto oops;
10391 SV* const tmpsv = sv_newmortal();
10392 gv_efullname3(tmpsv, namegv, NULL);
10393 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10394 SVfARG(tmpsv), SVfARG(protosv));
10398 op_lvalue(aop, OP_ENTERSUB);
10400 aop = OP_SIBLING(aop);
10402 if (aop == cvop && *proto == '_') {
10403 /* generate an access to $_ */
10404 op_sibling_splice(parent, prev, 0, newDEFSVOP());
10406 if (!optional && proto_end > proto &&
10407 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10408 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10413 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10415 Performs the fixup of the arguments part of an C<entersub> op tree either
10416 based on a subroutine prototype or using default list-context processing.
10417 This is the standard treatment used on a subroutine call, not marked
10418 with C<&>, where the callee can be identified at compile time.
10420 I<protosv> supplies the subroutine prototype to be applied to the call,
10421 or indicates that there is no prototype. It may be a normal scalar,
10422 in which case if it is defined then the string value will be used
10423 as a prototype, and if it is undefined then there is no prototype.
10424 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10425 that has been cast to C<SV*>), of which the prototype will be used if it
10426 has one. The prototype (or lack thereof) supplied, in whichever form,
10427 does not need to match the actual callee referenced by the op tree.
10429 If the argument ops disagree with the prototype, for example by having
10430 an unacceptable number of arguments, a valid op tree is returned anyway.
10431 The error is reflected in the parser state, normally resulting in a single
10432 exception at the top level of parsing which covers all the compilation
10433 errors that occurred. In the error message, the callee is referred to
10434 by the name defined by the I<namegv> parameter.
10440 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10441 GV *namegv, SV *protosv)
10443 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10444 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10445 return ck_entersub_args_proto(entersubop, namegv, protosv);
10447 return ck_entersub_args_list(entersubop);
10451 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10453 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10454 OP *aop = cUNOPx(entersubop)->op_first;
10456 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10460 if (!OP_HAS_SIBLING(aop))
10461 aop = cUNOPx(aop)->op_first;
10462 aop = OP_SIBLING(aop);
10463 for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10465 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10467 op_free(entersubop);
10468 switch(GvNAME(namegv)[2]) {
10469 case 'F': return newSVOP(OP_CONST, 0,
10470 newSVpv(CopFILE(PL_curcop),0));
10471 case 'L': return newSVOP(
10473 Perl_newSVpvf(aTHX_
10474 "%"IVdf, (IV)CopLINE(PL_curcop)
10477 case 'P': return newSVOP(OP_CONST, 0,
10479 ? newSVhek(HvNAME_HEK(PL_curstash))
10487 OP *prev, *cvop, *first, *parent;
10490 parent = entersubop;
10491 if (!OP_HAS_SIBLING(aop)) {
10493 aop = cUNOPx(aop)->op_first;
10496 first = prev = aop;
10497 aop = OP_SIBLING(aop);
10498 /* find last sibling */
10500 OP_HAS_SIBLING(cvop);
10501 prev = cvop, cvop = OP_SIBLING(cvop))
10503 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
10504 /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
10505 * parens, but these have their own meaning for that flag: */
10506 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
10507 && opnum != OP_DELETE && opnum != OP_EXISTS)
10508 flags |= OPf_SPECIAL;
10509 /* excise cvop from end of sibling chain */
10510 op_sibling_splice(parent, prev, 1, NULL);
10512 if (aop == cvop) aop = NULL;
10514 /* detach remaining siblings from the first sibling, then
10515 * dispose of original optree */
10518 op_sibling_splice(parent, first, -1, NULL);
10519 op_free(entersubop);
10521 if (opnum == OP_ENTEREVAL
10522 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10523 flags |= OPpEVAL_BYTES <<8;
10525 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10527 case OA_BASEOP_OR_UNOP:
10528 case OA_FILESTATOP:
10529 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10532 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10535 return opnum == OP_RUNCV
10536 ? newPVOP(OP_RUNCV,0,NULL)
10539 return convert(opnum,0,aop);
10547 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10549 Retrieves the function that will be used to fix up a call to I<cv>.
10550 Specifically, the function is applied to an C<entersub> op tree for a
10551 subroutine call, not marked with C<&>, where the callee can be identified
10552 at compile time as I<cv>.
10554 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10555 argument for it is returned in I<*ckobj_p>. The function is intended
10556 to be called in this manner:
10558 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10560 In this call, I<entersubop> is a pointer to the C<entersub> op,
10561 which may be replaced by the check function, and I<namegv> is a GV
10562 supplying the name that should be used by the check function to refer
10563 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10564 It is permitted to apply the check function in non-standard situations,
10565 such as to a call to a different subroutine or to a method call.
10567 By default, the function is
10568 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10569 and the SV parameter is I<cv> itself. This implements standard
10570 prototype processing. It can be changed, for a particular subroutine,
10571 by L</cv_set_call_checker>.
10577 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10580 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10581 PERL_UNUSED_CONTEXT;
10582 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10584 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10585 *ckobj_p = callmg->mg_obj;
10587 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10588 *ckobj_p = (SV*)cv;
10593 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10595 Sets the function that will be used to fix up a call to I<cv>.
10596 Specifically, the function is applied to an C<entersub> op tree for a
10597 subroutine call, not marked with C<&>, where the callee can be identified
10598 at compile time as I<cv>.
10600 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10601 for it is supplied in I<ckobj>. The function should be defined like this:
10603 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
10605 It is intended to be called in this manner:
10607 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10609 In this call, I<entersubop> is a pointer to the C<entersub> op,
10610 which may be replaced by the check function, and I<namegv> is a GV
10611 supplying the name that should be used by the check function to refer
10612 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10613 It is permitted to apply the check function in non-standard situations,
10614 such as to a call to a different subroutine or to a method call.
10616 The current setting for a particular CV can be retrieved by
10617 L</cv_get_call_checker>.
10623 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10625 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10626 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10627 if (SvMAGICAL((SV*)cv))
10628 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10631 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10632 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10634 if (callmg->mg_flags & MGf_REFCOUNTED) {
10635 SvREFCNT_dec(callmg->mg_obj);
10636 callmg->mg_flags &= ~MGf_REFCOUNTED;
10638 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10639 callmg->mg_obj = ckobj;
10640 if (ckobj != (SV*)cv) {
10641 SvREFCNT_inc_simple_void_NN(ckobj);
10642 callmg->mg_flags |= MGf_REFCOUNTED;
10644 callmg->mg_flags |= MGf_COPY;
10649 Perl_ck_subr(pTHX_ OP *o)
10655 PERL_ARGS_ASSERT_CK_SUBR;
10657 aop = cUNOPx(o)->op_first;
10658 if (!OP_HAS_SIBLING(aop))
10659 aop = cUNOPx(aop)->op_first;
10660 aop = OP_SIBLING(aop);
10661 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10662 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10663 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10665 o->op_private &= ~1;
10666 o->op_private |= OPpENTERSUB_HASTARG;
10667 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10668 if (PERLDB_SUB && PL_curstash != PL_debstash)
10669 o->op_private |= OPpENTERSUB_DB;
10670 if (cvop->op_type == OP_RV2CV) {
10671 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10673 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10674 if (aop->op_type == OP_CONST)
10675 aop->op_private &= ~OPpCONST_STRICT;
10676 else if (aop->op_type == OP_LIST) {
10677 OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
10678 if (sib && sib->op_type == OP_CONST)
10679 sib->op_private &= ~OPpCONST_STRICT;
10684 return ck_entersub_args_list(o);
10686 Perl_call_checker ckfun;
10688 cv_get_call_checker(cv, &ckfun, &ckobj);
10689 if (!namegv) { /* expletive! */
10690 /* XXX The call checker API is public. And it guarantees that
10691 a GV will be provided with the right name. So we have
10692 to create a GV. But it is still not correct, as its
10693 stringification will include the package. What we
10694 really need is a new call checker API that accepts a
10695 GV or string (or GV or CV). */
10696 HEK * const hek = CvNAME_HEK(cv);
10697 /* After a syntax error in a lexical sub, the cv that
10698 rv2cv_op_cv returns may be a nameless stub. */
10699 if (!hek) return ck_entersub_args_list(o);;
10700 namegv = (GV *)sv_newmortal();
10701 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10702 SVf_UTF8 * !!HEK_UTF8(hek));
10704 return ckfun(aTHX_ o, namegv, ckobj);
10709 Perl_ck_svconst(pTHX_ OP *o)
10711 SV * const sv = cSVOPo->op_sv;
10712 PERL_ARGS_ASSERT_CK_SVCONST;
10713 PERL_UNUSED_CONTEXT;
10714 #ifdef PERL_OLD_COPY_ON_WRITE
10715 if (SvIsCOW(sv)) sv_force_normal(sv);
10716 #elif defined(PERL_NEW_COPY_ON_WRITE)
10717 /* Since the read-only flag may be used to protect a string buffer, we
10718 cannot do copy-on-write with existing read-only scalars that are not
10719 already copy-on-write scalars. To allow $_ = "hello" to do COW with
10720 that constant, mark the constant as COWable here, if it is not
10721 already read-only. */
10722 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10725 # ifdef PERL_DEBUG_READONLY_COW
10735 Perl_ck_trunc(pTHX_ OP *o)
10737 PERL_ARGS_ASSERT_CK_TRUNC;
10739 if (o->op_flags & OPf_KIDS) {
10740 SVOP *kid = (SVOP*)cUNOPo->op_first;
10742 if (kid->op_type == OP_NULL)
10743 kid = (SVOP*)OP_SIBLING(kid);
10744 if (kid && kid->op_type == OP_CONST &&
10745 (kid->op_private & OPpCONST_BARE) &&
10748 o->op_flags |= OPf_SPECIAL;
10749 kid->op_private &= ~OPpCONST_STRICT;
10756 Perl_ck_substr(pTHX_ OP *o)
10758 PERL_ARGS_ASSERT_CK_SUBSTR;
10761 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10762 OP *kid = cLISTOPo->op_first;
10764 if (kid->op_type == OP_NULL)
10765 kid = OP_SIBLING(kid);
10767 kid->op_flags |= OPf_MOD;
10774 Perl_ck_tell(pTHX_ OP *o)
10776 PERL_ARGS_ASSERT_CK_TELL;
10778 if (o->op_flags & OPf_KIDS) {
10779 OP *kid = cLISTOPo->op_first;
10780 if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
10781 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10787 Perl_ck_each(pTHX_ OP *o)
10790 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10791 const unsigned orig_type = o->op_type;
10792 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10793 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10794 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10795 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10797 PERL_ARGS_ASSERT_CK_EACH;
10800 switch (kid->op_type) {
10806 CHANGE_TYPE(o, array_type);
10809 if (kid->op_private == OPpCONST_BARE
10810 || !SvROK(cSVOPx_sv(kid))
10811 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10812 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10814 /* we let ck_fun handle it */
10817 CHANGE_TYPE(o, ref_type);
10821 /* if treating as a reference, defer additional checks to runtime */
10822 if (o->op_type == ref_type) {
10823 /* diag_listed_as: keys on reference is experimental */
10824 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
10825 "%s is experimental", PL_op_desc[ref_type]);
10832 Perl_ck_length(pTHX_ OP *o)
10834 PERL_ARGS_ASSERT_CK_LENGTH;
10838 if (ckWARN(WARN_SYNTAX)) {
10839 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10843 const bool hash = kid->op_type == OP_PADHV
10844 || kid->op_type == OP_RV2HV;
10845 switch (kid->op_type) {
10850 name = S_op_varname(aTHX_ kid);
10856 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10857 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10859 SVfARG(name), hash ? "keys " : "", SVfARG(name)
10862 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10863 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10864 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10866 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10867 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10868 "length() used on @array (did you mean \"scalar(@array)\"?)");
10875 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10876 and modify the optree to make them work inplace */
10879 S_inplace_aassign(pTHX_ OP *o) {
10881 OP *modop, *modop_pushmark;
10883 OP *oleft, *oleft_pushmark;
10885 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10887 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10889 assert(cUNOPo->op_first->op_type == OP_NULL);
10890 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10891 assert(modop_pushmark->op_type == OP_PUSHMARK);
10892 modop = OP_SIBLING(modop_pushmark);
10894 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10897 /* no other operation except sort/reverse */
10898 if (OP_HAS_SIBLING(modop))
10901 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10902 if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
10904 if (modop->op_flags & OPf_STACKED) {
10905 /* skip sort subroutine/block */
10906 assert(oright->op_type == OP_NULL);
10907 oright = OP_SIBLING(oright);
10910 assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
10911 oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
10912 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10913 oleft = OP_SIBLING(oleft_pushmark);
10915 /* Check the lhs is an array */
10917 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10918 || OP_HAS_SIBLING(oleft)
10919 || (oleft->op_private & OPpLVAL_INTRO)
10923 /* Only one thing on the rhs */
10924 if (OP_HAS_SIBLING(oright))
10927 /* check the array is the same on both sides */
10928 if (oleft->op_type == OP_RV2AV) {
10929 if (oright->op_type != OP_RV2AV
10930 || !cUNOPx(oright)->op_first
10931 || cUNOPx(oright)->op_first->op_type != OP_GV
10932 || cUNOPx(oleft )->op_first->op_type != OP_GV
10933 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10934 cGVOPx_gv(cUNOPx(oright)->op_first)
10938 else if (oright->op_type != OP_PADAV
10939 || oright->op_targ != oleft->op_targ
10943 /* This actually is an inplace assignment */
10945 modop->op_private |= OPpSORT_INPLACE;
10947 /* transfer MODishness etc from LHS arg to RHS arg */
10948 oright->op_flags = oleft->op_flags;
10950 /* remove the aassign op and the lhs */
10952 op_null(oleft_pushmark);
10953 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10954 op_null(cUNOPx(oleft)->op_first);
10960 /* mechanism for deferring recursion in rpeep() */
10962 #define MAX_DEFERRED 4
10966 if (defer_ix == (MAX_DEFERRED-1)) { \
10967 OP **defer = defer_queue[defer_base]; \
10968 CALL_RPEEP(*defer); \
10969 S_prune_chain_head(defer); \
10970 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10973 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
10976 #define IS_AND_OP(o) (o->op_type == OP_AND)
10977 #define IS_OR_OP(o) (o->op_type == OP_OR)
10981 S_null_listop_in_list_context(pTHX_ OP *o)
10985 PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
10987 /* This is an OP_LIST in list context. That means we
10988 * can ditch the OP_LIST and the OP_PUSHMARK within. */
10990 kid = cLISTOPo->op_first;
10991 /* Find the end of the chain of OPs executed within the OP_LIST. */
10992 while (kid->op_next != o)
10993 kid = kid->op_next;
10995 kid->op_next = o->op_next; /* patch list out of exec chain */
10996 op_null(cUNOPo->op_first); /* NULL the pushmark */
10997 op_null(o); /* NULL the list */
11000 /* A peephole optimizer. We visit the ops in the order they're to execute.
11001 * See the comments at the top of this file for more details about when
11002 * peep() is called */
11005 Perl_rpeep(pTHX_ OP *o)
11009 OP* oldoldop = NULL;
11010 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11011 int defer_base = 0;
11016 if (!o || o->op_opt)
11020 SAVEVPTR(PL_curcop);
11021 for (;; o = o->op_next) {
11022 if (o && o->op_opt)
11025 while (defer_ix >= 0) {
11027 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
11028 CALL_RPEEP(*defer);
11029 S_prune_chain_head(defer);
11034 /* By default, this op has now been optimised. A couple of cases below
11035 clear this again. */
11040 /* The following will have the OP_LIST and OP_PUSHMARK
11041 * patched out later IF the OP_LIST is in list context.
11042 * So in that case, we can set the this OP's op_next
11043 * to skip to after the OP_PUSHMARK:
11049 * will eventually become:
11052 * - ex-pushmark -> -
11058 OP *other_pushmark;
11059 if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
11060 && (sibling = OP_SIBLING(o))
11061 && sibling->op_type == OP_LIST
11062 /* This KIDS check is likely superfluous since OP_LIST
11063 * would otherwise be an OP_STUB. */
11064 && sibling->op_flags & OPf_KIDS
11065 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
11066 && (other_pushmark = cLISTOPx(sibling)->op_first)
11067 /* Pointer equality also effectively checks that it's a
11069 && other_pushmark == o->op_next)
11071 o->op_next = other_pushmark->op_next;
11072 null_listop_in_list_context(sibling);
11076 switch (o->op_type) {
11078 PL_curcop = ((COP*)o); /* for warnings */
11081 PL_curcop = ((COP*)o); /* for warnings */
11083 /* Optimise a "return ..." at the end of a sub to just be "...".
11084 * This saves 2 ops. Before:
11085 * 1 <;> nextstate(main 1 -e:1) v ->2
11086 * 4 <@> return K ->5
11087 * 2 <0> pushmark s ->3
11088 * - <1> ex-rv2sv sK/1 ->4
11089 * 3 <#> gvsv[*cat] s ->4
11092 * - <@> return K ->-
11093 * - <0> pushmark s ->2
11094 * - <1> ex-rv2sv sK/1 ->-
11095 * 2 <$> gvsv(*cat) s ->3
11098 OP *next = o->op_next;
11099 OP *sibling = OP_SIBLING(o);
11100 if ( OP_TYPE_IS(next, OP_PUSHMARK)
11101 && OP_TYPE_IS(sibling, OP_RETURN)
11102 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
11103 && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
11104 && cUNOPx(sibling)->op_first == next
11105 && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
11108 /* Look through the PUSHMARK's siblings for one that
11109 * points to the RETURN */
11110 OP *top = OP_SIBLING(next);
11111 while (top && top->op_next) {
11112 if (top->op_next == sibling) {
11113 top->op_next = sibling->op_next;
11114 o->op_next = next->op_next;
11117 top = OP_SIBLING(top);
11122 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
11124 * This latter form is then suitable for conversion into padrange
11125 * later on. Convert:
11127 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
11131 * nextstate1 -> listop -> nextstate3
11133 * pushmark -> padop1 -> padop2
11135 if (o->op_next && (
11136 o->op_next->op_type == OP_PADSV
11137 || o->op_next->op_type == OP_PADAV
11138 || o->op_next->op_type == OP_PADHV
11140 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
11141 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
11142 && o->op_next->op_next->op_next && (
11143 o->op_next->op_next->op_next->op_type == OP_PADSV
11144 || o->op_next->op_next->op_next->op_type == OP_PADAV
11145 || o->op_next->op_next->op_next->op_type == OP_PADHV
11147 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
11148 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
11149 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
11150 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
11152 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
11155 ns2 = pad1->op_next;
11156 pad2 = ns2->op_next;
11157 ns3 = pad2->op_next;
11159 /* we assume here that the op_next chain is the same as
11160 * the op_sibling chain */
11161 assert(OP_SIBLING(o) == pad1);
11162 assert(OP_SIBLING(pad1) == ns2);
11163 assert(OP_SIBLING(ns2) == pad2);
11164 assert(OP_SIBLING(pad2) == ns3);
11166 /* create new listop, with children consisting of:
11167 * a new pushmark, pad1, pad2. */
11168 OP_SIBLING_set(pad2, NULL);
11169 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
11170 newop->op_flags |= OPf_PARENS;
11171 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11172 newpm = cUNOPx(newop)->op_first; /* pushmark */
11174 /* Kill nextstate2 between padop1/padop2 */
11177 o ->op_next = newpm;
11178 newpm->op_next = pad1;
11179 pad1 ->op_next = pad2;
11180 pad2 ->op_next = newop; /* listop */
11181 newop->op_next = ns3;
11183 OP_SIBLING_set(o, newop);
11184 OP_SIBLING_set(newop, ns3);
11185 newop->op_lastsib = 0;
11187 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11189 /* Ensure pushmark has this flag if padops do */
11190 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
11191 o->op_next->op_flags |= OPf_MOD;
11197 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11198 to carry two labels. For now, take the easier option, and skip
11199 this optimisation if the first NEXTSTATE has a label. */
11200 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
11201 OP *nextop = o->op_next;
11202 while (nextop && nextop->op_type == OP_NULL)
11203 nextop = nextop->op_next;
11205 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11206 COP *firstcop = (COP *)o;
11207 COP *secondcop = (COP *)nextop;
11208 /* We want the COP pointed to by o (and anything else) to
11209 become the next COP down the line. */
11210 cop_free(firstcop);
11212 firstcop->op_next = secondcop->op_next;
11214 /* Now steal all its pointers, and duplicate the other
11216 firstcop->cop_line = secondcop->cop_line;
11217 #ifdef USE_ITHREADS
11218 firstcop->cop_stashoff = secondcop->cop_stashoff;
11219 firstcop->cop_file = secondcop->cop_file;
11221 firstcop->cop_stash = secondcop->cop_stash;
11222 firstcop->cop_filegv = secondcop->cop_filegv;
11224 firstcop->cop_hints = secondcop->cop_hints;
11225 firstcop->cop_seq = secondcop->cop_seq;
11226 firstcop->cop_warnings = secondcop->cop_warnings;
11227 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11229 #ifdef USE_ITHREADS
11230 secondcop->cop_stashoff = 0;
11231 secondcop->cop_file = NULL;
11233 secondcop->cop_stash = NULL;
11234 secondcop->cop_filegv = NULL;
11236 secondcop->cop_warnings = NULL;
11237 secondcop->cop_hints_hash = NULL;
11239 /* If we use op_null(), and hence leave an ex-COP, some
11240 warnings are misreported. For example, the compile-time
11241 error in 'use strict; no strict refs;' */
11242 secondcop->op_type = OP_NULL;
11243 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11249 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11250 if (o->op_next->op_private & OPpTARGET_MY) {
11251 if (o->op_flags & OPf_STACKED) /* chained concats */
11252 break; /* ignore_optimization */
11254 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11255 o->op_targ = o->op_next->op_targ;
11256 o->op_next->op_targ = 0;
11257 o->op_private |= OPpTARGET_MY;
11260 op_null(o->op_next);
11264 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11265 break; /* Scalar stub must produce undef. List stub is noop */
11269 if (o->op_targ == OP_NEXTSTATE
11270 || o->op_targ == OP_DBSTATE)
11272 PL_curcop = ((COP*)o);
11274 /* XXX: We avoid setting op_seq here to prevent later calls
11275 to rpeep() from mistakenly concluding that optimisation
11276 has already occurred. This doesn't fix the real problem,
11277 though (See 20010220.007). AMS 20010719 */
11278 /* op_seq functionality is now replaced by op_opt */
11286 oldop->op_next = o->op_next;
11294 /* Convert a series of PAD ops for my vars plus support into a
11295 * single padrange op. Basically
11297 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11299 * becomes, depending on circumstances, one of
11301 * padrange ----------------------------------> (list) -> rest
11302 * padrange --------------------------------------------> rest
11304 * where all the pad indexes are sequential and of the same type
11306 * We convert the pushmark into a padrange op, then skip
11307 * any other pad ops, and possibly some trailing ops.
11308 * Note that we don't null() the skipped ops, to make it
11309 * easier for Deparse to undo this optimisation (and none of
11310 * the skipped ops are holding any resourses). It also makes
11311 * it easier for find_uninit_var(), as it can just ignore
11312 * padrange, and examine the original pad ops.
11316 OP *followop = NULL; /* the op that will follow the padrange op */
11319 PADOFFSET base = 0; /* init only to stop compiler whining */
11320 U8 gimme = 0; /* init only to stop compiler whining */
11321 bool defav = 0; /* seen (...) = @_ */
11322 bool reuse = 0; /* reuse an existing padrange op */
11324 /* look for a pushmark -> gv[_] -> rv2av */
11330 if ( p->op_type == OP_GV
11331 && (gv = cGVOPx_gv(p))
11332 && GvNAMELEN_get(gv) == 1
11333 && *GvNAME_get(gv) == '_'
11334 && GvSTASH(gv) == PL_defstash
11335 && (rv2av = p->op_next)
11336 && rv2av->op_type == OP_RV2AV
11337 && !(rv2av->op_flags & OPf_REF)
11338 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11339 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11340 && OP_SIBLING(o) == rv2av /* these two for Deparse */
11341 && cUNOPx(rv2av)->op_first == p
11343 q = rv2av->op_next;
11344 if (q->op_type == OP_NULL)
11346 if (q->op_type == OP_PUSHMARK) {
11353 /* To allow Deparse to pessimise this, it needs to be able
11354 * to restore the pushmark's original op_next, which it
11355 * will assume to be the same as OP_SIBLING. */
11356 if (o->op_next != OP_SIBLING(o))
11361 /* scan for PAD ops */
11363 for (p = p->op_next; p; p = p->op_next) {
11364 if (p->op_type == OP_NULL)
11367 if (( p->op_type != OP_PADSV
11368 && p->op_type != OP_PADAV
11369 && p->op_type != OP_PADHV
11371 /* any private flag other than INTRO? e.g. STATE */
11372 || (p->op_private & ~OPpLVAL_INTRO)
11376 /* let $a[N] potentially be optimised into AELEMFAST_LEX
11378 if ( p->op_type == OP_PADAV
11380 && p->op_next->op_type == OP_CONST
11381 && p->op_next->op_next
11382 && p->op_next->op_next->op_type == OP_AELEM
11386 /* for 1st padop, note what type it is and the range
11387 * start; for the others, check that it's the same type
11388 * and that the targs are contiguous */
11390 intro = (p->op_private & OPpLVAL_INTRO);
11392 gimme = (p->op_flags & OPf_WANT);
11395 if ((p->op_private & OPpLVAL_INTRO) != intro)
11397 /* Note that you'd normally expect targs to be
11398 * contiguous in my($a,$b,$c), but that's not the case
11399 * when external modules start doing things, e.g.
11400 i* Function::Parameters */
11401 if (p->op_targ != base + count)
11403 assert(p->op_targ == base + count);
11404 /* all the padops should be in the same context */
11405 if (gimme != (p->op_flags & OPf_WANT))
11409 /* for AV, HV, only when we're not flattening */
11410 if ( p->op_type != OP_PADSV
11411 && gimme != OPf_WANT_VOID
11412 && !(p->op_flags & OPf_REF)
11416 if (count >= OPpPADRANGE_COUNTMASK)
11419 /* there's a biggest base we can fit into a
11420 * SAVEt_CLEARPADRANGE in pp_padrange */
11421 if (intro && base >
11422 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11425 /* Success! We've got another valid pad op to optimise away */
11427 followop = p->op_next;
11433 /* pp_padrange in specifically compile-time void context
11434 * skips pushing a mark and lexicals; in all other contexts
11435 * (including unknown till runtime) it pushes a mark and the
11436 * lexicals. We must be very careful then, that the ops we
11437 * optimise away would have exactly the same effect as the
11439 * In particular in void context, we can only optimise to
11440 * a padrange if see see the complete sequence
11441 * pushmark, pad*v, ...., list, nextstate
11442 * which has the net effect of of leaving the stack empty
11443 * (for now we leave the nextstate in the execution chain, for
11444 * its other side-effects).
11447 if (gimme == OPf_WANT_VOID) {
11448 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
11449 && gimme == (followop->op_flags & OPf_WANT)
11450 && ( followop->op_next->op_type == OP_NEXTSTATE
11451 || followop->op_next->op_type == OP_DBSTATE))
11453 followop = followop->op_next; /* skip OP_LIST */
11455 /* consolidate two successive my(...);'s */
11458 && oldoldop->op_type == OP_PADRANGE
11459 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11460 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11461 && !(oldoldop->op_flags & OPf_SPECIAL)
11464 assert(oldoldop->op_next == oldop);
11465 assert( oldop->op_type == OP_NEXTSTATE
11466 || oldop->op_type == OP_DBSTATE);
11467 assert(oldop->op_next == o);
11470 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11472 /* Do not assume pad offsets for $c and $d are con-
11477 if ( oldoldop->op_targ + old_count == base
11478 && old_count < OPpPADRANGE_COUNTMASK - count) {
11479 base = oldoldop->op_targ;
11480 count += old_count;
11485 /* if there's any immediately following singleton
11486 * my var's; then swallow them and the associated
11488 * my ($a,$b); my $c; my $d;
11490 * my ($a,$b,$c,$d);
11493 while ( ((p = followop->op_next))
11494 && ( p->op_type == OP_PADSV
11495 || p->op_type == OP_PADAV
11496 || p->op_type == OP_PADHV)
11497 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11498 && (p->op_private & OPpLVAL_INTRO) == intro
11499 && !(p->op_private & ~OPpLVAL_INTRO)
11501 && ( p->op_next->op_type == OP_NEXTSTATE
11502 || p->op_next->op_type == OP_DBSTATE)
11503 && count < OPpPADRANGE_COUNTMASK
11504 && base + count == p->op_targ
11507 followop = p->op_next;
11515 assert(oldoldop->op_type == OP_PADRANGE);
11516 oldoldop->op_next = followop;
11517 oldoldop->op_private = (intro | count);
11523 /* Convert the pushmark into a padrange.
11524 * To make Deparse easier, we guarantee that a padrange was
11525 * *always* formerly a pushmark */
11526 assert(o->op_type == OP_PUSHMARK);
11527 o->op_next = followop;
11528 o->op_type = OP_PADRANGE;
11529 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11531 /* bit 7: INTRO; bit 6..0: count */
11532 o->op_private = (intro | count);
11533 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11534 | gimme | (defav ? OPf_SPECIAL : 0));
11541 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11542 OP* const pop = (o->op_type == OP_PADAV) ?
11543 o->op_next : o->op_next->op_next;
11545 if (pop && pop->op_type == OP_CONST &&
11546 ((PL_op = pop->op_next)) &&
11547 pop->op_next->op_type == OP_AELEM &&
11548 !(pop->op_next->op_private &
11549 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11550 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
11553 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11554 no_bareword_allowed(pop);
11555 if (o->op_type == OP_GV)
11556 op_null(o->op_next);
11557 op_null(pop->op_next);
11559 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11560 o->op_next = pop->op_next->op_next;
11561 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11562 o->op_private = (U8)i;
11563 if (o->op_type == OP_GV) {
11566 o->op_type = OP_AELEMFAST;
11569 o->op_type = OP_AELEMFAST_LEX;
11574 if (o->op_next->op_type == OP_RV2SV) {
11575 if (!(o->op_next->op_private & OPpDEREF)) {
11576 op_null(o->op_next);
11577 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11579 o->op_next = o->op_next->op_next;
11580 o->op_type = OP_GVSV;
11581 o->op_ppaddr = PL_ppaddr[OP_GVSV];
11584 else if (o->op_next->op_type == OP_READLINE
11585 && o->op_next->op_next->op_type == OP_CONCAT
11586 && (o->op_next->op_next->op_flags & OPf_STACKED))
11588 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11589 o->op_type = OP_RCATLINE;
11590 o->op_flags |= OPf_STACKED;
11591 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11592 op_null(o->op_next->op_next);
11593 op_null(o->op_next);
11598 #define HV_OR_SCALARHV(op) \
11599 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11601 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11602 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11603 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11604 ? cUNOPx(op)->op_first \
11608 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11609 fop->op_private |= OPpTRUEBOOL;
11615 fop = cLOGOP->op_first;
11616 sop = OP_SIBLING(fop);
11617 while (cLOGOP->op_other->op_type == OP_NULL)
11618 cLOGOP->op_other = cLOGOP->op_other->op_next;
11619 while (o->op_next && ( o->op_type == o->op_next->op_type
11620 || o->op_next->op_type == OP_NULL))
11621 o->op_next = o->op_next->op_next;
11623 /* if we're an OR and our next is a AND in void context, we'll
11624 follow it's op_other on short circuit, same for reverse.
11625 We can't do this with OP_DOR since if it's true, its return
11626 value is the underlying value which must be evaluated
11630 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
11631 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
11633 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
11635 o->op_next = ((LOGOP*)o->op_next)->op_other;
11637 DEFER(cLOGOP->op_other);
11640 fop = HV_OR_SCALARHV(fop);
11641 if (sop) sop = HV_OR_SCALARHV(sop);
11646 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11647 while (nop && nop->op_next) {
11648 switch (nop->op_next->op_type) {
11653 lop = nop = nop->op_next;
11656 nop = nop->op_next;
11665 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11666 || o->op_type == OP_AND )
11667 fop->op_private |= OPpTRUEBOOL;
11668 else if (!(lop->op_flags & OPf_WANT))
11669 fop->op_private |= OPpMAYBE_TRUEBOOL;
11671 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11673 sop->op_private |= OPpTRUEBOOL;
11680 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11681 fop->op_private |= OPpTRUEBOOL;
11682 #undef HV_OR_SCALARHV
11683 /* GERONIMO! */ /* FALLTHROUGH */
11692 while (cLOGOP->op_other->op_type == OP_NULL)
11693 cLOGOP->op_other = cLOGOP->op_other->op_next;
11694 DEFER(cLOGOP->op_other);
11699 while (cLOOP->op_redoop->op_type == OP_NULL)
11700 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11701 while (cLOOP->op_nextop->op_type == OP_NULL)
11702 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11703 while (cLOOP->op_lastop->op_type == OP_NULL)
11704 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11705 /* a while(1) loop doesn't have an op_next that escapes the
11706 * loop, so we have to explicitly follow the op_lastop to
11707 * process the rest of the code */
11708 DEFER(cLOOP->op_lastop);
11712 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
11713 DEFER(cLOGOPo->op_other);
11717 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11718 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11719 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11720 cPMOP->op_pmstashstartu.op_pmreplstart
11721 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11722 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11728 if (o->op_flags & OPf_SPECIAL) {
11729 /* first arg is a code block */
11730 OP * const nullop = OP_SIBLING(cLISTOP->op_first);
11731 OP * kid = cUNOPx(nullop)->op_first;
11733 assert(nullop->op_type == OP_NULL);
11734 assert(kid->op_type == OP_SCOPE
11735 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
11736 /* since OP_SORT doesn't have a handy op_other-style
11737 * field that can point directly to the start of the code
11738 * block, store it in the otherwise-unused op_next field
11739 * of the top-level OP_NULL. This will be quicker at
11740 * run-time, and it will also allow us to remove leading
11741 * OP_NULLs by just messing with op_nexts without
11742 * altering the basic op_first/op_sibling layout. */
11743 kid = kLISTOP->op_first;
11745 (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
11746 || kid->op_type == OP_STUB
11747 || kid->op_type == OP_ENTER);
11748 nullop->op_next = kLISTOP->op_next;
11749 DEFER(nullop->op_next);
11752 /* check that RHS of sort is a single plain array */
11753 oright = cUNOPo->op_first;
11754 if (!oright || oright->op_type != OP_PUSHMARK)
11757 if (o->op_private & OPpSORT_INPLACE)
11760 /* reverse sort ... can be optimised. */
11761 if (!OP_HAS_SIBLING(cUNOPo)) {
11762 /* Nothing follows us on the list. */
11763 OP * const reverse = o->op_next;
11765 if (reverse->op_type == OP_REVERSE &&
11766 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11767 OP * const pushmark = cUNOPx(reverse)->op_first;
11768 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11769 && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
11770 /* reverse -> pushmark -> sort */
11771 o->op_private |= OPpSORT_REVERSE;
11773 pushmark->op_next = oright->op_next;
11783 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11785 LISTOP *enter, *exlist;
11787 if (o->op_private & OPpSORT_INPLACE)
11790 enter = (LISTOP *) o->op_next;
11793 if (enter->op_type == OP_NULL) {
11794 enter = (LISTOP *) enter->op_next;
11798 /* for $a (...) will have OP_GV then OP_RV2GV here.
11799 for (...) just has an OP_GV. */
11800 if (enter->op_type == OP_GV) {
11801 gvop = (OP *) enter;
11802 enter = (LISTOP *) enter->op_next;
11805 if (enter->op_type == OP_RV2GV) {
11806 enter = (LISTOP *) enter->op_next;
11812 if (enter->op_type != OP_ENTERITER)
11815 iter = enter->op_next;
11816 if (!iter || iter->op_type != OP_ITER)
11819 expushmark = enter->op_first;
11820 if (!expushmark || expushmark->op_type != OP_NULL
11821 || expushmark->op_targ != OP_PUSHMARK)
11824 exlist = (LISTOP *) OP_SIBLING(expushmark);
11825 if (!exlist || exlist->op_type != OP_NULL
11826 || exlist->op_targ != OP_LIST)
11829 if (exlist->op_last != o) {
11830 /* Mmm. Was expecting to point back to this op. */
11833 theirmark = exlist->op_first;
11834 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11837 if (OP_SIBLING(theirmark) != o) {
11838 /* There's something between the mark and the reverse, eg
11839 for (1, reverse (...))
11844 ourmark = ((LISTOP *)o)->op_first;
11845 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11848 ourlast = ((LISTOP *)o)->op_last;
11849 if (!ourlast || ourlast->op_next != o)
11852 rv2av = OP_SIBLING(ourmark);
11853 if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av)
11854 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11855 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11856 /* We're just reversing a single array. */
11857 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11858 enter->op_flags |= OPf_STACKED;
11861 /* We don't have control over who points to theirmark, so sacrifice
11863 theirmark->op_next = ourmark->op_next;
11864 theirmark->op_flags = ourmark->op_flags;
11865 ourlast->op_next = gvop ? gvop : (OP *) enter;
11868 enter->op_private |= OPpITER_REVERSED;
11869 iter->op_private |= OPpITER_REVERSED;
11876 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11877 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11882 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11884 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11886 sv = newRV((SV *)PL_compcv);
11890 o->op_type = OP_CONST;
11891 o->op_ppaddr = PL_ppaddr[OP_CONST];
11892 o->op_flags |= OPf_SPECIAL;
11893 cSVOPo->op_sv = sv;
11898 if (OP_GIMME(o,0) == G_VOID) {
11899 OP *right = cBINOP->op_first;
11918 OP *left = OP_SIBLING(right);
11919 if (left->op_type == OP_SUBSTR
11920 && (left->op_private & 7) < 4) {
11922 /* cut out right */
11923 op_sibling_splice(o, NULL, 1, NULL);
11924 /* and insert it as second child of OP_SUBSTR */
11925 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
11927 left->op_private |= OPpSUBSTR_REPL_FIRST;
11929 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11936 Perl_cpeep_t cpeep =
11937 XopENTRYCUSTOM(o, xop_peep);
11939 cpeep(aTHX_ o, oldop);
11944 /* did we just null the current op? If so, re-process it to handle
11945 * eliding "empty" ops from the chain */
11946 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
11959 Perl_peep(pTHX_ OP *o)
11965 =head1 Custom Operators
11967 =for apidoc Ao||custom_op_xop
11968 Return the XOP structure for a given custom op. This macro should be
11969 considered internal to OP_NAME and the other access macros: use them instead.
11970 This macro does call a function. Prior
11971 to 5.19.6, this was implemented as a
11978 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
11984 static const XOP xop_null = { 0, 0, 0, 0, 0 };
11986 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
11987 assert(o->op_type == OP_CUSTOM);
11989 /* This is wrong. It assumes a function pointer can be cast to IV,
11990 * which isn't guaranteed, but this is what the old custom OP code
11991 * did. In principle it should be safer to Copy the bytes of the
11992 * pointer into a PV: since the new interface is hidden behind
11993 * functions, this can be changed later if necessary. */
11994 /* Change custom_op_xop if this ever happens */
11995 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
11998 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12000 /* assume noone will have just registered a desc */
12001 if (!he && PL_custom_op_names &&
12002 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
12007 /* XXX does all this need to be shared mem? */
12008 Newxz(xop, 1, XOP);
12009 pv = SvPV(HeVAL(he), l);
12010 XopENTRY_set(xop, xop_name, savepvn(pv, l));
12011 if (PL_custom_op_descs &&
12012 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
12014 pv = SvPV(HeVAL(he), l);
12015 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
12017 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
12021 xop = (XOP *)&xop_null;
12023 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
12027 if(field == XOPe_xop_ptr) {
12030 const U32 flags = XopFLAGS(xop);
12031 if(flags & field) {
12033 case XOPe_xop_name:
12034 any.xop_name = xop->xop_name;
12036 case XOPe_xop_desc:
12037 any.xop_desc = xop->xop_desc;
12039 case XOPe_xop_class:
12040 any.xop_class = xop->xop_class;
12042 case XOPe_xop_peep:
12043 any.xop_peep = xop->xop_peep;
12051 case XOPe_xop_name:
12052 any.xop_name = XOPd_xop_name;
12054 case XOPe_xop_desc:
12055 any.xop_desc = XOPd_xop_desc;
12057 case XOPe_xop_class:
12058 any.xop_class = XOPd_xop_class;
12060 case XOPe_xop_peep:
12061 any.xop_peep = XOPd_xop_peep;
12069 /* Some gcc releases emit a warning for this function:
12070 * op.c: In function 'Perl_custom_op_get_field':
12071 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
12072 * Whether this is true, is currently unknown. */
12078 =for apidoc Ao||custom_op_register
12079 Register a custom op. See L<perlguts/"Custom Operators">.
12085 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
12089 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
12091 /* see the comment in custom_op_xop */
12092 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
12094 if (!PL_custom_ops)
12095 PL_custom_ops = newHV();
12097 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
12098 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
12103 =for apidoc core_prototype
12105 This function assigns the prototype of the named core function to C<sv>, or
12106 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
12107 NULL if the core function has no prototype. C<code> is a code as returned
12108 by C<keyword()>. It must not be equal to 0.
12114 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
12117 int i = 0, n = 0, seen_question = 0, defgv = 0;
12119 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
12120 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
12121 bool nullret = FALSE;
12123 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
12127 if (!sv) sv = sv_newmortal();
12129 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
12131 switch (code < 0 ? -code : code) {
12132 case KEY_and : case KEY_chop: case KEY_chomp:
12133 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
12134 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
12135 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
12136 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
12137 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
12138 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
12139 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
12140 case KEY_x : case KEY_xor :
12141 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
12142 case KEY_glob: retsetpvs("_;", OP_GLOB);
12143 case KEY_keys: retsetpvs("+", OP_KEYS);
12144 case KEY_values: retsetpvs("+", OP_VALUES);
12145 case KEY_each: retsetpvs("+", OP_EACH);
12146 case KEY_push: retsetpvs("+@", OP_PUSH);
12147 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
12148 case KEY_pop: retsetpvs(";+", OP_POP);
12149 case KEY_shift: retsetpvs(";+", OP_SHIFT);
12150 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
12152 retsetpvs("+;$$@", OP_SPLICE);
12153 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
12155 case KEY_evalbytes:
12156 name = "entereval"; break;
12164 while (i < MAXO) { /* The slow way. */
12165 if (strEQ(name, PL_op_name[i])
12166 || strEQ(name, PL_op_desc[i]))
12168 if (nullret) { assert(opnum); *opnum = i; return NULL; }
12175 defgv = PL_opargs[i] & OA_DEFGV;
12176 oa = PL_opargs[i] >> OASHIFT;
12178 if (oa & OA_OPTIONAL && !seen_question && (
12179 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
12184 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
12185 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
12186 /* But globs are already references (kinda) */
12187 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
12191 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
12192 && !scalar_mod_type(NULL, i)) {
12197 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
12201 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
12202 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
12203 str[n-1] = '_'; defgv = 0;
12207 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
12209 sv_setpvn(sv, str, n - 1);
12210 if (opnum) *opnum = i;
12215 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
12218 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
12221 PERL_ARGS_ASSERT_CORESUB_OP;
12225 return op_append_elem(OP_LINESEQ,
12228 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
12232 case OP_SELECT: /* which represents OP_SSELECT as well */
12237 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12238 newSVOP(OP_CONST, 0, newSVuv(1))
12240 coresub_op(newSVuv((UV)OP_SSELECT), 0,
12242 coresub_op(coreargssv, 0, OP_SELECT)
12246 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12248 return op_append_elem(
12251 opnum == OP_WANTARRAY || opnum == OP_RUNCV
12252 ? OPpOFFBYONE << 8 : 0)
12254 case OA_BASEOP_OR_UNOP:
12255 if (opnum == OP_ENTEREVAL) {
12256 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12257 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12259 else o = newUNOP(opnum,0,argop);
12260 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12263 if (is_handle_constructor(o, 1))
12264 argop->op_private |= OPpCOREARGS_DEREF1;
12265 if (scalar_mod_type(NULL, opnum))
12266 argop->op_private |= OPpCOREARGS_SCALARMOD;
12270 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
12271 if (is_handle_constructor(o, 2))
12272 argop->op_private |= OPpCOREARGS_DEREF2;
12273 if (opnum == OP_SUBSTR) {
12274 o->op_private |= OPpMAYBE_LVSUB;
12283 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12284 SV * const *new_const_svp)
12286 const char *hvname;
12287 bool is_const = !!CvCONST(old_cv);
12288 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12290 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12292 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12294 /* They are 2 constant subroutines generated from
12295 the same constant. This probably means that
12296 they are really the "same" proxy subroutine
12297 instantiated in 2 places. Most likely this is
12298 when a constant is exported twice. Don't warn.
12301 (ckWARN(WARN_REDEFINE)
12303 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12304 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12305 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12306 strEQ(hvname, "autouse"))
12310 && ckWARN_d(WARN_REDEFINE)
12311 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
12314 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12316 ? "Constant subroutine %"SVf" redefined"
12317 : "Subroutine %"SVf" redefined",
12322 =head1 Hook manipulation
12324 These functions provide convenient and thread-safe means of manipulating
12331 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12333 Puts a C function into the chain of check functions for a specified op
12334 type. This is the preferred way to manipulate the L</PL_check> array.
12335 I<opcode> specifies which type of op is to be affected. I<new_checker>
12336 is a pointer to the C function that is to be added to that opcode's
12337 check chain, and I<old_checker_p> points to the storage location where a
12338 pointer to the next function in the chain will be stored. The value of
12339 I<new_pointer> is written into the L</PL_check> array, while the value
12340 previously stored there is written to I<*old_checker_p>.
12342 The function should be defined like this:
12344 static OP *new_checker(pTHX_ OP *op) { ... }
12346 It is intended to be called in this manner:
12348 new_checker(aTHX_ op)
12350 I<old_checker_p> should be defined like this:
12352 static Perl_check_t old_checker_p;
12354 L</PL_check> is global to an entire process, and a module wishing to
12355 hook op checking may find itself invoked more than once per process,
12356 typically in different threads. To handle that situation, this function
12357 is idempotent. The location I<*old_checker_p> must initially (once
12358 per process) contain a null pointer. A C variable of static duration
12359 (declared at file scope, typically also marked C<static> to give
12360 it internal linkage) will be implicitly initialised appropriately,
12361 if it does not have an explicit initialiser. This function will only
12362 actually modify the check chain if it finds I<*old_checker_p> to be null.
12363 This function is also thread safe on the small scale. It uses appropriate
12364 locking to avoid race conditions in accessing L</PL_check>.
12366 When this function is called, the function referenced by I<new_checker>
12367 must be ready to be called, except for I<*old_checker_p> being unfilled.
12368 In a threading situation, I<new_checker> may be called immediately,
12369 even before this function has returned. I<*old_checker_p> will always
12370 be appropriately set before I<new_checker> is called. If I<new_checker>
12371 decides not to do anything special with an op that it is given (which
12372 is the usual case for most uses of op check hooking), it must chain the
12373 check function referenced by I<*old_checker_p>.
12375 If you want to influence compilation of calls to a specific subroutine,
12376 then use L</cv_set_call_checker> rather than hooking checking of all
12383 Perl_wrap_op_checker(pTHX_ Optype opcode,
12384 Perl_check_t new_checker, Perl_check_t *old_checker_p)
12388 PERL_UNUSED_CONTEXT;
12389 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12390 if (*old_checker_p) return;
12391 OP_CHECK_MUTEX_LOCK;
12392 if (!*old_checker_p) {
12393 *old_checker_p = PL_check[opcode];
12394 PL_check[opcode] = new_checker;
12396 OP_CHECK_MUTEX_UNLOCK;
12401 /* Efficient sub that returns a constant scalar value. */
12403 const_sv_xsub(pTHX_ CV* cv)
12406 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12407 PERL_UNUSED_ARG(items);
12417 const_av_xsub(pTHX_ CV* cv)
12420 AV * const av = MUTABLE_AV(XSANY.any_ptr);
12428 if (SvRMAGICAL(av))
12429 Perl_croak(aTHX_ "Magical list constants are not supported");
12430 if (GIMME_V != G_ARRAY) {
12432 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
12435 EXTEND(SP, AvFILLp(av)+1);
12436 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12437 XSRETURN(AvFILLp(av)+1);
12442 * c-indentation-style: bsd
12443 * c-basic-offset: 4
12444 * indent-tabs-mode: nil
12447 * ex: set ts=8 sts=4 sw=4 et: