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);
7673 move_proto_attr(&proto, &attrs, gv);
7676 assert(proto->op_type == OP_CONST);
7677 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7678 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7692 if (name) SvREFCNT_dec(PL_compcv);
7693 else cv = PL_compcv;
7695 if (name && block) {
7696 const char *s = strrchr(name, ':');
7698 if (strEQ(s, "BEGIN")) {
7699 if (PL_in_eval & EVAL_KEEPERR)
7700 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7702 SV * const errsv = ERRSV;
7703 /* force display of errors found but not reported */
7704 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7705 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7712 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
7713 maximum a prototype before. */
7714 if (SvTYPE(gv) > SVt_NULL) {
7715 cv_ckproto_len_flags((const CV *)gv,
7716 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7720 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7721 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7724 sv_setiv(MUTABLE_SV(gv), -1);
7726 SvREFCNT_dec(PL_compcv);
7727 cv = PL_compcv = NULL;
7731 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7733 if (!block || !ps || *ps || attrs
7734 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7738 const_sv = op_const_sv(block, NULL);
7741 const bool exists = CvROOT(cv) || CvXSUB(cv);
7743 /* if the subroutine doesn't exist and wasn't pre-declared
7744 * with a prototype, assume it will be AUTOLOADed,
7745 * skipping the prototype check
7747 if (exists || SvPOK(cv))
7748 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7749 /* already defined (or promised)? */
7750 if (exists || GvASSUMECV(gv)) {
7751 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7754 if (attrs) goto attrs;
7755 /* just a "sub foo;" when &foo is already defined */
7756 SAVEFREESV(PL_compcv);
7762 SvREFCNT_inc_simple_void_NN(const_sv);
7763 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7765 assert(!CvROOT(cv) && !CvCONST(cv));
7767 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7768 CvXSUBANY(cv).any_ptr = const_sv;
7769 CvXSUB(cv) = const_sv_xsub;
7775 cv = newCONSTSUB_flags(
7776 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7781 SvREFCNT_dec(PL_compcv);
7785 if (cv) { /* must reuse cv if autoloaded */
7786 /* transfer PL_compcv to cv */
7789 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7790 PADLIST *const temp_av = CvPADLIST(cv);
7791 CV *const temp_cv = CvOUTSIDE(cv);
7792 const cv_flags_t other_flags =
7793 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7794 OP * const cvstart = CvSTART(cv);
7797 assert(!CvCVGV_RC(cv));
7798 assert(CvGV(cv) == gv);
7801 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7802 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7803 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7804 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7805 CvOUTSIDE(PL_compcv) = temp_cv;
7806 CvPADLIST(PL_compcv) = temp_av;
7807 CvSTART(cv) = CvSTART(PL_compcv);
7808 CvSTART(PL_compcv) = cvstart;
7809 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7810 CvFLAGS(PL_compcv) |= other_flags;
7812 if (CvFILE(cv) && CvDYNFILE(cv)) {
7813 Safefree(CvFILE(cv));
7815 CvFILE_set_from_cop(cv, PL_curcop);
7816 CvSTASH_set(cv, PL_curstash);
7818 /* inner references to PL_compcv must be fixed up ... */
7819 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7820 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7821 ++PL_sub_generation;
7824 /* Might have had built-in attributes applied -- propagate them. */
7825 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7827 /* ... before we throw it away */
7828 SvREFCNT_dec(PL_compcv);
7836 if (HvENAME_HEK(GvSTASH(gv)))
7837 /* sub Foo::bar { (shift)+1 } */
7838 gv_method_changed(gv);
7843 CvFILE_set_from_cop(cv, PL_curcop);
7844 CvSTASH_set(cv, PL_curstash);
7848 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7849 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7855 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7856 the debugger could be able to set a breakpoint in, so signal to
7857 pp_entereval that it should not throw away any saved lines at scope
7860 PL_breakable_sub_gen++;
7861 /* This makes sub {}; work as expected. */
7862 if (block->op_type == OP_STUB) {
7863 OP* const newblock = newSTATEOP(0, NULL, 0);
7867 CvROOT(cv) = CvLVALUE(cv)
7868 ? newUNOP(OP_LEAVESUBLV, 0,
7869 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7870 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7871 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7872 OpREFCNT_set(CvROOT(cv), 1);
7873 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7874 itself has a refcount. */
7876 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7877 #ifdef PERL_DEBUG_READONLY_OPS
7878 slab = (OPSLAB *)CvSTART(cv);
7880 CvSTART(cv) = LINKLIST(CvROOT(cv));
7881 CvROOT(cv)->op_next = 0;
7882 CALL_PEEP(CvSTART(cv));
7883 finalize_optree(CvROOT(cv));
7884 S_prune_chain_head(&CvSTART(cv));
7886 /* now that optimizer has done its work, adjust pad values */
7888 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7891 assert(!CvCONST(cv));
7892 if (ps && !*ps && op_const_sv(block, cv))
7898 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7899 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7900 if (!name) SAVEFREESV(cv);
7901 apply_attrs(stash, MUTABLE_SV(cv), attrs);
7902 if (!name) SvREFCNT_inc_simple_void_NN(cv);
7905 if (block && has_name) {
7906 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7907 SV * const tmpstr = sv_newmortal();
7908 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7909 GV_ADDMULTI, SVt_PVHV);
7911 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7914 (long)CopLINE(PL_curcop));
7915 gv_efullname3(tmpstr, gv, NULL);
7916 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7917 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7918 hv = GvHVn(db_postponed);
7919 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7920 CV * const pcv = GvCV(db_postponed);
7926 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7932 if (PL_parser && PL_parser->error_count)
7933 clear_special_blocks(name, gv, cv);
7935 process_special_blocks(floor, name, gv, cv);
7941 PL_parser->copline = NOLINE;
7943 #ifdef PERL_DEBUG_READONLY_OPS
7944 /* Watch out for BEGIN blocks */
7945 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7951 S_clear_special_blocks(pTHX_ const char *const fullname,
7952 GV *const gv, CV *const cv) {
7956 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
7958 colon = strrchr(fullname,':');
7959 name = colon ? colon + 1 : fullname;
7961 if ((*name == 'B' && strEQ(name, "BEGIN"))
7962 || (*name == 'E' && strEQ(name, "END"))
7963 || (*name == 'U' && strEQ(name, "UNITCHECK"))
7964 || (*name == 'C' && strEQ(name, "CHECK"))
7965 || (*name == 'I' && strEQ(name, "INIT"))) {
7967 SvREFCNT_dec_NN(MUTABLE_SV(cv));
7972 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7976 const char *const colon = strrchr(fullname,':');
7977 const char *const name = colon ? colon + 1 : fullname;
7979 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7982 if (strEQ(name, "BEGIN")) {
7983 const I32 oldscope = PL_scopestack_ix;
7985 if (floor) LEAVE_SCOPE(floor);
7987 PUSHSTACKi(PERLSI_REQUIRE);
7988 SAVECOPFILE(&PL_compiling);
7989 SAVECOPLINE(&PL_compiling);
7990 SAVEVPTR(PL_curcop);
7992 DEBUG_x( dump_sub(gv) );
7993 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7994 GvCV_set(gv,0); /* cv has been hijacked */
7995 call_list(oldscope, PL_beginav);
8004 if strEQ(name, "END") {
8005 DEBUG_x( dump_sub(gv) );
8006 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8009 } else if (*name == 'U') {
8010 if (strEQ(name, "UNITCHECK")) {
8011 /* It's never too late to run a unitcheck block */
8012 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8016 } else if (*name == 'C') {
8017 if (strEQ(name, "CHECK")) {
8019 /* diag_listed_as: Too late to run %s block */
8020 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8021 "Too late to run CHECK block");
8022 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8026 } else if (*name == 'I') {
8027 if (strEQ(name, "INIT")) {
8029 /* diag_listed_as: Too late to run %s block */
8030 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8031 "Too late to run INIT block");
8032 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8038 DEBUG_x( dump_sub(gv) );
8039 GvCV_set(gv,0); /* cv has been hijacked */
8044 =for apidoc newCONSTSUB
8046 See L</newCONSTSUB_flags>.
8052 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8054 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8058 =for apidoc newCONSTSUB_flags
8060 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8061 eligible for inlining at compile-time.
8063 Currently, the only useful value for C<flags> is SVf_UTF8.
8065 The newly created subroutine takes ownership of a reference to the passed in
8068 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8069 which won't be called if used as a destructor, but will suppress the overhead
8070 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8077 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8081 const char *const file = CopFILE(PL_curcop);
8085 if (IN_PERL_RUNTIME) {
8086 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8087 * an op shared between threads. Use a non-shared COP for our
8089 SAVEVPTR(PL_curcop);
8090 SAVECOMPILEWARNINGS();
8091 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8092 PL_curcop = &PL_compiling;
8094 SAVECOPLINE(PL_curcop);
8095 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8098 PL_hints &= ~HINT_BLOCK_SCOPE;
8101 SAVEGENERICSV(PL_curstash);
8102 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8105 /* Protect sv against leakage caused by fatal warnings. */
8106 if (sv) SAVEFREESV(sv);
8108 /* file becomes the CvFILE. For an XS, it's usually static storage,
8109 and so doesn't get free()d. (It's expected to be from the C pre-
8110 processor __FILE__ directive). But we need a dynamically allocated one,
8111 and we need it to get freed. */
8112 cv = newXS_len_flags(name, len,
8113 sv && SvTYPE(sv) == SVt_PVAV
8116 file ? file : "", "",
8117 &sv, XS_DYNAMIC_FILENAME | flags);
8118 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8127 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8128 const char *const filename, const char *const proto,
8131 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8132 return newXS_len_flags(
8133 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8138 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8139 XSUBADDR_t subaddr, const char *const filename,
8140 const char *const proto, SV **const_svp,
8144 bool interleave = FALSE;
8146 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8149 GV * const gv = gv_fetchpvn(
8150 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8151 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8152 sizeof("__ANON__::__ANON__") - 1,
8153 GV_ADDMULTI | flags, SVt_PVCV);
8156 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8158 if ((cv = (name ? GvCV(gv) : NULL))) {
8160 /* just a cached method */
8164 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8165 /* already defined (or promised) */
8166 /* Redundant check that allows us to avoid creating an SV
8167 most of the time: */
8168 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8169 report_redefined_cv(newSVpvn_flags(
8170 name,len,(flags&SVf_UTF8)|SVs_TEMP
8181 if (cv) /* must reuse cv if autoloaded */
8184 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8188 if (HvENAME_HEK(GvSTASH(gv)))
8189 gv_method_changed(gv); /* newXS */
8195 (void)gv_fetchfile(filename);
8196 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8197 an external constant string */
8198 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8200 CvXSUB(cv) = subaddr;
8203 process_special_blocks(0, name, gv, cv);
8206 if (flags & XS_DYNAMIC_FILENAME) {
8207 CvFILE(cv) = savepv(filename);
8210 sv_setpv(MUTABLE_SV(cv), proto);
8211 if (interleave) LEAVE;
8216 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8218 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8220 PERL_ARGS_ASSERT_NEWSTUB;
8224 if (!fake && HvENAME_HEK(GvSTASH(gv)))
8225 gv_method_changed(gv);
8227 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8232 CvFILE_set_from_cop(cv, PL_curcop);
8233 CvSTASH_set(cv, PL_curstash);
8239 =for apidoc U||newXS
8241 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
8242 static storage, as it is used directly as CvFILE(), without a copy being made.
8248 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8250 PERL_ARGS_ASSERT_NEWXS;
8251 return newXS_len_flags(
8252 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8257 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8263 if (PL_parser && PL_parser->error_count) {
8269 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8270 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8273 if ((cv = GvFORM(gv))) {
8274 if (ckWARN(WARN_REDEFINE)) {
8275 const line_t oldline = CopLINE(PL_curcop);
8276 if (PL_parser && PL_parser->copline != NOLINE)
8277 CopLINE_set(PL_curcop, PL_parser->copline);
8279 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8280 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8282 /* diag_listed_as: Format %s redefined */
8283 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8284 "Format STDOUT redefined");
8286 CopLINE_set(PL_curcop, oldline);
8291 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8293 CvFILE_set_from_cop(cv, PL_curcop);
8296 pad_tidy(padtidy_FORMAT);
8297 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8298 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8299 OpREFCNT_set(CvROOT(cv), 1);
8300 CvSTART(cv) = LINKLIST(CvROOT(cv));
8301 CvROOT(cv)->op_next = 0;
8302 CALL_PEEP(CvSTART(cv));
8303 finalize_optree(CvROOT(cv));
8304 S_prune_chain_head(&CvSTART(cv));
8310 PL_parser->copline = NOLINE;
8315 Perl_newANONLIST(pTHX_ OP *o)
8317 return convert(OP_ANONLIST, OPf_SPECIAL, o);
8321 Perl_newANONHASH(pTHX_ OP *o)
8323 return convert(OP_ANONHASH, OPf_SPECIAL, o);
8327 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8329 return newANONATTRSUB(floor, proto, NULL, block);
8333 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8335 return newUNOP(OP_REFGEN, 0,
8336 newSVOP(OP_ANONCODE, 0,
8337 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8341 Perl_oopsAV(pTHX_ OP *o)
8345 PERL_ARGS_ASSERT_OOPSAV;
8347 switch (o->op_type) {
8350 o->op_type = OP_PADAV;
8351 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8352 return ref(o, OP_RV2AV);
8356 o->op_type = OP_RV2AV;
8357 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8362 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8369 Perl_oopsHV(pTHX_ OP *o)
8373 PERL_ARGS_ASSERT_OOPSHV;
8375 switch (o->op_type) {
8378 o->op_type = OP_PADHV;
8379 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8380 return ref(o, OP_RV2HV);
8384 o->op_type = OP_RV2HV;
8385 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8390 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8397 Perl_newAVREF(pTHX_ OP *o)
8401 PERL_ARGS_ASSERT_NEWAVREF;
8403 if (o->op_type == OP_PADANY) {
8404 o->op_type = OP_PADAV;
8405 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8408 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8409 Perl_croak(aTHX_ "Can't use an array as a reference");
8411 return newUNOP(OP_RV2AV, 0, scalar(o));
8415 Perl_newGVREF(pTHX_ I32 type, OP *o)
8417 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8418 return newUNOP(OP_NULL, 0, o);
8419 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8423 Perl_newHVREF(pTHX_ OP *o)
8427 PERL_ARGS_ASSERT_NEWHVREF;
8429 if (o->op_type == OP_PADANY) {
8430 o->op_type = OP_PADHV;
8431 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8434 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8435 Perl_croak(aTHX_ "Can't use a hash as a reference");
8437 return newUNOP(OP_RV2HV, 0, scalar(o));
8441 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8443 if (o->op_type == OP_PADANY) {
8445 o->op_type = OP_PADCV;
8446 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8448 return newUNOP(OP_RV2CV, flags, scalar(o));
8452 Perl_newSVREF(pTHX_ OP *o)
8456 PERL_ARGS_ASSERT_NEWSVREF;
8458 if (o->op_type == OP_PADANY) {
8459 o->op_type = OP_PADSV;
8460 o->op_ppaddr = PL_ppaddr[OP_PADSV];
8463 return newUNOP(OP_RV2SV, 0, scalar(o));
8466 /* Check routines. See the comments at the top of this file for details
8467 * on when these are called */
8470 Perl_ck_anoncode(pTHX_ OP *o)
8472 PERL_ARGS_ASSERT_CK_ANONCODE;
8474 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8475 cSVOPo->op_sv = NULL;
8480 S_io_hints(pTHX_ OP *o)
8482 #if O_BINARY != 0 || O_TEXT != 0
8484 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8486 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8489 const char *d = SvPV_const(*svp, len);
8490 const I32 mode = mode_from_discipline(d, len);
8491 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8493 if (mode & O_BINARY)
8494 o->op_private |= OPpOPEN_IN_RAW;
8498 o->op_private |= OPpOPEN_IN_CRLF;
8502 svp = hv_fetchs(table, "open_OUT", FALSE);
8505 const char *d = SvPV_const(*svp, len);
8506 const I32 mode = mode_from_discipline(d, len);
8507 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8509 if (mode & O_BINARY)
8510 o->op_private |= OPpOPEN_OUT_RAW;
8514 o->op_private |= OPpOPEN_OUT_CRLF;
8519 PERL_UNUSED_CONTEXT;
8525 Perl_ck_backtick(pTHX_ OP *o)
8530 PERL_ARGS_ASSERT_CK_BACKTICK;
8531 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8532 if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
8533 && (gv = gv_override("readpipe",8)))
8535 /* detach rest of siblings from o and its first child */
8536 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
8537 newop = S_new_entersubop(aTHX_ gv, sibl);
8539 else if (!(o->op_flags & OPf_KIDS))
8540 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8545 S_io_hints(aTHX_ o);
8550 Perl_ck_bitop(pTHX_ OP *o)
8552 PERL_ARGS_ASSERT_CK_BITOP;
8554 o->op_private = (U8)(PL_hints & HINT_INTEGER);
8555 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8556 && (o->op_type == OP_BIT_OR
8557 || o->op_type == OP_BIT_AND
8558 || o->op_type == OP_BIT_XOR))
8560 const OP * const left = cBINOPo->op_first;
8561 const OP * const right = OP_SIBLING(left);
8562 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8563 (left->op_flags & OPf_PARENS) == 0) ||
8564 (OP_IS_NUMCOMPARE(right->op_type) &&
8565 (right->op_flags & OPf_PARENS) == 0))
8566 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8567 "Possible precedence problem on bitwise %c operator",
8568 o->op_type == OP_BIT_OR ? '|'
8569 : o->op_type == OP_BIT_AND ? '&' : '^'
8575 PERL_STATIC_INLINE bool
8576 is_dollar_bracket(pTHX_ const OP * const o)
8579 PERL_UNUSED_CONTEXT;
8580 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8581 && (kid = cUNOPx(o)->op_first)
8582 && kid->op_type == OP_GV
8583 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8587 Perl_ck_cmp(pTHX_ OP *o)
8589 PERL_ARGS_ASSERT_CK_CMP;
8590 if (ckWARN(WARN_SYNTAX)) {
8591 const OP *kid = cUNOPo->op_first;
8594 ( is_dollar_bracket(aTHX_ kid)
8595 && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
8597 || ( kid->op_type == OP_CONST
8598 && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
8602 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8603 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8609 Perl_ck_concat(pTHX_ OP *o)
8611 const OP * const kid = cUNOPo->op_first;
8613 PERL_ARGS_ASSERT_CK_CONCAT;
8614 PERL_UNUSED_CONTEXT;
8616 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8617 !(kUNOP->op_first->op_flags & OPf_MOD))
8618 o->op_flags |= OPf_STACKED;
8623 Perl_ck_spair(pTHX_ OP *o)
8627 PERL_ARGS_ASSERT_CK_SPAIR;
8629 if (o->op_flags & OPf_KIDS) {
8633 const OPCODE type = o->op_type;
8634 o = modkids(ck_fun(o), type);
8635 kid = cUNOPo->op_first;
8636 kidkid = kUNOP->op_first;
8637 newop = OP_SIBLING(kidkid);
8639 const OPCODE type = newop->op_type;
8640 if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) ||
8641 type == OP_PADAV || type == OP_PADHV ||
8642 type == OP_RV2AV || type == OP_RV2HV)
8645 /* excise first sibling */
8646 op_sibling_splice(kid, NULL, 1, NULL);
8649 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8650 * and OP_CHOMP into OP_SCHOMP */
8651 o->op_ppaddr = PL_ppaddr[++o->op_type];
8656 Perl_ck_delete(pTHX_ OP *o)
8658 PERL_ARGS_ASSERT_CK_DELETE;
8662 if (o->op_flags & OPf_KIDS) {
8663 OP * const kid = cUNOPo->op_first;
8664 switch (kid->op_type) {
8666 o->op_flags |= OPf_SPECIAL;
8669 o->op_private |= OPpSLICE;
8672 o->op_flags |= OPf_SPECIAL;
8677 Perl_croak(aTHX_ "delete argument is index/value array slice,"
8678 " use array slice");
8680 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8683 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8684 "element or slice");
8686 if (kid->op_private & OPpLVAL_INTRO)
8687 o->op_private |= OPpLVAL_INTRO;
8694 Perl_ck_eof(pTHX_ OP *o)
8696 PERL_ARGS_ASSERT_CK_EOF;
8698 if (o->op_flags & OPf_KIDS) {
8700 if (cLISTOPo->op_first->op_type == OP_STUB) {
8702 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8707 kid = cLISTOPo->op_first;
8708 if (kid->op_type == OP_RV2GV)
8709 kid->op_private |= OPpALLOW_FAKE;
8715 Perl_ck_eval(pTHX_ OP *o)
8719 PERL_ARGS_ASSERT_CK_EVAL;
8721 PL_hints |= HINT_BLOCK_SCOPE;
8722 if (o->op_flags & OPf_KIDS) {
8723 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8726 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8729 /* cut whole sibling chain free from o */
8730 op_sibling_splice(o, NULL, -1, NULL);
8733 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
8734 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8736 /* establish postfix order */
8737 enter->op_next = (OP*)enter;
8739 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8740 o->op_type = OP_LEAVETRY;
8741 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8742 enter->op_other = o;
8751 const U8 priv = o->op_private;
8753 /* the newUNOP will recursively call ck_eval(), which will handle
8754 * all the stuff at the end of this function, like adding
8757 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8759 o->op_targ = (PADOFFSET)PL_hints;
8760 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8761 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8762 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8763 /* Store a copy of %^H that pp_entereval can pick up. */
8764 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8765 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8766 /* append hhop to only child */
8767 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
8769 o->op_private |= OPpEVAL_HAS_HH;
8771 if (!(o->op_private & OPpEVAL_BYTES)
8772 && FEATURE_UNIEVAL_IS_ENABLED)
8773 o->op_private |= OPpEVAL_UNICODE;
8778 Perl_ck_exec(pTHX_ OP *o)
8780 PERL_ARGS_ASSERT_CK_EXEC;
8782 if (o->op_flags & OPf_STACKED) {
8785 kid = OP_SIBLING(cUNOPo->op_first);
8786 if (kid->op_type == OP_RV2GV)
8795 Perl_ck_exists(pTHX_ OP *o)
8797 PERL_ARGS_ASSERT_CK_EXISTS;
8800 if (o->op_flags & OPf_KIDS) {
8801 OP * const kid = cUNOPo->op_first;
8802 if (kid->op_type == OP_ENTERSUB) {
8803 (void) ref(kid, o->op_type);
8804 if (kid->op_type != OP_RV2CV
8805 && !(PL_parser && PL_parser->error_count))
8807 "exists argument is not a subroutine name");
8808 o->op_private |= OPpEXISTS_SUB;
8810 else if (kid->op_type == OP_AELEM)
8811 o->op_flags |= OPf_SPECIAL;
8812 else if (kid->op_type != OP_HELEM)
8813 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8814 "element or a subroutine");
8821 Perl_ck_rvconst(pTHX_ OP *o)
8824 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8826 PERL_ARGS_ASSERT_CK_RVCONST;
8828 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8829 if (o->op_type == OP_RV2CV)
8830 o->op_private &= ~1;
8832 if (kid->op_type == OP_CONST) {
8835 SV * const kidsv = kid->op_sv;
8837 /* Is it a constant from cv_const_sv()? */
8838 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8839 SV * const rsv = SvRV(kidsv);
8840 const svtype type = SvTYPE(rsv);
8841 const char *badtype = NULL;
8843 switch (o->op_type) {
8845 if (type > SVt_PVMG)
8846 badtype = "a SCALAR";
8849 if (type != SVt_PVAV)
8850 badtype = "an ARRAY";
8853 if (type != SVt_PVHV)
8857 if (type != SVt_PVCV)
8862 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8865 if (SvTYPE(kidsv) == SVt_PVAV) return o;
8866 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8867 const char *badthing;
8868 switch (o->op_type) {
8870 badthing = "a SCALAR";
8873 badthing = "an ARRAY";
8876 badthing = "a HASH";
8884 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8885 SVfARG(kidsv), badthing);
8888 * This is a little tricky. We only want to add the symbol if we
8889 * didn't add it in the lexer. Otherwise we get duplicate strict
8890 * warnings. But if we didn't add it in the lexer, we must at
8891 * least pretend like we wanted to add it even if it existed before,
8892 * or we get possible typo warnings. OPpCONST_ENTERED says
8893 * whether the lexer already added THIS instance of this symbol.
8895 iscv = (o->op_type == OP_RV2CV) * 2;
8897 gv = gv_fetchsv(kidsv,
8898 iscv | !(kid->op_private & OPpCONST_ENTERED),
8901 : o->op_type == OP_RV2SV
8903 : o->op_type == OP_RV2AV
8905 : o->op_type == OP_RV2HV
8908 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8910 kid->op_type = OP_GV;
8911 SvREFCNT_dec(kid->op_sv);
8913 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8914 assert (sizeof(PADOP) <= sizeof(SVOP));
8915 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8916 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8918 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8920 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8922 kid->op_private = 0;
8923 kid->op_ppaddr = PL_ppaddr[OP_GV];
8924 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8932 Perl_ck_ftst(pTHX_ OP *o)
8935 const I32 type = o->op_type;
8937 PERL_ARGS_ASSERT_CK_FTST;
8939 if (o->op_flags & OPf_REF) {
8942 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8943 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8944 const OPCODE kidtype = kid->op_type;
8946 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8947 && !kid->op_folded) {
8948 OP * const newop = newGVOP(type, OPf_REF,
8949 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8953 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8954 o->op_private |= OPpFT_ACCESS;
8955 if (PL_check[kidtype] == Perl_ck_ftst
8956 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8957 o->op_private |= OPpFT_STACKED;
8958 kid->op_private |= OPpFT_STACKING;
8959 if (kidtype == OP_FTTTY && (
8960 !(kid->op_private & OPpFT_STACKED)
8961 || kid->op_private & OPpFT_AFTER_t
8963 o->op_private |= OPpFT_AFTER_t;
8968 if (type == OP_FTTTY)
8969 o = newGVOP(type, OPf_REF, PL_stdingv);
8971 o = newUNOP(type, 0, newDEFSVOP());
8977 Perl_ck_fun(pTHX_ OP *o)
8979 const int type = o->op_type;
8980 I32 oa = PL_opargs[type] >> OASHIFT;
8982 PERL_ARGS_ASSERT_CK_FUN;
8984 if (o->op_flags & OPf_STACKED) {
8985 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8988 return no_fh_allowed(o);
8991 if (o->op_flags & OPf_KIDS) {
8992 OP *prev_kid = NULL;
8993 OP *kid = cLISTOPo->op_first;
8995 bool seen_optional = FALSE;
8997 if (kid->op_type == OP_PUSHMARK ||
8998 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9001 kid = OP_SIBLING(kid);
9003 if (kid && kid->op_type == OP_COREARGS) {
9004 bool optional = FALSE;
9007 if (oa & OA_OPTIONAL) optional = TRUE;
9010 if (optional) o->op_private |= numargs;
9015 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9016 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9018 /* append kid to chain */
9019 op_sibling_splice(o, prev_kid, 0, kid);
9021 seen_optional = TRUE;
9028 /* list seen where single (scalar) arg expected? */
9029 if (numargs == 1 && !(oa >> 4)
9030 && kid->op_type == OP_LIST && type != OP_SCALAR)
9032 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9034 if (type != OP_DELETE) scalar(kid);
9045 if ((type == OP_PUSH || type == OP_UNSHIFT)
9046 && !OP_HAS_SIBLING(kid))
9047 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9048 "Useless use of %s with no values",
9051 if (kid->op_type == OP_CONST
9052 && ( !SvROK(cSVOPx_sv(kid))
9053 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9055 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9056 /* Defer checks to run-time if we have a scalar arg */
9057 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9058 op_lvalue(kid, type);
9061 /* diag_listed_as: push on reference is experimental */
9062 Perl_ck_warner_d(aTHX_
9063 packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9064 "%s on reference is experimental",
9069 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9070 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9071 op_lvalue(kid, type);
9075 /* replace kid with newop in chain */
9077 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9078 newop->op_next = newop;
9083 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9084 if (kid->op_type == OP_CONST &&
9085 (kid->op_private & OPpCONST_BARE))
9087 OP * const newop = newGVOP(OP_GV, 0,
9088 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9089 /* replace kid with newop in chain */
9090 op_sibling_splice(o, prev_kid, 1, newop);
9094 else if (kid->op_type == OP_READLINE) {
9095 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9096 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9099 I32 flags = OPf_SPECIAL;
9103 /* is this op a FH constructor? */
9104 if (is_handle_constructor(o,numargs)) {
9105 const char *name = NULL;
9108 bool want_dollar = TRUE;
9111 /* Set a flag to tell rv2gv to vivify
9112 * need to "prove" flag does not mean something
9113 * else already - NI-S 1999/05/07
9116 if (kid->op_type == OP_PADSV) {
9118 = PAD_COMPNAME_SV(kid->op_targ);
9119 name = SvPV_const(namesv, len);
9120 name_utf8 = SvUTF8(namesv);
9122 else if (kid->op_type == OP_RV2SV
9123 && kUNOP->op_first->op_type == OP_GV)
9125 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9127 len = GvNAMELEN(gv);
9128 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9130 else if (kid->op_type == OP_AELEM
9131 || kid->op_type == OP_HELEM)
9134 OP *op = ((BINOP*)kid)->op_first;
9138 const char * const a =
9139 kid->op_type == OP_AELEM ?
9141 if (((op->op_type == OP_RV2AV) ||
9142 (op->op_type == OP_RV2HV)) &&
9143 (firstop = ((UNOP*)op)->op_first) &&
9144 (firstop->op_type == OP_GV)) {
9145 /* packagevar $a[] or $h{} */
9146 GV * const gv = cGVOPx_gv(firstop);
9154 else if (op->op_type == OP_PADAV
9155 || op->op_type == OP_PADHV) {
9156 /* lexicalvar $a[] or $h{} */
9157 const char * const padname =
9158 PAD_COMPNAME_PV(op->op_targ);
9167 name = SvPV_const(tmpstr, len);
9168 name_utf8 = SvUTF8(tmpstr);
9173 name = "__ANONIO__";
9175 want_dollar = FALSE;
9177 op_lvalue(kid, type);
9181 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9182 namesv = PAD_SVl(targ);
9183 if (want_dollar && *name != '$')
9184 sv_setpvs(namesv, "$");
9186 sv_setpvs(namesv, "");
9187 sv_catpvn(namesv, name, len);
9188 if ( name_utf8 ) SvUTF8_on(namesv);
9192 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9194 kid->op_targ = targ;
9195 kid->op_private |= priv;
9201 if ((type == OP_UNDEF || type == OP_POS)
9202 && numargs == 1 && !(oa >> 4)
9203 && kid->op_type == OP_LIST)
9204 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9205 op_lvalue(scalar(kid), type);
9210 kid = OP_SIBLING(kid);
9212 /* FIXME - should the numargs or-ing move after the too many
9213 * arguments check? */
9214 o->op_private |= numargs;
9216 return too_many_arguments_pv(o,OP_DESC(o), 0);
9219 else if (PL_opargs[type] & OA_DEFGV) {
9220 /* Ordering of these two is important to keep f_map.t passing. */
9222 return newUNOP(type, 0, newDEFSVOP());
9226 while (oa & OA_OPTIONAL)
9228 if (oa && oa != OA_LIST)
9229 return too_few_arguments_pv(o,OP_DESC(o), 0);
9235 Perl_ck_glob(pTHX_ OP *o)
9239 PERL_ARGS_ASSERT_CK_GLOB;
9242 if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
9243 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9245 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9249 * \ null - const(wildcard)
9254 * \ mark - glob - rv2cv
9255 * | \ gv(CORE::GLOBAL::glob)
9257 * \ null - const(wildcard)
9259 o->op_flags |= OPf_SPECIAL;
9260 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9261 o = S_new_entersubop(aTHX_ gv, o);
9262 o = newUNOP(OP_NULL, 0, o);
9263 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9266 else o->op_flags &= ~OPf_SPECIAL;
9267 #if !defined(PERL_EXTERNAL_GLOB)
9270 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9271 newSVpvs("File::Glob"), NULL, NULL, NULL);
9274 #endif /* !PERL_EXTERNAL_GLOB */
9275 gv = (GV *)newSV(0);
9276 gv_init(gv, 0, "", 0, 0);
9278 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9279 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9285 Perl_ck_grep(pTHX_ OP *o)
9290 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9293 PERL_ARGS_ASSERT_CK_GREP;
9295 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9296 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9298 if (o->op_flags & OPf_STACKED) {
9299 kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
9300 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9301 return no_fh_allowed(o);
9302 o->op_flags &= ~OPf_STACKED;
9304 kid = OP_SIBLING(cLISTOPo->op_first);
9305 if (type == OP_MAPWHILE)
9310 if (PL_parser && PL_parser->error_count)
9312 kid = OP_SIBLING(cLISTOPo->op_first);
9313 if (kid->op_type != OP_NULL)
9314 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9315 kid = kUNOP->op_first;
9317 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
9318 gwop->op_ppaddr = PL_ppaddr[type];
9319 kid->op_next = (OP*)gwop;
9320 offset = pad_findmy_pvs("$_", 0);
9321 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9322 o->op_private = gwop->op_private = 0;
9323 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9326 o->op_private = gwop->op_private = OPpGREP_LEX;
9327 gwop->op_targ = o->op_targ = offset;
9330 kid = OP_SIBLING(cLISTOPo->op_first);
9331 for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
9332 op_lvalue(kid, OP_GREPSTART);
9338 Perl_ck_index(pTHX_ OP *o)
9340 PERL_ARGS_ASSERT_CK_INDEX;
9342 if (o->op_flags & OPf_KIDS) {
9343 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9345 kid = OP_SIBLING(kid); /* get past "big" */
9346 if (kid && kid->op_type == OP_CONST) {
9347 const bool save_taint = TAINT_get;
9348 SV *sv = kSVOP->op_sv;
9349 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9351 sv_copypv(sv, kSVOP->op_sv);
9352 SvREFCNT_dec_NN(kSVOP->op_sv);
9355 if (SvOK(sv)) fbm_compile(sv, 0);
9356 TAINT_set(save_taint);
9357 #ifdef NO_TAINT_SUPPORT
9358 PERL_UNUSED_VAR(save_taint);
9366 Perl_ck_lfun(pTHX_ OP *o)
9368 const OPCODE type = o->op_type;
9370 PERL_ARGS_ASSERT_CK_LFUN;
9372 return modkids(ck_fun(o), type);
9376 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
9378 PERL_ARGS_ASSERT_CK_DEFINED;
9380 if ((o->op_flags & OPf_KIDS)) {
9381 switch (cUNOPo->op_first->op_type) {
9384 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
9385 " (Maybe you should just omit the defined()?)");
9389 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
9390 " (Maybe you should just omit the defined()?)");
9401 Perl_ck_readline(pTHX_ OP *o)
9403 PERL_ARGS_ASSERT_CK_READLINE;
9405 if (o->op_flags & OPf_KIDS) {
9406 OP *kid = cLISTOPo->op_first;
9407 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9411 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9419 Perl_ck_rfun(pTHX_ OP *o)
9421 const OPCODE type = o->op_type;
9423 PERL_ARGS_ASSERT_CK_RFUN;
9425 return refkids(ck_fun(o), type);
9429 Perl_ck_listiob(pTHX_ OP *o)
9433 PERL_ARGS_ASSERT_CK_LISTIOB;
9435 kid = cLISTOPo->op_first;
9437 o = force_list(o, 1);
9438 kid = cLISTOPo->op_first;
9440 if (kid->op_type == OP_PUSHMARK)
9441 kid = OP_SIBLING(kid);
9442 if (kid && o->op_flags & OPf_STACKED)
9443 kid = OP_SIBLING(kid);
9444 else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */
9445 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9446 && !kid->op_folded) {
9447 o->op_flags |= OPf_STACKED; /* make it a filehandle */
9449 /* replace old const op with new OP_RV2GV parent */
9450 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
9452 kid = OP_SIBLING(kid);
9457 op_append_elem(o->op_type, o, newDEFSVOP());
9459 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9464 Perl_ck_smartmatch(pTHX_ OP *o)
9467 PERL_ARGS_ASSERT_CK_SMARTMATCH;
9468 if (0 == (o->op_flags & OPf_SPECIAL)) {
9469 OP *first = cBINOPo->op_first;
9470 OP *second = OP_SIBLING(first);
9472 /* Implicitly take a reference to an array or hash */
9474 /* remove the original two siblings, then add back the
9475 * (possibly different) first and second sibs.
9477 op_sibling_splice(o, NULL, 1, NULL);
9478 op_sibling_splice(o, NULL, 1, NULL);
9479 first = ref_array_or_hash(first);
9480 second = ref_array_or_hash(second);
9481 op_sibling_splice(o, NULL, 0, second);
9482 op_sibling_splice(o, NULL, 0, first);
9484 /* Implicitly take a reference to a regular expression */
9485 if (first->op_type == OP_MATCH) {
9486 first->op_type = OP_QR;
9487 first->op_ppaddr = PL_ppaddr[OP_QR];
9489 if (second->op_type == OP_MATCH) {
9490 second->op_type = OP_QR;
9491 second->op_ppaddr = PL_ppaddr[OP_QR];
9500 Perl_ck_sassign(pTHX_ OP *o)
9503 OP * const kid = cLISTOPo->op_first;
9505 PERL_ARGS_ASSERT_CK_SASSIGN;
9507 /* has a disposable target? */
9508 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9509 && !(kid->op_flags & OPf_STACKED)
9510 /* Cannot steal the second time! */
9511 && !(kid->op_private & OPpTARGET_MY)
9514 OP * const kkid = OP_SIBLING(kid);
9516 /* Can just relocate the target. */
9517 if (kkid && kkid->op_type == OP_PADSV
9518 && !(kkid->op_private & OPpLVAL_INTRO))
9520 kid->op_targ = kkid->op_targ;
9522 /* Now we do not need PADSV and SASSIGN.
9523 * first replace the PADSV with OP_SIBLING(o), then
9524 * detach kid and OP_SIBLING(o) from o */
9525 op_sibling_splice(o, kid, 1, OP_SIBLING(o));
9526 op_sibling_splice(o, NULL, -1, NULL);
9529 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9533 if (OP_HAS_SIBLING(kid)) {
9534 OP *kkid = OP_SIBLING(kid);
9535 /* For state variable assignment, kkid is a list op whose op_last
9537 if ((kkid->op_type == OP_PADSV ||
9538 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
9539 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9542 && (kkid->op_private & OPpLVAL_INTRO)
9543 && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
9544 const PADOFFSET target = kkid->op_targ;
9545 OP *const other = newOP(OP_PADSV,
9547 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9548 OP *const first = newOP(OP_NULL, 0);
9549 OP *const nullop = newCONDOP(0, first, o, other);
9550 OP *const condop = first->op_next;
9551 /* hijacking PADSTALE for uninitialized state variables */
9552 SvPADSTALE_on(PAD_SVl(target));
9554 condop->op_type = OP_ONCE;
9555 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9556 condop->op_targ = target;
9557 other->op_targ = target;
9559 /* Because we change the type of the op here, we will skip the
9560 assignment binop->op_last = OP_SIBLING(binop->op_first); at the
9561 end of Perl_newBINOP(). So need to do it here. */
9562 cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first);
9563 cBINOPo->op_first->op_lastsib = 0;
9564 cBINOPo->op_last ->op_lastsib = 1;
9565 #ifdef PERL_OP_PARENT
9566 cBINOPo->op_last->op_sibling = o;
9575 Perl_ck_match(pTHX_ OP *o)
9577 PERL_ARGS_ASSERT_CK_MATCH;
9579 if (o->op_type != OP_QR && PL_compcv) {
9580 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9581 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9582 o->op_targ = offset;
9583 o->op_private |= OPpTARGET_MY;
9586 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9587 o->op_private |= OPpRUNTIME;
9592 Perl_ck_method(pTHX_ OP *o)
9594 OP * const kid = cUNOPo->op_first;
9596 PERL_ARGS_ASSERT_CK_METHOD;
9598 if (kid->op_type == OP_CONST) {
9599 SV* sv = kSVOP->op_sv;
9600 const char * const method = SvPVX_const(sv);
9601 if (!(strchr(method, ':') || strchr(method, '\''))) {
9603 if (!SvIsCOW_shared_hash(sv)) {
9604 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9607 kSVOP->op_sv = NULL;
9609 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9618 Perl_ck_null(pTHX_ OP *o)
9620 PERL_ARGS_ASSERT_CK_NULL;
9621 PERL_UNUSED_CONTEXT;
9626 Perl_ck_open(pTHX_ OP *o)
9628 PERL_ARGS_ASSERT_CK_OPEN;
9630 S_io_hints(aTHX_ o);
9632 /* In case of three-arg dup open remove strictness
9633 * from the last arg if it is a bareword. */
9634 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9635 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
9639 if ((last->op_type == OP_CONST) && /* The bareword. */
9640 (last->op_private & OPpCONST_BARE) &&
9641 (last->op_private & OPpCONST_STRICT) &&
9642 (oa = OP_SIBLING(first)) && /* The fh. */
9643 (oa = OP_SIBLING(oa)) && /* The mode. */
9644 (oa->op_type == OP_CONST) &&
9645 SvPOK(((SVOP*)oa)->op_sv) &&
9646 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9647 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9648 (last == OP_SIBLING(oa))) /* The bareword. */
9649 last->op_private &= ~OPpCONST_STRICT;
9655 Perl_ck_repeat(pTHX_ OP *o)
9657 PERL_ARGS_ASSERT_CK_REPEAT;
9659 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9661 o->op_private |= OPpREPEAT_DOLIST;
9662 kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
9663 kids = force_list(kids, 1); /* promote them to a list */
9664 op_sibling_splice(o, NULL, 0, kids); /* and add back */
9672 Perl_ck_require(pTHX_ OP *o)
9676 PERL_ARGS_ASSERT_CK_REQUIRE;
9678 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9679 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9681 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9682 SV * const sv = kid->op_sv;
9683 U32 was_readonly = SvREADONLY(sv);
9691 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9696 for (; s < end; s++) {
9697 if (*s == ':' && s[1] == ':') {
9699 Move(s+2, s+1, end - s - 1, char);
9704 sv_catpvs(sv, ".pm");
9705 SvFLAGS(sv) |= was_readonly;
9709 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9710 /* handle override, if any */
9711 && (gv = gv_override("require", 7))) {
9713 if (o->op_flags & OPf_KIDS) {
9714 kid = cUNOPo->op_first;
9715 op_sibling_splice(o, NULL, -1, NULL);
9721 newop = S_new_entersubop(aTHX_ gv, kid);
9725 return scalar(ck_fun(o));
9729 Perl_ck_return(pTHX_ OP *o)
9733 PERL_ARGS_ASSERT_CK_RETURN;
9735 kid = OP_SIBLING(cLISTOPo->op_first);
9736 if (CvLVALUE(PL_compcv)) {
9737 for (; kid; kid = OP_SIBLING(kid))
9738 op_lvalue(kid, OP_LEAVESUBLV);
9745 Perl_ck_select(pTHX_ OP *o)
9750 PERL_ARGS_ASSERT_CK_SELECT;
9752 if (o->op_flags & OPf_KIDS) {
9753 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9754 if (kid && OP_HAS_SIBLING(kid)) {
9755 o->op_type = OP_SSELECT;
9756 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9758 return fold_constants(op_integerize(op_std_init(o)));
9762 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9763 if (kid && kid->op_type == OP_RV2GV)
9764 kid->op_private &= ~HINT_STRICT_REFS;
9769 Perl_ck_shift(pTHX_ OP *o)
9771 const I32 type = o->op_type;
9773 PERL_ARGS_ASSERT_CK_SHIFT;
9775 if (!(o->op_flags & OPf_KIDS)) {
9778 if (!CvUNIQUE(PL_compcv)) {
9779 o->op_flags |= OPf_SPECIAL;
9783 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9785 return newUNOP(type, 0, scalar(argop));
9787 return scalar(ck_fun(o));
9791 Perl_ck_sort(pTHX_ OP *o)
9796 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9799 PERL_ARGS_ASSERT_CK_SORT;
9802 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9804 const I32 sorthints = (I32)SvIV(*svp);
9805 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9806 o->op_private |= OPpSORT_QSORT;
9807 if ((sorthints & HINT_SORT_STABLE) != 0)
9808 o->op_private |= OPpSORT_STABLE;
9812 if (o->op_flags & OPf_STACKED)
9814 firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9816 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
9817 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9819 /* if the first arg is a code block, process it and mark sort as
9821 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9823 if (kid->op_type == OP_LEAVE)
9824 op_null(kid); /* wipe out leave */
9825 /* Prevent execution from escaping out of the sort block. */
9828 /* provide scalar context for comparison function/block */
9829 kid = scalar(firstkid);
9831 o->op_flags |= OPf_SPECIAL;
9834 firstkid = OP_SIBLING(firstkid);
9837 for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
9838 /* provide list context for arguments */
9841 op_lvalue(kid, OP_GREPSTART);
9847 /* for sort { X } ..., where X is one of
9848 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
9849 * elide the second child of the sort (the one containing X),
9850 * and set these flags as appropriate
9854 * Also, check and warn on lexical $a, $b.
9858 S_simplify_sort(pTHX_ OP *o)
9860 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9867 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9869 kid = kUNOP->op_first; /* get past null */
9870 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9871 && kid->op_type != OP_LEAVE)
9873 kid = kLISTOP->op_last; /* get past scope */
9874 switch(kid->op_type) {
9878 if (!have_scopeop) goto padkids;
9883 k = kid; /* remember this node*/
9884 if (kBINOP->op_first->op_type != OP_RV2SV
9885 || kBINOP->op_last ->op_type != OP_RV2SV)
9888 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9889 then used in a comparison. This catches most, but not
9890 all cases. For instance, it catches
9891 sort { my($a); $a <=> $b }
9893 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9894 (although why you'd do that is anyone's guess).
9898 if (!ckWARN(WARN_SYNTAX)) return;
9899 kid = kBINOP->op_first;
9901 if (kid->op_type == OP_PADSV) {
9902 SV * const name = PAD_COMPNAME_SV(kid->op_targ);
9903 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9904 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9905 /* diag_listed_as: "my %s" used in sort comparison */
9906 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9907 "\"%s %s\" used in sort comparison",
9908 SvPAD_STATE(name) ? "state" : "my",
9911 } while ((kid = OP_SIBLING(kid)));
9914 kid = kBINOP->op_first; /* get past cmp */
9915 if (kUNOP->op_first->op_type != OP_GV)
9917 kid = kUNOP->op_first; /* get past rv2sv */
9919 if (GvSTASH(gv) != PL_curstash)
9921 gvname = GvNAME(gv);
9922 if (*gvname == 'a' && gvname[1] == '\0')
9924 else if (*gvname == 'b' && gvname[1] == '\0')
9929 kid = k; /* back to cmp */
9930 /* already checked above that it is rv2sv */
9931 kid = kBINOP->op_last; /* down to 2nd arg */
9932 if (kUNOP->op_first->op_type != OP_GV)
9934 kid = kUNOP->op_first; /* get past rv2sv */
9936 if (GvSTASH(gv) != PL_curstash)
9938 gvname = GvNAME(gv);
9940 ? !(*gvname == 'a' && gvname[1] == '\0')
9941 : !(*gvname == 'b' && gvname[1] == '\0'))
9943 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9945 o->op_private |= OPpSORT_DESCEND;
9946 if (k->op_type == OP_NCMP)
9947 o->op_private |= OPpSORT_NUMERIC;
9948 if (k->op_type == OP_I_NCMP)
9949 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9950 kid = OP_SIBLING(cLISTOPo->op_first);
9951 /* cut out and delete old block (second sibling) */
9952 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
9957 Perl_ck_split(pTHX_ OP *o)
9962 PERL_ARGS_ASSERT_CK_SPLIT;
9964 if (o->op_flags & OPf_STACKED)
9965 return no_fh_allowed(o);
9967 kid = cLISTOPo->op_first;
9968 if (kid->op_type != OP_NULL)
9969 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9970 /* delete leading NULL node, then add a CONST if no other nodes */
9971 op_sibling_splice(o, NULL, 1,
9972 OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
9974 kid = cLISTOPo->op_first;
9976 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9977 /* remove kid, and replace with new optree */
9978 op_sibling_splice(o, NULL, 1, NULL);
9979 /* OPf_SPECIAL is used to trigger split " " behavior */
9980 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
9981 op_sibling_splice(o, NULL, 0, kid);
9984 kid->op_type = OP_PUSHRE;
9985 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9987 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9988 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9989 "Use of /g modifier is meaningless in split");
9992 if (!OP_HAS_SIBLING(kid))
9993 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9995 kid = OP_SIBLING(kid);
9999 if (!OP_HAS_SIBLING(kid))
10001 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10002 o->op_private |= OPpSPLIT_IMPLIM;
10004 assert(OP_HAS_SIBLING(kid));
10006 kid = OP_SIBLING(kid);
10009 if (OP_HAS_SIBLING(kid))
10010 return too_many_arguments_pv(o,OP_DESC(o), 0);
10016 Perl_ck_join(pTHX_ OP *o)
10018 const OP * const kid = OP_SIBLING(cLISTOPo->op_first);
10020 PERL_ARGS_ASSERT_CK_JOIN;
10022 if (kid && kid->op_type == OP_MATCH) {
10023 if (ckWARN(WARN_SYNTAX)) {
10024 const REGEXP *re = PM_GETRE(kPMOP);
10026 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10027 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10028 : newSVpvs_flags( "STRING", SVs_TEMP );
10029 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10030 "/%"SVf"/ should probably be written as \"%"SVf"\"",
10031 SVfARG(msg), SVfARG(msg));
10038 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10040 Examines an op, which is expected to identify a subroutine at runtime,
10041 and attempts to determine at compile time which subroutine it identifies.
10042 This is normally used during Perl compilation to determine whether
10043 a prototype can be applied to a function call. I<cvop> is the op
10044 being considered, normally an C<rv2cv> op. A pointer to the identified
10045 subroutine is returned, if it could be determined statically, and a null
10046 pointer is returned if it was not possible to determine statically.
10048 Currently, the subroutine can be identified statically if the RV that the
10049 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10050 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
10051 suitable if the constant value must be an RV pointing to a CV. Details of
10052 this process may change in future versions of Perl. If the C<rv2cv> op
10053 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10054 the subroutine statically: this flag is used to suppress compile-time
10055 magic on a subroutine call, forcing it to use default runtime behaviour.
10057 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10058 of a GV reference is modified. If a GV was examined and its CV slot was
10059 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10060 If the op is not optimised away, and the CV slot is later populated with
10061 a subroutine having a prototype, that flag eventually triggers the warning
10062 "called too early to check prototype".
10064 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10065 of returning a pointer to the subroutine it returns a pointer to the
10066 GV giving the most appropriate name for the subroutine in this context.
10067 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10068 (C<CvANON>) subroutine that is referenced through a GV it will be the
10069 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
10070 A null pointer is returned as usual if there is no statically-determinable
10076 /* shared by toke.c:yylex */
10078 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10080 PADNAME *name = PAD_COMPNAME(off);
10081 CV *compcv = PL_compcv;
10082 while (PadnameOUTER(name)) {
10083 assert(PARENT_PAD_INDEX(name));
10084 compcv = CvOUTSIDE(PL_compcv);
10085 name = PadlistNAMESARRAY(CvPADLIST(compcv))
10086 [off = PARENT_PAD_INDEX(name)];
10088 assert(!PadnameIsOUR(name));
10089 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10090 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10092 assert(mg->mg_obj);
10093 return (CV *)mg->mg_obj;
10095 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10099 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10104 PERL_ARGS_ASSERT_RV2CV_OP_CV;
10105 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
10106 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10107 if (cvop->op_type != OP_RV2CV)
10109 if (cvop->op_private & OPpENTERSUB_AMPER)
10111 if (!(cvop->op_flags & OPf_KIDS))
10113 rvop = cUNOPx(cvop)->op_first;
10114 switch (rvop->op_type) {
10116 gv = cGVOPx_gv(rvop);
10119 if (flags & RV2CVOPCV_MARK_EARLY)
10120 rvop->op_private |= OPpEARLY_CV;
10125 SV *rv = cSVOPx_sv(rvop);
10128 cv = (CV*)SvRV(rv);
10132 cv = find_lexical_cv(rvop->op_targ);
10137 } NOT_REACHED; /* NOTREACHED */
10139 if (SvTYPE((SV*)cv) != SVt_PVCV)
10141 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10142 if (!CvANON(cv) || !gv)
10151 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10153 Performs the default fixup of the arguments part of an C<entersub>
10154 op tree. This consists of applying list context to each of the
10155 argument ops. This is the standard treatment used on a call marked
10156 with C<&>, or a method call, or a call through a subroutine reference,
10157 or any other call where the callee can't be identified at compile time,
10158 or a call where the callee has no prototype.
10164 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10167 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10168 aop = cUNOPx(entersubop)->op_first;
10169 if (!OP_HAS_SIBLING(aop))
10170 aop = cUNOPx(aop)->op_first;
10171 for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
10173 op_lvalue(aop, OP_ENTERSUB);
10179 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10181 Performs the fixup of the arguments part of an C<entersub> op tree
10182 based on a subroutine prototype. This makes various modifications to
10183 the argument ops, from applying context up to inserting C<refgen> ops,
10184 and checking the number and syntactic types of arguments, as directed by
10185 the prototype. This is the standard treatment used on a subroutine call,
10186 not marked with C<&>, where the callee can be identified at compile time
10187 and has a prototype.
10189 I<protosv> supplies the subroutine prototype to be applied to the call.
10190 It may be a normal defined scalar, of which the string value will be used.
10191 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10192 that has been cast to C<SV*>) which has a prototype. The prototype
10193 supplied, in whichever form, does not need to match the actual callee
10194 referenced by the op tree.
10196 If the argument ops disagree with the prototype, for example by having
10197 an unacceptable number of arguments, a valid op tree is returned anyway.
10198 The error is reflected in the parser state, normally resulting in a single
10199 exception at the top level of parsing which covers all the compilation
10200 errors that occurred. In the error message, the callee is referred to
10201 by the name defined by the I<namegv> parameter.
10207 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10210 const char *proto, *proto_end;
10211 OP *aop, *prev, *cvop, *parent;
10214 I32 contextclass = 0;
10215 const char *e = NULL;
10216 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10217 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10218 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10219 "flags=%lx", (unsigned long) SvFLAGS(protosv));
10220 if (SvTYPE(protosv) == SVt_PVCV)
10221 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10222 else proto = SvPV(protosv, proto_len);
10223 proto = S_strip_spaces(aTHX_ proto, &proto_len);
10224 proto_end = proto + proto_len;
10225 parent = entersubop;
10226 aop = cUNOPx(entersubop)->op_first;
10227 if (!OP_HAS_SIBLING(aop)) {
10229 aop = cUNOPx(aop)->op_first;
10232 aop = OP_SIBLING(aop);
10233 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10234 while (aop != cvop) {
10237 if (proto >= proto_end)
10238 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10246 /* _ must be at the end */
10247 if (proto[1] && !strchr(";@%", proto[1]))
10263 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10265 arg == 1 ? "block or sub {}" : "sub {}",
10269 /* '*' allows any scalar type, including bareword */
10272 if (o3->op_type == OP_RV2GV)
10273 goto wrapref; /* autoconvert GLOB -> GLOBref */
10274 else if (o3->op_type == OP_CONST)
10275 o3->op_private &= ~OPpCONST_STRICT;
10276 else if (o3->op_type == OP_ENTERSUB) {
10277 /* accidental subroutine, revert to bareword */
10278 OP *gvop = ((UNOP*)o3)->op_first;
10279 if (gvop && gvop->op_type == OP_NULL) {
10280 gvop = ((UNOP*)gvop)->op_first;
10282 for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop))
10285 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10286 (gvop = ((UNOP*)gvop)->op_first) &&
10287 gvop->op_type == OP_GV)
10290 GV * const gv = cGVOPx_gv(gvop);
10291 SV * const n = newSVpvs("");
10292 gv_fullname4(n, gv, "", FALSE);
10293 /* replace the aop subtree with a const op */
10294 newop = newSVOP(OP_CONST, 0, n);
10295 op_sibling_splice(parent, prev, 1, newop);
10307 if (o3->op_type == OP_RV2AV ||
10308 o3->op_type == OP_PADAV ||
10309 o3->op_type == OP_RV2HV ||
10310 o3->op_type == OP_PADHV
10316 case '[': case ']':
10323 switch (*proto++) {
10325 if (contextclass++ == 0) {
10326 e = strchr(proto, ']');
10327 if (!e || e == proto)
10335 if (contextclass) {
10336 const char *p = proto;
10337 const char *const end = proto;
10339 while (*--p != '[')
10340 /* \[$] accepts any scalar lvalue */
10342 && Perl_op_lvalue_flags(aTHX_
10344 OP_READ, /* not entersub */
10347 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10348 (int)(end - p), p),
10354 if (o3->op_type == OP_RV2GV)
10357 bad_type_gv(arg, "symbol", namegv, 0, o3);
10360 if (o3->op_type == OP_ENTERSUB)
10363 bad_type_gv(arg, "subroutine entry", namegv, 0,
10367 if (o3->op_type == OP_RV2SV ||
10368 o3->op_type == OP_PADSV ||
10369 o3->op_type == OP_HELEM ||
10370 o3->op_type == OP_AELEM)
10372 if (!contextclass) {
10373 /* \$ accepts any scalar lvalue */
10374 if (Perl_op_lvalue_flags(aTHX_
10376 OP_READ, /* not entersub */
10379 bad_type_gv(arg, "scalar", namegv, 0, o3);
10383 if (o3->op_type == OP_RV2AV ||
10384 o3->op_type == OP_PADAV)
10387 bad_type_gv(arg, "array", namegv, 0, o3);
10390 if (o3->op_type == OP_RV2HV ||
10391 o3->op_type == OP_PADHV)
10394 bad_type_gv(arg, "hash", namegv, 0, o3);
10397 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
10399 if (contextclass && e) {
10404 default: goto oops;
10414 SV* const tmpsv = sv_newmortal();
10415 gv_efullname3(tmpsv, namegv, NULL);
10416 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10417 SVfARG(tmpsv), SVfARG(protosv));
10421 op_lvalue(aop, OP_ENTERSUB);
10423 aop = OP_SIBLING(aop);
10425 if (aop == cvop && *proto == '_') {
10426 /* generate an access to $_ */
10427 op_sibling_splice(parent, prev, 0, newDEFSVOP());
10429 if (!optional && proto_end > proto &&
10430 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10431 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10436 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10438 Performs the fixup of the arguments part of an C<entersub> op tree either
10439 based on a subroutine prototype or using default list-context processing.
10440 This is the standard treatment used on a subroutine call, not marked
10441 with C<&>, where the callee can be identified at compile time.
10443 I<protosv> supplies the subroutine prototype to be applied to the call,
10444 or indicates that there is no prototype. It may be a normal scalar,
10445 in which case if it is defined then the string value will be used
10446 as a prototype, and if it is undefined then there is no prototype.
10447 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10448 that has been cast to C<SV*>), of which the prototype will be used if it
10449 has one. The prototype (or lack thereof) supplied, in whichever form,
10450 does not need to match the actual callee referenced by the op tree.
10452 If the argument ops disagree with the prototype, for example by having
10453 an unacceptable number of arguments, a valid op tree is returned anyway.
10454 The error is reflected in the parser state, normally resulting in a single
10455 exception at the top level of parsing which covers all the compilation
10456 errors that occurred. In the error message, the callee is referred to
10457 by the name defined by the I<namegv> parameter.
10463 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10464 GV *namegv, SV *protosv)
10466 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10467 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10468 return ck_entersub_args_proto(entersubop, namegv, protosv);
10470 return ck_entersub_args_list(entersubop);
10474 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10476 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10477 OP *aop = cUNOPx(entersubop)->op_first;
10479 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10483 if (!OP_HAS_SIBLING(aop))
10484 aop = cUNOPx(aop)->op_first;
10485 aop = OP_SIBLING(aop);
10486 for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10488 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10490 op_free(entersubop);
10491 switch(GvNAME(namegv)[2]) {
10492 case 'F': return newSVOP(OP_CONST, 0,
10493 newSVpv(CopFILE(PL_curcop),0));
10494 case 'L': return newSVOP(
10496 Perl_newSVpvf(aTHX_
10497 "%"IVdf, (IV)CopLINE(PL_curcop)
10500 case 'P': return newSVOP(OP_CONST, 0,
10502 ? newSVhek(HvNAME_HEK(PL_curstash))
10510 OP *prev, *cvop, *first, *parent;
10513 parent = entersubop;
10514 if (!OP_HAS_SIBLING(aop)) {
10516 aop = cUNOPx(aop)->op_first;
10519 first = prev = aop;
10520 aop = OP_SIBLING(aop);
10521 /* find last sibling */
10523 OP_HAS_SIBLING(cvop);
10524 prev = cvop, cvop = OP_SIBLING(cvop))
10526 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
10527 /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
10528 * parens, but these have their own meaning for that flag: */
10529 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
10530 && opnum != OP_DELETE && opnum != OP_EXISTS)
10531 flags |= OPf_SPECIAL;
10532 /* excise cvop from end of sibling chain */
10533 op_sibling_splice(parent, prev, 1, NULL);
10535 if (aop == cvop) aop = NULL;
10537 /* detach remaining siblings from the first sibling, then
10538 * dispose of original optree */
10541 op_sibling_splice(parent, first, -1, NULL);
10542 op_free(entersubop);
10544 if (opnum == OP_ENTEREVAL
10545 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10546 flags |= OPpEVAL_BYTES <<8;
10548 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10550 case OA_BASEOP_OR_UNOP:
10551 case OA_FILESTATOP:
10552 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10555 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10558 return opnum == OP_RUNCV
10559 ? newPVOP(OP_RUNCV,0,NULL)
10562 return convert(opnum,0,aop);
10570 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10572 Retrieves the function that will be used to fix up a call to I<cv>.
10573 Specifically, the function is applied to an C<entersub> op tree for a
10574 subroutine call, not marked with C<&>, where the callee can be identified
10575 at compile time as I<cv>.
10577 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10578 argument for it is returned in I<*ckobj_p>. The function is intended
10579 to be called in this manner:
10581 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10583 In this call, I<entersubop> is a pointer to the C<entersub> op,
10584 which may be replaced by the check function, and I<namegv> is a GV
10585 supplying the name that should be used by the check function to refer
10586 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10587 It is permitted to apply the check function in non-standard situations,
10588 such as to a call to a different subroutine or to a method call.
10590 By default, the function is
10591 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10592 and the SV parameter is I<cv> itself. This implements standard
10593 prototype processing. It can be changed, for a particular subroutine,
10594 by L</cv_set_call_checker>.
10600 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10603 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10604 PERL_UNUSED_CONTEXT;
10605 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10607 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10608 *ckobj_p = callmg->mg_obj;
10610 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10611 *ckobj_p = (SV*)cv;
10616 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10618 Sets the function that will be used to fix up a call to I<cv>.
10619 Specifically, the function is applied to an C<entersub> op tree for a
10620 subroutine call, not marked with C<&>, where the callee can be identified
10621 at compile time as I<cv>.
10623 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10624 for it is supplied in I<ckobj>. The function should be defined like this:
10626 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
10628 It is intended to be called in this manner:
10630 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10632 In this call, I<entersubop> is a pointer to the C<entersub> op,
10633 which may be replaced by the check function, and I<namegv> is a GV
10634 supplying the name that should be used by the check function to refer
10635 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10636 It is permitted to apply the check function in non-standard situations,
10637 such as to a call to a different subroutine or to a method call.
10639 The current setting for a particular CV can be retrieved by
10640 L</cv_get_call_checker>.
10646 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10648 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10649 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10650 if (SvMAGICAL((SV*)cv))
10651 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10654 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10655 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10657 if (callmg->mg_flags & MGf_REFCOUNTED) {
10658 SvREFCNT_dec(callmg->mg_obj);
10659 callmg->mg_flags &= ~MGf_REFCOUNTED;
10661 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10662 callmg->mg_obj = ckobj;
10663 if (ckobj != (SV*)cv) {
10664 SvREFCNT_inc_simple_void_NN(ckobj);
10665 callmg->mg_flags |= MGf_REFCOUNTED;
10667 callmg->mg_flags |= MGf_COPY;
10672 Perl_ck_subr(pTHX_ OP *o)
10678 PERL_ARGS_ASSERT_CK_SUBR;
10680 aop = cUNOPx(o)->op_first;
10681 if (!OP_HAS_SIBLING(aop))
10682 aop = cUNOPx(aop)->op_first;
10683 aop = OP_SIBLING(aop);
10684 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10685 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10686 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10688 o->op_private &= ~1;
10689 o->op_private |= OPpENTERSUB_HASTARG;
10690 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10691 if (PERLDB_SUB && PL_curstash != PL_debstash)
10692 o->op_private |= OPpENTERSUB_DB;
10693 if (cvop->op_type == OP_RV2CV) {
10694 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10696 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10697 if (aop->op_type == OP_CONST)
10698 aop->op_private &= ~OPpCONST_STRICT;
10699 else if (aop->op_type == OP_LIST) {
10700 OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
10701 if (sib && sib->op_type == OP_CONST)
10702 sib->op_private &= ~OPpCONST_STRICT;
10707 return ck_entersub_args_list(o);
10709 Perl_call_checker ckfun;
10711 cv_get_call_checker(cv, &ckfun, &ckobj);
10712 if (!namegv) { /* expletive! */
10713 /* XXX The call checker API is public. And it guarantees that
10714 a GV will be provided with the right name. So we have
10715 to create a GV. But it is still not correct, as its
10716 stringification will include the package. What we
10717 really need is a new call checker API that accepts a
10718 GV or string (or GV or CV). */
10719 HEK * const hek = CvNAME_HEK(cv);
10720 /* After a syntax error in a lexical sub, the cv that
10721 rv2cv_op_cv returns may be a nameless stub. */
10722 if (!hek) return ck_entersub_args_list(o);;
10723 namegv = (GV *)sv_newmortal();
10724 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10725 SVf_UTF8 * !!HEK_UTF8(hek));
10727 return ckfun(aTHX_ o, namegv, ckobj);
10732 Perl_ck_svconst(pTHX_ OP *o)
10734 SV * const sv = cSVOPo->op_sv;
10735 PERL_ARGS_ASSERT_CK_SVCONST;
10736 PERL_UNUSED_CONTEXT;
10737 #ifdef PERL_OLD_COPY_ON_WRITE
10738 if (SvIsCOW(sv)) sv_force_normal(sv);
10739 #elif defined(PERL_NEW_COPY_ON_WRITE)
10740 /* Since the read-only flag may be used to protect a string buffer, we
10741 cannot do copy-on-write with existing read-only scalars that are not
10742 already copy-on-write scalars. To allow $_ = "hello" to do COW with
10743 that constant, mark the constant as COWable here, if it is not
10744 already read-only. */
10745 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10748 # ifdef PERL_DEBUG_READONLY_COW
10758 Perl_ck_trunc(pTHX_ OP *o)
10760 PERL_ARGS_ASSERT_CK_TRUNC;
10762 if (o->op_flags & OPf_KIDS) {
10763 SVOP *kid = (SVOP*)cUNOPo->op_first;
10765 if (kid->op_type == OP_NULL)
10766 kid = (SVOP*)OP_SIBLING(kid);
10767 if (kid && kid->op_type == OP_CONST &&
10768 (kid->op_private & OPpCONST_BARE) &&
10771 o->op_flags |= OPf_SPECIAL;
10772 kid->op_private &= ~OPpCONST_STRICT;
10779 Perl_ck_substr(pTHX_ OP *o)
10781 PERL_ARGS_ASSERT_CK_SUBSTR;
10784 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10785 OP *kid = cLISTOPo->op_first;
10787 if (kid->op_type == OP_NULL)
10788 kid = OP_SIBLING(kid);
10790 kid->op_flags |= OPf_MOD;
10797 Perl_ck_tell(pTHX_ OP *o)
10799 PERL_ARGS_ASSERT_CK_TELL;
10801 if (o->op_flags & OPf_KIDS) {
10802 OP *kid = cLISTOPo->op_first;
10803 if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
10804 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10810 Perl_ck_each(pTHX_ OP *o)
10813 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10814 const unsigned orig_type = o->op_type;
10815 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10816 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10817 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10818 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10820 PERL_ARGS_ASSERT_CK_EACH;
10823 switch (kid->op_type) {
10829 CHANGE_TYPE(o, array_type);
10832 if (kid->op_private == OPpCONST_BARE
10833 || !SvROK(cSVOPx_sv(kid))
10834 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10835 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10837 /* we let ck_fun handle it */
10840 CHANGE_TYPE(o, ref_type);
10844 /* if treating as a reference, defer additional checks to runtime */
10845 if (o->op_type == ref_type) {
10846 /* diag_listed_as: keys on reference is experimental */
10847 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
10848 "%s is experimental", PL_op_desc[ref_type]);
10855 Perl_ck_length(pTHX_ OP *o)
10857 PERL_ARGS_ASSERT_CK_LENGTH;
10861 if (ckWARN(WARN_SYNTAX)) {
10862 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10866 const bool hash = kid->op_type == OP_PADHV
10867 || kid->op_type == OP_RV2HV;
10868 switch (kid->op_type) {
10873 name = S_op_varname(aTHX_ kid);
10879 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10880 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10882 SVfARG(name), hash ? "keys " : "", SVfARG(name)
10885 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10886 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10887 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10889 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
10890 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10891 "length() used on @array (did you mean \"scalar(@array)\"?)");
10898 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10899 and modify the optree to make them work inplace */
10902 S_inplace_aassign(pTHX_ OP *o) {
10904 OP *modop, *modop_pushmark;
10906 OP *oleft, *oleft_pushmark;
10908 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10910 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10912 assert(cUNOPo->op_first->op_type == OP_NULL);
10913 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10914 assert(modop_pushmark->op_type == OP_PUSHMARK);
10915 modop = OP_SIBLING(modop_pushmark);
10917 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10920 /* no other operation except sort/reverse */
10921 if (OP_HAS_SIBLING(modop))
10924 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10925 if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
10927 if (modop->op_flags & OPf_STACKED) {
10928 /* skip sort subroutine/block */
10929 assert(oright->op_type == OP_NULL);
10930 oright = OP_SIBLING(oright);
10933 assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
10934 oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
10935 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10936 oleft = OP_SIBLING(oleft_pushmark);
10938 /* Check the lhs is an array */
10940 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10941 || OP_HAS_SIBLING(oleft)
10942 || (oleft->op_private & OPpLVAL_INTRO)
10946 /* Only one thing on the rhs */
10947 if (OP_HAS_SIBLING(oright))
10950 /* check the array is the same on both sides */
10951 if (oleft->op_type == OP_RV2AV) {
10952 if (oright->op_type != OP_RV2AV
10953 || !cUNOPx(oright)->op_first
10954 || cUNOPx(oright)->op_first->op_type != OP_GV
10955 || cUNOPx(oleft )->op_first->op_type != OP_GV
10956 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10957 cGVOPx_gv(cUNOPx(oright)->op_first)
10961 else if (oright->op_type != OP_PADAV
10962 || oright->op_targ != oleft->op_targ
10966 /* This actually is an inplace assignment */
10968 modop->op_private |= OPpSORT_INPLACE;
10970 /* transfer MODishness etc from LHS arg to RHS arg */
10971 oright->op_flags = oleft->op_flags;
10973 /* remove the aassign op and the lhs */
10975 op_null(oleft_pushmark);
10976 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10977 op_null(cUNOPx(oleft)->op_first);
10983 /* mechanism for deferring recursion in rpeep() */
10985 #define MAX_DEFERRED 4
10989 if (defer_ix == (MAX_DEFERRED-1)) { \
10990 OP **defer = defer_queue[defer_base]; \
10991 CALL_RPEEP(*defer); \
10992 S_prune_chain_head(defer); \
10993 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10996 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
10999 #define IS_AND_OP(o) (o->op_type == OP_AND)
11000 #define IS_OR_OP(o) (o->op_type == OP_OR)
11004 S_null_listop_in_list_context(pTHX_ OP *o)
11008 PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
11010 /* This is an OP_LIST in list context. That means we
11011 * can ditch the OP_LIST and the OP_PUSHMARK within. */
11013 kid = cLISTOPo->op_first;
11014 /* Find the end of the chain of OPs executed within the OP_LIST. */
11015 while (kid->op_next != o)
11016 kid = kid->op_next;
11018 kid->op_next = o->op_next; /* patch list out of exec chain */
11019 op_null(cUNOPo->op_first); /* NULL the pushmark */
11020 op_null(o); /* NULL the list */
11023 /* A peephole optimizer. We visit the ops in the order they're to execute.
11024 * See the comments at the top of this file for more details about when
11025 * peep() is called */
11028 Perl_rpeep(pTHX_ OP *o)
11032 OP* oldoldop = NULL;
11033 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11034 int defer_base = 0;
11039 if (!o || o->op_opt)
11043 SAVEVPTR(PL_curcop);
11044 for (;; o = o->op_next) {
11045 if (o && o->op_opt)
11048 while (defer_ix >= 0) {
11050 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
11051 CALL_RPEEP(*defer);
11052 S_prune_chain_head(defer);
11057 /* By default, this op has now been optimised. A couple of cases below
11058 clear this again. */
11063 /* The following will have the OP_LIST and OP_PUSHMARK
11064 * patched out later IF the OP_LIST is in list context.
11065 * So in that case, we can set the this OP's op_next
11066 * to skip to after the OP_PUSHMARK:
11072 * will eventually become:
11075 * - ex-pushmark -> -
11081 OP *other_pushmark;
11082 if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
11083 && (sibling = OP_SIBLING(o))
11084 && sibling->op_type == OP_LIST
11085 /* This KIDS check is likely superfluous since OP_LIST
11086 * would otherwise be an OP_STUB. */
11087 && sibling->op_flags & OPf_KIDS
11088 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
11089 && (other_pushmark = cLISTOPx(sibling)->op_first)
11090 /* Pointer equality also effectively checks that it's a
11092 && other_pushmark == o->op_next)
11094 o->op_next = other_pushmark->op_next;
11095 null_listop_in_list_context(sibling);
11099 switch (o->op_type) {
11101 PL_curcop = ((COP*)o); /* for warnings */
11104 PL_curcop = ((COP*)o); /* for warnings */
11106 /* Optimise a "return ..." at the end of a sub to just be "...".
11107 * This saves 2 ops. Before:
11108 * 1 <;> nextstate(main 1 -e:1) v ->2
11109 * 4 <@> return K ->5
11110 * 2 <0> pushmark s ->3
11111 * - <1> ex-rv2sv sK/1 ->4
11112 * 3 <#> gvsv[*cat] s ->4
11115 * - <@> return K ->-
11116 * - <0> pushmark s ->2
11117 * - <1> ex-rv2sv sK/1 ->-
11118 * 2 <$> gvsv(*cat) s ->3
11121 OP *next = o->op_next;
11122 OP *sibling = OP_SIBLING(o);
11123 if ( OP_TYPE_IS(next, OP_PUSHMARK)
11124 && OP_TYPE_IS(sibling, OP_RETURN)
11125 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
11126 && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
11127 && cUNOPx(sibling)->op_first == next
11128 && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
11131 /* Look through the PUSHMARK's siblings for one that
11132 * points to the RETURN */
11133 OP *top = OP_SIBLING(next);
11134 while (top && top->op_next) {
11135 if (top->op_next == sibling) {
11136 top->op_next = sibling->op_next;
11137 o->op_next = next->op_next;
11140 top = OP_SIBLING(top);
11145 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
11147 * This latter form is then suitable for conversion into padrange
11148 * later on. Convert:
11150 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
11154 * nextstate1 -> listop -> nextstate3
11156 * pushmark -> padop1 -> padop2
11158 if (o->op_next && (
11159 o->op_next->op_type == OP_PADSV
11160 || o->op_next->op_type == OP_PADAV
11161 || o->op_next->op_type == OP_PADHV
11163 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
11164 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
11165 && o->op_next->op_next->op_next && (
11166 o->op_next->op_next->op_next->op_type == OP_PADSV
11167 || o->op_next->op_next->op_next->op_type == OP_PADAV
11168 || o->op_next->op_next->op_next->op_type == OP_PADHV
11170 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
11171 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
11172 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
11173 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
11175 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
11178 ns2 = pad1->op_next;
11179 pad2 = ns2->op_next;
11180 ns3 = pad2->op_next;
11182 /* we assume here that the op_next chain is the same as
11183 * the op_sibling chain */
11184 assert(OP_SIBLING(o) == pad1);
11185 assert(OP_SIBLING(pad1) == ns2);
11186 assert(OP_SIBLING(ns2) == pad2);
11187 assert(OP_SIBLING(pad2) == ns3);
11189 /* create new listop, with children consisting of:
11190 * a new pushmark, pad1, pad2. */
11191 OP_SIBLING_set(pad2, NULL);
11192 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
11193 newop->op_flags |= OPf_PARENS;
11194 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11195 newpm = cUNOPx(newop)->op_first; /* pushmark */
11197 /* Kill nextstate2 between padop1/padop2 */
11200 o ->op_next = newpm;
11201 newpm->op_next = pad1;
11202 pad1 ->op_next = pad2;
11203 pad2 ->op_next = newop; /* listop */
11204 newop->op_next = ns3;
11206 OP_SIBLING_set(o, newop);
11207 OP_SIBLING_set(newop, ns3);
11208 newop->op_lastsib = 0;
11210 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11212 /* Ensure pushmark has this flag if padops do */
11213 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
11214 o->op_next->op_flags |= OPf_MOD;
11220 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11221 to carry two labels. For now, take the easier option, and skip
11222 this optimisation if the first NEXTSTATE has a label. */
11223 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
11224 OP *nextop = o->op_next;
11225 while (nextop && nextop->op_type == OP_NULL)
11226 nextop = nextop->op_next;
11228 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11229 COP *firstcop = (COP *)o;
11230 COP *secondcop = (COP *)nextop;
11231 /* We want the COP pointed to by o (and anything else) to
11232 become the next COP down the line. */
11233 cop_free(firstcop);
11235 firstcop->op_next = secondcop->op_next;
11237 /* Now steal all its pointers, and duplicate the other
11239 firstcop->cop_line = secondcop->cop_line;
11240 #ifdef USE_ITHREADS
11241 firstcop->cop_stashoff = secondcop->cop_stashoff;
11242 firstcop->cop_file = secondcop->cop_file;
11244 firstcop->cop_stash = secondcop->cop_stash;
11245 firstcop->cop_filegv = secondcop->cop_filegv;
11247 firstcop->cop_hints = secondcop->cop_hints;
11248 firstcop->cop_seq = secondcop->cop_seq;
11249 firstcop->cop_warnings = secondcop->cop_warnings;
11250 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11252 #ifdef USE_ITHREADS
11253 secondcop->cop_stashoff = 0;
11254 secondcop->cop_file = NULL;
11256 secondcop->cop_stash = NULL;
11257 secondcop->cop_filegv = NULL;
11259 secondcop->cop_warnings = NULL;
11260 secondcop->cop_hints_hash = NULL;
11262 /* If we use op_null(), and hence leave an ex-COP, some
11263 warnings are misreported. For example, the compile-time
11264 error in 'use strict; no strict refs;' */
11265 secondcop->op_type = OP_NULL;
11266 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11272 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11273 if (o->op_next->op_private & OPpTARGET_MY) {
11274 if (o->op_flags & OPf_STACKED) /* chained concats */
11275 break; /* ignore_optimization */
11277 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11278 o->op_targ = o->op_next->op_targ;
11279 o->op_next->op_targ = 0;
11280 o->op_private |= OPpTARGET_MY;
11283 op_null(o->op_next);
11287 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11288 break; /* Scalar stub must produce undef. List stub is noop */
11292 if (o->op_targ == OP_NEXTSTATE
11293 || o->op_targ == OP_DBSTATE)
11295 PL_curcop = ((COP*)o);
11297 /* XXX: We avoid setting op_seq here to prevent later calls
11298 to rpeep() from mistakenly concluding that optimisation
11299 has already occurred. This doesn't fix the real problem,
11300 though (See 20010220.007). AMS 20010719 */
11301 /* op_seq functionality is now replaced by op_opt */
11309 oldop->op_next = o->op_next;
11317 /* Convert a series of PAD ops for my vars plus support into a
11318 * single padrange op. Basically
11320 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11322 * becomes, depending on circumstances, one of
11324 * padrange ----------------------------------> (list) -> rest
11325 * padrange --------------------------------------------> rest
11327 * where all the pad indexes are sequential and of the same type
11329 * We convert the pushmark into a padrange op, then skip
11330 * any other pad ops, and possibly some trailing ops.
11331 * Note that we don't null() the skipped ops, to make it
11332 * easier for Deparse to undo this optimisation (and none of
11333 * the skipped ops are holding any resourses). It also makes
11334 * it easier for find_uninit_var(), as it can just ignore
11335 * padrange, and examine the original pad ops.
11339 OP *followop = NULL; /* the op that will follow the padrange op */
11342 PADOFFSET base = 0; /* init only to stop compiler whining */
11343 U8 gimme = 0; /* init only to stop compiler whining */
11344 bool defav = 0; /* seen (...) = @_ */
11345 bool reuse = 0; /* reuse an existing padrange op */
11347 /* look for a pushmark -> gv[_] -> rv2av */
11353 if ( p->op_type == OP_GV
11354 && (gv = cGVOPx_gv(p))
11355 && GvNAMELEN_get(gv) == 1
11356 && *GvNAME_get(gv) == '_'
11357 && GvSTASH(gv) == PL_defstash
11358 && (rv2av = p->op_next)
11359 && rv2av->op_type == OP_RV2AV
11360 && !(rv2av->op_flags & OPf_REF)
11361 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11362 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11363 && OP_SIBLING(o) == rv2av /* these two for Deparse */
11364 && cUNOPx(rv2av)->op_first == p
11366 q = rv2av->op_next;
11367 if (q->op_type == OP_NULL)
11369 if (q->op_type == OP_PUSHMARK) {
11376 /* To allow Deparse to pessimise this, it needs to be able
11377 * to restore the pushmark's original op_next, which it
11378 * will assume to be the same as OP_SIBLING. */
11379 if (o->op_next != OP_SIBLING(o))
11384 /* scan for PAD ops */
11386 for (p = p->op_next; p; p = p->op_next) {
11387 if (p->op_type == OP_NULL)
11390 if (( p->op_type != OP_PADSV
11391 && p->op_type != OP_PADAV
11392 && p->op_type != OP_PADHV
11394 /* any private flag other than INTRO? e.g. STATE */
11395 || (p->op_private & ~OPpLVAL_INTRO)
11399 /* let $a[N] potentially be optimised into AELEMFAST_LEX
11401 if ( p->op_type == OP_PADAV
11403 && p->op_next->op_type == OP_CONST
11404 && p->op_next->op_next
11405 && p->op_next->op_next->op_type == OP_AELEM
11409 /* for 1st padop, note what type it is and the range
11410 * start; for the others, check that it's the same type
11411 * and that the targs are contiguous */
11413 intro = (p->op_private & OPpLVAL_INTRO);
11415 gimme = (p->op_flags & OPf_WANT);
11418 if ((p->op_private & OPpLVAL_INTRO) != intro)
11420 /* Note that you'd normally expect targs to be
11421 * contiguous in my($a,$b,$c), but that's not the case
11422 * when external modules start doing things, e.g.
11423 i* Function::Parameters */
11424 if (p->op_targ != base + count)
11426 assert(p->op_targ == base + count);
11427 /* all the padops should be in the same context */
11428 if (gimme != (p->op_flags & OPf_WANT))
11432 /* for AV, HV, only when we're not flattening */
11433 if ( p->op_type != OP_PADSV
11434 && gimme != OPf_WANT_VOID
11435 && !(p->op_flags & OPf_REF)
11439 if (count >= OPpPADRANGE_COUNTMASK)
11442 /* there's a biggest base we can fit into a
11443 * SAVEt_CLEARPADRANGE in pp_padrange */
11444 if (intro && base >
11445 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11448 /* Success! We've got another valid pad op to optimise away */
11450 followop = p->op_next;
11456 /* pp_padrange in specifically compile-time void context
11457 * skips pushing a mark and lexicals; in all other contexts
11458 * (including unknown till runtime) it pushes a mark and the
11459 * lexicals. We must be very careful then, that the ops we
11460 * optimise away would have exactly the same effect as the
11462 * In particular in void context, we can only optimise to
11463 * a padrange if see see the complete sequence
11464 * pushmark, pad*v, ...., list, nextstate
11465 * which has the net effect of of leaving the stack empty
11466 * (for now we leave the nextstate in the execution chain, for
11467 * its other side-effects).
11470 if (gimme == OPf_WANT_VOID) {
11471 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
11472 && gimme == (followop->op_flags & OPf_WANT)
11473 && ( followop->op_next->op_type == OP_NEXTSTATE
11474 || followop->op_next->op_type == OP_DBSTATE))
11476 followop = followop->op_next; /* skip OP_LIST */
11478 /* consolidate two successive my(...);'s */
11481 && oldoldop->op_type == OP_PADRANGE
11482 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11483 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11484 && !(oldoldop->op_flags & OPf_SPECIAL)
11487 assert(oldoldop->op_next == oldop);
11488 assert( oldop->op_type == OP_NEXTSTATE
11489 || oldop->op_type == OP_DBSTATE);
11490 assert(oldop->op_next == o);
11493 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11495 /* Do not assume pad offsets for $c and $d are con-
11500 if ( oldoldop->op_targ + old_count == base
11501 && old_count < OPpPADRANGE_COUNTMASK - count) {
11502 base = oldoldop->op_targ;
11503 count += old_count;
11508 /* if there's any immediately following singleton
11509 * my var's; then swallow them and the associated
11511 * my ($a,$b); my $c; my $d;
11513 * my ($a,$b,$c,$d);
11516 while ( ((p = followop->op_next))
11517 && ( p->op_type == OP_PADSV
11518 || p->op_type == OP_PADAV
11519 || p->op_type == OP_PADHV)
11520 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11521 && (p->op_private & OPpLVAL_INTRO) == intro
11522 && !(p->op_private & ~OPpLVAL_INTRO)
11524 && ( p->op_next->op_type == OP_NEXTSTATE
11525 || p->op_next->op_type == OP_DBSTATE)
11526 && count < OPpPADRANGE_COUNTMASK
11527 && base + count == p->op_targ
11530 followop = p->op_next;
11538 assert(oldoldop->op_type == OP_PADRANGE);
11539 oldoldop->op_next = followop;
11540 oldoldop->op_private = (intro | count);
11546 /* Convert the pushmark into a padrange.
11547 * To make Deparse easier, we guarantee that a padrange was
11548 * *always* formerly a pushmark */
11549 assert(o->op_type == OP_PUSHMARK);
11550 o->op_next = followop;
11551 o->op_type = OP_PADRANGE;
11552 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11554 /* bit 7: INTRO; bit 6..0: count */
11555 o->op_private = (intro | count);
11556 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11557 | gimme | (defav ? OPf_SPECIAL : 0));
11564 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11565 OP* const pop = (o->op_type == OP_PADAV) ?
11566 o->op_next : o->op_next->op_next;
11568 if (pop && pop->op_type == OP_CONST &&
11569 ((PL_op = pop->op_next)) &&
11570 pop->op_next->op_type == OP_AELEM &&
11571 !(pop->op_next->op_private &
11572 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11573 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
11576 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11577 no_bareword_allowed(pop);
11578 if (o->op_type == OP_GV)
11579 op_null(o->op_next);
11580 op_null(pop->op_next);
11582 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11583 o->op_next = pop->op_next->op_next;
11584 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11585 o->op_private = (U8)i;
11586 if (o->op_type == OP_GV) {
11589 o->op_type = OP_AELEMFAST;
11592 o->op_type = OP_AELEMFAST_LEX;
11597 if (o->op_next->op_type == OP_RV2SV) {
11598 if (!(o->op_next->op_private & OPpDEREF)) {
11599 op_null(o->op_next);
11600 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11602 o->op_next = o->op_next->op_next;
11603 o->op_type = OP_GVSV;
11604 o->op_ppaddr = PL_ppaddr[OP_GVSV];
11607 else if (o->op_next->op_type == OP_READLINE
11608 && o->op_next->op_next->op_type == OP_CONCAT
11609 && (o->op_next->op_next->op_flags & OPf_STACKED))
11611 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11612 o->op_type = OP_RCATLINE;
11613 o->op_flags |= OPf_STACKED;
11614 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11615 op_null(o->op_next->op_next);
11616 op_null(o->op_next);
11621 #define HV_OR_SCALARHV(op) \
11622 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11624 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11625 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11626 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11627 ? cUNOPx(op)->op_first \
11631 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11632 fop->op_private |= OPpTRUEBOOL;
11638 fop = cLOGOP->op_first;
11639 sop = OP_SIBLING(fop);
11640 while (cLOGOP->op_other->op_type == OP_NULL)
11641 cLOGOP->op_other = cLOGOP->op_other->op_next;
11642 while (o->op_next && ( o->op_type == o->op_next->op_type
11643 || o->op_next->op_type == OP_NULL))
11644 o->op_next = o->op_next->op_next;
11646 /* if we're an OR and our next is a AND in void context, we'll
11647 follow it's op_other on short circuit, same for reverse.
11648 We can't do this with OP_DOR since if it's true, its return
11649 value is the underlying value which must be evaluated
11653 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
11654 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
11656 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
11658 o->op_next = ((LOGOP*)o->op_next)->op_other;
11660 DEFER(cLOGOP->op_other);
11663 fop = HV_OR_SCALARHV(fop);
11664 if (sop) sop = HV_OR_SCALARHV(sop);
11669 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11670 while (nop && nop->op_next) {
11671 switch (nop->op_next->op_type) {
11676 lop = nop = nop->op_next;
11679 nop = nop->op_next;
11688 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11689 || o->op_type == OP_AND )
11690 fop->op_private |= OPpTRUEBOOL;
11691 else if (!(lop->op_flags & OPf_WANT))
11692 fop->op_private |= OPpMAYBE_TRUEBOOL;
11694 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11696 sop->op_private |= OPpTRUEBOOL;
11703 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11704 fop->op_private |= OPpTRUEBOOL;
11705 #undef HV_OR_SCALARHV
11706 /* GERONIMO! */ /* FALLTHROUGH */
11715 while (cLOGOP->op_other->op_type == OP_NULL)
11716 cLOGOP->op_other = cLOGOP->op_other->op_next;
11717 DEFER(cLOGOP->op_other);
11722 while (cLOOP->op_redoop->op_type == OP_NULL)
11723 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11724 while (cLOOP->op_nextop->op_type == OP_NULL)
11725 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11726 while (cLOOP->op_lastop->op_type == OP_NULL)
11727 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11728 /* a while(1) loop doesn't have an op_next that escapes the
11729 * loop, so we have to explicitly follow the op_lastop to
11730 * process the rest of the code */
11731 DEFER(cLOOP->op_lastop);
11735 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
11736 DEFER(cLOGOPo->op_other);
11740 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11741 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11742 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11743 cPMOP->op_pmstashstartu.op_pmreplstart
11744 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11745 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11751 if (o->op_flags & OPf_SPECIAL) {
11752 /* first arg is a code block */
11753 OP * const nullop = OP_SIBLING(cLISTOP->op_first);
11754 OP * kid = cUNOPx(nullop)->op_first;
11756 assert(nullop->op_type == OP_NULL);
11757 assert(kid->op_type == OP_SCOPE
11758 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
11759 /* since OP_SORT doesn't have a handy op_other-style
11760 * field that can point directly to the start of the code
11761 * block, store it in the otherwise-unused op_next field
11762 * of the top-level OP_NULL. This will be quicker at
11763 * run-time, and it will also allow us to remove leading
11764 * OP_NULLs by just messing with op_nexts without
11765 * altering the basic op_first/op_sibling layout. */
11766 kid = kLISTOP->op_first;
11768 (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
11769 || kid->op_type == OP_STUB
11770 || kid->op_type == OP_ENTER);
11771 nullop->op_next = kLISTOP->op_next;
11772 DEFER(nullop->op_next);
11775 /* check that RHS of sort is a single plain array */
11776 oright = cUNOPo->op_first;
11777 if (!oright || oright->op_type != OP_PUSHMARK)
11780 if (o->op_private & OPpSORT_INPLACE)
11783 /* reverse sort ... can be optimised. */
11784 if (!OP_HAS_SIBLING(cUNOPo)) {
11785 /* Nothing follows us on the list. */
11786 OP * const reverse = o->op_next;
11788 if (reverse->op_type == OP_REVERSE &&
11789 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11790 OP * const pushmark = cUNOPx(reverse)->op_first;
11791 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11792 && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
11793 /* reverse -> pushmark -> sort */
11794 o->op_private |= OPpSORT_REVERSE;
11796 pushmark->op_next = oright->op_next;
11806 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11808 LISTOP *enter, *exlist;
11810 if (o->op_private & OPpSORT_INPLACE)
11813 enter = (LISTOP *) o->op_next;
11816 if (enter->op_type == OP_NULL) {
11817 enter = (LISTOP *) enter->op_next;
11821 /* for $a (...) will have OP_GV then OP_RV2GV here.
11822 for (...) just has an OP_GV. */
11823 if (enter->op_type == OP_GV) {
11824 gvop = (OP *) enter;
11825 enter = (LISTOP *) enter->op_next;
11828 if (enter->op_type == OP_RV2GV) {
11829 enter = (LISTOP *) enter->op_next;
11835 if (enter->op_type != OP_ENTERITER)
11838 iter = enter->op_next;
11839 if (!iter || iter->op_type != OP_ITER)
11842 expushmark = enter->op_first;
11843 if (!expushmark || expushmark->op_type != OP_NULL
11844 || expushmark->op_targ != OP_PUSHMARK)
11847 exlist = (LISTOP *) OP_SIBLING(expushmark);
11848 if (!exlist || exlist->op_type != OP_NULL
11849 || exlist->op_targ != OP_LIST)
11852 if (exlist->op_last != o) {
11853 /* Mmm. Was expecting to point back to this op. */
11856 theirmark = exlist->op_first;
11857 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11860 if (OP_SIBLING(theirmark) != o) {
11861 /* There's something between the mark and the reverse, eg
11862 for (1, reverse (...))
11867 ourmark = ((LISTOP *)o)->op_first;
11868 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11871 ourlast = ((LISTOP *)o)->op_last;
11872 if (!ourlast || ourlast->op_next != o)
11875 rv2av = OP_SIBLING(ourmark);
11876 if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av)
11877 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11878 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11879 /* We're just reversing a single array. */
11880 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11881 enter->op_flags |= OPf_STACKED;
11884 /* We don't have control over who points to theirmark, so sacrifice
11886 theirmark->op_next = ourmark->op_next;
11887 theirmark->op_flags = ourmark->op_flags;
11888 ourlast->op_next = gvop ? gvop : (OP *) enter;
11891 enter->op_private |= OPpITER_REVERSED;
11892 iter->op_private |= OPpITER_REVERSED;
11899 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11900 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11905 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11907 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11909 sv = newRV((SV *)PL_compcv);
11913 o->op_type = OP_CONST;
11914 o->op_ppaddr = PL_ppaddr[OP_CONST];
11915 o->op_flags |= OPf_SPECIAL;
11916 cSVOPo->op_sv = sv;
11921 if (OP_GIMME(o,0) == G_VOID) {
11922 OP *right = cBINOP->op_first;
11941 OP *left = OP_SIBLING(right);
11942 if (left->op_type == OP_SUBSTR
11943 && (left->op_private & 7) < 4) {
11945 /* cut out right */
11946 op_sibling_splice(o, NULL, 1, NULL);
11947 /* and insert it as second child of OP_SUBSTR */
11948 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
11950 left->op_private |= OPpSUBSTR_REPL_FIRST;
11952 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11959 Perl_cpeep_t cpeep =
11960 XopENTRYCUSTOM(o, xop_peep);
11962 cpeep(aTHX_ o, oldop);
11967 /* did we just null the current op? If so, re-process it to handle
11968 * eliding "empty" ops from the chain */
11969 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
11982 Perl_peep(pTHX_ OP *o)
11988 =head1 Custom Operators
11990 =for apidoc Ao||custom_op_xop
11991 Return the XOP structure for a given custom op. This macro should be
11992 considered internal to OP_NAME and the other access macros: use them instead.
11993 This macro does call a function. Prior
11994 to 5.19.6, this was implemented as a
12001 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
12007 static const XOP xop_null = { 0, 0, 0, 0, 0 };
12009 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
12010 assert(o->op_type == OP_CUSTOM);
12012 /* This is wrong. It assumes a function pointer can be cast to IV,
12013 * which isn't guaranteed, but this is what the old custom OP code
12014 * did. In principle it should be safer to Copy the bytes of the
12015 * pointer into a PV: since the new interface is hidden behind
12016 * functions, this can be changed later if necessary. */
12017 /* Change custom_op_xop if this ever happens */
12018 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
12021 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12023 /* assume noone will have just registered a desc */
12024 if (!he && PL_custom_op_names &&
12025 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
12030 /* XXX does all this need to be shared mem? */
12031 Newxz(xop, 1, XOP);
12032 pv = SvPV(HeVAL(he), l);
12033 XopENTRY_set(xop, xop_name, savepvn(pv, l));
12034 if (PL_custom_op_descs &&
12035 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
12037 pv = SvPV(HeVAL(he), l);
12038 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
12040 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
12044 xop = (XOP *)&xop_null;
12046 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
12050 if(field == XOPe_xop_ptr) {
12053 const U32 flags = XopFLAGS(xop);
12054 if(flags & field) {
12056 case XOPe_xop_name:
12057 any.xop_name = xop->xop_name;
12059 case XOPe_xop_desc:
12060 any.xop_desc = xop->xop_desc;
12062 case XOPe_xop_class:
12063 any.xop_class = xop->xop_class;
12065 case XOPe_xop_peep:
12066 any.xop_peep = xop->xop_peep;
12074 case XOPe_xop_name:
12075 any.xop_name = XOPd_xop_name;
12077 case XOPe_xop_desc:
12078 any.xop_desc = XOPd_xop_desc;
12080 case XOPe_xop_class:
12081 any.xop_class = XOPd_xop_class;
12083 case XOPe_xop_peep:
12084 any.xop_peep = XOPd_xop_peep;
12092 /* Some gcc releases emit a warning for this function:
12093 * op.c: In function 'Perl_custom_op_get_field':
12094 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
12095 * Whether this is true, is currently unknown. */
12101 =for apidoc Ao||custom_op_register
12102 Register a custom op. See L<perlguts/"Custom Operators">.
12108 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
12112 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
12114 /* see the comment in custom_op_xop */
12115 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
12117 if (!PL_custom_ops)
12118 PL_custom_ops = newHV();
12120 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
12121 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
12126 =for apidoc core_prototype
12128 This function assigns the prototype of the named core function to C<sv>, or
12129 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
12130 NULL if the core function has no prototype. C<code> is a code as returned
12131 by C<keyword()>. It must not be equal to 0.
12137 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
12140 int i = 0, n = 0, seen_question = 0, defgv = 0;
12142 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
12143 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
12144 bool nullret = FALSE;
12146 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
12150 if (!sv) sv = sv_newmortal();
12152 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
12154 switch (code < 0 ? -code : code) {
12155 case KEY_and : case KEY_chop: case KEY_chomp:
12156 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
12157 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
12158 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
12159 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
12160 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
12161 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
12162 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
12163 case KEY_x : case KEY_xor :
12164 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
12165 case KEY_glob: retsetpvs("_;", OP_GLOB);
12166 case KEY_keys: retsetpvs("+", OP_KEYS);
12167 case KEY_values: retsetpvs("+", OP_VALUES);
12168 case KEY_each: retsetpvs("+", OP_EACH);
12169 case KEY_push: retsetpvs("+@", OP_PUSH);
12170 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
12171 case KEY_pop: retsetpvs(";+", OP_POP);
12172 case KEY_shift: retsetpvs(";+", OP_SHIFT);
12173 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
12175 retsetpvs("+;$$@", OP_SPLICE);
12176 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
12178 case KEY_evalbytes:
12179 name = "entereval"; break;
12187 while (i < MAXO) { /* The slow way. */
12188 if (strEQ(name, PL_op_name[i])
12189 || strEQ(name, PL_op_desc[i]))
12191 if (nullret) { assert(opnum); *opnum = i; return NULL; }
12198 defgv = PL_opargs[i] & OA_DEFGV;
12199 oa = PL_opargs[i] >> OASHIFT;
12201 if (oa & OA_OPTIONAL && !seen_question && (
12202 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
12207 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
12208 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
12209 /* But globs are already references (kinda) */
12210 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
12214 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
12215 && !scalar_mod_type(NULL, i)) {
12220 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
12224 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
12225 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
12226 str[n-1] = '_'; defgv = 0;
12230 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
12232 sv_setpvn(sv, str, n - 1);
12233 if (opnum) *opnum = i;
12238 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
12241 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
12244 PERL_ARGS_ASSERT_CORESUB_OP;
12248 return op_append_elem(OP_LINESEQ,
12251 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
12255 case OP_SELECT: /* which represents OP_SSELECT as well */
12260 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12261 newSVOP(OP_CONST, 0, newSVuv(1))
12263 coresub_op(newSVuv((UV)OP_SSELECT), 0,
12265 coresub_op(coreargssv, 0, OP_SELECT)
12269 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12271 return op_append_elem(
12274 opnum == OP_WANTARRAY || opnum == OP_RUNCV
12275 ? OPpOFFBYONE << 8 : 0)
12277 case OA_BASEOP_OR_UNOP:
12278 if (opnum == OP_ENTEREVAL) {
12279 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12280 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12282 else o = newUNOP(opnum,0,argop);
12283 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12286 if (is_handle_constructor(o, 1))
12287 argop->op_private |= OPpCOREARGS_DEREF1;
12288 if (scalar_mod_type(NULL, opnum))
12289 argop->op_private |= OPpCOREARGS_SCALARMOD;
12293 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
12294 if (is_handle_constructor(o, 2))
12295 argop->op_private |= OPpCOREARGS_DEREF2;
12296 if (opnum == OP_SUBSTR) {
12297 o->op_private |= OPpMAYBE_LVSUB;
12306 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12307 SV * const *new_const_svp)
12309 const char *hvname;
12310 bool is_const = !!CvCONST(old_cv);
12311 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12313 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12315 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12317 /* They are 2 constant subroutines generated from
12318 the same constant. This probably means that
12319 they are really the "same" proxy subroutine
12320 instantiated in 2 places. Most likely this is
12321 when a constant is exported twice. Don't warn.
12324 (ckWARN(WARN_REDEFINE)
12326 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12327 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12328 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12329 strEQ(hvname, "autouse"))
12333 && ckWARN_d(WARN_REDEFINE)
12334 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
12337 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12339 ? "Constant subroutine %"SVf" redefined"
12340 : "Subroutine %"SVf" redefined",
12345 =head1 Hook manipulation
12347 These functions provide convenient and thread-safe means of manipulating
12354 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12356 Puts a C function into the chain of check functions for a specified op
12357 type. This is the preferred way to manipulate the L</PL_check> array.
12358 I<opcode> specifies which type of op is to be affected. I<new_checker>
12359 is a pointer to the C function that is to be added to that opcode's
12360 check chain, and I<old_checker_p> points to the storage location where a
12361 pointer to the next function in the chain will be stored. The value of
12362 I<new_pointer> is written into the L</PL_check> array, while the value
12363 previously stored there is written to I<*old_checker_p>.
12365 The function should be defined like this:
12367 static OP *new_checker(pTHX_ OP *op) { ... }
12369 It is intended to be called in this manner:
12371 new_checker(aTHX_ op)
12373 I<old_checker_p> should be defined like this:
12375 static Perl_check_t old_checker_p;
12377 L</PL_check> is global to an entire process, and a module wishing to
12378 hook op checking may find itself invoked more than once per process,
12379 typically in different threads. To handle that situation, this function
12380 is idempotent. The location I<*old_checker_p> must initially (once
12381 per process) contain a null pointer. A C variable of static duration
12382 (declared at file scope, typically also marked C<static> to give
12383 it internal linkage) will be implicitly initialised appropriately,
12384 if it does not have an explicit initialiser. This function will only
12385 actually modify the check chain if it finds I<*old_checker_p> to be null.
12386 This function is also thread safe on the small scale. It uses appropriate
12387 locking to avoid race conditions in accessing L</PL_check>.
12389 When this function is called, the function referenced by I<new_checker>
12390 must be ready to be called, except for I<*old_checker_p> being unfilled.
12391 In a threading situation, I<new_checker> may be called immediately,
12392 even before this function has returned. I<*old_checker_p> will always
12393 be appropriately set before I<new_checker> is called. If I<new_checker>
12394 decides not to do anything special with an op that it is given (which
12395 is the usual case for most uses of op check hooking), it must chain the
12396 check function referenced by I<*old_checker_p>.
12398 If you want to influence compilation of calls to a specific subroutine,
12399 then use L</cv_set_call_checker> rather than hooking checking of all
12406 Perl_wrap_op_checker(pTHX_ Optype opcode,
12407 Perl_check_t new_checker, Perl_check_t *old_checker_p)
12411 PERL_UNUSED_CONTEXT;
12412 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12413 if (*old_checker_p) return;
12414 OP_CHECK_MUTEX_LOCK;
12415 if (!*old_checker_p) {
12416 *old_checker_p = PL_check[opcode];
12417 PL_check[opcode] = new_checker;
12419 OP_CHECK_MUTEX_UNLOCK;
12424 /* Efficient sub that returns a constant scalar value. */
12426 const_sv_xsub(pTHX_ CV* cv)
12429 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12430 PERL_UNUSED_ARG(items);
12440 const_av_xsub(pTHX_ CV* cv)
12443 AV * const av = MUTABLE_AV(XSANY.any_ptr);
12451 if (SvRMAGICAL(av))
12452 Perl_croak(aTHX_ "Magical list constants are not supported");
12453 if (GIMME_V != G_ARRAY) {
12455 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
12458 EXTEND(SP, AvFILLp(av)+1);
12459 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12460 XSRETURN(AvFILLp(av)+1);
12465 * c-indentation-style: bsd
12466 * c-basic-offset: 4
12467 * indent-tabs-mode: nil
12470 * ex: set ts=8 sts=4 sw=4 et: