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 /* See the explanatory comments above struct opslab in op.h. */
114 #ifdef PERL_DEBUG_READONLY_OPS
115 # define PERL_SLAB_SIZE 128
116 # define PERL_MAX_SLAB_SIZE 4096
117 # include <sys/mman.h>
120 #ifndef PERL_SLAB_SIZE
121 # define PERL_SLAB_SIZE 64
123 #ifndef PERL_MAX_SLAB_SIZE
124 # define PERL_MAX_SLAB_SIZE 2048
127 /* rounds up to nearest pointer */
128 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
129 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
132 S_new_slab(pTHX_ size_t sz)
134 #ifdef PERL_DEBUG_READONLY_OPS
135 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
136 PROT_READ|PROT_WRITE,
137 MAP_ANON|MAP_PRIVATE, -1, 0);
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) sz, slab));
140 if (slab == MAP_FAILED) {
141 perror("mmap failed");
144 slab->opslab_size = (U16)sz;
146 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
148 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
152 /* requires double parens and aTHX_ */
153 #define DEBUG_S_warn(args) \
155 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
159 Perl_Slab_Alloc(pTHX_ size_t sz)
168 /* We only allocate ops from the slab during subroutine compilation.
169 We find the slab via PL_compcv, hence that must be non-NULL. It could
170 also be pointing to a subroutine which is now fully set up (CvROOT()
171 pointing to the top of the optree for that sub), or a subroutine
172 which isn't using the slab allocator. If our sanity checks aren't met,
173 don't use a slab, but allocate the OP directly from the heap. */
174 if (!PL_compcv || CvROOT(PL_compcv)
175 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
176 return PerlMemShared_calloc(1, sz);
178 #if defined(USE_ITHREADS) && IVSIZE > U32SIZE && IVSIZE > PTRSIZE
179 /* Work around a goof with alignment on our part. For sparc32 (and
180 possibly other architectures), if built with -Duse64bitint, the IV
181 op_pmoffset in struct pmop should be 8 byte aligned, but the slab
182 allocator is only providing 4 byte alignment. The real fix is to change
183 the IV to a type the same size as a pointer, such as size_t, but we
184 can't do that without breaking the ABI, which is a no-no in a maint
185 release. So instead, simply allocate struct pmop directly, which will be
187 if (sz == sizeof(struct pmop))
188 return PerlMemShared_calloc(1, sz);
191 /* While the subroutine is under construction, the slabs are accessed via
192 CvSTART(), to avoid needing to expand PVCV by one pointer for something
193 unneeded at runtime. Once a subroutine is constructed, the slabs are
194 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
195 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
197 if (!CvSTART(PL_compcv)) {
199 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
200 CvSLABBED_on(PL_compcv);
201 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
203 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
205 opsz = SIZE_TO_PSIZE(sz);
206 sz = opsz + OPSLOT_HEADER_P;
208 /* The slabs maintain a free list of OPs. In particular, constant folding
209 will free up OPs, so it makes sense to re-use them where possible. A
210 freed up slot is used in preference to a new allocation. */
211 if (slab->opslab_freed) {
212 OP **too = &slab->opslab_freed;
214 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
215 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
216 DEBUG_S_warn((aTHX_ "Alas! too small"));
217 o = *(too = &o->op_next);
218 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
222 Zero(o, opsz, I32 *);
228 #define INIT_OPSLOT \
229 slot->opslot_slab = slab; \
230 slot->opslot_next = slab2->opslab_first; \
231 slab2->opslab_first = slot; \
232 o = &slot->opslot_op; \
235 /* The partially-filled slab is next in the chain. */
236 slab2 = slab->opslab_next ? slab->opslab_next : slab;
237 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
238 /* Remaining space is too small. */
240 /* If we can fit a BASEOP, add it to the free chain, so as not
242 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
243 slot = &slab2->opslab_slots;
245 o->op_type = OP_FREED;
246 o->op_next = slab->opslab_freed;
247 slab->opslab_freed = o;
250 /* Create a new slab. Make this one twice as big. */
251 slot = slab2->opslab_first;
252 while (slot->opslot_next) slot = slot->opslot_next;
253 slab2 = S_new_slab(aTHX_
254 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
256 : (DIFF(slab2, slot)+1)*2);
257 slab2->opslab_next = slab->opslab_next;
258 slab->opslab_next = slab2;
260 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
262 /* Create a new op slot */
263 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
264 assert(slot >= &slab2->opslab_slots);
265 if (DIFF(&slab2->opslab_slots, slot)
266 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
267 slot = &slab2->opslab_slots;
269 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
275 #ifdef PERL_DEBUG_READONLY_OPS
277 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
279 PERL_ARGS_ASSERT_SLAB_TO_RO;
281 if (slab->opslab_readonly) return;
282 slab->opslab_readonly = 1;
283 for (; slab; slab = slab->opslab_next) {
284 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
285 (unsigned long) slab->opslab_size, slab));*/
286 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
287 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
288 (unsigned long)slab->opslab_size, errno);
293 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
297 PERL_ARGS_ASSERT_SLAB_TO_RW;
299 if (!slab->opslab_readonly) return;
301 for (; slab2; slab2 = slab2->opslab_next) {
302 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
303 (unsigned long) size, slab2));*/
304 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
305 PROT_READ|PROT_WRITE)) {
306 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
307 (unsigned long)slab2->opslab_size, errno);
310 slab->opslab_readonly = 0;
314 # define Slab_to_rw(op)
317 /* This cannot possibly be right, but it was copied from the old slab
318 allocator, to which it was originally added, without explanation, in
321 # define PerlMemShared PerlMem
325 Perl_Slab_Free(pTHX_ void *op)
328 OP * const o = (OP *)op;
331 PERL_ARGS_ASSERT_SLAB_FREE;
333 if (!o->op_slabbed) {
335 PerlMemShared_free(op);
340 /* If this op is already freed, our refcount will get screwy. */
341 assert(o->op_type != OP_FREED);
342 o->op_type = OP_FREED;
343 o->op_next = slab->opslab_freed;
344 slab->opslab_freed = o;
345 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
346 OpslabREFCNT_dec_padok(slab);
350 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
353 const bool havepad = !!PL_comppad;
354 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
357 PAD_SAVE_SETNULLPAD();
364 Perl_opslab_free(pTHX_ OPSLAB *slab)
368 PERL_ARGS_ASSERT_OPSLAB_FREE;
369 DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
370 assert(slab->opslab_refcnt == 1);
371 for (; slab; slab = slab2) {
372 slab2 = slab->opslab_next;
374 slab->opslab_refcnt = ~(size_t)0;
376 #ifdef PERL_DEBUG_READONLY_OPS
377 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
379 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
380 perror("munmap failed");
384 PerlMemShared_free(slab);
390 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
395 size_t savestack_count = 0;
397 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
400 for (slot = slab2->opslab_first;
402 slot = slot->opslot_next) {
403 if (slot->opslot_op.op_type != OP_FREED
404 && !(slot->opslot_op.op_savefree
410 assert(slot->opslot_op.op_slabbed);
411 op_free(&slot->opslot_op);
412 if (slab->opslab_refcnt == 1) goto free;
415 } while ((slab2 = slab2->opslab_next));
416 /* > 1 because the CV still holds a reference count. */
417 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
419 assert(savestack_count == slab->opslab_refcnt-1);
421 /* Remove the CV’s reference count. */
422 slab->opslab_refcnt--;
429 #ifdef PERL_DEBUG_READONLY_OPS
431 Perl_op_refcnt_inc(pTHX_ OP *o)
434 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
435 if (slab && slab->opslab_readonly) {
448 Perl_op_refcnt_dec(pTHX_ OP *o)
451 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
453 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
455 if (slab && slab->opslab_readonly) {
457 result = --o->op_targ;
460 result = --o->op_targ;
466 * In the following definition, the ", (OP*)0" is just to make the compiler
467 * think the expression is of the right type: croak actually does a Siglongjmp.
469 #define CHECKOP(type,o) \
470 ((PL_op_mask && PL_op_mask[type]) \
471 ? ( op_free((OP*)o), \
472 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
474 : PL_check[type](aTHX_ (OP*)o))
476 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
478 #define CHANGE_TYPE(o,type) \
480 o->op_type = (OPCODE)type; \
481 o->op_ppaddr = PL_ppaddr[type]; \
485 S_gv_ename(pTHX_ GV *gv)
487 SV* const tmpsv = sv_newmortal();
489 PERL_ARGS_ASSERT_GV_ENAME;
491 gv_efullname3(tmpsv, gv, NULL);
496 S_no_fh_allowed(pTHX_ OP *o)
498 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
500 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
506 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
508 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
509 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
510 SvUTF8(namesv) | flags);
515 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
517 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
518 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
523 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
525 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
527 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
532 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
534 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
536 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
537 SvUTF8(namesv) | flags);
542 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
544 PERL_ARGS_ASSERT_BAD_TYPE_PV;
546 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
547 (int)n, name, t, OP_DESC(kid)), flags);
551 S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
553 PERL_ARGS_ASSERT_BAD_TYPE_SV;
555 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
556 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
560 S_no_bareword_allowed(pTHX_ OP *o)
562 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
565 return; /* various ok barewords are hidden in extra OP_NULL */
566 qerror(Perl_mess(aTHX_
567 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
569 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
572 /* "register" allocation */
575 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
579 const bool is_our = (PL_parser->in_my == KEY_our);
581 PERL_ARGS_ASSERT_ALLOCMY;
583 if (flags & ~SVf_UTF8)
584 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
587 /* Until we're using the length for real, cross check that we're being
589 assert(strlen(name) == len);
591 /* complain about "my $<special_var>" etc etc */
595 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
596 (name[1] == '_' && (*name == '$' || len > 2))))
598 /* name[2] is true if strlen(name) > 2 */
599 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
600 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
601 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
602 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
603 PL_parser->in_my == KEY_state ? "state" : "my"));
605 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
606 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
609 else if (len == 2 && name[1] == '_' && !is_our)
610 /* diag_listed_as: Use of my $_ is experimental */
611 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
612 "Use of %s $_ is experimental",
613 PL_parser->in_my == KEY_state
617 /* allocate a spare slot and store the name in that slot */
619 off = pad_add_name_pvn(name, len,
620 (is_our ? padadd_OUR :
621 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
622 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
623 PL_parser->in_my_stash,
625 /* $_ is always in main::, even with our */
626 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
630 /* anon sub prototypes contains state vars should always be cloned,
631 * otherwise the state var would be shared between anon subs */
633 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
634 CvCLONE_on(PL_compcv);
640 =for apidoc alloccopstash
642 Available only under threaded builds, this function allocates an entry in
643 C<PL_stashpad> for the stash passed to it.
650 Perl_alloccopstash(pTHX_ HV *hv)
652 PADOFFSET off = 0, o = 1;
653 bool found_slot = FALSE;
655 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
657 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
659 for (; o < PL_stashpadmax; ++o) {
660 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
661 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
662 found_slot = TRUE, off = o;
665 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
666 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
667 off = PL_stashpadmax;
668 PL_stashpadmax += 10;
671 PL_stashpad[PL_stashpadix = off] = hv;
676 /* free the body of an op without examining its contents.
677 * Always use this rather than FreeOp directly */
680 S_op_destroy(pTHX_ OP *o)
688 Perl_op_free(pTHX_ OP *o)
693 /* Though ops may be freed twice, freeing the op after its slab is a
695 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
696 /* During the forced freeing of ops after compilation failure, kidops
697 may be freed before their parents. */
698 if (!o || o->op_type == OP_FREED)
702 if (o->op_private & OPpREFCOUNTED) {
713 refcnt = OpREFCNT_dec(o);
716 /* Need to find and remove any pattern match ops from the list
717 we maintain for reset(). */
718 find_and_forget_pmops(o);
728 /* Call the op_free hook if it has been set. Do it now so that it's called
729 * at the right time for refcounted ops, but still before all of the kids
733 if (o->op_flags & OPf_KIDS) {
735 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
736 nextkid = kid->op_sibling; /* Get before next freeing kid */
741 type = (OPCODE)o->op_targ;
744 Slab_to_rw(OpSLAB(o));
747 /* COP* is not cleared by op_clear() so that we may track line
748 * numbers etc even after null() */
749 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
755 #ifdef DEBUG_LEAKING_SCALARS
762 Perl_op_clear(pTHX_ OP *o)
767 PERL_ARGS_ASSERT_OP_CLEAR;
770 mad_free(o->op_madprop);
775 switch (o->op_type) {
776 case OP_NULL: /* Was holding old type, if any. */
777 if (PL_madskills && o->op_targ != OP_NULL) {
778 o->op_type = (Optype)o->op_targ;
783 case OP_ENTEREVAL: /* Was holding hints. */
787 if (!(o->op_flags & OPf_REF)
788 || (PL_check[o->op_type] != Perl_ck_ftst))
795 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
800 /* It's possible during global destruction that the GV is freed
801 before the optree. Whilst the SvREFCNT_inc is happy to bump from
802 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
803 will trigger an assertion failure, because the entry to sv_clear
804 checks that the scalar is not already freed. A check of for
805 !SvIS_FREED(gv) turns out to be invalid, because during global
806 destruction the reference count can be forced down to zero
807 (with SVf_BREAK set). In which case raising to 1 and then
808 dropping to 0 triggers cleanup before it should happen. I
809 *think* that this might actually be a general, systematic,
810 weakness of the whole idea of SVf_BREAK, in that code *is*
811 allowed to raise and lower references during global destruction,
812 so any *valid* code that happens to do this during global
813 destruction might well trigger premature cleanup. */
814 bool still_valid = gv && SvREFCNT(gv);
817 SvREFCNT_inc_simple_void(gv);
819 if (cPADOPo->op_padix > 0) {
820 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
821 * may still exist on the pad */
822 pad_swipe(cPADOPo->op_padix, TRUE);
823 cPADOPo->op_padix = 0;
826 SvREFCNT_dec(cSVOPo->op_sv);
827 cSVOPo->op_sv = NULL;
830 int try_downgrade = SvREFCNT(gv) == 2;
833 gv_try_downgrade(gv);
837 case OP_METHOD_NAMED:
840 SvREFCNT_dec(cSVOPo->op_sv);
841 cSVOPo->op_sv = NULL;
844 Even if op_clear does a pad_free for the target of the op,
845 pad_free doesn't actually remove the sv that exists in the pad;
846 instead it lives on. This results in that it could be reused as
847 a target later on when the pad was reallocated.
850 pad_swipe(o->op_targ,1);
860 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
865 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
866 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
868 if (cPADOPo->op_padix > 0) {
869 pad_swipe(cPADOPo->op_padix, TRUE);
870 cPADOPo->op_padix = 0;
873 SvREFCNT_dec(cSVOPo->op_sv);
874 cSVOPo->op_sv = NULL;
878 PerlMemShared_free(cPVOPo->op_pv);
879 cPVOPo->op_pv = NULL;
883 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
887 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
888 /* No GvIN_PAD_off here, because other references may still
889 * exist on the pad */
890 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
893 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
899 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
900 op_free(cPMOPo->op_code_list);
901 cPMOPo->op_code_list = NULL;
903 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
904 /* we use the same protection as the "SAFE" version of the PM_ macros
905 * here since sv_clean_all might release some PMOPs
906 * after PL_regex_padav has been cleared
907 * and the clearing of PL_regex_padav needs to
908 * happen before sv_clean_all
911 if(PL_regex_pad) { /* We could be in destruction */
912 const IV offset = (cPMOPo)->op_pmoffset;
913 ReREFCNT_dec(PM_GETRE(cPMOPo));
914 PL_regex_pad[offset] = &PL_sv_undef;
915 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
919 ReREFCNT_dec(PM_GETRE(cPMOPo));
920 PM_SETRE(cPMOPo, NULL);
926 if (o->op_targ > 0) {
927 pad_free(o->op_targ);
933 S_cop_free(pTHX_ COP* cop)
935 PERL_ARGS_ASSERT_COP_FREE;
938 if (! specialWARN(cop->cop_warnings))
939 PerlMemShared_free(cop->cop_warnings);
940 cophh_free(CopHINTHASH_get(cop));
944 S_forget_pmop(pTHX_ PMOP *const o
947 HV * const pmstash = PmopSTASH(o);
949 PERL_ARGS_ASSERT_FORGET_PMOP;
951 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
952 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
954 PMOP **const array = (PMOP**) mg->mg_ptr;
955 U32 count = mg->mg_len / sizeof(PMOP**);
960 /* Found it. Move the entry at the end to overwrite it. */
961 array[i] = array[--count];
962 mg->mg_len = count * sizeof(PMOP**);
963 /* Could realloc smaller at this point always, but probably
964 not worth it. Probably worth free()ing if we're the
967 Safefree(mg->mg_ptr);
980 S_find_and_forget_pmops(pTHX_ OP *o)
982 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
984 if (o->op_flags & OPf_KIDS) {
985 OP *kid = cUNOPo->op_first;
987 switch (kid->op_type) {
992 forget_pmop((PMOP*)kid);
994 find_and_forget_pmops(kid);
995 kid = kid->op_sibling;
1001 Perl_op_null(pTHX_ OP *o)
1005 PERL_ARGS_ASSERT_OP_NULL;
1007 if (o->op_type == OP_NULL)
1011 o->op_targ = o->op_type;
1012 o->op_type = OP_NULL;
1013 o->op_ppaddr = PL_ppaddr[OP_NULL];
1017 Perl_op_refcnt_lock(pTHX)
1020 PERL_UNUSED_CONTEXT;
1025 Perl_op_refcnt_unlock(pTHX)
1028 PERL_UNUSED_CONTEXT;
1032 /* Contextualizers */
1035 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1037 Applies a syntactic context to an op tree representing an expression.
1038 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1039 or C<G_VOID> to specify the context to apply. The modified op tree
1046 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1048 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1050 case G_SCALAR: return scalar(o);
1051 case G_ARRAY: return list(o);
1052 case G_VOID: return scalarvoid(o);
1054 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1061 =head1 Optree Manipulation Functions
1063 =for apidoc Am|OP*|op_linklist|OP *o
1064 This function is the implementation of the L</LINKLIST> macro. It should
1065 not be called directly.
1071 Perl_op_linklist(pTHX_ OP *o)
1075 PERL_ARGS_ASSERT_OP_LINKLIST;
1080 /* establish postfix order */
1081 first = cUNOPo->op_first;
1084 o->op_next = LINKLIST(first);
1087 if (kid->op_sibling) {
1088 kid->op_next = LINKLIST(kid->op_sibling);
1089 kid = kid->op_sibling;
1103 S_scalarkids(pTHX_ OP *o)
1105 if (o && o->op_flags & OPf_KIDS) {
1107 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1114 S_scalarboolean(pTHX_ OP *o)
1118 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1120 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1121 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1122 if (ckWARN(WARN_SYNTAX)) {
1123 const line_t oldline = CopLINE(PL_curcop);
1125 if (PL_parser && PL_parser->copline != NOLINE) {
1126 /* This ensures that warnings are reported at the first line
1127 of the conditional, not the last. */
1128 CopLINE_set(PL_curcop, PL_parser->copline);
1130 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1131 CopLINE_set(PL_curcop, oldline);
1138 Perl_scalar(pTHX_ OP *o)
1143 /* assumes no premature commitment */
1144 if (!o || (PL_parser && PL_parser->error_count)
1145 || (o->op_flags & OPf_WANT)
1146 || o->op_type == OP_RETURN)
1151 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1153 switch (o->op_type) {
1155 scalar(cBINOPo->op_first);
1160 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1170 if (o->op_flags & OPf_KIDS) {
1171 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1177 kid = cLISTOPo->op_first;
1179 kid = kid->op_sibling;
1182 OP *sib = kid->op_sibling;
1183 if (sib && kid->op_type != OP_LEAVEWHEN)
1189 PL_curcop = &PL_compiling;
1194 kid = cLISTOPo->op_first;
1197 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1204 Perl_scalarvoid(pTHX_ OP *o)
1208 SV *useless_sv = NULL;
1209 const char* useless = NULL;
1213 PERL_ARGS_ASSERT_SCALARVOID;
1215 /* trailing mad null ops don't count as "there" for void processing */
1217 o->op_type != OP_NULL &&
1219 o->op_sibling->op_type == OP_NULL)
1222 for (sib = o->op_sibling;
1223 sib && sib->op_type == OP_NULL;
1224 sib = sib->op_sibling) ;
1230 if (o->op_type == OP_NEXTSTATE
1231 || o->op_type == OP_DBSTATE
1232 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1233 || o->op_targ == OP_DBSTATE)))
1234 PL_curcop = (COP*)o; /* for warning below */
1236 /* assumes no premature commitment */
1237 want = o->op_flags & OPf_WANT;
1238 if ((want && want != OPf_WANT_SCALAR)
1239 || (PL_parser && PL_parser->error_count)
1240 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1245 if ((o->op_private & OPpTARGET_MY)
1246 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1248 return scalar(o); /* As if inside SASSIGN */
1251 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1253 switch (o->op_type) {
1255 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1259 if (o->op_flags & OPf_STACKED)
1263 if (o->op_private == 4)
1288 case OP_AELEMFAST_LEX:
1307 case OP_GETSOCKNAME:
1308 case OP_GETPEERNAME:
1313 case OP_GETPRIORITY:
1338 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1339 /* Otherwise it's "Useless use of grep iterator" */
1340 useless = OP_DESC(o);
1344 kid = cLISTOPo->op_first;
1345 if (kid && kid->op_type == OP_PUSHRE
1347 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1349 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1351 useless = OP_DESC(o);
1355 kid = cUNOPo->op_first;
1356 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1357 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1360 useless = "negative pattern binding (!~)";
1364 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1365 useless = "non-destructive substitution (s///r)";
1369 useless = "non-destructive transliteration (tr///r)";
1376 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1377 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1378 useless = "a variable";
1383 if (cSVOPo->op_private & OPpCONST_STRICT)
1384 no_bareword_allowed(o);
1386 if (ckWARN(WARN_VOID)) {
1387 /* don't warn on optimised away booleans, eg
1388 * use constant Foo, 5; Foo || print; */
1389 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1391 /* the constants 0 and 1 are permitted as they are
1392 conventionally used as dummies in constructs like
1393 1 while some_condition_with_side_effects; */
1394 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1396 else if (SvPOK(sv)) {
1397 /* perl4's way of mixing documentation and code
1398 (before the invention of POD) was based on a
1399 trick to mix nroff and perl code. The trick was
1400 built upon these three nroff macros being used in
1401 void context. The pink camel has the details in
1402 the script wrapman near page 319. */
1403 const char * const maybe_macro = SvPVX_const(sv);
1404 if (strnEQ(maybe_macro, "di", 2) ||
1405 strnEQ(maybe_macro, "ds", 2) ||
1406 strnEQ(maybe_macro, "ig", 2))
1409 SV * const dsv = newSVpvs("");
1411 = Perl_newSVpvf(aTHX_
1413 pv_pretty(dsv, maybe_macro,
1414 SvCUR(sv), 32, NULL, NULL,
1416 | PERL_PV_ESCAPE_NOCLEAR
1417 | PERL_PV_ESCAPE_UNI_DETECT));
1418 SvREFCNT_dec_NN(dsv);
1421 else if (SvOK(sv)) {
1422 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
1425 useless = "a constant (undef)";
1428 op_null(o); /* don't execute or even remember it */
1432 o->op_type = OP_PREINC; /* pre-increment is faster */
1433 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1437 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1438 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1442 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1443 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1447 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1448 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1453 UNOP *refgen, *rv2cv;
1456 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1459 rv2gv = ((BINOP *)o)->op_last;
1460 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1463 refgen = (UNOP *)((BINOP *)o)->op_first;
1465 if (!refgen || refgen->op_type != OP_REFGEN)
1468 exlist = (LISTOP *)refgen->op_first;
1469 if (!exlist || exlist->op_type != OP_NULL
1470 || exlist->op_targ != OP_LIST)
1473 if (exlist->op_first->op_type != OP_PUSHMARK)
1476 rv2cv = (UNOP*)exlist->op_last;
1478 if (rv2cv->op_type != OP_RV2CV)
1481 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1482 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1483 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1485 o->op_private |= OPpASSIGN_CV_TO_GV;
1486 rv2gv->op_private |= OPpDONT_INIT_GV;
1487 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1499 kid = cLOGOPo->op_first;
1500 if (kid->op_type == OP_NOT
1501 && (kid->op_flags & OPf_KIDS)
1503 if (o->op_type == OP_AND) {
1505 o->op_ppaddr = PL_ppaddr[OP_OR];
1507 o->op_type = OP_AND;
1508 o->op_ppaddr = PL_ppaddr[OP_AND];
1517 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1522 if (o->op_flags & OPf_STACKED)
1529 if (!(o->op_flags & OPf_KIDS))
1540 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1551 /* mortalise it, in case warnings are fatal. */
1552 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1553 "Useless use of %"SVf" in void context",
1554 sv_2mortal(useless_sv));
1557 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1558 "Useless use of %s in void context",
1565 S_listkids(pTHX_ OP *o)
1567 if (o && o->op_flags & OPf_KIDS) {
1569 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1576 Perl_list(pTHX_ OP *o)
1581 /* assumes no premature commitment */
1582 if (!o || (o->op_flags & OPf_WANT)
1583 || (PL_parser && PL_parser->error_count)
1584 || o->op_type == OP_RETURN)
1589 if ((o->op_private & OPpTARGET_MY)
1590 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1592 return o; /* As if inside SASSIGN */
1595 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1597 switch (o->op_type) {
1600 list(cBINOPo->op_first);
1605 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1613 if (!(o->op_flags & OPf_KIDS))
1615 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1616 list(cBINOPo->op_first);
1617 return gen_constant_list(o);
1624 kid = cLISTOPo->op_first;
1626 kid = kid->op_sibling;
1629 OP *sib = kid->op_sibling;
1630 if (sib && kid->op_type != OP_LEAVEWHEN)
1636 PL_curcop = &PL_compiling;
1640 kid = cLISTOPo->op_first;
1647 S_scalarseq(pTHX_ OP *o)
1651 const OPCODE type = o->op_type;
1653 if (type == OP_LINESEQ || type == OP_SCOPE ||
1654 type == OP_LEAVE || type == OP_LEAVETRY)
1657 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1658 if (kid->op_sibling) {
1662 PL_curcop = &PL_compiling;
1664 o->op_flags &= ~OPf_PARENS;
1665 if (PL_hints & HINT_BLOCK_SCOPE)
1666 o->op_flags |= OPf_PARENS;
1669 o = newOP(OP_STUB, 0);
1674 S_modkids(pTHX_ OP *o, I32 type)
1676 if (o && o->op_flags & OPf_KIDS) {
1678 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1679 op_lvalue(kid, type);
1685 =for apidoc finalize_optree
1687 This function finalizes the optree. Should be called directly after
1688 the complete optree is built. It does some additional
1689 checking which can't be done in the normal ck_xxx functions and makes
1690 the tree thread-safe.
1695 Perl_finalize_optree(pTHX_ OP* o)
1697 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1700 SAVEVPTR(PL_curcop);
1708 S_finalize_op(pTHX_ OP* o)
1710 PERL_ARGS_ASSERT_FINALIZE_OP;
1712 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1714 /* Make sure mad ops are also thread-safe */
1715 MADPROP *mp = o->op_madprop;
1717 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1718 OP *prop_op = (OP *) mp->mad_val;
1719 /* We only need "Relocate sv to the pad for thread safety.", but this
1720 easiest way to make sure it traverses everything */
1721 if (prop_op->op_type == OP_CONST)
1722 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1723 finalize_op(prop_op);
1730 switch (o->op_type) {
1733 PL_curcop = ((COP*)o); /* for warnings */
1737 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1738 && ckWARN(WARN_EXEC))
1740 if (o->op_sibling->op_sibling) {
1741 const OPCODE type = o->op_sibling->op_sibling->op_type;
1742 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1743 const line_t oldline = CopLINE(PL_curcop);
1744 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1745 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1746 "Statement unlikely to be reached");
1747 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1748 "\t(Maybe you meant system() when you said exec()?)\n");
1749 CopLINE_set(PL_curcop, oldline);
1756 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1757 GV * const gv = cGVOPo_gv;
1758 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1759 /* XXX could check prototype here instead of just carping */
1760 SV * const sv = sv_newmortal();
1761 gv_efullname3(sv, gv, NULL);
1762 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1763 "%"SVf"() called too early to check prototype",
1770 if (cSVOPo->op_private & OPpCONST_STRICT)
1771 no_bareword_allowed(o);
1775 case OP_METHOD_NAMED:
1776 /* Relocate sv to the pad for thread safety.
1777 * Despite being a "constant", the SV is written to,
1778 * for reference counts, sv_upgrade() etc. */
1779 if (cSVOPo->op_sv) {
1780 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1781 if (o->op_type != OP_METHOD_NAMED &&
1782 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1784 /* If op_sv is already a PADTMP/MY then it is being used by
1785 * some pad, so make a copy. */
1786 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1787 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1788 SvREFCNT_dec(cSVOPo->op_sv);
1790 else if (o->op_type != OP_METHOD_NAMED
1791 && cSVOPo->op_sv == &PL_sv_undef) {
1792 /* PL_sv_undef is hack - it's unsafe to store it in the
1793 AV that is the pad, because av_fetch treats values of
1794 PL_sv_undef as a "free" AV entry and will merrily
1795 replace them with a new SV, causing pad_alloc to think
1796 that this pad slot is free. (When, clearly, it is not)
1798 SvOK_off(PAD_SVl(ix));
1799 SvPADTMP_on(PAD_SVl(ix));
1800 SvREADONLY_on(PAD_SVl(ix));
1803 SvREFCNT_dec(PAD_SVl(ix));
1804 SvPADTMP_on(cSVOPo->op_sv);
1805 PAD_SETSV(ix, cSVOPo->op_sv);
1806 /* XXX I don't know how this isn't readonly already. */
1807 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1809 cSVOPo->op_sv = NULL;
1820 const char *key = NULL;
1823 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1826 /* Make the CONST have a shared SV */
1827 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1828 if ((!SvIsCOW(sv = *svp))
1829 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1830 key = SvPV_const(sv, keylen);
1831 lexname = newSVpvn_share(key,
1832 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1834 SvREFCNT_dec_NN(sv);
1838 if ((o->op_private & (OPpLVAL_INTRO)))
1841 rop = (UNOP*)((BINOP*)o)->op_first;
1842 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1844 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1845 if (!SvPAD_TYPED(lexname))
1847 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1848 if (!fields || !GvHV(*fields))
1850 key = SvPV_const(*svp, keylen);
1851 if (!hv_fetch(GvHV(*fields), key,
1852 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1853 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1854 "in variable %"SVf" of type %"HEKf,
1855 SVfARG(*svp), SVfARG(lexname),
1856 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1868 SVOP *first_key_op, *key_op;
1870 if ((o->op_private & (OPpLVAL_INTRO))
1871 /* I bet there's always a pushmark... */
1872 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1873 /* hmmm, no optimization if list contains only one key. */
1875 rop = (UNOP*)((LISTOP*)o)->op_last;
1876 if (rop->op_type != OP_RV2HV)
1878 if (rop->op_first->op_type == OP_PADSV)
1879 /* @$hash{qw(keys here)} */
1880 rop = (UNOP*)rop->op_first;
1882 /* @{$hash}{qw(keys here)} */
1883 if (rop->op_first->op_type == OP_SCOPE
1884 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1886 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1892 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1893 if (!SvPAD_TYPED(lexname))
1895 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1896 if (!fields || !GvHV(*fields))
1898 /* Again guessing that the pushmark can be jumped over.... */
1899 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1900 ->op_first->op_sibling;
1901 for (key_op = first_key_op; key_op;
1902 key_op = (SVOP*)key_op->op_sibling) {
1903 if (key_op->op_type != OP_CONST)
1905 svp = cSVOPx_svp(key_op);
1906 key = SvPV_const(*svp, keylen);
1907 if (!hv_fetch(GvHV(*fields), key,
1908 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1909 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1910 "in variable %"SVf" of type %"HEKf,
1911 SVfARG(*svp), SVfARG(lexname),
1912 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1919 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1920 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1927 if (o->op_flags & OPf_KIDS) {
1929 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1935 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1937 Propagate lvalue ("modifiable") context to an op and its children.
1938 I<type> represents the context type, roughly based on the type of op that
1939 would do the modifying, although C<local()> is represented by OP_NULL,
1940 because it has no op type of its own (it is signalled by a flag on
1943 This function detects things that can't be modified, such as C<$x+1>, and
1944 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1945 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1947 It also flags things that need to behave specially in an lvalue context,
1948 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1954 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1958 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1961 if (!o || (PL_parser && PL_parser->error_count))
1964 if ((o->op_private & OPpTARGET_MY)
1965 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1970 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1972 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1974 switch (o->op_type) {
1979 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1983 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1984 !(o->op_flags & OPf_STACKED)) {
1985 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1986 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1987 poses, so we need it clear. */
1988 o->op_private &= ~1;
1989 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1990 assert(cUNOPo->op_first->op_type == OP_NULL);
1991 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1994 else { /* lvalue subroutine call */
1995 o->op_private |= OPpLVAL_INTRO
1996 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1997 PL_modcount = RETURN_UNLIMITED_NUMBER;
1998 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1999 /* Potential lvalue context: */
2000 o->op_private |= OPpENTERSUB_INARGS;
2003 else { /* Compile-time error message: */
2004 OP *kid = cUNOPo->op_first;
2007 if (kid->op_type != OP_PUSHMARK) {
2008 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2010 "panic: unexpected lvalue entersub "
2011 "args: type/targ %ld:%"UVuf,
2012 (long)kid->op_type, (UV)kid->op_targ);
2013 kid = kLISTOP->op_first;
2015 while (kid->op_sibling)
2016 kid = kid->op_sibling;
2017 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2018 break; /* Postpone until runtime */
2021 kid = kUNOP->op_first;
2022 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2023 kid = kUNOP->op_first;
2024 if (kid->op_type == OP_NULL)
2026 "Unexpected constant lvalue entersub "
2027 "entry via type/targ %ld:%"UVuf,
2028 (long)kid->op_type, (UV)kid->op_targ);
2029 if (kid->op_type != OP_GV) {
2033 cv = GvCV(kGVOP_gv);
2043 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2044 /* grep, foreach, subcalls, refgen */
2045 if (type == OP_GREPSTART || type == OP_ENTERSUB
2046 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2048 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2049 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2051 : (o->op_type == OP_ENTERSUB
2052 ? "non-lvalue subroutine call"
2054 type ? PL_op_desc[type] : "local"));
2068 case OP_RIGHT_SHIFT:
2077 if (!(o->op_flags & OPf_STACKED))
2084 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2085 op_lvalue(kid, type);
2090 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2091 PL_modcount = RETURN_UNLIMITED_NUMBER;
2092 return o; /* Treat \(@foo) like ordinary list. */
2096 if (scalar_mod_type(o, type))
2098 ref(cUNOPo->op_first, o->op_type);
2105 if (type == OP_LEAVESUBLV)
2106 o->op_private |= OPpMAYBE_LVSUB;
2110 PL_modcount = RETURN_UNLIMITED_NUMBER;
2113 PL_hints |= HINT_BLOCK_SCOPE;
2114 if (type == OP_LEAVESUBLV)
2115 o->op_private |= OPpMAYBE_LVSUB;
2119 ref(cUNOPo->op_first, o->op_type);
2123 PL_hints |= HINT_BLOCK_SCOPE;
2132 case OP_AELEMFAST_LEX:
2139 PL_modcount = RETURN_UNLIMITED_NUMBER;
2140 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2141 return o; /* Treat \(@foo) like ordinary list. */
2142 if (scalar_mod_type(o, type))
2144 if (type == OP_LEAVESUBLV)
2145 o->op_private |= OPpMAYBE_LVSUB;
2149 if (!type) /* local() */
2150 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2151 PAD_COMPNAME_SV(o->op_targ));
2160 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2164 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2170 if (type == OP_LEAVESUBLV)
2171 o->op_private |= OPpMAYBE_LVSUB;
2172 if (o->op_flags & OPf_KIDS)
2173 op_lvalue(cBINOPo->op_first->op_sibling, type);
2178 ref(cBINOPo->op_first, o->op_type);
2179 if (type == OP_ENTERSUB &&
2180 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2181 o->op_private |= OPpLVAL_DEFER;
2182 if (type == OP_LEAVESUBLV)
2183 o->op_private |= OPpMAYBE_LVSUB;
2193 if (o->op_flags & OPf_KIDS)
2194 op_lvalue(cLISTOPo->op_last, type);
2199 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2201 else if (!(o->op_flags & OPf_KIDS))
2203 if (o->op_targ != OP_LIST) {
2204 op_lvalue(cBINOPo->op_first, type);
2210 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2211 /* elements might be in void context because the list is
2212 in scalar context or because they are attribute sub calls */
2213 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2214 op_lvalue(kid, type);
2218 if (type != OP_LEAVESUBLV)
2220 break; /* op_lvalue()ing was handled by ck_return() */
2226 /* [20011101.069] File test operators interpret OPf_REF to mean that
2227 their argument is a filehandle; thus \stat(".") should not set
2229 if (type == OP_REFGEN &&
2230 PL_check[o->op_type] == Perl_ck_ftst)
2233 if (type != OP_LEAVESUBLV)
2234 o->op_flags |= OPf_MOD;
2236 if (type == OP_AASSIGN || type == OP_SASSIGN)
2237 o->op_flags |= OPf_SPECIAL|OPf_REF;
2238 else if (!type) { /* local() */
2241 o->op_private |= OPpLVAL_INTRO;
2242 o->op_flags &= ~OPf_SPECIAL;
2243 PL_hints |= HINT_BLOCK_SCOPE;
2248 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2249 "Useless localization of %s", OP_DESC(o));
2252 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2253 && type != OP_LEAVESUBLV)
2254 o->op_flags |= OPf_REF;
2259 S_scalar_mod_type(const OP *o, I32 type)
2264 if (o && o->op_type == OP_RV2GV)
2288 case OP_RIGHT_SHIFT:
2309 S_is_handle_constructor(const OP *o, I32 numargs)
2311 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2313 switch (o->op_type) {
2321 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2334 S_refkids(pTHX_ OP *o, I32 type)
2336 if (o && o->op_flags & OPf_KIDS) {
2338 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2345 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2350 PERL_ARGS_ASSERT_DOREF;
2352 if (!o || (PL_parser && PL_parser->error_count))
2355 switch (o->op_type) {
2357 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2358 !(o->op_flags & OPf_STACKED)) {
2359 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2360 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2361 assert(cUNOPo->op_first->op_type == OP_NULL);
2362 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2363 o->op_flags |= OPf_SPECIAL;
2364 o->op_private &= ~1;
2366 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2367 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2368 : type == OP_RV2HV ? OPpDEREF_HV
2370 o->op_flags |= OPf_MOD;
2376 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2377 doref(kid, type, set_op_ref);
2380 if (type == OP_DEFINED)
2381 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2382 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2385 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2386 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2387 : type == OP_RV2HV ? OPpDEREF_HV
2389 o->op_flags |= OPf_MOD;
2396 o->op_flags |= OPf_REF;
2399 if (type == OP_DEFINED)
2400 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2401 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2407 o->op_flags |= OPf_REF;
2412 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2414 doref(cBINOPo->op_first, type, set_op_ref);
2418 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2419 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2420 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2421 : type == OP_RV2HV ? OPpDEREF_HV
2423 o->op_flags |= OPf_MOD;
2433 if (!(o->op_flags & OPf_KIDS))
2435 doref(cLISTOPo->op_last, type, set_op_ref);
2445 S_dup_attrlist(pTHX_ OP *o)
2450 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2452 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2453 * where the first kid is OP_PUSHMARK and the remaining ones
2454 * are OP_CONST. We need to push the OP_CONST values.
2456 if (o->op_type == OP_CONST)
2457 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2459 else if (o->op_type == OP_NULL)
2463 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2465 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2466 if (o->op_type == OP_CONST)
2467 rop = op_append_elem(OP_LIST, rop,
2468 newSVOP(OP_CONST, o->op_flags,
2469 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2476 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2479 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2481 PERL_ARGS_ASSERT_APPLY_ATTRS;
2483 /* fake up C<use attributes $pkg,$rv,@attrs> */
2484 ENTER; /* need to protect against side-effects of 'use' */
2486 #define ATTRSMODULE "attributes"
2487 #define ATTRSMODULE_PM "attributes.pm"
2489 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2490 newSVpvs(ATTRSMODULE),
2492 op_prepend_elem(OP_LIST,
2493 newSVOP(OP_CONST, 0, stashsv),
2494 op_prepend_elem(OP_LIST,
2495 newSVOP(OP_CONST, 0,
2497 dup_attrlist(attrs))));
2502 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2505 OP *pack, *imop, *arg;
2506 SV *meth, *stashsv, **svp;
2508 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2513 assert(target->op_type == OP_PADSV ||
2514 target->op_type == OP_PADHV ||
2515 target->op_type == OP_PADAV);
2517 /* Ensure that attributes.pm is loaded. */
2518 ENTER; /* need to protect against side-effects of 'use' */
2519 /* Don't force the C<use> if we don't need it. */
2520 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2521 if (svp && *svp != &PL_sv_undef)
2522 NOOP; /* already in %INC */
2524 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2525 newSVpvs(ATTRSMODULE), NULL);
2528 /* Need package name for method call. */
2529 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2531 /* Build up the real arg-list. */
2532 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2534 arg = newOP(OP_PADSV, 0);
2535 arg->op_targ = target->op_targ;
2536 arg = op_prepend_elem(OP_LIST,
2537 newSVOP(OP_CONST, 0, stashsv),
2538 op_prepend_elem(OP_LIST,
2539 newUNOP(OP_REFGEN, 0,
2540 op_lvalue(arg, OP_REFGEN)),
2541 dup_attrlist(attrs)));
2543 /* Fake up a method call to import */
2544 meth = newSVpvs_share("import");
2545 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2546 op_append_elem(OP_LIST,
2547 op_prepend_elem(OP_LIST, pack, list(arg)),
2548 newSVOP(OP_METHOD_NAMED, 0, meth)));
2550 /* Combine the ops. */
2551 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2555 =notfor apidoc apply_attrs_string
2557 Attempts to apply a list of attributes specified by the C<attrstr> and
2558 C<len> arguments to the subroutine identified by the C<cv> argument which
2559 is expected to be associated with the package identified by the C<stashpv>
2560 argument (see L<attributes>). It gets this wrong, though, in that it
2561 does not correctly identify the boundaries of the individual attribute
2562 specifications within C<attrstr>. This is not really intended for the
2563 public API, but has to be listed here for systems such as AIX which
2564 need an explicit export list for symbols. (It's called from XS code
2565 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2566 to respect attribute syntax properly would be welcome.
2572 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2573 const char *attrstr, STRLEN len)
2577 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2580 len = strlen(attrstr);
2584 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2586 const char * const sstr = attrstr;
2587 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2588 attrs = op_append_elem(OP_LIST, attrs,
2589 newSVOP(OP_CONST, 0,
2590 newSVpvn(sstr, attrstr-sstr)));
2594 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2595 newSVpvs(ATTRSMODULE),
2596 NULL, op_prepend_elem(OP_LIST,
2597 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2598 op_prepend_elem(OP_LIST,
2599 newSVOP(OP_CONST, 0,
2600 newRV(MUTABLE_SV(cv))),
2605 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2609 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2611 PERL_ARGS_ASSERT_MY_KID;
2613 if (!o || (PL_parser && PL_parser->error_count))
2617 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2618 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2622 if (type == OP_LIST) {
2624 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2625 my_kid(kid, attrs, imopsp);
2627 } else if (type == OP_UNDEF || type == OP_STUB) {
2629 } else if (type == OP_RV2SV || /* "our" declaration */
2631 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2632 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2633 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2635 PL_parser->in_my == KEY_our
2637 : PL_parser->in_my == KEY_state ? "state" : "my"));
2639 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2640 PL_parser->in_my = FALSE;
2641 PL_parser->in_my_stash = NULL;
2642 apply_attrs(GvSTASH(gv),
2643 (type == OP_RV2SV ? GvSV(gv) :
2644 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2645 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2648 o->op_private |= OPpOUR_INTRO;
2651 else if (type != OP_PADSV &&
2654 type != OP_PUSHMARK)
2656 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2658 PL_parser->in_my == KEY_our
2660 : PL_parser->in_my == KEY_state ? "state" : "my"));
2663 else if (attrs && type != OP_PUSHMARK) {
2666 PL_parser->in_my = FALSE;
2667 PL_parser->in_my_stash = NULL;
2669 /* check for C<my Dog $spot> when deciding package */
2670 stash = PAD_COMPNAME_TYPE(o->op_targ);
2672 stash = PL_curstash;
2673 apply_attrs_my(stash, o, attrs, imopsp);
2675 o->op_flags |= OPf_MOD;
2676 o->op_private |= OPpLVAL_INTRO;
2678 o->op_private |= OPpPAD_STATE;
2683 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2687 int maybe_scalar = 0;
2689 PERL_ARGS_ASSERT_MY_ATTRS;
2691 /* [perl #17376]: this appears to be premature, and results in code such as
2692 C< our(%x); > executing in list mode rather than void mode */
2694 if (o->op_flags & OPf_PARENS)
2704 o = my_kid(o, attrs, &rops);
2706 if (maybe_scalar && o->op_type == OP_PADSV) {
2707 o = scalar(op_append_list(OP_LIST, rops, o));
2708 o->op_private |= OPpLVAL_INTRO;
2711 /* The listop in rops might have a pushmark at the beginning,
2712 which will mess up list assignment. */
2713 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2714 if (rops->op_type == OP_LIST &&
2715 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2717 OP * const pushmark = lrops->op_first;
2718 lrops->op_first = pushmark->op_sibling;
2721 o = op_append_list(OP_LIST, o, rops);
2724 PL_parser->in_my = FALSE;
2725 PL_parser->in_my_stash = NULL;
2730 Perl_sawparens(pTHX_ OP *o)
2732 PERL_UNUSED_CONTEXT;
2734 o->op_flags |= OPf_PARENS;
2739 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2743 const OPCODE ltype = left->op_type;
2744 const OPCODE rtype = right->op_type;
2746 PERL_ARGS_ASSERT_BIND_MATCH;
2748 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2749 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2751 const char * const desc
2753 rtype == OP_SUBST || rtype == OP_TRANS
2754 || rtype == OP_TRANSR
2756 ? (int)rtype : OP_MATCH];
2757 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2760 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2761 ? cUNOPx(left)->op_first->op_type == OP_GV
2762 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2763 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2766 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2769 Perl_warner(aTHX_ packWARN(WARN_MISC),
2770 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2773 const char * const sample = (isary
2774 ? "@array" : "%hash");
2775 Perl_warner(aTHX_ packWARN(WARN_MISC),
2776 "Applying %s to %s will act on scalar(%s)",
2777 desc, sample, sample);
2781 if (rtype == OP_CONST &&
2782 cSVOPx(right)->op_private & OPpCONST_BARE &&
2783 cSVOPx(right)->op_private & OPpCONST_STRICT)
2785 no_bareword_allowed(right);
2788 /* !~ doesn't make sense with /r, so error on it for now */
2789 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2791 yyerror("Using !~ with s///r doesn't make sense");
2792 if (rtype == OP_TRANSR && type == OP_NOT)
2793 yyerror("Using !~ with tr///r doesn't make sense");
2795 ismatchop = (rtype == OP_MATCH ||
2796 rtype == OP_SUBST ||
2797 rtype == OP_TRANS || rtype == OP_TRANSR)
2798 && !(right->op_flags & OPf_SPECIAL);
2799 if (ismatchop && right->op_private & OPpTARGET_MY) {
2801 right->op_private &= ~OPpTARGET_MY;
2803 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2806 right->op_flags |= OPf_STACKED;
2807 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2808 ! (rtype == OP_TRANS &&
2809 right->op_private & OPpTRANS_IDENTICAL) &&
2810 ! (rtype == OP_SUBST &&
2811 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2812 newleft = op_lvalue(left, rtype);
2815 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2816 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2818 o = op_prepend_elem(rtype, scalar(newleft), right);
2820 return newUNOP(OP_NOT, 0, scalar(o));
2824 return bind_match(type, left,
2825 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2829 Perl_invert(pTHX_ OP *o)
2833 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2837 =for apidoc Amx|OP *|op_scope|OP *o
2839 Wraps up an op tree with some additional ops so that at runtime a dynamic
2840 scope will be created. The original ops run in the new dynamic scope,
2841 and then, provided that they exit normally, the scope will be unwound.
2842 The additional ops used to create and unwind the dynamic scope will
2843 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2844 instead if the ops are simple enough to not need the full dynamic scope
2851 Perl_op_scope(pTHX_ OP *o)
2855 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2856 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2857 o->op_type = OP_LEAVE;
2858 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2860 else if (o->op_type == OP_LINESEQ) {
2862 o->op_type = OP_SCOPE;
2863 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2864 kid = ((LISTOP*)o)->op_first;
2865 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2868 /* The following deals with things like 'do {1 for 1}' */
2869 kid = kid->op_sibling;
2871 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2876 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2882 Perl_op_unscope(pTHX_ OP *o)
2884 if (o && o->op_type == OP_LINESEQ) {
2885 OP *kid = cLISTOPo->op_first;
2886 for(; kid; kid = kid->op_sibling)
2887 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2894 Perl_block_start(pTHX_ int full)
2897 const int retval = PL_savestack_ix;
2899 pad_block_start(full);
2901 PL_hints &= ~HINT_BLOCK_SCOPE;
2902 SAVECOMPILEWARNINGS();
2903 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2905 CALL_BLOCK_HOOKS(bhk_start, full);
2911 Perl_block_end(pTHX_ I32 floor, OP *seq)
2914 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2915 OP* retval = scalarseq(seq);
2918 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2921 CopHINTS_set(&PL_compiling, PL_hints);
2923 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2927 /* pad_leavemy has created a sequence of introcv ops for all my
2928 subs declared in the block. We have to replicate that list with
2929 clonecv ops, to deal with this situation:
2934 sub s1 { state sub foo { \&s2 } }
2937 Originally, I was going to have introcv clone the CV and turn
2938 off the stale flag. Since &s1 is declared before &s2, the
2939 introcv op for &s1 is executed (on sub entry) before the one for
2940 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
2941 cloned, since it is a state sub) closes over &s2 and expects
2942 to see it in its outer CV’s pad. If the introcv op clones &s1,
2943 then &s2 is still marked stale. Since &s1 is not active, and
2944 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
2945 ble will not stay shared’ warning. Because it is the same stub
2946 that will be used when the introcv op for &s2 is executed, clos-
2947 ing over it is safe. Hence, we have to turn off the stale flag
2948 on all lexical subs in the block before we clone any of them.
2949 Hence, having introcv clone the sub cannot work. So we create a
2950 list of ops like this:
2974 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
2975 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
2976 for (;; kid = kid->op_sibling) {
2977 OP *newkid = newOP(OP_CLONECV, 0);
2978 newkid->op_targ = kid->op_targ;
2979 o = op_append_elem(OP_LINESEQ, o, newkid);
2980 if (kid == last) break;
2982 retval = op_prepend_elem(OP_LINESEQ, o, retval);
2985 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2991 =head1 Compile-time scope hooks
2993 =for apidoc Aox||blockhook_register
2995 Register a set of hooks to be called when the Perl lexical scope changes
2996 at compile time. See L<perlguts/"Compile-time scope hooks">.
3002 Perl_blockhook_register(pTHX_ BHK *hk)
3004 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3006 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3013 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3014 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3015 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3018 OP * const o = newOP(OP_PADSV, 0);
3019 o->op_targ = offset;
3025 Perl_newPROG(pTHX_ OP *o)
3029 PERL_ARGS_ASSERT_NEWPROG;
3036 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3037 ((PL_in_eval & EVAL_KEEPERR)
3038 ? OPf_SPECIAL : 0), o);
3040 cx = &cxstack[cxstack_ix];
3041 assert(CxTYPE(cx) == CXt_EVAL);
3043 if ((cx->blk_gimme & G_WANT) == G_VOID)
3044 scalarvoid(PL_eval_root);
3045 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3048 scalar(PL_eval_root);
3050 PL_eval_start = op_linklist(PL_eval_root);
3051 PL_eval_root->op_private |= OPpREFCOUNTED;
3052 OpREFCNT_set(PL_eval_root, 1);
3053 PL_eval_root->op_next = 0;
3054 i = PL_savestack_ix;
3057 CALL_PEEP(PL_eval_start);
3058 finalize_optree(PL_eval_root);
3060 PL_savestack_ix = i;
3063 if (o->op_type == OP_STUB) {
3064 /* This block is entered if nothing is compiled for the main
3065 program. This will be the case for an genuinely empty main
3066 program, or one which only has BEGIN blocks etc, so already
3069 Historically (5.000) the guard above was !o. However, commit
3070 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3071 c71fccf11fde0068, changed perly.y so that newPROG() is now
3072 called with the output of block_end(), which returns a new
3073 OP_STUB for the case of an empty optree. ByteLoader (and
3074 maybe other things) also take this path, because they set up
3075 PL_main_start and PL_main_root directly, without generating an
3078 If the parsing the main program aborts (due to parse errors,
3079 or due to BEGIN or similar calling exit), then newPROG()
3080 isn't even called, and hence this code path and its cleanups
3081 are skipped. This shouldn't make a make a difference:
3082 * a non-zero return from perl_parse is a failure, and
3083 perl_destruct() should be called immediately.
3084 * however, if exit(0) is called during the parse, then
3085 perl_parse() returns 0, and perl_run() is called. As
3086 PL_main_start will be NULL, perl_run() will return
3087 promptly, and the exit code will remain 0.
3090 PL_comppad_name = 0;
3092 S_op_destroy(aTHX_ o);
3095 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3096 PL_curcop = &PL_compiling;
3097 PL_main_start = LINKLIST(PL_main_root);
3098 PL_main_root->op_private |= OPpREFCOUNTED;
3099 OpREFCNT_set(PL_main_root, 1);
3100 PL_main_root->op_next = 0;
3101 CALL_PEEP(PL_main_start);
3102 finalize_optree(PL_main_root);
3103 cv_forget_slab(PL_compcv);
3106 /* Register with debugger */
3108 CV * const cv = get_cvs("DB::postponed", 0);
3112 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3114 call_sv(MUTABLE_SV(cv), G_DISCARD);
3121 Perl_localize(pTHX_ OP *o, I32 lex)
3125 PERL_ARGS_ASSERT_LOCALIZE;
3127 if (o->op_flags & OPf_PARENS)
3128 /* [perl #17376]: this appears to be premature, and results in code such as
3129 C< our(%x); > executing in list mode rather than void mode */
3136 if ( PL_parser->bufptr > PL_parser->oldbufptr
3137 && PL_parser->bufptr[-1] == ','
3138 && ckWARN(WARN_PARENTHESIS))
3140 char *s = PL_parser->bufptr;
3143 /* some heuristics to detect a potential error */
3144 while (*s && (strchr(", \t\n", *s)))
3148 if (*s && strchr("@$%*", *s) && *++s
3149 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3152 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3154 while (*s && (strchr(", \t\n", *s)))
3160 if (sigil && (*s == ';' || *s == '=')) {
3161 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3162 "Parentheses missing around \"%s\" list",
3164 ? (PL_parser->in_my == KEY_our
3166 : PL_parser->in_my == KEY_state
3176 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3177 PL_parser->in_my = FALSE;
3178 PL_parser->in_my_stash = NULL;
3183 Perl_jmaybe(pTHX_ OP *o)
3185 PERL_ARGS_ASSERT_JMAYBE;
3187 if (o->op_type == OP_LIST) {
3189 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3190 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3195 PERL_STATIC_INLINE OP *
3196 S_op_std_init(pTHX_ OP *o)
3198 I32 type = o->op_type;
3200 PERL_ARGS_ASSERT_OP_STD_INIT;
3202 if (PL_opargs[type] & OA_RETSCALAR)
3204 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3205 o->op_targ = pad_alloc(type, SVs_PADTMP);
3210 PERL_STATIC_INLINE OP *
3211 S_op_integerize(pTHX_ OP *o)
3213 I32 type = o->op_type;
3215 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3217 /* integerize op. */
3218 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3221 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3224 if (type == OP_NEGATE)
3225 /* XXX might want a ck_negate() for this */
3226 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3232 S_fold_constants(pTHX_ OP *o)
3237 VOL I32 type = o->op_type;
3242 SV * const oldwarnhook = PL_warnhook;
3243 SV * const olddiehook = PL_diehook;
3247 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3249 if (!(PL_opargs[type] & OA_FOLDCONST))
3264 /* XXX what about the numeric ops? */
3265 if (IN_LOCALE_COMPILETIME)
3269 if (!cLISTOPo->op_first->op_sibling
3270 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3273 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3274 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3276 const char *s = SvPVX_const(sv);
3277 while (s < SvEND(sv)) {
3278 if (*s == 'p' || *s == 'P') goto nope;
3285 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3288 if (PL_parser && PL_parser->error_count)
3289 goto nope; /* Don't try to run w/ errors */
3291 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3292 const OPCODE type = curop->op_type;
3293 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3295 type != OP_SCALAR &&
3297 type != OP_PUSHMARK)
3303 curop = LINKLIST(o);
3304 old_next = o->op_next;
3308 oldscope = PL_scopestack_ix;
3309 create_eval_scope(G_FAKINGEVAL);
3311 /* Verify that we don't need to save it: */
3312 assert(PL_curcop == &PL_compiling);
3313 StructCopy(&PL_compiling, ¬_compiling, COP);
3314 PL_curcop = ¬_compiling;
3315 /* The above ensures that we run with all the correct hints of the
3316 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3317 assert(IN_PERL_RUNTIME);
3318 PL_warnhook = PERL_WARNHOOK_FATAL;
3325 sv = *(PL_stack_sp--);
3326 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3328 /* Can't simply swipe the SV from the pad, because that relies on
3329 the op being freed "real soon now". Under MAD, this doesn't
3330 happen (see the #ifdef below). */
3333 pad_swipe(o->op_targ, FALSE);
3336 else if (SvTEMP(sv)) { /* grab mortal temp? */
3337 SvREFCNT_inc_simple_void(sv);
3342 /* Something tried to die. Abandon constant folding. */
3343 /* Pretend the error never happened. */
3345 o->op_next = old_next;
3349 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3350 PL_warnhook = oldwarnhook;
3351 PL_diehook = olddiehook;
3352 /* XXX note that this croak may fail as we've already blown away
3353 * the stack - eg any nested evals */
3354 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3357 PL_warnhook = oldwarnhook;
3358 PL_diehook = olddiehook;
3359 PL_curcop = &PL_compiling;
3361 if (PL_scopestack_ix > oldscope)
3362 delete_eval_scope();
3371 if (type == OP_RV2GV)
3372 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3374 newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
3375 op_getmad(o,newop,'f');
3383 S_gen_constant_list(pTHX_ OP *o)
3387 const I32 oldtmps_floor = PL_tmps_floor;
3390 if (PL_parser && PL_parser->error_count)
3391 return o; /* Don't attempt to run with errors */
3393 PL_op = curop = LINKLIST(o);
3396 Perl_pp_pushmark(aTHX);
3399 assert (!(curop->op_flags & OPf_SPECIAL));
3400 assert(curop->op_type == OP_RANGE);
3401 Perl_pp_anonlist(aTHX);
3402 PL_tmps_floor = oldtmps_floor;
3404 o->op_type = OP_RV2AV;
3405 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3406 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3407 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3408 o->op_opt = 0; /* needs to be revisited in rpeep() */
3409 curop = ((UNOP*)o)->op_first;
3410 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3412 op_getmad(curop,o,'O');
3421 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3424 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3425 if (!o || o->op_type != OP_LIST)
3426 o = newLISTOP(OP_LIST, 0, o, NULL);
3428 o->op_flags &= ~OPf_WANT;
3430 if (!(PL_opargs[type] & OA_MARK))
3431 op_null(cLISTOPo->op_first);
3433 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3434 if (kid2 && kid2->op_type == OP_COREARGS) {
3435 op_null(cLISTOPo->op_first);
3436 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3440 o->op_type = (OPCODE)type;
3441 o->op_ppaddr = PL_ppaddr[type];
3442 o->op_flags |= flags;
3444 o = CHECKOP(type, o);
3445 if (o->op_type != (unsigned)type)
3448 return fold_constants(op_integerize(op_std_init(o)));
3452 =head1 Optree Manipulation Functions
3455 /* List constructors */
3458 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3460 Append an item to the list of ops contained directly within a list-type
3461 op, returning the lengthened list. I<first> is the list-type op,
3462 and I<last> is the op to append to the list. I<optype> specifies the
3463 intended opcode for the list. If I<first> is not already a list of the
3464 right type, it will be upgraded into one. If either I<first> or I<last>
3465 is null, the other is returned unchanged.
3471 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3479 if (first->op_type != (unsigned)type
3480 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3482 return newLISTOP(type, 0, first, last);
3485 if (first->op_flags & OPf_KIDS)
3486 ((LISTOP*)first)->op_last->op_sibling = last;
3488 first->op_flags |= OPf_KIDS;
3489 ((LISTOP*)first)->op_first = last;
3491 ((LISTOP*)first)->op_last = last;
3496 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3498 Concatenate the lists of ops contained directly within two list-type ops,
3499 returning the combined list. I<first> and I<last> are the list-type ops
3500 to concatenate. I<optype> specifies the intended opcode for the list.
3501 If either I<first> or I<last> is not already a list of the right type,
3502 it will be upgraded into one. If either I<first> or I<last> is null,
3503 the other is returned unchanged.
3509 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3517 if (first->op_type != (unsigned)type)
3518 return op_prepend_elem(type, first, last);
3520 if (last->op_type != (unsigned)type)
3521 return op_append_elem(type, first, last);
3523 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3524 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3525 first->op_flags |= (last->op_flags & OPf_KIDS);
3528 if (((LISTOP*)last)->op_first && first->op_madprop) {
3529 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3531 while (mp->mad_next)
3533 mp->mad_next = first->op_madprop;
3536 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3539 first->op_madprop = last->op_madprop;
3540 last->op_madprop = 0;
3543 S_op_destroy(aTHX_ last);
3549 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3551 Prepend an item to the list of ops contained directly within a list-type
3552 op, returning the lengthened list. I<first> is the op to prepend to the
3553 list, and I<last> is the list-type op. I<optype> specifies the intended
3554 opcode for the list. If I<last> is not already a list of the right type,
3555 it will be upgraded into one. If either I<first> or I<last> is null,
3556 the other is returned unchanged.
3562 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3570 if (last->op_type == (unsigned)type) {
3571 if (type == OP_LIST) { /* already a PUSHMARK there */
3572 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3573 ((LISTOP*)last)->op_first->op_sibling = first;
3574 if (!(first->op_flags & OPf_PARENS))
3575 last->op_flags &= ~OPf_PARENS;
3578 if (!(last->op_flags & OPf_KIDS)) {
3579 ((LISTOP*)last)->op_last = first;
3580 last->op_flags |= OPf_KIDS;
3582 first->op_sibling = ((LISTOP*)last)->op_first;
3583 ((LISTOP*)last)->op_first = first;
3585 last->op_flags |= OPf_KIDS;
3589 return newLISTOP(type, 0, first, last);
3597 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3600 Newxz(tk, 1, TOKEN);
3601 tk->tk_type = (OPCODE)optype;
3602 tk->tk_type = 12345;
3604 tk->tk_mad = madprop;
3609 Perl_token_free(pTHX_ TOKEN* tk)
3611 PERL_ARGS_ASSERT_TOKEN_FREE;
3613 if (tk->tk_type != 12345)
3615 mad_free(tk->tk_mad);
3620 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3625 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3627 if (tk->tk_type != 12345) {
3628 Perl_warner(aTHX_ packWARN(WARN_MISC),
3629 "Invalid TOKEN object ignored");
3636 /* faked up qw list? */
3638 tm->mad_type == MAD_SV &&
3639 SvPVX((SV *)tm->mad_val)[0] == 'q')
3646 /* pretend constant fold didn't happen? */
3647 if (mp->mad_key == 'f' &&
3648 (o->op_type == OP_CONST ||
3649 o->op_type == OP_GV) )
3651 token_getmad(tk,(OP*)mp->mad_val,slot);
3665 if (mp->mad_key == 'X')
3666 mp->mad_key = slot; /* just change the first one */
3676 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3685 /* pretend constant fold didn't happen? */
3686 if (mp->mad_key == 'f' &&
3687 (o->op_type == OP_CONST ||
3688 o->op_type == OP_GV) )
3690 op_getmad(from,(OP*)mp->mad_val,slot);
3697 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3700 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3706 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3715 /* pretend constant fold didn't happen? */
3716 if (mp->mad_key == 'f' &&
3717 (o->op_type == OP_CONST ||
3718 o->op_type == OP_GV) )
3720 op_getmad(from,(OP*)mp->mad_val,slot);
3727 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3730 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3734 PerlIO_printf(PerlIO_stderr(),
3735 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3741 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3759 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3763 addmad(tm, &(o->op_madprop), slot);
3767 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3788 Perl_newMADsv(pTHX_ char key, SV* sv)
3790 PERL_ARGS_ASSERT_NEWMADSV;
3792 return newMADPROP(key, MAD_SV, sv, 0);
3796 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3798 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3801 mp->mad_vlen = vlen;
3802 mp->mad_type = type;
3804 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3809 Perl_mad_free(pTHX_ MADPROP* mp)
3811 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3815 mad_free(mp->mad_next);
3816 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3817 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3818 switch (mp->mad_type) {
3822 Safefree(mp->mad_val);
3825 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3826 op_free((OP*)mp->mad_val);
3829 sv_free(MUTABLE_SV(mp->mad_val));
3832 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3835 PerlMemShared_free(mp);
3841 =head1 Optree construction
3843 =for apidoc Am|OP *|newNULLLIST
3845 Constructs, checks, and returns a new C<stub> op, which represents an
3846 empty list expression.
3852 Perl_newNULLLIST(pTHX)
3854 return newOP(OP_STUB, 0);
3858 S_force_list(pTHX_ OP *o)
3860 if (!o || o->op_type != OP_LIST)
3861 o = newLISTOP(OP_LIST, 0, o, NULL);
3867 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3869 Constructs, checks, and returns an op of any list type. I<type> is
3870 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3871 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3872 supply up to two ops to be direct children of the list op; they are
3873 consumed by this function and become part of the constructed op tree.
3879 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3884 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3886 NewOp(1101, listop, 1, LISTOP);
3888 listop->op_type = (OPCODE)type;
3889 listop->op_ppaddr = PL_ppaddr[type];
3892 listop->op_flags = (U8)flags;
3896 else if (!first && last)
3899 first->op_sibling = last;
3900 listop->op_first = first;
3901 listop->op_last = last;
3902 if (type == OP_LIST) {
3903 OP* const pushop = newOP(OP_PUSHMARK, 0);
3904 pushop->op_sibling = first;
3905 listop->op_first = pushop;
3906 listop->op_flags |= OPf_KIDS;
3908 listop->op_last = pushop;
3911 return CHECKOP(type, listop);
3915 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3917 Constructs, checks, and returns an op of any base type (any type that
3918 has no extra fields). I<type> is the opcode. I<flags> gives the
3919 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3926 Perl_newOP(pTHX_ I32 type, I32 flags)
3931 if (type == -OP_ENTEREVAL) {
3932 type = OP_ENTEREVAL;
3933 flags |= OPpEVAL_BYTES<<8;
3936 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3937 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3938 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3939 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3941 NewOp(1101, o, 1, OP);
3942 o->op_type = (OPCODE)type;
3943 o->op_ppaddr = PL_ppaddr[type];
3944 o->op_flags = (U8)flags;
3947 o->op_private = (U8)(0 | (flags >> 8));
3948 if (PL_opargs[type] & OA_RETSCALAR)
3950 if (PL_opargs[type] & OA_TARGET)
3951 o->op_targ = pad_alloc(type, SVs_PADTMP);
3952 return CHECKOP(type, o);
3956 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3958 Constructs, checks, and returns an op of any unary type. I<type> is
3959 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3960 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3961 bits, the eight bits of C<op_private>, except that the bit with value 1
3962 is automatically set. I<first> supplies an optional op to be the direct
3963 child of the unary op; it is consumed by this function and become part
3964 of the constructed op tree.
3970 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3975 if (type == -OP_ENTEREVAL) {
3976 type = OP_ENTEREVAL;
3977 flags |= OPpEVAL_BYTES<<8;
3980 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3981 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3982 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3983 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3984 || type == OP_SASSIGN
3985 || type == OP_ENTERTRY
3986 || type == OP_NULL );
3989 first = newOP(OP_STUB, 0);
3990 if (PL_opargs[type] & OA_MARK)
3991 first = force_list(first);
3993 NewOp(1101, unop, 1, UNOP);
3994 unop->op_type = (OPCODE)type;
3995 unop->op_ppaddr = PL_ppaddr[type];
3996 unop->op_first = first;
3997 unop->op_flags = (U8)(flags | OPf_KIDS);
3998 unop->op_private = (U8)(1 | (flags >> 8));
3999 unop = (UNOP*) CHECKOP(type, unop);
4003 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4007 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4009 Constructs, checks, and returns an op of any binary type. I<type>
4010 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4011 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4012 the eight bits of C<op_private>, except that the bit with value 1 or
4013 2 is automatically set as required. I<first> and I<last> supply up to
4014 two ops to be the direct children of the binary op; they are consumed
4015 by this function and become part of the constructed op tree.
4021 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4026 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4027 || type == OP_SASSIGN || type == OP_NULL );
4029 NewOp(1101, binop, 1, BINOP);
4032 first = newOP(OP_NULL, 0);
4034 binop->op_type = (OPCODE)type;
4035 binop->op_ppaddr = PL_ppaddr[type];
4036 binop->op_first = first;
4037 binop->op_flags = (U8)(flags | OPf_KIDS);
4040 binop->op_private = (U8)(1 | (flags >> 8));
4043 binop->op_private = (U8)(2 | (flags >> 8));
4044 first->op_sibling = last;
4047 binop = (BINOP*)CHECKOP(type, binop);
4048 if (binop->op_next || binop->op_type != (OPCODE)type)
4051 binop->op_last = binop->op_first->op_sibling;
4053 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4056 static int uvcompare(const void *a, const void *b)
4057 __attribute__nonnull__(1)
4058 __attribute__nonnull__(2)
4059 __attribute__pure__;
4060 static int uvcompare(const void *a, const void *b)
4062 if (*((const UV *)a) < (*(const UV *)b))
4064 if (*((const UV *)a) > (*(const UV *)b))
4066 if (*((const UV *)a+1) < (*(const UV *)b+1))
4068 if (*((const UV *)a+1) > (*(const UV *)b+1))
4074 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4077 SV * const tstr = ((SVOP*)expr)->op_sv;
4080 (repl->op_type == OP_NULL)
4081 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4083 ((SVOP*)repl)->op_sv;
4086 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4087 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4093 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4094 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4095 I32 del = o->op_private & OPpTRANS_DELETE;
4098 PERL_ARGS_ASSERT_PMTRANS;
4100 PL_hints |= HINT_BLOCK_SCOPE;
4103 o->op_private |= OPpTRANS_FROM_UTF;
4106 o->op_private |= OPpTRANS_TO_UTF;
4108 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4109 SV* const listsv = newSVpvs("# comment\n");
4111 const U8* tend = t + tlen;
4112 const U8* rend = r + rlen;
4126 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4127 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4130 const U32 flags = UTF8_ALLOW_DEFAULT;
4134 t = tsave = bytes_to_utf8(t, &len);
4137 if (!to_utf && rlen) {
4139 r = rsave = bytes_to_utf8(r, &len);
4143 /* There are several snags with this code on EBCDIC:
4144 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4145 2. scan_const() in toke.c has encoded chars in native encoding which makes
4146 ranges at least in EBCDIC 0..255 range the bottom odd.
4150 U8 tmpbuf[UTF8_MAXBYTES+1];
4153 Newx(cp, 2*tlen, UV);
4155 transv = newSVpvs("");
4157 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4159 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
4161 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4165 cp[2*i+1] = cp[2*i];
4169 qsort(cp, i, 2*sizeof(UV), uvcompare);
4170 for (j = 0; j < i; j++) {
4172 diff = val - nextmin;
4174 t = uvuni_to_utf8(tmpbuf,nextmin);
4175 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4177 U8 range_mark = UTF_TO_NATIVE(0xff);
4178 t = uvuni_to_utf8(tmpbuf, val - 1);
4179 sv_catpvn(transv, (char *)&range_mark, 1);
4180 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4187 t = uvuni_to_utf8(tmpbuf,nextmin);
4188 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4190 U8 range_mark = UTF_TO_NATIVE(0xff);
4191 sv_catpvn(transv, (char *)&range_mark, 1);
4193 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
4194 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4195 t = (const U8*)SvPVX_const(transv);
4196 tlen = SvCUR(transv);
4200 else if (!rlen && !del) {
4201 r = t; rlen = tlen; rend = tend;
4204 if ((!rlen && !del) || t == r ||
4205 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4207 o->op_private |= OPpTRANS_IDENTICAL;
4211 while (t < tend || tfirst <= tlast) {
4212 /* see if we need more "t" chars */
4213 if (tfirst > tlast) {
4214 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4216 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
4218 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4225 /* now see if we need more "r" chars */
4226 if (rfirst > rlast) {
4228 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4230 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
4232 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4241 rfirst = rlast = 0xffffffff;
4245 /* now see which range will peter our first, if either. */
4246 tdiff = tlast - tfirst;
4247 rdiff = rlast - rfirst;
4254 if (rfirst == 0xffffffff) {
4255 diff = tdiff; /* oops, pretend rdiff is infinite */
4257 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4258 (long)tfirst, (long)tlast);
4260 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4264 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4265 (long)tfirst, (long)(tfirst + diff),
4268 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4269 (long)tfirst, (long)rfirst);
4271 if (rfirst + diff > max)
4272 max = rfirst + diff;
4274 grows = (tfirst < rfirst &&
4275 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4287 else if (max > 0xff)
4292 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4294 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4295 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4296 PAD_SETSV(cPADOPo->op_padix, swash);
4298 SvREADONLY_on(swash);
4300 cSVOPo->op_sv = swash;
4302 SvREFCNT_dec(listsv);
4303 SvREFCNT_dec(transv);
4305 if (!del && havefinal && rlen)
4306 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4307 newSVuv((UV)final), 0);
4310 o->op_private |= OPpTRANS_GROWS;
4316 op_getmad(expr,o,'e');
4317 op_getmad(repl,o,'r');
4325 tbl = (short*)PerlMemShared_calloc(
4326 (o->op_private & OPpTRANS_COMPLEMENT) &&
4327 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4329 cPVOPo->op_pv = (char*)tbl;
4331 for (i = 0; i < (I32)tlen; i++)
4333 for (i = 0, j = 0; i < 256; i++) {
4335 if (j >= (I32)rlen) {
4344 if (i < 128 && r[j] >= 128)
4354 o->op_private |= OPpTRANS_IDENTICAL;
4356 else if (j >= (I32)rlen)
4361 PerlMemShared_realloc(tbl,
4362 (0x101+rlen-j) * sizeof(short));
4363 cPVOPo->op_pv = (char*)tbl;
4365 tbl[0x100] = (short)(rlen - j);
4366 for (i=0; i < (I32)rlen - j; i++)
4367 tbl[0x101+i] = r[j+i];
4371 if (!rlen && !del) {
4374 o->op_private |= OPpTRANS_IDENTICAL;
4376 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4377 o->op_private |= OPpTRANS_IDENTICAL;
4379 for (i = 0; i < 256; i++)
4381 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4382 if (j >= (I32)rlen) {
4384 if (tbl[t[i]] == -1)
4390 if (tbl[t[i]] == -1) {
4391 if (t[i] < 128 && r[j] >= 128)
4398 if(del && rlen == tlen) {
4399 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4400 } else if(rlen > tlen && !complement) {
4401 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4405 o->op_private |= OPpTRANS_GROWS;
4407 op_getmad(expr,o,'e');
4408 op_getmad(repl,o,'r');
4418 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4420 Constructs, checks, and returns an op of any pattern matching type.
4421 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4422 and, shifted up eight bits, the eight bits of C<op_private>.
4428 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4433 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4435 NewOp(1101, pmop, 1, PMOP);
4436 pmop->op_type = (OPCODE)type;
4437 pmop->op_ppaddr = PL_ppaddr[type];
4438 pmop->op_flags = (U8)flags;
4439 pmop->op_private = (U8)(0 | (flags >> 8));
4441 if (PL_hints & HINT_RE_TAINT)
4442 pmop->op_pmflags |= PMf_RETAINT;
4443 if (IN_LOCALE_COMPILETIME) {
4444 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4446 else if ((! (PL_hints & HINT_BYTES))
4447 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4448 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4450 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4452 if (PL_hints & HINT_RE_FLAGS) {
4453 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4454 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4456 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4457 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4458 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4460 if (reflags && SvOK(reflags)) {
4461 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4467 assert(SvPOK(PL_regex_pad[0]));
4468 if (SvCUR(PL_regex_pad[0])) {
4469 /* Pop off the "packed" IV from the end. */
4470 SV *const repointer_list = PL_regex_pad[0];
4471 const char *p = SvEND(repointer_list) - sizeof(IV);
4472 const IV offset = *((IV*)p);
4474 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4476 SvEND_set(repointer_list, p);
4478 pmop->op_pmoffset = offset;
4479 /* This slot should be free, so assert this: */
4480 assert(PL_regex_pad[offset] == &PL_sv_undef);
4482 SV * const repointer = &PL_sv_undef;
4483 av_push(PL_regex_padav, repointer);
4484 pmop->op_pmoffset = av_len(PL_regex_padav);
4485 PL_regex_pad = AvARRAY(PL_regex_padav);
4489 return CHECKOP(type, pmop);
4492 /* Given some sort of match op o, and an expression expr containing a
4493 * pattern, either compile expr into a regex and attach it to o (if it's
4494 * constant), or convert expr into a runtime regcomp op sequence (if it's
4497 * isreg indicates that the pattern is part of a regex construct, eg
4498 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4499 * split "pattern", which aren't. In the former case, expr will be a list
4500 * if the pattern contains more than one term (eg /a$b/) or if it contains
4501 * a replacement, ie s/// or tr///.
4503 * When the pattern has been compiled within a new anon CV (for
4504 * qr/(?{...})/ ), then floor indicates the savestack level just before
4505 * the new sub was created
4509 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4514 I32 repl_has_vars = 0;
4516 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4517 bool is_compiletime;
4520 PERL_ARGS_ASSERT_PMRUNTIME;
4522 /* for s/// and tr///, last element in list is the replacement; pop it */
4524 if (is_trans || o->op_type == OP_SUBST) {
4526 repl = cLISTOPx(expr)->op_last;
4527 kid = cLISTOPx(expr)->op_first;
4528 while (kid->op_sibling != repl)
4529 kid = kid->op_sibling;
4530 kid->op_sibling = NULL;
4531 cLISTOPx(expr)->op_last = kid;
4534 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4537 OP* const oe = expr;
4538 assert(expr->op_type == OP_LIST);
4539 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4540 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4541 expr = cLISTOPx(oe)->op_last;
4542 cLISTOPx(oe)->op_first->op_sibling = NULL;
4543 cLISTOPx(oe)->op_last = NULL;
4546 return pmtrans(o, expr, repl);
4549 /* find whether we have any runtime or code elements;
4550 * at the same time, temporarily set the op_next of each DO block;
4551 * then when we LINKLIST, this will cause the DO blocks to be excluded
4552 * from the op_next chain (and from having LINKLIST recursively
4553 * applied to them). We fix up the DOs specially later */
4557 if (expr->op_type == OP_LIST) {
4559 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4560 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4562 assert(!o->op_next && o->op_sibling);
4563 o->op_next = o->op_sibling;
4565 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4569 else if (expr->op_type != OP_CONST)
4574 /* fix up DO blocks; treat each one as a separate little sub;
4575 * also, mark any arrays as LIST/REF */
4577 if (expr->op_type == OP_LIST) {
4579 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4581 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4582 assert( !(o->op_flags & OPf_WANT));
4583 /* push the array rather than its contents. The regex
4584 * engine will retrieve and join the elements later */
4585 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4589 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4591 o->op_next = NULL; /* undo temporary hack from above */
4594 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4595 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4597 assert(leaveop->op_first->op_type == OP_ENTER);
4598 assert(leaveop->op_first->op_sibling);
4599 o->op_next = leaveop->op_first->op_sibling;
4601 assert(leaveop->op_flags & OPf_KIDS);
4602 assert(leaveop->op_last->op_next == (OP*)leaveop);
4603 leaveop->op_next = NULL; /* stop on last op */
4604 op_null((OP*)leaveop);
4608 OP *scope = cLISTOPo->op_first;
4609 assert(scope->op_type == OP_SCOPE);
4610 assert(scope->op_flags & OPf_KIDS);
4611 scope->op_next = NULL; /* stop on last op */
4614 /* have to peep the DOs individually as we've removed it from
4615 * the op_next chain */
4618 /* runtime finalizes as part of finalizing whole tree */
4622 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4623 assert( !(expr->op_flags & OPf_WANT));
4624 /* push the array rather than its contents. The regex
4625 * engine will retrieve and join the elements later */
4626 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4629 PL_hints |= HINT_BLOCK_SCOPE;
4631 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4633 if (is_compiletime) {
4634 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4635 regexp_engine const *eng = current_re_engine();
4637 if (o->op_flags & OPf_SPECIAL)
4638 rx_flags |= RXf_SPLIT;
4640 if (!has_code || !eng->op_comp) {
4641 /* compile-time simple constant pattern */
4643 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4644 /* whoops! we guessed that a qr// had a code block, but we
4645 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4646 * that isn't required now. Note that we have to be pretty
4647 * confident that nothing used that CV's pad while the
4648 * regex was parsed */
4649 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4650 /* But we know that one op is using this CV's slab. */
4651 cv_forget_slab(PL_compcv);
4653 pm->op_pmflags &= ~PMf_HAS_CV;
4658 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4659 rx_flags, pm->op_pmflags)
4660 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4661 rx_flags, pm->op_pmflags)
4664 op_getmad(expr,(OP*)pm,'e');
4670 /* compile-time pattern that includes literal code blocks */
4671 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4674 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4677 if (pm->op_pmflags & PMf_HAS_CV) {
4679 /* this QR op (and the anon sub we embed it in) is never
4680 * actually executed. It's just a placeholder where we can
4681 * squirrel away expr in op_code_list without the peephole
4682 * optimiser etc processing it for a second time */
4683 OP *qr = newPMOP(OP_QR, 0);
4684 ((PMOP*)qr)->op_code_list = expr;
4686 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4687 SvREFCNT_inc_simple_void(PL_compcv);
4688 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4689 ReANY(re)->qr_anoncv = cv;
4691 /* attach the anon CV to the pad so that
4692 * pad_fixup_inner_anons() can find it */
4693 (void)pad_add_anon(cv, o->op_type);
4694 SvREFCNT_inc_simple_void(cv);
4697 pm->op_code_list = expr;
4702 /* runtime pattern: build chain of regcomp etc ops */
4704 PADOFFSET cv_targ = 0;
4706 reglist = isreg && expr->op_type == OP_LIST;
4711 pm->op_code_list = expr;
4712 /* don't free op_code_list; its ops are embedded elsewhere too */
4713 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4716 if (o->op_flags & OPf_SPECIAL)
4717 pm->op_pmflags |= PMf_SPLIT;
4719 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4720 * to allow its op_next to be pointed past the regcomp and
4721 * preceding stacking ops;
4722 * OP_REGCRESET is there to reset taint before executing the
4724 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4725 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4727 if (pm->op_pmflags & PMf_HAS_CV) {
4728 /* we have a runtime qr with literal code. This means
4729 * that the qr// has been wrapped in a new CV, which
4730 * means that runtime consts, vars etc will have been compiled
4731 * against a new pad. So... we need to execute those ops
4732 * within the environment of the new CV. So wrap them in a call
4733 * to a new anon sub. i.e. for
4737 * we build an anon sub that looks like
4739 * sub { "a", $b, '(?{...})' }
4741 * and call it, passing the returned list to regcomp.
4742 * Or to put it another way, the list of ops that get executed
4746 * ------ -------------------
4747 * pushmark (for regcomp)
4748 * pushmark (for entersub)
4749 * pushmark (for refgen)
4753 * regcreset regcreset
4755 * const("a") const("a")
4757 * const("(?{...})") const("(?{...})")
4762 SvREFCNT_inc_simple_void(PL_compcv);
4763 /* these lines are just an unrolled newANONATTRSUB */
4764 expr = newSVOP(OP_ANONCODE, 0,
4765 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4766 cv_targ = expr->op_targ;
4767 expr = newUNOP(OP_REFGEN, 0, expr);
4769 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4772 NewOp(1101, rcop, 1, LOGOP);
4773 rcop->op_type = OP_REGCOMP;
4774 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4775 rcop->op_first = scalar(expr);
4776 rcop->op_flags |= OPf_KIDS
4777 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4778 | (reglist ? OPf_STACKED : 0);
4779 rcop->op_private = 0;
4781 rcop->op_targ = cv_targ;
4783 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4784 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4786 /* establish postfix order */
4787 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4789 rcop->op_next = expr;
4790 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4793 rcop->op_next = LINKLIST(expr);
4794 expr->op_next = (OP*)rcop;
4797 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4803 if (pm->op_pmflags & PMf_EVAL) {
4804 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4805 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4807 /* If we are looking at s//.../e with a single statement, get past
4808 the implicit do{}. */
4809 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
4810 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
4811 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
4812 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
4813 if (kid->op_type == OP_NULL && kid->op_sibling
4814 && !kid->op_sibling->op_sibling)
4815 curop = kid->op_sibling;
4817 if (curop->op_type == OP_CONST)
4819 else if (( (curop->op_type == OP_RV2SV ||
4820 curop->op_type == OP_RV2AV ||
4821 curop->op_type == OP_RV2HV ||
4822 curop->op_type == OP_RV2GV)
4823 && cUNOPx(curop)->op_first
4824 && cUNOPx(curop)->op_first->op_type == OP_GV )
4825 || curop->op_type == OP_PADSV
4826 || curop->op_type == OP_PADAV
4827 || curop->op_type == OP_PADHV
4828 || curop->op_type == OP_PADANY) {
4836 || !RX_PRELEN(PM_GETRE(pm))
4837 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4839 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4840 op_prepend_elem(o->op_type, scalar(repl), o);
4843 NewOp(1101, rcop, 1, LOGOP);
4844 rcop->op_type = OP_SUBSTCONT;
4845 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4846 rcop->op_first = scalar(repl);
4847 rcop->op_flags |= OPf_KIDS;
4848 rcop->op_private = 1;
4851 /* establish postfix order */
4852 rcop->op_next = LINKLIST(repl);
4853 repl->op_next = (OP*)rcop;
4855 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4856 assert(!(pm->op_pmflags & PMf_ONCE));
4857 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4866 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4868 Constructs, checks, and returns an op of any type that involves an
4869 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4870 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4871 takes ownership of one reference to it.
4877 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4882 PERL_ARGS_ASSERT_NEWSVOP;
4884 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4885 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4886 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4888 NewOp(1101, svop, 1, SVOP);
4889 svop->op_type = (OPCODE)type;
4890 svop->op_ppaddr = PL_ppaddr[type];
4892 svop->op_next = (OP*)svop;
4893 svop->op_flags = (U8)flags;
4894 svop->op_private = (U8)(0 | (flags >> 8));
4895 if (PL_opargs[type] & OA_RETSCALAR)
4897 if (PL_opargs[type] & OA_TARGET)
4898 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4899 return CHECKOP(type, svop);
4905 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4907 Constructs, checks, and returns an op of any type that involves a
4908 reference to a pad element. I<type> is the opcode. I<flags> gives the
4909 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4910 is populated with I<sv>; this function takes ownership of one reference
4913 This function only exists if Perl has been compiled to use ithreads.
4919 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4924 PERL_ARGS_ASSERT_NEWPADOP;
4926 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4927 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4928 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4930 NewOp(1101, padop, 1, PADOP);
4931 padop->op_type = (OPCODE)type;
4932 padop->op_ppaddr = PL_ppaddr[type];
4933 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4934 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4935 PAD_SETSV(padop->op_padix, sv);
4938 padop->op_next = (OP*)padop;
4939 padop->op_flags = (U8)flags;
4940 if (PL_opargs[type] & OA_RETSCALAR)
4942 if (PL_opargs[type] & OA_TARGET)
4943 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4944 return CHECKOP(type, padop);
4947 #endif /* !USE_ITHREADS */
4950 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4952 Constructs, checks, and returns an op of any type that involves an
4953 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4954 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4955 reference; calling this function does not transfer ownership of any
4962 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4966 PERL_ARGS_ASSERT_NEWGVOP;
4970 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4972 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4977 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4979 Constructs, checks, and returns an op of any type that involves an
4980 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4981 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4982 must have been allocated using C<PerlMemShared_malloc>; the memory will
4983 be freed when the op is destroyed.
4989 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4992 const bool utf8 = cBOOL(flags & SVf_UTF8);
4997 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4999 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5001 NewOp(1101, pvop, 1, PVOP);
5002 pvop->op_type = (OPCODE)type;
5003 pvop->op_ppaddr = PL_ppaddr[type];
5005 pvop->op_next = (OP*)pvop;
5006 pvop->op_flags = (U8)flags;
5007 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5008 if (PL_opargs[type] & OA_RETSCALAR)
5010 if (PL_opargs[type] & OA_TARGET)
5011 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5012 return CHECKOP(type, pvop);
5020 Perl_package(pTHX_ OP *o)
5023 SV *const sv = cSVOPo->op_sv;
5028 PERL_ARGS_ASSERT_PACKAGE;
5030 SAVEGENERICSV(PL_curstash);
5031 save_item(PL_curstname);
5033 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5035 sv_setsv(PL_curstname, sv);
5037 PL_hints |= HINT_BLOCK_SCOPE;
5038 PL_parser->copline = NOLINE;
5039 PL_parser->expect = XSTATE;
5044 if (!PL_madskills) {
5049 pegop = newOP(OP_NULL,0);
5050 op_getmad(o,pegop,'P');
5056 Perl_package_version( pTHX_ OP *v )
5059 U32 savehints = PL_hints;
5060 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5061 PL_hints &= ~HINT_STRICT_VARS;
5062 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5063 PL_hints = savehints;
5072 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5079 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
5081 SV *use_version = NULL;
5083 PERL_ARGS_ASSERT_UTILIZE;
5085 if (idop->op_type != OP_CONST)
5086 Perl_croak(aTHX_ "Module name must be constant");
5089 op_getmad(idop,pegop,'U');
5094 SV * const vesv = ((SVOP*)version)->op_sv;
5097 op_getmad(version,pegop,'V');
5098 if (!arg && !SvNIOKp(vesv)) {
5105 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5106 Perl_croak(aTHX_ "Version number must be a constant number");
5108 /* Make copy of idop so we don't free it twice */
5109 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5111 /* Fake up a method call to VERSION */
5112 meth = newSVpvs_share("VERSION");
5113 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5114 op_append_elem(OP_LIST,
5115 op_prepend_elem(OP_LIST, pack, list(version)),
5116 newSVOP(OP_METHOD_NAMED, 0, meth)));
5120 /* Fake up an import/unimport */
5121 if (arg && arg->op_type == OP_STUB) {
5123 op_getmad(arg,pegop,'S');
5124 imop = arg; /* no import on explicit () */
5126 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5127 imop = NULL; /* use 5.0; */
5129 use_version = ((SVOP*)idop)->op_sv;
5131 idop->op_private |= OPpCONST_NOVER;
5137 op_getmad(arg,pegop,'A');
5139 /* Make copy of idop so we don't free it twice */
5140 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5142 /* Fake up a method call to import/unimport */
5144 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5145 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5146 op_append_elem(OP_LIST,
5147 op_prepend_elem(OP_LIST, pack, list(arg)),
5148 newSVOP(OP_METHOD_NAMED, 0, meth)));
5151 /* Fake up the BEGIN {}, which does its thing immediately. */
5153 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5156 op_append_elem(OP_LINESEQ,
5157 op_append_elem(OP_LINESEQ,
5158 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5159 newSTATEOP(0, NULL, veop)),
5160 newSTATEOP(0, NULL, imop) ));
5164 * feature bundle that corresponds to the required version. */
5165 use_version = sv_2mortal(new_version(use_version));
5166 S_enable_feature_bundle(aTHX_ use_version);
5168 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5169 if (vcmp(use_version,
5170 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5171 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5172 PL_hints |= HINT_STRICT_REFS;
5173 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5174 PL_hints |= HINT_STRICT_SUBS;
5175 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5176 PL_hints |= HINT_STRICT_VARS;
5178 /* otherwise they are off */
5180 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5181 PL_hints &= ~HINT_STRICT_REFS;
5182 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5183 PL_hints &= ~HINT_STRICT_SUBS;
5184 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5185 PL_hints &= ~HINT_STRICT_VARS;
5189 /* The "did you use incorrect case?" warning used to be here.
5190 * The problem is that on case-insensitive filesystems one
5191 * might get false positives for "use" (and "require"):
5192 * "use Strict" or "require CARP" will work. This causes
5193 * portability problems for the script: in case-strict
5194 * filesystems the script will stop working.
5196 * The "incorrect case" warning checked whether "use Foo"
5197 * imported "Foo" to your namespace, but that is wrong, too:
5198 * there is no requirement nor promise in the language that
5199 * a Foo.pm should or would contain anything in package "Foo".
5201 * There is very little Configure-wise that can be done, either:
5202 * the case-sensitivity of the build filesystem of Perl does not
5203 * help in guessing the case-sensitivity of the runtime environment.
5206 PL_hints |= HINT_BLOCK_SCOPE;
5207 PL_parser->copline = NOLINE;
5208 PL_parser->expect = XSTATE;
5209 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5210 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5219 =head1 Embedding Functions
5221 =for apidoc load_module
5223 Loads the module whose name is pointed to by the string part of name.
5224 Note that the actual module name, not its filename, should be given.
5225 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5226 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5227 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
5228 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5229 arguments can be used to specify arguments to the module's import()
5230 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5231 terminated with a final NULL pointer. Note that this list can only
5232 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5233 Otherwise at least a single NULL pointer to designate the default
5234 import list is required.
5236 The reference count for each specified C<SV*> parameter is decremented.
5241 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5245 PERL_ARGS_ASSERT_LOAD_MODULE;
5247 va_start(args, ver);
5248 vload_module(flags, name, ver, &args);
5252 #ifdef PERL_IMPLICIT_CONTEXT
5254 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5258 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5259 va_start(args, ver);
5260 vload_module(flags, name, ver, &args);
5266 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5270 OP * const modname = newSVOP(OP_CONST, 0, name);
5272 PERL_ARGS_ASSERT_VLOAD_MODULE;
5274 modname->op_private |= OPpCONST_BARE;
5276 veop = newSVOP(OP_CONST, 0, ver);
5280 if (flags & PERL_LOADMOD_NOIMPORT) {
5281 imop = sawparens(newNULLLIST());
5283 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5284 imop = va_arg(*args, OP*);
5289 sv = va_arg(*args, SV*);
5291 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5292 sv = va_arg(*args, SV*);
5296 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5297 * that it has a PL_parser to play with while doing that, and also
5298 * that it doesn't mess with any existing parser, by creating a tmp
5299 * new parser with lex_start(). This won't actually be used for much,
5300 * since pp_require() will create another parser for the real work. */
5303 SAVEVPTR(PL_curcop);
5304 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5305 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5306 veop, modname, imop);
5311 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5317 PERL_ARGS_ASSERT_DOFILE;
5319 if (!force_builtin) {
5320 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
5321 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5322 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
5323 gv = gvp ? *gvp : NULL;
5327 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5328 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
5329 op_append_elem(OP_LIST, term,
5330 scalar(newUNOP(OP_RV2CV, 0,
5331 newGVOP(OP_GV, 0, gv)))));
5334 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5340 =head1 Optree construction
5342 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5344 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5345 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5346 be set automatically, and, shifted up eight bits, the eight bits of
5347 C<op_private>, except that the bit with value 1 or 2 is automatically
5348 set as required. I<listval> and I<subscript> supply the parameters of
5349 the slice; they are consumed by this function and become part of the
5350 constructed op tree.
5356 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5358 return newBINOP(OP_LSLICE, flags,
5359 list(force_list(subscript)),
5360 list(force_list(listval)) );
5364 S_is_list_assignment(pTHX_ const OP *o)
5372 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5373 o = cUNOPo->op_first;
5375 flags = o->op_flags;
5377 if (type == OP_COND_EXPR) {
5378 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5379 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5384 yyerror("Assignment to both a list and a scalar");
5388 if (type == OP_LIST &&
5389 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5390 o->op_private & OPpLVAL_INTRO)
5393 if (type == OP_LIST || flags & OPf_PARENS ||
5394 type == OP_RV2AV || type == OP_RV2HV ||
5395 type == OP_ASLICE || type == OP_HSLICE)
5398 if (type == OP_PADAV || type == OP_PADHV)
5401 if (type == OP_RV2SV)
5408 Helper function for newASSIGNOP to detection commonality between the
5409 lhs and the rhs. Marks all variables with PL_generation. If it
5410 returns TRUE the assignment must be able to handle common variables.
5412 PERL_STATIC_INLINE bool
5413 S_aassign_common_vars(pTHX_ OP* o)
5416 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5417 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5418 if (curop->op_type == OP_GV) {
5419 GV *gv = cGVOPx_gv(curop);
5421 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5423 GvASSIGN_GENERATION_set(gv, PL_generation);
5425 else if (curop->op_type == OP_PADSV ||
5426 curop->op_type == OP_PADAV ||
5427 curop->op_type == OP_PADHV ||
5428 curop->op_type == OP_PADANY)
5430 if (PAD_COMPNAME_GEN(curop->op_targ)
5431 == (STRLEN)PL_generation)
5433 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5436 else if (curop->op_type == OP_RV2CV)
5438 else if (curop->op_type == OP_RV2SV ||
5439 curop->op_type == OP_RV2AV ||
5440 curop->op_type == OP_RV2HV ||
5441 curop->op_type == OP_RV2GV) {
5442 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5445 else if (curop->op_type == OP_PUSHRE) {
5447 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5448 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5450 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5452 GvASSIGN_GENERATION_set(gv, PL_generation);
5456 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5459 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5461 GvASSIGN_GENERATION_set(gv, PL_generation);
5469 if (curop->op_flags & OPf_KIDS) {
5470 if (aassign_common_vars(curop))
5478 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5480 Constructs, checks, and returns an assignment op. I<left> and I<right>
5481 supply the parameters of the assignment; they are consumed by this
5482 function and become part of the constructed op tree.
5484 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5485 a suitable conditional optree is constructed. If I<optype> is the opcode
5486 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5487 performs the binary operation and assigns the result to the left argument.
5488 Either way, if I<optype> is non-zero then I<flags> has no effect.
5490 If I<optype> is zero, then a plain scalar or list assignment is
5491 constructed. Which type of assignment it is is automatically determined.
5492 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5493 will be set automatically, and, shifted up eight bits, the eight bits
5494 of C<op_private>, except that the bit with value 1 or 2 is automatically
5501 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5507 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5508 return newLOGOP(optype, 0,
5509 op_lvalue(scalar(left), optype),
5510 newUNOP(OP_SASSIGN, 0, scalar(right)));
5513 return newBINOP(optype, OPf_STACKED,
5514 op_lvalue(scalar(left), optype), scalar(right));
5518 if (is_list_assignment(left)) {
5519 static const char no_list_state[] = "Initialization of state variables"
5520 " in list context currently forbidden";
5522 bool maybe_common_vars = TRUE;
5525 left = op_lvalue(left, OP_AASSIGN);
5526 curop = list(force_list(left));
5527 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5528 o->op_private = (U8)(0 | (flags >> 8));
5530 if ((left->op_type == OP_LIST
5531 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5533 OP* lop = ((LISTOP*)left)->op_first;
5534 maybe_common_vars = FALSE;
5536 if (lop->op_type == OP_PADSV ||
5537 lop->op_type == OP_PADAV ||
5538 lop->op_type == OP_PADHV ||
5539 lop->op_type == OP_PADANY) {
5540 if (!(lop->op_private & OPpLVAL_INTRO))
5541 maybe_common_vars = TRUE;
5543 if (lop->op_private & OPpPAD_STATE) {
5544 if (left->op_private & OPpLVAL_INTRO) {
5545 /* Each variable in state($a, $b, $c) = ... */
5548 /* Each state variable in
5549 (state $a, my $b, our $c, $d, undef) = ... */
5551 yyerror(no_list_state);
5553 /* Each my variable in
5554 (state $a, my $b, our $c, $d, undef) = ... */
5556 } else if (lop->op_type == OP_UNDEF ||
5557 lop->op_type == OP_PUSHMARK) {
5558 /* undef may be interesting in
5559 (state $a, undef, state $c) */
5561 /* Other ops in the list. */
5562 maybe_common_vars = TRUE;
5564 lop = lop->op_sibling;
5567 else if ((left->op_private & OPpLVAL_INTRO)
5568 && ( left->op_type == OP_PADSV
5569 || left->op_type == OP_PADAV
5570 || left->op_type == OP_PADHV
5571 || left->op_type == OP_PADANY))
5573 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5574 if (left->op_private & OPpPAD_STATE) {
5575 /* All single variable list context state assignments, hence
5585 yyerror(no_list_state);
5589 /* PL_generation sorcery:
5590 * an assignment like ($a,$b) = ($c,$d) is easier than
5591 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5592 * To detect whether there are common vars, the global var
5593 * PL_generation is incremented for each assign op we compile.
5594 * Then, while compiling the assign op, we run through all the
5595 * variables on both sides of the assignment, setting a spare slot
5596 * in each of them to PL_generation. If any of them already have
5597 * that value, we know we've got commonality. We could use a
5598 * single bit marker, but then we'd have to make 2 passes, first
5599 * to clear the flag, then to test and set it. To find somewhere
5600 * to store these values, evil chicanery is done with SvUVX().
5603 if (maybe_common_vars) {
5605 if (aassign_common_vars(o))
5606 o->op_private |= OPpASSIGN_COMMON;
5610 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5611 OP* tmpop = ((LISTOP*)right)->op_first;
5612 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5613 PMOP * const pm = (PMOP*)tmpop;
5614 if (left->op_type == OP_RV2AV &&
5615 !(left->op_private & OPpLVAL_INTRO) &&
5616 !(o->op_private & OPpASSIGN_COMMON) )
5618 tmpop = ((UNOP*)left)->op_first;
5619 if (tmpop->op_type == OP_GV
5621 && !pm->op_pmreplrootu.op_pmtargetoff
5623 && !pm->op_pmreplrootu.op_pmtargetgv
5627 pm->op_pmreplrootu.op_pmtargetoff
5628 = cPADOPx(tmpop)->op_padix;
5629 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5631 pm->op_pmreplrootu.op_pmtargetgv
5632 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5633 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5635 tmpop = cUNOPo->op_first; /* to list (nulled) */
5636 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5637 tmpop->op_sibling = NULL; /* don't free split */
5638 right->op_next = tmpop->op_next; /* fix starting loc */
5639 op_free(o); /* blow off assign */
5640 right->op_flags &= ~OPf_WANT;
5641 /* "I don't know and I don't care." */
5646 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5647 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5649 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5650 if (SvIOK(sv) && SvIVX(sv) == 0)
5651 sv_setiv(sv, PL_modcount+1);
5659 right = newOP(OP_UNDEF, 0);
5660 if (right->op_type == OP_READLINE) {
5661 right->op_flags |= OPf_STACKED;
5662 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5666 o = newBINOP(OP_SASSIGN, flags,
5667 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5673 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5675 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5676 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5677 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5678 If I<label> is non-null, it supplies the name of a label to attach to
5679 the state op; this function takes ownership of the memory pointed at by
5680 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5683 If I<o> is null, the state op is returned. Otherwise the state op is
5684 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5685 is consumed by this function and becomes part of the returned op tree.
5691 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5694 const U32 seq = intro_my();
5695 const U32 utf8 = flags & SVf_UTF8;
5700 NewOp(1101, cop, 1, COP);
5701 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5702 cop->op_type = OP_DBSTATE;
5703 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5706 cop->op_type = OP_NEXTSTATE;
5707 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5709 cop->op_flags = (U8)flags;
5710 CopHINTS_set(cop, PL_hints);
5712 cop->op_private |= NATIVE_HINTS;
5714 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5715 cop->op_next = (OP*)cop;
5718 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5719 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5721 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5723 PL_hints |= HINT_BLOCK_SCOPE;
5724 /* It seems that we need to defer freeing this pointer, as other parts
5725 of the grammar end up wanting to copy it after this op has been
5730 if (PL_parser && PL_parser->copline == NOLINE)
5731 CopLINE_set(cop, CopLINE(PL_curcop));
5733 CopLINE_set(cop, PL_parser->copline);
5734 PL_parser->copline = NOLINE;
5737 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5739 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5741 CopSTASH_set(cop, PL_curstash);
5743 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5744 /* this line can have a breakpoint - store the cop in IV */
5745 AV *av = CopFILEAVx(PL_curcop);
5747 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5748 if (svp && *svp != &PL_sv_undef ) {
5749 (void)SvIOK_on(*svp);
5750 SvIV_set(*svp, PTR2IV(cop));
5755 if (flags & OPf_SPECIAL)
5757 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5761 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5763 Constructs, checks, and returns a logical (flow control) op. I<type>
5764 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5765 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5766 the eight bits of C<op_private>, except that the bit with value 1 is
5767 automatically set. I<first> supplies the expression controlling the
5768 flow, and I<other> supplies the side (alternate) chain of ops; they are
5769 consumed by this function and become part of the constructed op tree.
5775 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5779 PERL_ARGS_ASSERT_NEWLOGOP;
5781 return new_logop(type, flags, &first, &other);
5785 S_search_const(pTHX_ OP *o)
5787 PERL_ARGS_ASSERT_SEARCH_CONST;
5789 switch (o->op_type) {
5793 if (o->op_flags & OPf_KIDS)
5794 return search_const(cUNOPo->op_first);
5801 if (!(o->op_flags & OPf_KIDS))
5803 kid = cLISTOPo->op_first;
5805 switch (kid->op_type) {
5809 kid = kid->op_sibling;
5812 if (kid != cLISTOPo->op_last)
5818 kid = cLISTOPo->op_last;
5820 return search_const(kid);
5828 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5836 int prepend_not = 0;
5838 PERL_ARGS_ASSERT_NEW_LOGOP;
5843 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5844 return newBINOP(type, flags, scalar(first), scalar(other));
5846 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5848 scalarboolean(first);
5849 /* optimize AND and OR ops that have NOTs as children */
5850 if (first->op_type == OP_NOT
5851 && (first->op_flags & OPf_KIDS)
5852 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5853 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5855 if (type == OP_AND || type == OP_OR) {
5861 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5863 prepend_not = 1; /* prepend a NOT op later */
5867 /* search for a constant op that could let us fold the test */
5868 if ((cstop = search_const(first))) {
5869 if (cstop->op_private & OPpCONST_STRICT)
5870 no_bareword_allowed(cstop);
5871 else if ((cstop->op_private & OPpCONST_BARE))
5872 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5873 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5874 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5875 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5877 if (other->op_type == OP_CONST)
5878 other->op_private |= OPpCONST_SHORTCIRCUIT;
5880 OP *newop = newUNOP(OP_NULL, 0, other);
5881 op_getmad(first, newop, '1');
5882 newop->op_targ = type; /* set "was" field */
5886 if (other->op_type == OP_LEAVE)
5887 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5888 else if (other->op_type == OP_MATCH
5889 || other->op_type == OP_SUBST
5890 || other->op_type == OP_TRANSR
5891 || other->op_type == OP_TRANS)
5892 /* Mark the op as being unbindable with =~ */
5893 other->op_flags |= OPf_SPECIAL;
5894 else if (other->op_type == OP_CONST)
5895 other->op_private |= OPpCONST_FOLDED;
5899 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5900 const OP *o2 = other;
5901 if ( ! (o2->op_type == OP_LIST
5902 && (( o2 = cUNOPx(o2)->op_first))
5903 && o2->op_type == OP_PUSHMARK
5904 && (( o2 = o2->op_sibling)) )
5907 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5908 || o2->op_type == OP_PADHV)
5909 && o2->op_private & OPpLVAL_INTRO
5910 && !(o2->op_private & OPpPAD_STATE))
5912 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5913 "Deprecated use of my() in false conditional");
5917 if (first->op_type == OP_CONST)
5918 first->op_private |= OPpCONST_SHORTCIRCUIT;
5920 first = newUNOP(OP_NULL, 0, first);
5921 op_getmad(other, first, '2');
5922 first->op_targ = type; /* set "was" field */
5929 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5930 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5932 const OP * const k1 = ((UNOP*)first)->op_first;
5933 const OP * const k2 = k1->op_sibling;
5935 switch (first->op_type)
5938 if (k2 && k2->op_type == OP_READLINE
5939 && (k2->op_flags & OPf_STACKED)
5940 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5942 warnop = k2->op_type;
5947 if (k1->op_type == OP_READDIR
5948 || k1->op_type == OP_GLOB
5949 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5950 || k1->op_type == OP_EACH
5951 || k1->op_type == OP_AEACH)
5953 warnop = ((k1->op_type == OP_NULL)
5954 ? (OPCODE)k1->op_targ : k1->op_type);
5959 const line_t oldline = CopLINE(PL_curcop);
5960 /* This ensures that warnings are reported at the first line
5961 of the construction, not the last. */
5962 CopLINE_set(PL_curcop, PL_parser->copline);
5963 Perl_warner(aTHX_ packWARN(WARN_MISC),
5964 "Value of %s%s can be \"0\"; test with defined()",
5966 ((warnop == OP_READLINE || warnop == OP_GLOB)
5967 ? " construct" : "() operator"));
5968 CopLINE_set(PL_curcop, oldline);
5975 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5976 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5978 NewOp(1101, logop, 1, LOGOP);
5980 logop->op_type = (OPCODE)type;
5981 logop->op_ppaddr = PL_ppaddr[type];
5982 logop->op_first = first;
5983 logop->op_flags = (U8)(flags | OPf_KIDS);
5984 logop->op_other = LINKLIST(other);
5985 logop->op_private = (U8)(1 | (flags >> 8));
5987 /* establish postfix order */
5988 logop->op_next = LINKLIST(first);
5989 first->op_next = (OP*)logop;
5990 first->op_sibling = other;
5992 CHECKOP(type,logop);
5994 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6001 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6003 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6004 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6005 will be set automatically, and, shifted up eight bits, the eight bits of
6006 C<op_private>, except that the bit with value 1 is automatically set.
6007 I<first> supplies the expression selecting between the two branches,
6008 and I<trueop> and I<falseop> supply the branches; they are consumed by
6009 this function and become part of the constructed op tree.
6015 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6023 PERL_ARGS_ASSERT_NEWCONDOP;
6026 return newLOGOP(OP_AND, 0, first, trueop);
6028 return newLOGOP(OP_OR, 0, first, falseop);
6030 scalarboolean(first);
6031 if ((cstop = search_const(first))) {
6032 /* Left or right arm of the conditional? */
6033 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6034 OP *live = left ? trueop : falseop;
6035 OP *const dead = left ? falseop : trueop;
6036 if (cstop->op_private & OPpCONST_BARE &&
6037 cstop->op_private & OPpCONST_STRICT) {
6038 no_bareword_allowed(cstop);
6041 /* This is all dead code when PERL_MAD is not defined. */
6042 live = newUNOP(OP_NULL, 0, live);
6043 op_getmad(first, live, 'C');
6044 op_getmad(dead, live, left ? 'e' : 't');
6049 if (live->op_type == OP_LEAVE)
6050 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6051 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6052 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6053 /* Mark the op as being unbindable with =~ */
6054 live->op_flags |= OPf_SPECIAL;
6055 else if (live->op_type == OP_CONST)
6056 live->op_private |= OPpCONST_FOLDED;
6059 NewOp(1101, logop, 1, LOGOP);
6060 logop->op_type = OP_COND_EXPR;
6061 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6062 logop->op_first = first;
6063 logop->op_flags = (U8)(flags | OPf_KIDS);
6064 logop->op_private = (U8)(1 | (flags >> 8));
6065 logop->op_other = LINKLIST(trueop);
6066 logop->op_next = LINKLIST(falseop);
6068 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6071 /* establish postfix order */
6072 start = LINKLIST(first);
6073 first->op_next = (OP*)logop;
6075 first->op_sibling = trueop;
6076 trueop->op_sibling = falseop;
6077 o = newUNOP(OP_NULL, 0, (OP*)logop);
6079 trueop->op_next = falseop->op_next = o;
6086 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6088 Constructs and returns a C<range> op, with subordinate C<flip> and
6089 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6090 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6091 for both the C<flip> and C<range> ops, except that the bit with value
6092 1 is automatically set. I<left> and I<right> supply the expressions
6093 controlling the endpoints of the range; they are consumed by this function
6094 and become part of the constructed op tree.
6100 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6109 PERL_ARGS_ASSERT_NEWRANGE;
6111 NewOp(1101, range, 1, LOGOP);
6113 range->op_type = OP_RANGE;
6114 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6115 range->op_first = left;
6116 range->op_flags = OPf_KIDS;
6117 leftstart = LINKLIST(left);
6118 range->op_other = LINKLIST(right);
6119 range->op_private = (U8)(1 | (flags >> 8));
6121 left->op_sibling = right;
6123 range->op_next = (OP*)range;
6124 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6125 flop = newUNOP(OP_FLOP, 0, flip);
6126 o = newUNOP(OP_NULL, 0, flop);
6128 range->op_next = leftstart;
6130 left->op_next = flip;
6131 right->op_next = flop;
6133 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6134 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6135 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6136 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6138 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6139 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6141 /* check barewords before they might be optimized aways */
6142 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6143 no_bareword_allowed(left);
6144 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6145 no_bareword_allowed(right);
6148 if (!flip->op_private || !flop->op_private)
6149 LINKLIST(o); /* blow off optimizer unless constant */
6155 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6157 Constructs, checks, and returns an op tree expressing a loop. This is
6158 only a loop in the control flow through the op tree; it does not have
6159 the heavyweight loop structure that allows exiting the loop by C<last>
6160 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6161 top-level op, except that some bits will be set automatically as required.
6162 I<expr> supplies the expression controlling loop iteration, and I<block>
6163 supplies the body of the loop; they are consumed by this function and
6164 become part of the constructed op tree. I<debuggable> is currently
6165 unused and should always be 1.
6171 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6176 const bool once = block && block->op_flags & OPf_SPECIAL &&
6177 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
6179 PERL_UNUSED_ARG(debuggable);
6182 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6183 return block; /* do {} while 0 does once */
6184 if (expr->op_type == OP_READLINE
6185 || expr->op_type == OP_READDIR
6186 || expr->op_type == OP_GLOB
6187 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6188 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6189 expr = newUNOP(OP_DEFINED, 0,
6190 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6191 } else if (expr->op_flags & OPf_KIDS) {
6192 const OP * const k1 = ((UNOP*)expr)->op_first;
6193 const OP * const k2 = k1 ? k1->op_sibling : NULL;
6194 switch (expr->op_type) {
6196 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6197 && (k2->op_flags & OPf_STACKED)
6198 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6199 expr = newUNOP(OP_DEFINED, 0, expr);
6203 if (k1 && (k1->op_type == OP_READDIR
6204 || k1->op_type == OP_GLOB
6205 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6206 || k1->op_type == OP_EACH
6207 || k1->op_type == OP_AEACH))
6208 expr = newUNOP(OP_DEFINED, 0, expr);
6214 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6215 * op, in listop. This is wrong. [perl #27024] */
6217 block = newOP(OP_NULL, 0);
6218 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6219 o = new_logop(OP_AND, 0, &expr, &listop);
6222 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6224 if (once && o != listop)
6225 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6228 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6230 o->op_flags |= flags;
6232 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6237 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6239 Constructs, checks, and returns an op tree expressing a C<while> loop.
6240 This is a heavyweight loop, with structure that allows exiting the loop
6241 by C<last> and suchlike.
6243 I<loop> is an optional preconstructed C<enterloop> op to use in the
6244 loop; if it is null then a suitable op will be constructed automatically.
6245 I<expr> supplies the loop's controlling expression. I<block> supplies the
6246 main body of the loop, and I<cont> optionally supplies a C<continue> block
6247 that operates as a second half of the body. All of these optree inputs
6248 are consumed by this function and become part of the constructed op tree.
6250 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6251 op and, shifted up eight bits, the eight bits of C<op_private> for
6252 the C<leaveloop> op, except that (in both cases) some bits will be set
6253 automatically. I<debuggable> is currently unused and should always be 1.
6254 I<has_my> can be supplied as true to force the
6255 loop body to be enclosed in its own scope.
6261 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6262 OP *expr, OP *block, OP *cont, I32 has_my)
6271 PERL_UNUSED_ARG(debuggable);
6274 if (expr->op_type == OP_READLINE
6275 || expr->op_type == OP_READDIR
6276 || expr->op_type == OP_GLOB
6277 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6278 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6279 expr = newUNOP(OP_DEFINED, 0,
6280 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6281 } else if (expr->op_flags & OPf_KIDS) {
6282 const OP * const k1 = ((UNOP*)expr)->op_first;
6283 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6284 switch (expr->op_type) {
6286 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6287 && (k2->op_flags & OPf_STACKED)
6288 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6289 expr = newUNOP(OP_DEFINED, 0, expr);
6293 if (k1 && (k1->op_type == OP_READDIR
6294 || k1->op_type == OP_GLOB
6295 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6296 || k1->op_type == OP_EACH
6297 || k1->op_type == OP_AEACH))
6298 expr = newUNOP(OP_DEFINED, 0, expr);
6305 block = newOP(OP_NULL, 0);
6306 else if (cont || has_my) {
6307 block = op_scope(block);
6311 next = LINKLIST(cont);
6314 OP * const unstack = newOP(OP_UNSTACK, 0);
6317 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6321 listop = op_append_list(OP_LINESEQ, block, cont);
6323 redo = LINKLIST(listop);
6327 o = new_logop(OP_AND, 0, &expr, &listop);
6328 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6330 return expr; /* listop already freed by new_logop */
6333 ((LISTOP*)listop)->op_last->op_next =
6334 (o == listop ? redo : LINKLIST(o));
6340 NewOp(1101,loop,1,LOOP);
6341 loop->op_type = OP_ENTERLOOP;
6342 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6343 loop->op_private = 0;
6344 loop->op_next = (OP*)loop;
6347 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6349 loop->op_redoop = redo;
6350 loop->op_lastop = o;
6351 o->op_private |= loopflags;
6354 loop->op_nextop = next;
6356 loop->op_nextop = o;
6358 o->op_flags |= flags;
6359 o->op_private |= (flags >> 8);
6364 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6366 Constructs, checks, and returns an op tree expressing a C<foreach>
6367 loop (iteration through a list of values). This is a heavyweight loop,
6368 with structure that allows exiting the loop by C<last> and suchlike.
6370 I<sv> optionally supplies the variable that will be aliased to each
6371 item in turn; if null, it defaults to C<$_> (either lexical or global).
6372 I<expr> supplies the list of values to iterate over. I<block> supplies
6373 the main body of the loop, and I<cont> optionally supplies a C<continue>
6374 block that operates as a second half of the body. All of these optree
6375 inputs are consumed by this function and become part of the constructed
6378 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6379 op and, shifted up eight bits, the eight bits of C<op_private> for
6380 the C<leaveloop> op, except that (in both cases) some bits will be set
6387 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6392 PADOFFSET padoff = 0;
6397 PERL_ARGS_ASSERT_NEWFOROP;
6400 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6401 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6402 sv->op_type = OP_RV2GV;
6403 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6405 /* The op_type check is needed to prevent a possible segfault
6406 * if the loop variable is undeclared and 'strict vars' is in
6407 * effect. This is illegal but is nonetheless parsed, so we
6408 * may reach this point with an OP_CONST where we're expecting
6411 if (cUNOPx(sv)->op_first->op_type == OP_GV
6412 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6413 iterpflags |= OPpITER_DEF;
6415 else if (sv->op_type == OP_PADSV) { /* private variable */
6416 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6417 padoff = sv->op_targ;
6427 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6429 SV *const namesv = PAD_COMPNAME_SV(padoff);
6431 const char *const name = SvPV_const(namesv, len);
6433 if (len == 2 && name[0] == '$' && name[1] == '_')
6434 iterpflags |= OPpITER_DEF;
6438 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6439 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6440 sv = newGVOP(OP_GV, 0, PL_defgv);
6445 iterpflags |= OPpITER_DEF;
6447 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6448 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6449 iterflags |= OPf_STACKED;
6451 else if (expr->op_type == OP_NULL &&
6452 (expr->op_flags & OPf_KIDS) &&
6453 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6455 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6456 * set the STACKED flag to indicate that these values are to be
6457 * treated as min/max values by 'pp_enteriter'.
6459 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6460 LOGOP* const range = (LOGOP*) flip->op_first;
6461 OP* const left = range->op_first;
6462 OP* const right = left->op_sibling;
6465 range->op_flags &= ~OPf_KIDS;
6466 range->op_first = NULL;
6468 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6469 listop->op_first->op_next = range->op_next;
6470 left->op_next = range->op_other;
6471 right->op_next = (OP*)listop;
6472 listop->op_next = listop->op_first;
6475 op_getmad(expr,(OP*)listop,'O');
6479 expr = (OP*)(listop);
6481 iterflags |= OPf_STACKED;
6484 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6487 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6488 op_append_elem(OP_LIST, expr, scalar(sv))));
6489 assert(!loop->op_next);
6490 /* for my $x () sets OPpLVAL_INTRO;
6491 * for our $x () sets OPpOUR_INTRO */
6492 loop->op_private = (U8)iterpflags;
6493 if (loop->op_slabbed
6494 && DIFF(loop, OpSLOT(loop)->opslot_next)
6495 < SIZE_TO_PSIZE(sizeof(LOOP)))
6498 NewOp(1234,tmp,1,LOOP);
6499 Copy(loop,tmp,1,LISTOP);
6500 S_op_destroy(aTHX_ (OP*)loop);
6503 else if (!loop->op_slabbed)
6504 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6505 loop->op_targ = padoff;
6506 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6508 op_getmad(madsv, (OP*)loop, 'v');
6513 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6515 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6516 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6517 determining the target of the op; it is consumed by this function and
6518 becomes part of the constructed op tree.
6524 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6529 PERL_ARGS_ASSERT_NEWLOOPEX;
6531 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6533 if (type != OP_GOTO) {
6534 /* "last()" means "last" */
6535 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6536 o = newOP(type, OPf_SPECIAL);
6540 /* Check whether it's going to be a goto &function */
6541 if (label->op_type == OP_ENTERSUB
6542 && !(label->op_flags & OPf_STACKED))
6543 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6546 /* Check for a constant argument */
6547 if (label->op_type == OP_CONST) {
6548 SV * const sv = ((SVOP *)label)->op_sv;
6550 const char *s = SvPV_const(sv,l);
6551 if (l == strlen(s)) {
6553 SvUTF8(((SVOP*)label)->op_sv),
6555 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6559 /* If we have already created an op, we do not need the label. */
6562 op_getmad(label,o,'L');
6566 else o = newUNOP(type, OPf_STACKED, label);
6568 PL_hints |= HINT_BLOCK_SCOPE;
6572 /* if the condition is a literal array or hash
6573 (or @{ ... } etc), make a reference to it.
6576 S_ref_array_or_hash(pTHX_ OP *cond)
6579 && (cond->op_type == OP_RV2AV
6580 || cond->op_type == OP_PADAV
6581 || cond->op_type == OP_RV2HV
6582 || cond->op_type == OP_PADHV))
6584 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6587 && (cond->op_type == OP_ASLICE
6588 || cond->op_type == OP_HSLICE)) {
6590 /* anonlist now needs a list from this op, was previously used in
6592 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6593 cond->op_flags |= OPf_WANT_LIST;
6595 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6602 /* These construct the optree fragments representing given()
6605 entergiven and enterwhen are LOGOPs; the op_other pointer
6606 points up to the associated leave op. We need this so we
6607 can put it in the context and make break/continue work.
6608 (Also, of course, pp_enterwhen will jump straight to
6609 op_other if the match fails.)
6613 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6614 I32 enter_opcode, I32 leave_opcode,
6615 PADOFFSET entertarg)
6621 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6623 NewOp(1101, enterop, 1, LOGOP);
6624 enterop->op_type = (Optype)enter_opcode;
6625 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6626 enterop->op_flags = (U8) OPf_KIDS;
6627 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6628 enterop->op_private = 0;
6630 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6633 enterop->op_first = scalar(cond);
6634 cond->op_sibling = block;
6636 o->op_next = LINKLIST(cond);
6637 cond->op_next = (OP *) enterop;
6640 /* This is a default {} block */
6641 enterop->op_first = block;
6642 enterop->op_flags |= OPf_SPECIAL;
6643 o ->op_flags |= OPf_SPECIAL;
6645 o->op_next = (OP *) enterop;
6648 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6649 entergiven and enterwhen both
6652 enterop->op_next = LINKLIST(block);
6653 block->op_next = enterop->op_other = o;
6658 /* Does this look like a boolean operation? For these purposes
6659 a boolean operation is:
6660 - a subroutine call [*]
6661 - a logical connective
6662 - a comparison operator
6663 - a filetest operator, with the exception of -s -M -A -C
6664 - defined(), exists() or eof()
6665 - /$re/ or $foo =~ /$re/
6667 [*] possibly surprising
6670 S_looks_like_bool(pTHX_ const OP *o)
6674 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6676 switch(o->op_type) {
6679 return looks_like_bool(cLOGOPo->op_first);
6683 looks_like_bool(cLOGOPo->op_first)
6684 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6689 o->op_flags & OPf_KIDS
6690 && looks_like_bool(cUNOPo->op_first));
6694 case OP_NOT: case OP_XOR:
6696 case OP_EQ: case OP_NE: case OP_LT:
6697 case OP_GT: case OP_LE: case OP_GE:
6699 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6700 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6702 case OP_SEQ: case OP_SNE: case OP_SLT:
6703 case OP_SGT: case OP_SLE: case OP_SGE:
6707 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6708 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6709 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6710 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6711 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6712 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6713 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6714 case OP_FTTEXT: case OP_FTBINARY:
6716 case OP_DEFINED: case OP_EXISTS:
6717 case OP_MATCH: case OP_EOF:
6724 /* Detect comparisons that have been optimized away */
6725 if (cSVOPo->op_sv == &PL_sv_yes
6726 || cSVOPo->op_sv == &PL_sv_no)
6739 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6741 Constructs, checks, and returns an op tree expressing a C<given> block.
6742 I<cond> supplies the expression that will be locally assigned to a lexical
6743 variable, and I<block> supplies the body of the C<given> construct; they
6744 are consumed by this function and become part of the constructed op tree.
6745 I<defsv_off> is the pad offset of the scalar lexical variable that will
6746 be affected. If it is 0, the global $_ will be used.
6752 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6755 PERL_ARGS_ASSERT_NEWGIVENOP;
6756 return newGIVWHENOP(
6757 ref_array_or_hash(cond),
6759 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6764 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6766 Constructs, checks, and returns an op tree expressing a C<when> block.
6767 I<cond> supplies the test expression, and I<block> supplies the block
6768 that will be executed if the test evaluates to true; they are consumed
6769 by this function and become part of the constructed op tree. I<cond>
6770 will be interpreted DWIMically, often as a comparison against C<$_>,
6771 and may be null to generate a C<default> block.
6777 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6779 const bool cond_llb = (!cond || looks_like_bool(cond));
6782 PERL_ARGS_ASSERT_NEWWHENOP;
6787 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6789 scalar(ref_array_or_hash(cond)));
6792 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6796 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6797 const STRLEN len, const U32 flags)
6799 const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
6800 const STRLEN clen = CvPROTOLEN(cv);
6802 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6804 if (((!p != !cvp) /* One has prototype, one has not. */
6806 (flags & SVf_UTF8) == SvUTF8(cv)
6807 ? len != clen || memNE(cvp, p, len)
6809 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6811 : bytes_cmp_utf8((const U8 *)p, len,
6812 (const U8 *)cvp, clen)
6816 && ckWARN_d(WARN_PROTOTYPE)) {
6817 SV* const msg = sv_newmortal();
6823 gv_efullname3(name = sv_newmortal(), gv, NULL);
6824 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
6825 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1,
6826 SvUTF8(gv)|SVs_TEMP);
6827 else name = (SV *)gv;
6829 sv_setpvs(msg, "Prototype mismatch:");
6831 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6833 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6834 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6837 sv_catpvs(msg, ": none");
6838 sv_catpvs(msg, " vs ");
6840 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6842 sv_catpvs(msg, "none");
6843 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6847 static void const_sv_xsub(pTHX_ CV* cv);
6851 =head1 Optree Manipulation Functions
6853 =for apidoc cv_const_sv
6855 If C<cv> is a constant sub eligible for inlining. returns the constant
6856 value returned by the sub. Otherwise, returns NULL.
6858 Constant subs can be created with C<newCONSTSUB> or as described in
6859 L<perlsub/"Constant Functions">.
6864 Perl_cv_const_sv(pTHX_ const CV *const cv)
6866 PERL_UNUSED_CONTEXT;
6869 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6871 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6874 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6875 * Can be called in 3 ways:
6878 * look for a single OP_CONST with attached value: return the value
6880 * cv && CvCLONE(cv) && !CvCONST(cv)
6882 * examine the clone prototype, and if contains only a single
6883 * OP_CONST referencing a pad const, or a single PADSV referencing
6884 * an outer lexical, return a non-zero value to indicate the CV is
6885 * a candidate for "constizing" at clone time
6889 * We have just cloned an anon prototype that was marked as a const
6890 * candidate. Try to grab the current value, and in the case of
6891 * PADSV, ignore it if it has multiple references. In this case we
6892 * return a newly created *copy* of the value.
6896 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6907 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6908 o = cLISTOPo->op_first->op_sibling;
6910 for (; o; o = o->op_next) {
6911 const OPCODE type = o->op_type;
6913 if (sv && o->op_next == o)
6915 if (o->op_next != o) {
6916 if (type == OP_NEXTSTATE
6917 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6918 || type == OP_PUSHMARK)
6920 if (type == OP_DBSTATE)
6923 if (type == OP_LEAVESUB || type == OP_RETURN)
6927 if (type == OP_CONST && cSVOPo->op_sv)
6929 else if (cv && type == OP_CONST) {
6930 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6934 else if (cv && type == OP_PADSV) {
6935 if (CvCONST(cv)) { /* newly cloned anon */
6936 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6937 /* the candidate should have 1 ref from this pad and 1 ref
6938 * from the parent */
6939 if (!sv || SvREFCNT(sv) != 2)
6946 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6947 sv = &PL_sv_undef; /* an arbitrary non-null value */
6958 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
6959 PADNAME * const name, SV ** const const_svp)
6966 || block->op_type == OP_NULL
6969 if (CvFLAGS(PL_compcv)) {
6970 /* might have had built-in attrs applied */
6971 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6972 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6973 && ckWARN(WARN_MISC))
6975 /* protect against fatal warnings leaking compcv */
6976 SAVEFREESV(PL_compcv);
6977 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6978 SvREFCNT_inc_simple_void_NN(PL_compcv);
6981 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6982 & ~(CVf_LVALUE * pureperl));
6987 /* redundant check for speed: */
6988 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
6989 const line_t oldline = CopLINE(PL_curcop);
6992 : sv_2mortal(newSVpvn_utf8(
6993 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
6995 if (PL_parser && PL_parser->copline != NOLINE)
6996 /* This ensures that warnings are reported at the first
6997 line of a redefinition, not the last. */
6998 CopLINE_set(PL_curcop, PL_parser->copline);
6999 /* protect against fatal warnings leaking compcv */
7000 SAVEFREESV(PL_compcv);
7001 report_redefined_cv(namesv, cv, const_svp);
7002 SvREFCNT_inc_simple_void_NN(PL_compcv);
7003 CopLINE_set(PL_curcop, oldline);
7006 if (!PL_minus_c) /* keep old one around for madskills */
7009 /* (PL_madskills unset in used file.) */
7016 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7022 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7025 CV *compcv = PL_compcv;
7028 PADOFFSET pax = o->op_targ;
7029 CV *outcv = CvOUTSIDE(PL_compcv);
7032 bool reusable = FALSE;
7034 PERL_ARGS_ASSERT_NEWMYSUB;
7036 /* Find the pad slot for storing the new sub.
7037 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7038 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7039 ing sub. And then we need to dig deeper if this is a lexical from
7041 my sub foo; sub { sub foo { } }
7044 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7045 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7046 pax = PARENT_PAD_INDEX(name);
7047 outcv = CvOUTSIDE(outcv);
7052 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7053 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7054 spot = (CV **)svspot;
7057 assert(proto->op_type == OP_CONST);
7058 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7059 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7064 if (!PL_madskills) {
7071 if (PL_parser && PL_parser->error_count) {
7073 SvREFCNT_dec(PL_compcv);
7078 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7080 svspot = (SV **)(spot = &clonee);
7082 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7086 SvUPGRADE(name, SVt_PVMG);
7087 mg = mg_find(name, PERL_MAGIC_proto);
7088 assert (SvTYPE(*spot) == SVt_PVCV);
7090 hek = CvNAME_HEK(*spot);
7092 CvNAME_HEK_set(*spot, hek =
7095 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
7101 cv = (CV *)mg->mg_obj;
7104 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7105 mg = mg_find(name, PERL_MAGIC_proto);
7107 spot = (CV **)(svspot = &mg->mg_obj);
7110 if (!block || !ps || *ps || attrs
7111 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7113 || block->op_type == OP_NULL
7118 const_sv = op_const_sv(block, NULL);
7121 const bool exists = CvROOT(cv) || CvXSUB(cv);
7123 /* if the subroutine doesn't exist and wasn't pre-declared
7124 * with a prototype, assume it will be AUTOLOADed,
7125 * skipping the prototype check
7127 if (exists || SvPOK(cv))
7128 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7129 /* already defined? */
7131 if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
7134 if (attrs) goto attrs;
7135 /* just a "sub foo;" when &foo is already defined */
7140 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7146 SvREFCNT_inc_simple_void_NN(const_sv);
7148 assert(!CvROOT(cv) && !CvCONST(cv));
7152 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7153 CvFILE_set_from_cop(cv, PL_curcop);
7154 CvSTASH_set(cv, PL_curstash);
7157 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7158 CvXSUBANY(cv).any_ptr = const_sv;
7159 CvXSUB(cv) = const_sv_xsub;
7165 SvREFCNT_dec(compcv);
7169 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7170 determine whether this sub definition is in the same scope as its
7171 declaration. If this sub definition is inside an inner named pack-
7172 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7173 the package sub. So check PadnameOUTER(name) too.
7175 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7176 assert(!CvWEAKOUTSIDE(compcv));
7177 SvREFCNT_dec(CvOUTSIDE(compcv));
7178 CvWEAKOUTSIDE_on(compcv);
7180 /* XXX else do we have a circular reference? */
7181 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7182 /* transfer PL_compcv to cv */
7185 && block->op_type != OP_NULL
7188 cv_flags_t preserved_flags =
7189 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7190 PADLIST *const temp_padl = CvPADLIST(cv);
7191 CV *const temp_cv = CvOUTSIDE(cv);
7192 const cv_flags_t other_flags =
7193 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7194 OP * const cvstart = CvSTART(cv);
7198 CvFLAGS(compcv) | preserved_flags;
7199 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7200 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7201 CvPADLIST(cv) = CvPADLIST(compcv);
7202 CvOUTSIDE(compcv) = temp_cv;
7203 CvPADLIST(compcv) = temp_padl;
7204 CvSTART(cv) = CvSTART(compcv);
7205 CvSTART(compcv) = cvstart;
7206 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7207 CvFLAGS(compcv) |= other_flags;
7209 if (CvFILE(cv) && CvDYNFILE(cv)) {
7210 Safefree(CvFILE(cv));
7213 /* inner references to compcv must be fixed up ... */
7214 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7215 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7216 ++PL_sub_generation;
7219 /* Might have had built-in attributes applied -- propagate them. */
7220 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7222 /* ... before we throw it away */
7223 SvREFCNT_dec(compcv);
7224 PL_compcv = compcv = cv;
7231 if (!CvNAME_HEK(cv)) {
7234 ? share_hek_hek(hek)
7235 : share_hek(PadnamePV(name)+1,
7236 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7240 if (const_sv) goto clone;
7242 CvFILE_set_from_cop(cv, PL_curcop);
7243 CvSTASH_set(cv, PL_curstash);
7246 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7247 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7254 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7255 the debugger could be able to set a breakpoint in, so signal to
7256 pp_entereval that it should not throw away any saved lines at scope
7259 PL_breakable_sub_gen++;
7260 /* This makes sub {}; work as expected. */
7261 if (block->op_type == OP_STUB) {
7262 OP* const newblock = newSTATEOP(0, NULL, 0);
7264 op_getmad(block,newblock,'B');
7270 CvROOT(cv) = CvLVALUE(cv)
7271 ? newUNOP(OP_LEAVESUBLV, 0,
7272 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7273 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7274 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7275 OpREFCNT_set(CvROOT(cv), 1);
7276 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7277 itself has a refcount. */
7279 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7280 CvSTART(cv) = LINKLIST(CvROOT(cv));
7281 CvROOT(cv)->op_next = 0;
7282 CALL_PEEP(CvSTART(cv));
7283 finalize_optree(CvROOT(cv));
7285 /* now that optimizer has done its work, adjust pad values */
7287 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7290 assert(!CvCONST(cv));
7291 if (ps && !*ps && op_const_sv(block, cv))
7297 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7298 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7302 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7303 SV * const tmpstr = sv_newmortal();
7304 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7305 GV_ADDMULTI, SVt_PVHV);
7307 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7310 (long)CopLINE(PL_curcop));
7311 if (HvNAME_HEK(PL_curstash)) {
7312 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7313 sv_catpvs(tmpstr, "::");
7315 else sv_setpvs(tmpstr, "__ANON__::");
7316 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7317 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7318 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7319 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7320 hv = GvHVn(db_postponed);
7321 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7322 CV * const pcv = GvCV(db_postponed);
7328 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7336 assert(CvDEPTH(outcv));
7338 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7339 if (reusable) cv_clone_into(clonee, *spot);
7340 else *spot = cv_clone(clonee);
7341 SvREFCNT_dec_NN(clonee);
7345 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7346 PADOFFSET depth = CvDEPTH(outcv);
7349 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7351 *svspot = SvREFCNT_inc_simple_NN(cv);
7352 SvREFCNT_dec(oldcv);
7358 PL_parser->copline = NOLINE;
7365 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7367 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
7371 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7372 OP *block, U32 flags)
7377 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7381 const bool ec = PL_parser && PL_parser->error_count;
7382 /* If the subroutine has no body, no attributes, and no builtin attributes
7383 then it's just a sub declaration, and we may be able to get away with
7384 storing with a placeholder scalar in the symbol table, rather than a
7385 full GV and CV. If anything is present then it will take a full CV to
7387 const I32 gv_fetch_flags
7388 = ec ? GV_NOADD_NOINIT :
7389 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7391 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7393 const bool o_is_gv = flags & 1;
7394 const char * const name =
7395 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7397 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7398 #ifdef PERL_DEBUG_READONLY_OPS
7399 OPSLAB *slab = NULL;
7403 assert(proto->op_type == OP_CONST);
7404 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7405 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7415 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7417 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7418 SV * const sv = sv_newmortal();
7419 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7420 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7421 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7422 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7424 } else if (PL_curstash) {
7425 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7428 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7432 if (!PL_madskills) {
7443 if (name) SvREFCNT_dec(PL_compcv);
7444 else cv = PL_compcv;
7446 if (name && block) {
7447 const char *s = strrchr(name, ':');
7449 if (strEQ(s, "BEGIN")) {
7450 if (PL_in_eval & EVAL_KEEPERR)
7451 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7453 SV * const errsv = ERRSV;
7454 /* force display of errors found but not reported */
7455 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7456 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7463 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
7464 maximum a prototype before. */
7465 if (SvTYPE(gv) > SVt_NULL) {
7466 cv_ckproto_len_flags((const CV *)gv,
7467 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7471 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7472 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7475 sv_setiv(MUTABLE_SV(gv), -1);
7477 SvREFCNT_dec(PL_compcv);
7478 cv = PL_compcv = NULL;
7482 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7484 if (!block || !ps || *ps || attrs
7485 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7487 || block->op_type == OP_NULL
7492 const_sv = op_const_sv(block, NULL);
7495 const bool exists = CvROOT(cv) || CvXSUB(cv);
7497 /* if the subroutine doesn't exist and wasn't pre-declared
7498 * with a prototype, assume it will be AUTOLOADed,
7499 * skipping the prototype check
7501 if (exists || SvPOK(cv))
7502 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7503 /* already defined (or promised)? */
7504 if (exists || GvASSUMECV(gv)) {
7505 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7508 if (attrs) goto attrs;
7509 /* just a "sub foo;" when &foo is already defined */
7510 SAVEFREESV(PL_compcv);
7516 SvREFCNT_inc_simple_void_NN(const_sv);
7518 assert(!CvROOT(cv) && !CvCONST(cv));
7520 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7521 CvXSUBANY(cv).any_ptr = const_sv;
7522 CvXSUB(cv) = const_sv_xsub;
7528 cv = newCONSTSUB_flags(
7529 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7536 SvREFCNT_dec(PL_compcv);
7540 if (cv) { /* must reuse cv if autoloaded */
7541 /* transfer PL_compcv to cv */
7544 && block->op_type != OP_NULL
7547 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7548 PADLIST *const temp_av = CvPADLIST(cv);
7549 CV *const temp_cv = CvOUTSIDE(cv);
7550 const cv_flags_t other_flags =
7551 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7552 OP * const cvstart = CvSTART(cv);
7555 assert(!CvCVGV_RC(cv));
7556 assert(CvGV(cv) == gv);
7559 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7560 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7561 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7562 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7563 CvOUTSIDE(PL_compcv) = temp_cv;
7564 CvPADLIST(PL_compcv) = temp_av;
7565 CvSTART(cv) = CvSTART(PL_compcv);
7566 CvSTART(PL_compcv) = cvstart;
7567 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7568 CvFLAGS(PL_compcv) |= other_flags;
7570 if (CvFILE(cv) && CvDYNFILE(cv)) {
7571 Safefree(CvFILE(cv));
7573 CvFILE_set_from_cop(cv, PL_curcop);
7574 CvSTASH_set(cv, PL_curstash);
7576 /* inner references to PL_compcv must be fixed up ... */
7577 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7578 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7579 ++PL_sub_generation;
7582 /* Might have had built-in attributes applied -- propagate them. */
7583 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7585 /* ... before we throw it away */
7586 SvREFCNT_dec(PL_compcv);
7594 if (HvENAME_HEK(GvSTASH(gv)))
7595 /* sub Foo::bar { (shift)+1 } */
7596 gv_method_changed(gv);
7601 CvFILE_set_from_cop(cv, PL_curcop);
7602 CvSTASH_set(cv, PL_curstash);
7606 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7607 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7614 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7615 the debugger could be able to set a breakpoint in, so signal to
7616 pp_entereval that it should not throw away any saved lines at scope
7619 PL_breakable_sub_gen++;
7620 /* This makes sub {}; work as expected. */
7621 if (block->op_type == OP_STUB) {
7622 OP* const newblock = newSTATEOP(0, NULL, 0);
7624 op_getmad(block,newblock,'B');
7630 CvROOT(cv) = CvLVALUE(cv)
7631 ? newUNOP(OP_LEAVESUBLV, 0,
7632 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7633 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7634 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7635 OpREFCNT_set(CvROOT(cv), 1);
7636 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7637 itself has a refcount. */
7639 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7640 #ifdef PERL_DEBUG_READONLY_OPS
7641 slab = (OPSLAB *)CvSTART(cv);
7643 CvSTART(cv) = LINKLIST(CvROOT(cv));
7644 CvROOT(cv)->op_next = 0;
7645 CALL_PEEP(CvSTART(cv));
7646 finalize_optree(CvROOT(cv));
7648 /* now that optimizer has done its work, adjust pad values */
7650 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7653 assert(!CvCONST(cv));
7654 if (ps && !*ps && op_const_sv(block, cv))
7660 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7661 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7662 if (!name) SAVEFREESV(cv);
7663 apply_attrs(stash, MUTABLE_SV(cv), attrs);
7664 if (!name) SvREFCNT_inc_simple_void_NN(cv);
7667 if (block && has_name) {
7668 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7669 SV * const tmpstr = sv_newmortal();
7670 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7671 GV_ADDMULTI, SVt_PVHV);
7673 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7676 (long)CopLINE(PL_curcop));
7677 gv_efullname3(tmpstr, gv, NULL);
7678 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7679 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7680 hv = GvHVn(db_postponed);
7681 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7682 CV * const pcv = GvCV(db_postponed);
7688 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7693 if (name && ! (PL_parser && PL_parser->error_count))
7694 process_special_blocks(floor, name, gv, cv);
7699 PL_parser->copline = NOLINE;
7701 #ifdef PERL_DEBUG_READONLY_OPS
7702 /* Watch out for BEGIN blocks */
7703 if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
7709 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
7713 const char *const colon = strrchr(fullname,':');
7714 const char *const name = colon ? colon + 1 : fullname;
7716 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7719 if (strEQ(name, "BEGIN")) {
7720 const I32 oldscope = PL_scopestack_ix;
7721 if (floor) LEAVE_SCOPE(floor);
7723 SAVECOPFILE(&PL_compiling);
7724 SAVECOPLINE(&PL_compiling);
7725 SAVEVPTR(PL_curcop);
7727 DEBUG_x( dump_sub(gv) );
7728 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7729 GvCV_set(gv,0); /* cv has been hijacked */
7730 call_list(oldscope, PL_beginav);
7732 CopHINTS_set(&PL_compiling, PL_hints);
7739 if strEQ(name, "END") {
7740 DEBUG_x( dump_sub(gv) );
7741 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7744 } else if (*name == 'U') {
7745 if (strEQ(name, "UNITCHECK")) {
7746 /* It's never too late to run a unitcheck block */
7747 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7751 } else if (*name == 'C') {
7752 if (strEQ(name, "CHECK")) {
7754 /* diag_listed_as: Too late to run %s block */
7755 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7756 "Too late to run CHECK block");
7757 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7761 } else if (*name == 'I') {
7762 if (strEQ(name, "INIT")) {
7764 /* diag_listed_as: Too late to run %s block */
7765 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7766 "Too late to run INIT block");
7767 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7773 DEBUG_x( dump_sub(gv) );
7774 GvCV_set(gv,0); /* cv has been hijacked */
7779 =for apidoc newCONSTSUB
7781 See L</newCONSTSUB_flags>.
7787 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7789 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7793 =for apidoc newCONSTSUB_flags
7795 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7796 eligible for inlining at compile-time.
7798 Currently, the only useful value for C<flags> is SVf_UTF8.
7800 The newly created subroutine takes ownership of a reference to the passed in
7803 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7804 which won't be called if used as a destructor, but will suppress the overhead
7805 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7812 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7818 const char *const file = CopFILE(PL_curcop);
7820 SV *const temp_sv = CopFILESV(PL_curcop);
7821 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
7826 if (IN_PERL_RUNTIME) {
7827 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7828 * an op shared between threads. Use a non-shared COP for our
7830 SAVEVPTR(PL_curcop);
7831 SAVECOMPILEWARNINGS();
7832 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7833 PL_curcop = &PL_compiling;
7835 SAVECOPLINE(PL_curcop);
7836 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7839 PL_hints &= ~HINT_BLOCK_SCOPE;
7842 SAVEGENERICSV(PL_curstash);
7843 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7846 /* Protect sv against leakage caused by fatal warnings. */
7847 if (sv) SAVEFREESV(sv);
7849 /* file becomes the CvFILE. For an XS, it's usually static storage,
7850 and so doesn't get free()d. (It's expected to be from the C pre-
7851 processor __FILE__ directive). But we need a dynamically allocated one,
7852 and we need it to get freed. */
7853 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
7854 &sv, XS_DYNAMIC_FILENAME | flags);
7855 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
7864 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7865 const char *const filename, const char *const proto,
7868 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7869 return newXS_len_flags(
7870 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7875 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7876 XSUBADDR_t subaddr, const char *const filename,
7877 const char *const proto, SV **const_svp,
7882 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7885 GV * const gv = gv_fetchpvn(
7886 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7887 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
7888 sizeof("__ANON__::__ANON__") - 1,
7889 GV_ADDMULTI | flags, SVt_PVCV);
7892 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7894 if ((cv = (name ? GvCV(gv) : NULL))) {
7896 /* just a cached method */
7900 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7901 /* already defined (or promised) */
7902 /* Redundant check that allows us to avoid creating an SV
7903 most of the time: */
7904 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7905 report_redefined_cv(newSVpvn_flags(
7906 name,len,(flags&SVf_UTF8)|SVs_TEMP
7910 SvREFCNT_dec_NN(cv);
7915 if (cv) /* must reuse cv if autoloaded */
7918 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7922 if (HvENAME_HEK(GvSTASH(gv)))
7923 gv_method_changed(gv); /* newXS */
7929 (void)gv_fetchfile(filename);
7930 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7931 an external constant string */
7932 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7934 CvXSUB(cv) = subaddr;
7937 process_special_blocks(0, name, gv, cv);
7940 if (flags & XS_DYNAMIC_FILENAME) {
7941 CvFILE(cv) = savepv(filename);
7944 sv_setpv(MUTABLE_SV(cv), proto);
7949 Perl_newSTUB(pTHX_ GV *gv, bool fake)
7951 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7952 PERL_ARGS_ASSERT_NEWSTUB;
7956 if (!fake && HvENAME_HEK(GvSTASH(gv)))
7957 gv_method_changed(gv);
7959 CvFILE_set_from_cop(cv, PL_curcop);
7960 CvSTASH_set(cv, PL_curstash);
7966 =for apidoc U||newXS
7968 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7969 static storage, as it is used directly as CvFILE(), without a copy being made.
7975 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7977 PERL_ARGS_ASSERT_NEWXS;
7978 return newXS_len_flags(
7979 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7988 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7993 OP* pegop = newOP(OP_NULL, 0);
7998 if (PL_parser && PL_parser->error_count) {
8004 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8005 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8008 if ((cv = GvFORM(gv))) {
8009 if (ckWARN(WARN_REDEFINE)) {
8010 const line_t oldline = CopLINE(PL_curcop);
8011 if (PL_parser && PL_parser->copline != NOLINE)
8012 CopLINE_set(PL_curcop, PL_parser->copline);
8014 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8015 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8017 /* diag_listed_as: Format %s redefined */
8018 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8019 "Format STDOUT redefined");
8021 CopLINE_set(PL_curcop, oldline);
8026 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8028 CvFILE_set_from_cop(cv, PL_curcop);
8031 pad_tidy(padtidy_FORMAT);
8032 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8033 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8034 OpREFCNT_set(CvROOT(cv), 1);
8035 CvSTART(cv) = LINKLIST(CvROOT(cv));
8036 CvROOT(cv)->op_next = 0;
8037 CALL_PEEP(CvSTART(cv));
8038 finalize_optree(CvROOT(cv));
8043 op_getmad(o,pegop,'n');
8044 op_getmad_weak(block, pegop, 'b');
8049 PL_parser->copline = NOLINE;
8057 Perl_newANONLIST(pTHX_ OP *o)
8059 return convert(OP_ANONLIST, OPf_SPECIAL, o);
8063 Perl_newANONHASH(pTHX_ OP *o)
8065 return convert(OP_ANONHASH, OPf_SPECIAL, o);
8069 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8071 return newANONATTRSUB(floor, proto, NULL, block);
8075 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8077 return newUNOP(OP_REFGEN, 0,
8078 newSVOP(OP_ANONCODE, 0,
8079 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8083 Perl_oopsAV(pTHX_ OP *o)
8087 PERL_ARGS_ASSERT_OOPSAV;
8089 switch (o->op_type) {
8091 o->op_type = OP_PADAV;
8092 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8093 return ref(o, OP_RV2AV);
8096 o->op_type = OP_RV2AV;
8097 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8102 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8109 Perl_oopsHV(pTHX_ OP *o)
8113 PERL_ARGS_ASSERT_OOPSHV;
8115 switch (o->op_type) {
8118 o->op_type = OP_PADHV;
8119 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8120 return ref(o, OP_RV2HV);
8124 o->op_type = OP_RV2HV;
8125 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8130 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8137 Perl_newAVREF(pTHX_ OP *o)
8141 PERL_ARGS_ASSERT_NEWAVREF;
8143 if (o->op_type == OP_PADANY) {
8144 o->op_type = OP_PADAV;
8145 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8148 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8149 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8150 "Using an array as a reference is deprecated");
8152 return newUNOP(OP_RV2AV, 0, scalar(o));
8156 Perl_newGVREF(pTHX_ I32 type, OP *o)
8158 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8159 return newUNOP(OP_NULL, 0, o);
8160 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8164 Perl_newHVREF(pTHX_ OP *o)
8168 PERL_ARGS_ASSERT_NEWHVREF;
8170 if (o->op_type == OP_PADANY) {
8171 o->op_type = OP_PADHV;
8172 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8175 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8176 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8177 "Using a hash as a reference is deprecated");
8179 return newUNOP(OP_RV2HV, 0, scalar(o));
8183 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8185 if (o->op_type == OP_PADANY) {
8187 o->op_type = OP_PADCV;
8188 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8190 return newUNOP(OP_RV2CV, flags, scalar(o));
8194 Perl_newSVREF(pTHX_ OP *o)
8198 PERL_ARGS_ASSERT_NEWSVREF;
8200 if (o->op_type == OP_PADANY) {
8201 o->op_type = OP_PADSV;
8202 o->op_ppaddr = PL_ppaddr[OP_PADSV];
8205 return newUNOP(OP_RV2SV, 0, scalar(o));
8208 /* Check routines. See the comments at the top of this file for details
8209 * on when these are called */
8212 Perl_ck_anoncode(pTHX_ OP *o)
8214 PERL_ARGS_ASSERT_CK_ANONCODE;
8216 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8218 cSVOPo->op_sv = NULL;
8223 Perl_ck_bitop(pTHX_ OP *o)
8227 PERL_ARGS_ASSERT_CK_BITOP;
8229 o->op_private = (U8)(PL_hints & HINT_INTEGER);
8230 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8231 && (o->op_type == OP_BIT_OR
8232 || o->op_type == OP_BIT_AND
8233 || o->op_type == OP_BIT_XOR))
8235 const OP * const left = cBINOPo->op_first;
8236 const OP * const right = left->op_sibling;
8237 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8238 (left->op_flags & OPf_PARENS) == 0) ||
8239 (OP_IS_NUMCOMPARE(right->op_type) &&
8240 (right->op_flags & OPf_PARENS) == 0))
8241 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8242 "Possible precedence problem on bitwise %c operator",
8243 o->op_type == OP_BIT_OR ? '|'
8244 : o->op_type == OP_BIT_AND ? '&' : '^'
8250 PERL_STATIC_INLINE bool
8251 is_dollar_bracket(pTHX_ const OP * const o)
8254 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8255 && (kid = cUNOPx(o)->op_first)
8256 && kid->op_type == OP_GV
8257 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8261 Perl_ck_cmp(pTHX_ OP *o)
8263 PERL_ARGS_ASSERT_CK_CMP;
8264 if (ckWARN(WARN_SYNTAX)) {
8265 const OP *kid = cUNOPo->op_first;
8268 is_dollar_bracket(aTHX_ kid)
8269 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8271 || ( kid->op_type == OP_CONST
8272 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8274 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8275 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8281 Perl_ck_concat(pTHX_ OP *o)
8283 const OP * const kid = cUNOPo->op_first;
8285 PERL_ARGS_ASSERT_CK_CONCAT;
8286 PERL_UNUSED_CONTEXT;
8288 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8289 !(kUNOP->op_first->op_flags & OPf_MOD))
8290 o->op_flags |= OPf_STACKED;
8295 Perl_ck_spair(pTHX_ OP *o)
8299 PERL_ARGS_ASSERT_CK_SPAIR;
8301 if (o->op_flags & OPf_KIDS) {
8304 const OPCODE type = o->op_type;
8305 o = modkids(ck_fun(o), type);
8306 kid = cUNOPo->op_first;
8307 newop = kUNOP->op_first->op_sibling;
8309 const OPCODE type = newop->op_type;
8310 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8311 type == OP_PADAV || type == OP_PADHV ||
8312 type == OP_RV2AV || type == OP_RV2HV)
8316 op_getmad(kUNOP->op_first,newop,'K');
8318 op_free(kUNOP->op_first);
8320 kUNOP->op_first = newop;
8322 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8323 * and OP_CHOMP into OP_SCHOMP */
8324 o->op_ppaddr = PL_ppaddr[++o->op_type];
8329 Perl_ck_delete(pTHX_ OP *o)
8331 PERL_ARGS_ASSERT_CK_DELETE;
8335 if (o->op_flags & OPf_KIDS) {
8336 OP * const kid = cUNOPo->op_first;
8337 switch (kid->op_type) {
8339 o->op_flags |= OPf_SPECIAL;
8342 o->op_private |= OPpSLICE;
8345 o->op_flags |= OPf_SPECIAL;
8350 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
8353 if (kid->op_private & OPpLVAL_INTRO)
8354 o->op_private |= OPpLVAL_INTRO;
8361 Perl_ck_die(pTHX_ OP *o)
8363 PERL_ARGS_ASSERT_CK_DIE;
8366 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8372 Perl_ck_eof(pTHX_ OP *o)
8376 PERL_ARGS_ASSERT_CK_EOF;
8378 if (o->op_flags & OPf_KIDS) {
8380 if (cLISTOPo->op_first->op_type == OP_STUB) {
8382 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8384 op_getmad(o,newop,'O');
8391 kid = cLISTOPo->op_first;
8392 if (kid->op_type == OP_RV2GV)
8393 kid->op_private |= OPpALLOW_FAKE;
8399 Perl_ck_eval(pTHX_ OP *o)
8403 PERL_ARGS_ASSERT_CK_EVAL;
8405 PL_hints |= HINT_BLOCK_SCOPE;
8406 if (o->op_flags & OPf_KIDS) {
8407 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8410 o->op_flags &= ~OPf_KIDS;
8413 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8419 cUNOPo->op_first = 0;
8424 NewOp(1101, enter, 1, LOGOP);
8425 enter->op_type = OP_ENTERTRY;
8426 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8427 enter->op_private = 0;
8429 /* establish postfix order */
8430 enter->op_next = (OP*)enter;
8432 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8433 o->op_type = OP_LEAVETRY;
8434 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8435 enter->op_other = o;
8436 op_getmad(oldo,o,'O');
8445 const U8 priv = o->op_private;
8451 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8452 op_getmad(oldo,o,'O');
8454 o->op_targ = (PADOFFSET)PL_hints;
8455 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8456 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8457 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8458 /* Store a copy of %^H that pp_entereval can pick up. */
8459 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8460 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8461 cUNOPo->op_first->op_sibling = hhop;
8462 o->op_private |= OPpEVAL_HAS_HH;
8464 if (!(o->op_private & OPpEVAL_BYTES)
8465 && FEATURE_UNIEVAL_IS_ENABLED)
8466 o->op_private |= OPpEVAL_UNICODE;
8471 Perl_ck_exit(pTHX_ OP *o)
8473 PERL_ARGS_ASSERT_CK_EXIT;
8476 HV * const table = GvHV(PL_hintgv);
8478 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
8479 if (svp && *svp && SvTRUE(*svp))
8480 o->op_private |= OPpEXIT_VMSISH;
8482 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8488 Perl_ck_exec(pTHX_ OP *o)
8490 PERL_ARGS_ASSERT_CK_EXEC;
8492 if (o->op_flags & OPf_STACKED) {
8495 kid = cUNOPo->op_first->op_sibling;
8496 if (kid->op_type == OP_RV2GV)
8505 Perl_ck_exists(pTHX_ OP *o)
8509 PERL_ARGS_ASSERT_CK_EXISTS;
8512 if (o->op_flags & OPf_KIDS) {
8513 OP * const kid = cUNOPo->op_first;
8514 if (kid->op_type == OP_ENTERSUB) {
8515 (void) ref(kid, o->op_type);
8516 if (kid->op_type != OP_RV2CV
8517 && !(PL_parser && PL_parser->error_count))
8518 Perl_croak(aTHX_ "%s argument is not a subroutine name",
8520 o->op_private |= OPpEXISTS_SUB;
8522 else if (kid->op_type == OP_AELEM)
8523 o->op_flags |= OPf_SPECIAL;
8524 else if (kid->op_type != OP_HELEM)
8525 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
8533 Perl_ck_rvconst(pTHX_ OP *o)
8536 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8538 PERL_ARGS_ASSERT_CK_RVCONST;
8540 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8541 if (o->op_type == OP_RV2CV)
8542 o->op_private &= ~1;
8544 if (kid->op_type == OP_CONST) {
8547 SV * const kidsv = kid->op_sv;
8549 /* Is it a constant from cv_const_sv()? */
8550 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8551 SV * const rsv = SvRV(kidsv);
8552 const svtype type = SvTYPE(rsv);
8553 const char *badtype = NULL;
8555 switch (o->op_type) {
8557 if (type > SVt_PVMG)
8558 badtype = "a SCALAR";
8561 if (type != SVt_PVAV)
8562 badtype = "an ARRAY";
8565 if (type != SVt_PVHV)
8569 if (type != SVt_PVCV)
8574 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8577 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8578 const char *badthing;
8579 switch (o->op_type) {
8581 badthing = "a SCALAR";
8584 badthing = "an ARRAY";
8587 badthing = "a HASH";
8595 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8596 SVfARG(kidsv), badthing);
8599 * This is a little tricky. We only want to add the symbol if we
8600 * didn't add it in the lexer. Otherwise we get duplicate strict
8601 * warnings. But if we didn't add it in the lexer, we must at
8602 * least pretend like we wanted to add it even if it existed before,
8603 * or we get possible typo warnings. OPpCONST_ENTERED says
8604 * whether the lexer already added THIS instance of this symbol.
8606 iscv = (o->op_type == OP_RV2CV) * 2;
8608 gv = gv_fetchsv(kidsv,
8609 iscv | !(kid->op_private & OPpCONST_ENTERED),
8612 : o->op_type == OP_RV2SV
8614 : o->op_type == OP_RV2AV
8616 : o->op_type == OP_RV2HV
8619 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8621 kid->op_type = OP_GV;
8622 SvREFCNT_dec(kid->op_sv);
8624 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8625 assert (sizeof(PADOP) <= sizeof(SVOP));
8626 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8627 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8629 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8631 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8633 kid->op_private = 0;
8634 kid->op_ppaddr = PL_ppaddr[OP_GV];
8635 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8643 Perl_ck_ftst(pTHX_ OP *o)
8646 const I32 type = o->op_type;
8648 PERL_ARGS_ASSERT_CK_FTST;
8650 if (o->op_flags & OPf_REF) {
8653 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8654 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8655 const OPCODE kidtype = kid->op_type;
8657 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
8658 && !(kid->op_private & OPpCONST_FOLDED)) {
8659 OP * const newop = newGVOP(type, OPf_REF,
8660 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8662 op_getmad(o,newop,'O');
8668 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8669 o->op_private |= OPpFT_ACCESS;
8670 if (PL_check[kidtype] == Perl_ck_ftst
8671 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8672 o->op_private |= OPpFT_STACKED;
8673 kid->op_private |= OPpFT_STACKING;
8674 if (kidtype == OP_FTTTY && (
8675 !(kid->op_private & OPpFT_STACKED)
8676 || kid->op_private & OPpFT_AFTER_t
8678 o->op_private |= OPpFT_AFTER_t;
8687 if (type == OP_FTTTY)
8688 o = newGVOP(type, OPf_REF, PL_stdingv);
8690 o = newUNOP(type, 0, newDEFSVOP());
8691 op_getmad(oldo,o,'O');
8697 Perl_ck_fun(pTHX_ OP *o)
8700 const int type = o->op_type;
8701 I32 oa = PL_opargs[type] >> OASHIFT;
8703 PERL_ARGS_ASSERT_CK_FUN;
8705 if (o->op_flags & OPf_STACKED) {
8706 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8709 return no_fh_allowed(o);
8712 if (o->op_flags & OPf_KIDS) {
8713 OP **tokid = &cLISTOPo->op_first;
8714 OP *kid = cLISTOPo->op_first;
8717 bool seen_optional = FALSE;
8719 if (kid->op_type == OP_PUSHMARK ||
8720 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8722 tokid = &kid->op_sibling;
8723 kid = kid->op_sibling;
8725 if (kid && kid->op_type == OP_COREARGS) {
8726 bool optional = FALSE;
8729 if (oa & OA_OPTIONAL) optional = TRUE;
8732 if (optional) o->op_private |= numargs;
8737 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8738 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8739 *tokid = kid = newDEFSVOP();
8740 seen_optional = TRUE;
8745 sibl = kid->op_sibling;
8747 if (!sibl && kid->op_type == OP_STUB) {
8754 /* list seen where single (scalar) arg expected? */
8755 if (numargs == 1 && !(oa >> 4)
8756 && kid->op_type == OP_LIST && type != OP_SCALAR)
8758 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8771 if ((type == OP_PUSH || type == OP_UNSHIFT)
8772 && !kid->op_sibling)
8773 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8774 "Useless use of %s with no values",
8777 if (kid->op_type == OP_CONST &&
8778 (kid->op_private & OPpCONST_BARE))
8780 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
8781 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
8782 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8783 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8784 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8786 op_getmad(kid,newop,'K');
8791 kid->op_sibling = sibl;
8794 else if (kid->op_type == OP_CONST
8795 && ( !SvROK(cSVOPx_sv(kid))
8796 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8798 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8799 /* Defer checks to run-time if we have a scalar arg */
8800 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8801 op_lvalue(kid, type);
8805 if (kid->op_type == OP_CONST &&
8806 (kid->op_private & OPpCONST_BARE))
8808 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
8809 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
8810 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8811 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8812 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8814 op_getmad(kid,newop,'K');
8819 kid->op_sibling = sibl;
8822 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8823 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8824 op_lvalue(kid, type);
8828 OP * const newop = newUNOP(OP_NULL, 0, kid);
8829 kid->op_sibling = 0;
8830 newop->op_next = newop;
8832 kid->op_sibling = sibl;
8837 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8838 if (kid->op_type == OP_CONST &&
8839 (kid->op_private & OPpCONST_BARE))
8841 OP * const newop = newGVOP(OP_GV, 0,
8842 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8843 if (!(o->op_private & 1) && /* if not unop */
8844 kid == cLISTOPo->op_last)
8845 cLISTOPo->op_last = newop;
8847 op_getmad(kid,newop,'K');
8853 else if (kid->op_type == OP_READLINE) {
8854 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8855 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8858 I32 flags = OPf_SPECIAL;
8862 /* is this op a FH constructor? */
8863 if (is_handle_constructor(o,numargs)) {
8864 const char *name = NULL;
8867 bool want_dollar = TRUE;
8870 /* Set a flag to tell rv2gv to vivify
8871 * need to "prove" flag does not mean something
8872 * else already - NI-S 1999/05/07
8875 if (kid->op_type == OP_PADSV) {
8877 = PAD_COMPNAME_SV(kid->op_targ);
8878 name = SvPV_const(namesv, len);
8879 name_utf8 = SvUTF8(namesv);
8881 else if (kid->op_type == OP_RV2SV
8882 && kUNOP->op_first->op_type == OP_GV)
8884 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8886 len = GvNAMELEN(gv);
8887 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8889 else if (kid->op_type == OP_AELEM
8890 || kid->op_type == OP_HELEM)
8893 OP *op = ((BINOP*)kid)->op_first;
8897 const char * const a =
8898 kid->op_type == OP_AELEM ?
8900 if (((op->op_type == OP_RV2AV) ||
8901 (op->op_type == OP_RV2HV)) &&
8902 (firstop = ((UNOP*)op)->op_first) &&
8903 (firstop->op_type == OP_GV)) {
8904 /* packagevar $a[] or $h{} */
8905 GV * const gv = cGVOPx_gv(firstop);
8913 else if (op->op_type == OP_PADAV
8914 || op->op_type == OP_PADHV) {
8915 /* lexicalvar $a[] or $h{} */
8916 const char * const padname =
8917 PAD_COMPNAME_PV(op->op_targ);
8926 name = SvPV_const(tmpstr, len);
8927 name_utf8 = SvUTF8(tmpstr);
8932 name = "__ANONIO__";
8934 want_dollar = FALSE;
8936 op_lvalue(kid, type);
8940 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8941 namesv = PAD_SVl(targ);
8942 SvUPGRADE(namesv, SVt_PV);
8943 if (want_dollar && *name != '$')
8944 sv_setpvs(namesv, "$");
8945 sv_catpvn(namesv, name, len);
8946 if ( name_utf8 ) SvUTF8_on(namesv);
8949 kid->op_sibling = 0;
8950 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8951 kid->op_targ = targ;
8952 kid->op_private |= priv;
8954 kid->op_sibling = sibl;
8960 if ((type == OP_UNDEF || type == OP_POS)
8961 && numargs == 1 && !(oa >> 4)
8962 && kid->op_type == OP_LIST)
8963 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8964 op_lvalue(scalar(kid), type);
8968 tokid = &kid->op_sibling;
8969 kid = kid->op_sibling;
8972 if (kid && kid->op_type != OP_STUB)
8973 return too_many_arguments_pv(o,OP_DESC(o), 0);
8974 o->op_private |= numargs;
8976 /* FIXME - should the numargs move as for the PERL_MAD case? */
8977 o->op_private |= numargs;
8979 return too_many_arguments_pv(o,OP_DESC(o), 0);
8983 else if (PL_opargs[type] & OA_DEFGV) {
8985 OP *newop = newUNOP(type, 0, newDEFSVOP());
8986 op_getmad(o,newop,'O');
8989 /* Ordering of these two is important to keep f_map.t passing. */
8991 return newUNOP(type, 0, newDEFSVOP());
8996 while (oa & OA_OPTIONAL)
8998 if (oa && oa != OA_LIST)
8999 return too_few_arguments_pv(o,OP_DESC(o), 0);
9005 Perl_ck_glob(pTHX_ OP *o)
9009 const bool core = o->op_flags & OPf_SPECIAL;
9011 PERL_ARGS_ASSERT_CK_GLOB;
9014 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
9015 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9017 if (core) gv = NULL;
9018 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
9019 && GvCVu(gv) && GvIMPORTED_CV(gv)))
9021 GV * const * const gvp =
9022 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
9023 gv = gvp ? *gvp : NULL;
9026 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
9029 * \ null - const(wildcard)
9034 * \ mark - glob - rv2cv
9035 * | \ gv(CORE::GLOBAL::glob)
9037 * \ null - const(wildcard)
9039 o->op_flags |= OPf_SPECIAL;
9040 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9041 o = newLISTOP(OP_LIST, 0, o, NULL);
9042 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
9043 op_append_elem(OP_LIST, o,
9044 scalar(newUNOP(OP_RV2CV, 0,
9045 newGVOP(OP_GV, 0, gv)))));
9046 o = newUNOP(OP_NULL, 0, o);
9047 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9050 else o->op_flags &= ~OPf_SPECIAL;
9051 #if !defined(PERL_EXTERNAL_GLOB)
9054 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9055 newSVpvs("File::Glob"), NULL, NULL, NULL);
9058 #endif /* !PERL_EXTERNAL_GLOB */
9059 gv = (GV *)newSV(0);
9060 gv_init(gv, 0, "", 0, 0);
9062 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9063 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9069 Perl_ck_grep(pTHX_ OP *o)
9074 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9077 PERL_ARGS_ASSERT_CK_GREP;
9079 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9080 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9082 if (o->op_flags & OPf_STACKED) {
9083 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
9084 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9085 return no_fh_allowed(o);
9086 o->op_flags &= ~OPf_STACKED;
9088 kid = cLISTOPo->op_first->op_sibling;
9089 if (type == OP_MAPWHILE)
9094 if (PL_parser && PL_parser->error_count)
9096 kid = cLISTOPo->op_first->op_sibling;
9097 if (kid->op_type != OP_NULL)
9098 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9099 kid = kUNOP->op_first;
9101 NewOp(1101, gwop, 1, LOGOP);
9102 gwop->op_type = type;
9103 gwop->op_ppaddr = PL_ppaddr[type];
9105 gwop->op_flags |= OPf_KIDS;
9106 gwop->op_other = LINKLIST(kid);
9107 kid->op_next = (OP*)gwop;
9108 offset = pad_findmy_pvs("$_", 0);
9109 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9110 o->op_private = gwop->op_private = 0;
9111 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9114 o->op_private = gwop->op_private = OPpGREP_LEX;
9115 gwop->op_targ = o->op_targ = offset;
9118 kid = cLISTOPo->op_first->op_sibling;
9119 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
9120 op_lvalue(kid, OP_GREPSTART);
9126 Perl_ck_index(pTHX_ OP *o)
9128 PERL_ARGS_ASSERT_CK_INDEX;
9130 if (o->op_flags & OPf_KIDS) {
9131 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9133 kid = kid->op_sibling; /* get past "big" */
9134 if (kid && kid->op_type == OP_CONST) {
9135 const bool save_taint = TAINT_get;
9136 fbm_compile(((SVOP*)kid)->op_sv, 0);
9137 TAINT_set(save_taint);
9138 #ifdef NO_TAINT_SUPPORT
9139 PERL_UNUSED_VAR(save_taint);
9147 Perl_ck_lfun(pTHX_ OP *o)
9149 const OPCODE type = o->op_type;
9151 PERL_ARGS_ASSERT_CK_LFUN;
9153 return modkids(ck_fun(o), type);
9157 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
9159 PERL_ARGS_ASSERT_CK_DEFINED;
9161 if ((o->op_flags & OPf_KIDS)) {
9162 switch (cUNOPo->op_first->op_type) {
9165 case OP_AASSIGN: /* Is this a good idea? */
9166 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9167 "defined(@array) is deprecated");
9168 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9169 "\t(Maybe you should just omit the defined()?)\n");
9173 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9174 "defined(%%hash) is deprecated");
9175 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9176 "\t(Maybe you should just omit the defined()?)\n");
9187 Perl_ck_readline(pTHX_ OP *o)
9189 PERL_ARGS_ASSERT_CK_READLINE;
9191 if (o->op_flags & OPf_KIDS) {
9192 OP *kid = cLISTOPo->op_first;
9193 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9197 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9199 op_getmad(o,newop,'O');
9209 Perl_ck_rfun(pTHX_ OP *o)
9211 const OPCODE type = o->op_type;
9213 PERL_ARGS_ASSERT_CK_RFUN;
9215 return refkids(ck_fun(o), type);
9219 Perl_ck_listiob(pTHX_ OP *o)
9223 PERL_ARGS_ASSERT_CK_LISTIOB;
9225 kid = cLISTOPo->op_first;
9228 kid = cLISTOPo->op_first;
9230 if (kid->op_type == OP_PUSHMARK)
9231 kid = kid->op_sibling;
9232 if (kid && o->op_flags & OPf_STACKED)
9233 kid = kid->op_sibling;
9234 else if (kid && !kid->op_sibling) { /* print HANDLE; */
9235 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9236 && !(kid->op_private & OPpCONST_FOLDED)) {
9237 o->op_flags |= OPf_STACKED; /* make it a filehandle */
9238 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9239 cLISTOPo->op_first->op_sibling = kid;
9240 cLISTOPo->op_last = kid;
9241 kid = kid->op_sibling;
9246 op_append_elem(o->op_type, o, newDEFSVOP());
9248 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9253 Perl_ck_smartmatch(pTHX_ OP *o)
9256 PERL_ARGS_ASSERT_CK_SMARTMATCH;
9257 if (0 == (o->op_flags & OPf_SPECIAL)) {
9258 OP *first = cBINOPo->op_first;
9259 OP *second = first->op_sibling;
9261 /* Implicitly take a reference to an array or hash */
9262 first->op_sibling = NULL;
9263 first = cBINOPo->op_first = ref_array_or_hash(first);
9264 second = first->op_sibling = ref_array_or_hash(second);
9266 /* Implicitly take a reference to a regular expression */
9267 if (first->op_type == OP_MATCH) {
9268 first->op_type = OP_QR;
9269 first->op_ppaddr = PL_ppaddr[OP_QR];
9271 if (second->op_type == OP_MATCH) {
9272 second->op_type = OP_QR;
9273 second->op_ppaddr = PL_ppaddr[OP_QR];
9282 Perl_ck_sassign(pTHX_ OP *o)
9285 OP * const kid = cLISTOPo->op_first;
9287 PERL_ARGS_ASSERT_CK_SASSIGN;
9289 /* has a disposable target? */
9290 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9291 && !(kid->op_flags & OPf_STACKED)
9292 /* Cannot steal the second time! */
9293 && !(kid->op_private & OPpTARGET_MY)
9294 /* Keep the full thing for madskills */
9298 OP * const kkid = kid->op_sibling;
9300 /* Can just relocate the target. */
9301 if (kkid && kkid->op_type == OP_PADSV
9302 && !(kkid->op_private & OPpLVAL_INTRO))
9304 kid->op_targ = kkid->op_targ;
9306 /* Now we do not need PADSV and SASSIGN. */
9307 kid->op_sibling = o->op_sibling; /* NULL */
9308 cLISTOPo->op_first = NULL;
9311 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9315 if (kid->op_sibling) {
9316 OP *kkid = kid->op_sibling;
9317 /* For state variable assignment, kkid is a list op whose op_last
9319 if ((kkid->op_type == OP_PADSV ||
9320 (kkid->op_type == OP_LIST &&
9321 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9324 && (kkid->op_private & OPpLVAL_INTRO)
9325 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9326 const PADOFFSET target = kkid->op_targ;
9327 OP *const other = newOP(OP_PADSV,
9329 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9330 OP *const first = newOP(OP_NULL, 0);
9331 OP *const nullop = newCONDOP(0, first, o, other);
9332 OP *const condop = first->op_next;
9333 /* hijacking PADSTALE for uninitialized state variables */
9334 SvPADSTALE_on(PAD_SVl(target));
9336 condop->op_type = OP_ONCE;
9337 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9338 condop->op_targ = target;
9339 other->op_targ = target;
9341 /* Because we change the type of the op here, we will skip the
9342 assignment binop->op_last = binop->op_first->op_sibling; at the
9343 end of Perl_newBINOP(). So need to do it here. */
9344 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9353 Perl_ck_match(pTHX_ OP *o)
9357 PERL_ARGS_ASSERT_CK_MATCH;
9359 if (o->op_type != OP_QR && PL_compcv) {
9360 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9361 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9362 o->op_targ = offset;
9363 o->op_private |= OPpTARGET_MY;
9366 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9367 o->op_private |= OPpRUNTIME;
9372 Perl_ck_method(pTHX_ OP *o)
9374 OP * const kid = cUNOPo->op_first;
9376 PERL_ARGS_ASSERT_CK_METHOD;
9378 if (kid->op_type == OP_CONST) {
9379 SV* sv = kSVOP->op_sv;
9380 const char * const method = SvPVX_const(sv);
9381 if (!(strchr(method, ':') || strchr(method, '\''))) {
9384 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9387 kSVOP->op_sv = NULL;
9389 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9391 op_getmad(o,cmop,'O');
9402 Perl_ck_null(pTHX_ OP *o)
9404 PERL_ARGS_ASSERT_CK_NULL;
9405 PERL_UNUSED_CONTEXT;
9410 Perl_ck_open(pTHX_ OP *o)
9413 HV * const table = GvHV(PL_hintgv);
9415 PERL_ARGS_ASSERT_CK_OPEN;
9418 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9421 const char *d = SvPV_const(*svp, len);
9422 const I32 mode = mode_from_discipline(d, len);
9423 if (mode & O_BINARY)
9424 o->op_private |= OPpOPEN_IN_RAW;
9425 else if (mode & O_TEXT)
9426 o->op_private |= OPpOPEN_IN_CRLF;
9429 svp = hv_fetchs(table, "open_OUT", FALSE);
9432 const char *d = SvPV_const(*svp, len);
9433 const I32 mode = mode_from_discipline(d, len);
9434 if (mode & O_BINARY)
9435 o->op_private |= OPpOPEN_OUT_RAW;
9436 else if (mode & O_TEXT)
9437 o->op_private |= OPpOPEN_OUT_CRLF;
9440 if (o->op_type == OP_BACKTICK) {
9441 if (!(o->op_flags & OPf_KIDS)) {
9442 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9444 op_getmad(o,newop,'O');
9453 /* In case of three-arg dup open remove strictness
9454 * from the last arg if it is a bareword. */
9455 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9456 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
9460 if ((last->op_type == OP_CONST) && /* The bareword. */
9461 (last->op_private & OPpCONST_BARE) &&
9462 (last->op_private & OPpCONST_STRICT) &&
9463 (oa = first->op_sibling) && /* The fh. */
9464 (oa = oa->op_sibling) && /* The mode. */
9465 (oa->op_type == OP_CONST) &&
9466 SvPOK(((SVOP*)oa)->op_sv) &&
9467 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9468 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9469 (last == oa->op_sibling)) /* The bareword. */
9470 last->op_private &= ~OPpCONST_STRICT;
9476 Perl_ck_repeat(pTHX_ OP *o)
9478 PERL_ARGS_ASSERT_CK_REPEAT;
9480 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9481 o->op_private |= OPpREPEAT_DOLIST;
9482 cBINOPo->op_first = force_list(cBINOPo->op_first);
9490 Perl_ck_require(pTHX_ OP *o)
9495 PERL_ARGS_ASSERT_CK_REQUIRE;
9497 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9498 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9500 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9501 SV * const sv = kid->op_sv;
9502 U32 was_readonly = SvREADONLY(sv);
9510 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9515 for (; s < end; s++) {
9516 if (*s == ':' && s[1] == ':') {
9518 Move(s+2, s+1, end - s - 1, char);
9523 sv_catpvs(sv, ".pm");
9524 SvFLAGS(sv) |= was_readonly;
9528 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9529 /* handle override, if any */
9530 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
9531 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
9532 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
9533 gv = gvp ? *gvp : NULL;
9537 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
9539 if (o->op_flags & OPf_KIDS) {
9540 kid = cUNOPo->op_first;
9541 cUNOPo->op_first = NULL;
9549 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
9550 op_append_elem(OP_LIST, kid,
9551 scalar(newUNOP(OP_RV2CV, 0,
9554 op_getmad(o,newop,'O');
9558 return scalar(ck_fun(o));
9562 Perl_ck_return(pTHX_ OP *o)
9567 PERL_ARGS_ASSERT_CK_RETURN;
9569 kid = cLISTOPo->op_first->op_sibling;
9570 if (CvLVALUE(PL_compcv)) {
9571 for (; kid; kid = kid->op_sibling)
9572 op_lvalue(kid, OP_LEAVESUBLV);
9579 Perl_ck_select(pTHX_ OP *o)
9584 PERL_ARGS_ASSERT_CK_SELECT;
9586 if (o->op_flags & OPf_KIDS) {
9587 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9588 if (kid && kid->op_sibling) {
9589 o->op_type = OP_SSELECT;
9590 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9592 return fold_constants(op_integerize(op_std_init(o)));
9596 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9597 if (kid && kid->op_type == OP_RV2GV)
9598 kid->op_private &= ~HINT_STRICT_REFS;
9603 Perl_ck_shift(pTHX_ OP *o)
9606 const I32 type = o->op_type;
9608 PERL_ARGS_ASSERT_CK_SHIFT;
9610 if (!(o->op_flags & OPf_KIDS)) {
9613 if (!CvUNIQUE(PL_compcv)) {
9614 o->op_flags |= OPf_SPECIAL;
9618 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9621 OP * const oldo = o;
9622 o = newUNOP(type, 0, scalar(argop));
9623 op_getmad(oldo,o,'O');
9628 return newUNOP(type, 0, scalar(argop));
9631 return scalar(ck_fun(o));
9635 Perl_ck_sort(pTHX_ OP *o)
9639 HV * const hinthv = GvHV(PL_hintgv);
9641 PERL_ARGS_ASSERT_CK_SORT;
9644 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9646 const I32 sorthints = (I32)SvIV(*svp);
9647 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9648 o->op_private |= OPpSORT_QSORT;
9649 if ((sorthints & HINT_SORT_STABLE) != 0)
9650 o->op_private |= OPpSORT_STABLE;
9654 if (o->op_flags & OPf_STACKED)
9656 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9657 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9658 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9660 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9662 if (kid->op_type == OP_LEAVE)
9663 op_null(kid); /* wipe out leave */
9664 /* Prevent execution from escaping out of the sort block. */
9667 /* provide scalar context for comparison function/block */
9668 kid = scalar(firstkid);
9670 o->op_flags |= OPf_SPECIAL;
9673 firstkid = firstkid->op_sibling;
9676 /* provide list context for arguments */
9683 S_simplify_sort(pTHX_ OP *o)
9686 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9693 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9695 if (!(o->op_flags & OPf_STACKED))
9697 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9698 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
9699 kid = kUNOP->op_first; /* get past null */
9700 if (!(have_scopeop = kid->op_type == OP_SCOPE)
9701 && kid->op_type != OP_LEAVE)
9703 kid = kLISTOP->op_last; /* get past scope */
9704 switch(kid->op_type) {
9708 if (!have_scopeop) goto padkids;
9713 k = kid; /* remember this node*/
9714 if (kBINOP->op_first->op_type != OP_RV2SV
9715 || kBINOP->op_last ->op_type != OP_RV2SV)
9718 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
9719 then used in a comparison. This catches most, but not
9720 all cases. For instance, it catches
9721 sort { my($a); $a <=> $b }
9723 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
9724 (although why you'd do that is anyone's guess).
9728 if (!ckWARN(WARN_SYNTAX)) return;
9729 kid = kBINOP->op_first;
9731 if (kid->op_type == OP_PADSV) {
9732 SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
9733 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
9734 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
9735 /* diag_listed_as: "my %s" used in sort comparison */
9736 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9737 "\"%s %s\" used in sort comparison",
9738 SvPAD_STATE(name) ? "state" : "my",
9741 } while ((kid = kid->op_sibling));
9744 kid = kBINOP->op_first; /* get past cmp */
9745 if (kUNOP->op_first->op_type != OP_GV)
9747 kid = kUNOP->op_first; /* get past rv2sv */
9749 if (GvSTASH(gv) != PL_curstash)
9751 gvname = GvNAME(gv);
9752 if (*gvname == 'a' && gvname[1] == '\0')
9754 else if (*gvname == 'b' && gvname[1] == '\0')
9759 kid = k; /* back to cmp */
9760 /* already checked above that it is rv2sv */
9761 kid = kBINOP->op_last; /* down to 2nd arg */
9762 if (kUNOP->op_first->op_type != OP_GV)
9764 kid = kUNOP->op_first; /* get past rv2sv */
9766 if (GvSTASH(gv) != PL_curstash)
9768 gvname = GvNAME(gv);
9770 ? !(*gvname == 'a' && gvname[1] == '\0')
9771 : !(*gvname == 'b' && gvname[1] == '\0'))
9773 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9775 o->op_private |= OPpSORT_DESCEND;
9776 if (k->op_type == OP_NCMP)
9777 o->op_private |= OPpSORT_NUMERIC;
9778 if (k->op_type == OP_I_NCMP)
9779 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9780 kid = cLISTOPo->op_first->op_sibling;
9781 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9783 op_getmad(kid,o,'S'); /* then delete it */
9785 op_free(kid); /* then delete it */
9790 Perl_ck_split(pTHX_ OP *o)
9795 PERL_ARGS_ASSERT_CK_SPLIT;
9797 if (o->op_flags & OPf_STACKED)
9798 return no_fh_allowed(o);
9800 kid = cLISTOPo->op_first;
9801 if (kid->op_type != OP_NULL)
9802 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9803 kid = kid->op_sibling;
9804 op_free(cLISTOPo->op_first);
9806 cLISTOPo->op_first = kid;
9808 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9809 cLISTOPo->op_last = kid; /* There was only one element previously */
9812 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9813 OP * const sibl = kid->op_sibling;
9814 kid->op_sibling = 0;
9815 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
9816 if (cLISTOPo->op_first == cLISTOPo->op_last)
9817 cLISTOPo->op_last = kid;
9818 cLISTOPo->op_first = kid;
9819 kid->op_sibling = sibl;
9822 kid->op_type = OP_PUSHRE;
9823 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9825 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9826 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9827 "Use of /g modifier is meaningless in split");
9830 if (!kid->op_sibling)
9831 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9833 kid = kid->op_sibling;
9836 if (!kid->op_sibling)
9837 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9838 assert(kid->op_sibling);
9840 kid = kid->op_sibling;
9843 if (kid->op_sibling)
9844 return too_many_arguments_pv(o,OP_DESC(o), 0);
9850 Perl_ck_join(pTHX_ OP *o)
9852 const OP * const kid = cLISTOPo->op_first->op_sibling;
9854 PERL_ARGS_ASSERT_CK_JOIN;
9856 if (kid && kid->op_type == OP_MATCH) {
9857 if (ckWARN(WARN_SYNTAX)) {
9858 const REGEXP *re = PM_GETRE(kPMOP);
9860 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9861 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9862 : newSVpvs_flags( "STRING", SVs_TEMP );
9863 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9864 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9865 SVfARG(msg), SVfARG(msg));
9872 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9874 Examines an op, which is expected to identify a subroutine at runtime,
9875 and attempts to determine at compile time which subroutine it identifies.
9876 This is normally used during Perl compilation to determine whether
9877 a prototype can be applied to a function call. I<cvop> is the op
9878 being considered, normally an C<rv2cv> op. A pointer to the identified
9879 subroutine is returned, if it could be determined statically, and a null
9880 pointer is returned if it was not possible to determine statically.
9882 Currently, the subroutine can be identified statically if the RV that the
9883 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9884 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9885 suitable if the constant value must be an RV pointing to a CV. Details of
9886 this process may change in future versions of Perl. If the C<rv2cv> op
9887 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9888 the subroutine statically: this flag is used to suppress compile-time
9889 magic on a subroutine call, forcing it to use default runtime behaviour.
9891 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9892 of a GV reference is modified. If a GV was examined and its CV slot was
9893 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9894 If the op is not optimised away, and the CV slot is later populated with
9895 a subroutine having a prototype, that flag eventually triggers the warning
9896 "called too early to check prototype".
9898 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9899 of returning a pointer to the subroutine it returns a pointer to the
9900 GV giving the most appropriate name for the subroutine in this context.
9901 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9902 (C<CvANON>) subroutine that is referenced through a GV it will be the
9903 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9904 A null pointer is returned as usual if there is no statically-determinable
9910 /* shared by toke.c:yylex */
9912 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
9914 PADNAME *name = PAD_COMPNAME(off);
9915 CV *compcv = PL_compcv;
9916 while (PadnameOUTER(name)) {
9917 assert(PARENT_PAD_INDEX(name));
9918 compcv = CvOUTSIDE(PL_compcv);
9919 name = PadlistNAMESARRAY(CvPADLIST(compcv))
9920 [off = PARENT_PAD_INDEX(name)];
9922 assert(!PadnameIsOUR(name));
9923 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
9924 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
9927 return (CV *)mg->mg_obj;
9929 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
9933 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9938 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9939 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9940 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9941 if (cvop->op_type != OP_RV2CV)
9943 if (cvop->op_private & OPpENTERSUB_AMPER)
9945 if (!(cvop->op_flags & OPf_KIDS))
9947 rvop = cUNOPx(cvop)->op_first;
9948 switch (rvop->op_type) {
9950 gv = cGVOPx_gv(rvop);
9953 if (flags & RV2CVOPCV_MARK_EARLY)
9954 rvop->op_private |= OPpEARLY_CV;
9959 SV *rv = cSVOPx_sv(rvop);
9966 cv = find_lexical_cv(rvop->op_targ);
9973 if (SvTYPE((SV*)cv) != SVt_PVCV)
9975 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9976 if (!CvANON(cv) || !gv)
9985 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9987 Performs the default fixup of the arguments part of an C<entersub>
9988 op tree. This consists of applying list context to each of the
9989 argument ops. This is the standard treatment used on a call marked
9990 with C<&>, or a method call, or a call through a subroutine reference,
9991 or any other call where the callee can't be identified at compile time,
9992 or a call where the callee has no prototype.
9998 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10001 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10002 aop = cUNOPx(entersubop)->op_first;
10003 if (!aop->op_sibling)
10004 aop = cUNOPx(aop)->op_first;
10005 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
10006 if (!(PL_madskills && aop->op_type == OP_STUB)) {
10008 op_lvalue(aop, OP_ENTERSUB);
10015 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10017 Performs the fixup of the arguments part of an C<entersub> op tree
10018 based on a subroutine prototype. This makes various modifications to
10019 the argument ops, from applying context up to inserting C<refgen> ops,
10020 and checking the number and syntactic types of arguments, as directed by
10021 the prototype. This is the standard treatment used on a subroutine call,
10022 not marked with C<&>, where the callee can be identified at compile time
10023 and has a prototype.
10025 I<protosv> supplies the subroutine prototype to be applied to the call.
10026 It may be a normal defined scalar, of which the string value will be used.
10027 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10028 that has been cast to C<SV*>) which has a prototype. The prototype
10029 supplied, in whichever form, does not need to match the actual callee
10030 referenced by the op tree.
10032 If the argument ops disagree with the prototype, for example by having
10033 an unacceptable number of arguments, a valid op tree is returned anyway.
10034 The error is reflected in the parser state, normally resulting in a single
10035 exception at the top level of parsing which covers all the compilation
10036 errors that occurred. In the error message, the callee is referred to
10037 by the name defined by the I<namegv> parameter.
10043 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10046 const char *proto, *proto_end;
10047 OP *aop, *prev, *cvop;
10050 I32 contextclass = 0;
10051 const char *e = NULL;
10052 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10053 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10054 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10055 "flags=%lx", (unsigned long) SvFLAGS(protosv));
10056 if (SvTYPE(protosv) == SVt_PVCV)
10057 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10058 else proto = SvPV(protosv, proto_len);
10059 proto_end = proto + proto_len;
10060 aop = cUNOPx(entersubop)->op_first;
10061 if (!aop->op_sibling)
10062 aop = cUNOPx(aop)->op_first;
10064 aop = aop->op_sibling;
10065 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10066 while (aop != cvop) {
10068 if (PL_madskills && aop->op_type == OP_STUB) {
10069 aop = aop->op_sibling;
10072 if (PL_madskills && aop->op_type == OP_NULL)
10073 o3 = ((UNOP*)aop)->op_first;
10077 if (proto >= proto_end)
10078 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10086 /* _ must be at the end */
10087 if (proto[1] && !strchr(";@%", proto[1]))
10102 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10104 arg == 1 ? "block or sub {}" : "sub {}",
10105 gv_ename(namegv), 0, o3);
10108 /* '*' allows any scalar type, including bareword */
10111 if (o3->op_type == OP_RV2GV)
10112 goto wrapref; /* autoconvert GLOB -> GLOBref */
10113 else if (o3->op_type == OP_CONST)
10114 o3->op_private &= ~OPpCONST_STRICT;
10115 else if (o3->op_type == OP_ENTERSUB) {
10116 /* accidental subroutine, revert to bareword */
10117 OP *gvop = ((UNOP*)o3)->op_first;
10118 if (gvop && gvop->op_type == OP_NULL) {
10119 gvop = ((UNOP*)gvop)->op_first;
10121 for (; gvop->op_sibling; gvop = gvop->op_sibling)
10124 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10125 (gvop = ((UNOP*)gvop)->op_first) &&
10126 gvop->op_type == OP_GV)
10128 GV * const gv = cGVOPx_gv(gvop);
10129 OP * const sibling = aop->op_sibling;
10130 SV * const n = newSVpvs("");
10132 OP * const oldaop = aop;
10136 gv_fullname4(n, gv, "", FALSE);
10137 aop = newSVOP(OP_CONST, 0, n);
10138 op_getmad(oldaop,aop,'O');
10139 prev->op_sibling = aop;
10140 aop->op_sibling = sibling;
10150 if (o3->op_type == OP_RV2AV ||
10151 o3->op_type == OP_PADAV ||
10152 o3->op_type == OP_RV2HV ||
10153 o3->op_type == OP_PADHV
10159 case '[': case ']':
10166 switch (*proto++) {
10168 if (contextclass++ == 0) {
10169 e = strchr(proto, ']');
10170 if (!e || e == proto)
10178 if (contextclass) {
10179 const char *p = proto;
10180 const char *const end = proto;
10182 while (*--p != '[')
10183 /* \[$] accepts any scalar lvalue */
10185 && Perl_op_lvalue_flags(aTHX_
10187 OP_READ, /* not entersub */
10190 bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
10191 (int)(end - p), p),
10192 gv_ename(namegv), 0, o3);
10197 if (o3->op_type == OP_RV2GV)
10200 bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
10203 if (o3->op_type == OP_ENTERSUB)
10206 bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
10210 if (o3->op_type == OP_RV2SV ||
10211 o3->op_type == OP_PADSV ||
10212 o3->op_type == OP_HELEM ||
10213 o3->op_type == OP_AELEM)
10215 if (!contextclass) {
10216 /* \$ accepts any scalar lvalue */
10217 if (Perl_op_lvalue_flags(aTHX_
10219 OP_READ, /* not entersub */
10222 bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
10226 if (o3->op_type == OP_RV2AV ||
10227 o3->op_type == OP_PADAV)
10230 bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
10233 if (o3->op_type == OP_RV2HV ||
10234 o3->op_type == OP_PADHV)
10237 bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
10241 OP* const kid = aop;
10242 OP* const sib = kid->op_sibling;
10243 kid->op_sibling = 0;
10244 aop = newUNOP(OP_REFGEN, 0, kid);
10245 aop->op_sibling = sib;
10246 prev->op_sibling = aop;
10248 if (contextclass && e) {
10253 default: goto oops;
10263 SV* const tmpsv = sv_newmortal();
10264 gv_efullname3(tmpsv, namegv, NULL);
10265 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10266 SVfARG(tmpsv), SVfARG(protosv));
10270 op_lvalue(aop, OP_ENTERSUB);
10272 aop = aop->op_sibling;
10274 if (aop == cvop && *proto == '_') {
10275 /* generate an access to $_ */
10276 aop = newDEFSVOP();
10277 aop->op_sibling = prev->op_sibling;
10278 prev->op_sibling = aop; /* instead of cvop */
10280 if (!optional && proto_end > proto &&
10281 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10282 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10287 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10289 Performs the fixup of the arguments part of an C<entersub> op tree either
10290 based on a subroutine prototype or using default list-context processing.
10291 This is the standard treatment used on a subroutine call, not marked
10292 with C<&>, where the callee can be identified at compile time.
10294 I<protosv> supplies the subroutine prototype to be applied to the call,
10295 or indicates that there is no prototype. It may be a normal scalar,
10296 in which case if it is defined then the string value will be used
10297 as a prototype, and if it is undefined then there is no prototype.
10298 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10299 that has been cast to C<SV*>), of which the prototype will be used if it
10300 has one. The prototype (or lack thereof) supplied, in whichever form,
10301 does not need to match the actual callee referenced by the op tree.
10303 If the argument ops disagree with the prototype, for example by having
10304 an unacceptable number of arguments, a valid op tree is returned anyway.
10305 The error is reflected in the parser state, normally resulting in a single
10306 exception at the top level of parsing which covers all the compilation
10307 errors that occurred. In the error message, the callee is referred to
10308 by the name defined by the I<namegv> parameter.
10314 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10315 GV *namegv, SV *protosv)
10317 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10318 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10319 return ck_entersub_args_proto(entersubop, namegv, protosv);
10321 return ck_entersub_args_list(entersubop);
10325 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10327 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10328 OP *aop = cUNOPx(entersubop)->op_first;
10330 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10334 if (!aop->op_sibling)
10335 aop = cUNOPx(aop)->op_first;
10336 aop = aop->op_sibling;
10337 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10338 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10339 aop = aop->op_sibling;
10342 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10344 op_free(entersubop);
10345 switch(GvNAME(namegv)[2]) {
10346 case 'F': return newSVOP(OP_CONST, 0,
10347 newSVpv(CopFILE(PL_curcop),0));
10348 case 'L': return newSVOP(
10350 Perl_newSVpvf(aTHX_
10351 "%"IVdf, (IV)CopLINE(PL_curcop)
10354 case 'P': return newSVOP(OP_CONST, 0,
10356 ? newSVhek(HvNAME_HEK(PL_curstash))
10367 bool seenarg = FALSE;
10369 if (!aop->op_sibling)
10370 aop = cUNOPx(aop)->op_first;
10373 aop = aop->op_sibling;
10374 prev->op_sibling = NULL;
10377 prev=cvop, cvop = cvop->op_sibling)
10379 if (PL_madskills && cvop->op_sibling
10380 && cvop->op_type != OP_STUB) seenarg = TRUE
10383 prev->op_sibling = NULL;
10384 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10386 if (aop == cvop) aop = NULL;
10387 op_free(entersubop);
10389 if (opnum == OP_ENTEREVAL
10390 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10391 flags |= OPpEVAL_BYTES <<8;
10393 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10395 case OA_BASEOP_OR_UNOP:
10396 case OA_FILESTATOP:
10397 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10401 if (!PL_madskills || seenarg)
10403 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10406 return opnum == OP_RUNCV
10407 ? newPVOP(OP_RUNCV,0,NULL)
10410 return convert(opnum,0,aop);
10418 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10420 Retrieves the function that will be used to fix up a call to I<cv>.
10421 Specifically, the function is applied to an C<entersub> op tree for a
10422 subroutine call, not marked with C<&>, where the callee can be identified
10423 at compile time as I<cv>.
10425 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10426 argument for it is returned in I<*ckobj_p>. The function is intended
10427 to be called in this manner:
10429 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10431 In this call, I<entersubop> is a pointer to the C<entersub> op,
10432 which may be replaced by the check function, and I<namegv> is a GV
10433 supplying the name that should be used by the check function to refer
10434 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10435 It is permitted to apply the check function in non-standard situations,
10436 such as to a call to a different subroutine or to a method call.
10438 By default, the function is
10439 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10440 and the SV parameter is I<cv> itself. This implements standard
10441 prototype processing. It can be changed, for a particular subroutine,
10442 by L</cv_set_call_checker>.
10448 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10451 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10452 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10454 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10455 *ckobj_p = callmg->mg_obj;
10457 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10458 *ckobj_p = (SV*)cv;
10463 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10465 Sets the function that will be used to fix up a call to I<cv>.
10466 Specifically, the function is applied to an C<entersub> op tree for a
10467 subroutine call, not marked with C<&>, where the callee can be identified
10468 at compile time as I<cv>.
10470 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10471 for it is supplied in I<ckobj>. The function is intended to be called
10474 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10476 In this call, I<entersubop> is a pointer to the C<entersub> op,
10477 which may be replaced by the check function, and I<namegv> is a GV
10478 supplying the name that should be used by the check function to refer
10479 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10480 It is permitted to apply the check function in non-standard situations,
10481 such as to a call to a different subroutine or to a method call.
10483 The current setting for a particular CV can be retrieved by
10484 L</cv_get_call_checker>.
10490 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10492 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10493 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10494 if (SvMAGICAL((SV*)cv))
10495 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10498 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10499 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10500 if (callmg->mg_flags & MGf_REFCOUNTED) {
10501 SvREFCNT_dec(callmg->mg_obj);
10502 callmg->mg_flags &= ~MGf_REFCOUNTED;
10504 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10505 callmg->mg_obj = ckobj;
10506 if (ckobj != (SV*)cv) {
10507 SvREFCNT_inc_simple_void_NN(ckobj);
10508 callmg->mg_flags |= MGf_REFCOUNTED;
10510 callmg->mg_flags |= MGf_COPY;
10515 Perl_ck_subr(pTHX_ OP *o)
10521 PERL_ARGS_ASSERT_CK_SUBR;
10523 aop = cUNOPx(o)->op_first;
10524 if (!aop->op_sibling)
10525 aop = cUNOPx(aop)->op_first;
10526 aop = aop->op_sibling;
10527 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10528 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10529 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10531 o->op_private &= ~1;
10532 o->op_private |= OPpENTERSUB_HASTARG;
10533 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10534 if (PERLDB_SUB && PL_curstash != PL_debstash)
10535 o->op_private |= OPpENTERSUB_DB;
10536 if (cvop->op_type == OP_RV2CV) {
10537 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10539 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10540 if (aop->op_type == OP_CONST)
10541 aop->op_private &= ~OPpCONST_STRICT;
10542 else if (aop->op_type == OP_LIST) {
10543 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10544 if (sib && sib->op_type == OP_CONST)
10545 sib->op_private &= ~OPpCONST_STRICT;
10550 return ck_entersub_args_list(o);
10552 Perl_call_checker ckfun;
10554 cv_get_call_checker(cv, &ckfun, &ckobj);
10555 if (!namegv) { /* expletive! */
10556 /* XXX The call checker API is public. And it guarantees that
10557 a GV will be provided with the right name. So we have
10558 to create a GV. But it is still not correct, as its
10559 stringification will include the package. What we
10560 really need is a new call checker API that accepts a
10561 GV or string (or GV or CV). */
10562 HEK * const hek = CvNAME_HEK(cv);
10563 /* After a syntax error in a lexical sub, the cv that
10564 rv2cv_op_cv returns may be a nameless stub. */
10565 if (!hek) return ck_entersub_args_list(o);;
10566 namegv = (GV *)sv_newmortal();
10567 gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10568 SVf_UTF8 * !!HEK_UTF8(hek));
10570 return ckfun(aTHX_ o, namegv, ckobj);
10575 Perl_ck_svconst(pTHX_ OP *o)
10577 PERL_ARGS_ASSERT_CK_SVCONST;
10578 PERL_UNUSED_CONTEXT;
10579 if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
10584 Perl_ck_trunc(pTHX_ OP *o)
10586 PERL_ARGS_ASSERT_CK_TRUNC;
10588 if (o->op_flags & OPf_KIDS) {
10589 SVOP *kid = (SVOP*)cUNOPo->op_first;
10591 if (kid->op_type == OP_NULL)
10592 kid = (SVOP*)kid->op_sibling;
10593 if (kid && kid->op_type == OP_CONST &&
10594 (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
10597 o->op_flags |= OPf_SPECIAL;
10598 kid->op_private &= ~OPpCONST_STRICT;
10605 Perl_ck_substr(pTHX_ OP *o)
10607 PERL_ARGS_ASSERT_CK_SUBSTR;
10610 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10611 OP *kid = cLISTOPo->op_first;
10613 if (kid->op_type == OP_NULL)
10614 kid = kid->op_sibling;
10616 kid->op_flags |= OPf_MOD;
10623 Perl_ck_tell(pTHX_ OP *o)
10625 PERL_ARGS_ASSERT_CK_TELL;
10627 if (o->op_flags & OPf_KIDS) {
10628 OP *kid = cLISTOPo->op_first;
10629 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10630 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10636 Perl_ck_each(pTHX_ OP *o)
10639 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10640 const unsigned orig_type = o->op_type;
10641 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10642 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10643 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10644 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10646 PERL_ARGS_ASSERT_CK_EACH;
10649 switch (kid->op_type) {
10655 CHANGE_TYPE(o, array_type);
10658 if (kid->op_private == OPpCONST_BARE
10659 || !SvROK(cSVOPx_sv(kid))
10660 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10661 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10663 /* we let ck_fun handle it */
10666 CHANGE_TYPE(o, ref_type);
10670 /* if treating as a reference, defer additional checks to runtime */
10671 return o->op_type == ref_type ? o : ck_fun(o);
10675 Perl_ck_length(pTHX_ OP *o)
10677 PERL_ARGS_ASSERT_CK_LENGTH;
10681 if (ckWARN(WARN_SYNTAX)) {
10682 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10686 const bool hash = kid->op_type == OP_PADHV
10687 || kid->op_type == OP_RV2HV;
10688 switch (kid->op_type) {
10692 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10698 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10700 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10702 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10709 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10710 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10712 name, hash ? "keys " : "", name
10715 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10716 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10718 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10719 "length() used on @array (did you mean \"scalar(@array)\"?)");
10726 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10727 and modify the optree to make them work inplace */
10730 S_inplace_aassign(pTHX_ OP *o) {
10732 OP *modop, *modop_pushmark;
10734 OP *oleft, *oleft_pushmark;
10736 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10738 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10740 assert(cUNOPo->op_first->op_type == OP_NULL);
10741 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10742 assert(modop_pushmark->op_type == OP_PUSHMARK);
10743 modop = modop_pushmark->op_sibling;
10745 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10748 /* no other operation except sort/reverse */
10749 if (modop->op_sibling)
10752 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10753 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10755 if (modop->op_flags & OPf_STACKED) {
10756 /* skip sort subroutine/block */
10757 assert(oright->op_type == OP_NULL);
10758 oright = oright->op_sibling;
10761 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10762 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10763 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10764 oleft = oleft_pushmark->op_sibling;
10766 /* Check the lhs is an array */
10768 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10769 || oleft->op_sibling
10770 || (oleft->op_private & OPpLVAL_INTRO)
10774 /* Only one thing on the rhs */
10775 if (oright->op_sibling)
10778 /* check the array is the same on both sides */
10779 if (oleft->op_type == OP_RV2AV) {
10780 if (oright->op_type != OP_RV2AV
10781 || !cUNOPx(oright)->op_first
10782 || cUNOPx(oright)->op_first->op_type != OP_GV
10783 || cUNOPx(oleft )->op_first->op_type != OP_GV
10784 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10785 cGVOPx_gv(cUNOPx(oright)->op_first)
10789 else if (oright->op_type != OP_PADAV
10790 || oright->op_targ != oleft->op_targ
10794 /* This actually is an inplace assignment */
10796 modop->op_private |= OPpSORT_INPLACE;
10798 /* transfer MODishness etc from LHS arg to RHS arg */
10799 oright->op_flags = oleft->op_flags;
10801 /* remove the aassign op and the lhs */
10803 op_null(oleft_pushmark);
10804 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10805 op_null(cUNOPx(oleft)->op_first);
10809 #define MAX_DEFERRED 4
10813 if (defer_ix == (MAX_DEFERRED-1)) { \
10814 CALL_RPEEP(defer_queue[defer_base]); \
10815 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10818 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \
10821 /* A peephole optimizer. We visit the ops in the order they're to execute.
10822 * See the comments at the top of this file for more details about when
10823 * peep() is called */
10826 Perl_rpeep(pTHX_ OP *o)
10830 OP* oldoldop = NULL;
10831 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10832 int defer_base = 0;
10835 if (!o || o->op_opt)
10839 SAVEVPTR(PL_curcop);
10840 for (;; o = o->op_next) {
10841 if (o && o->op_opt)
10844 while (defer_ix >= 0)
10845 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
10849 /* By default, this op has now been optimised. A couple of cases below
10850 clear this again. */
10853 switch (o->op_type) {
10855 PL_curcop = ((COP*)o); /* for warnings */
10858 PL_curcop = ((COP*)o); /* for warnings */
10860 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10861 to carry two labels. For now, take the easier option, and skip
10862 this optimisation if the first NEXTSTATE has a label. */
10863 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10864 OP *nextop = o->op_next;
10865 while (nextop && nextop->op_type == OP_NULL)
10866 nextop = nextop->op_next;
10868 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10869 COP *firstcop = (COP *)o;
10870 COP *secondcop = (COP *)nextop;
10871 /* We want the COP pointed to by o (and anything else) to
10872 become the next COP down the line. */
10873 cop_free(firstcop);
10875 firstcop->op_next = secondcop->op_next;
10877 /* Now steal all its pointers, and duplicate the other
10879 firstcop->cop_line = secondcop->cop_line;
10880 #ifdef USE_ITHREADS
10881 firstcop->cop_stashoff = secondcop->cop_stashoff;
10882 firstcop->cop_file = secondcop->cop_file;
10884 firstcop->cop_stash = secondcop->cop_stash;
10885 firstcop->cop_filegv = secondcop->cop_filegv;
10887 firstcop->cop_hints = secondcop->cop_hints;
10888 firstcop->cop_seq = secondcop->cop_seq;
10889 firstcop->cop_warnings = secondcop->cop_warnings;
10890 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10892 #ifdef USE_ITHREADS
10893 secondcop->cop_stashoff = 0;
10894 secondcop->cop_file = NULL;
10896 secondcop->cop_stash = NULL;
10897 secondcop->cop_filegv = NULL;
10899 secondcop->cop_warnings = NULL;
10900 secondcop->cop_hints_hash = NULL;
10902 /* If we use op_null(), and hence leave an ex-COP, some
10903 warnings are misreported. For example, the compile-time
10904 error in 'use strict; no strict refs;' */
10905 secondcop->op_type = OP_NULL;
10906 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10912 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10913 if (o->op_next->op_private & OPpTARGET_MY) {
10914 if (o->op_flags & OPf_STACKED) /* chained concats */
10915 break; /* ignore_optimization */
10917 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10918 o->op_targ = o->op_next->op_targ;
10919 o->op_next->op_targ = 0;
10920 o->op_private |= OPpTARGET_MY;
10923 op_null(o->op_next);
10927 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10928 break; /* Scalar stub must produce undef. List stub is noop */
10932 if (o->op_targ == OP_NEXTSTATE
10933 || o->op_targ == OP_DBSTATE)
10935 PL_curcop = ((COP*)o);
10937 /* XXX: We avoid setting op_seq here to prevent later calls
10938 to rpeep() from mistakenly concluding that optimisation
10939 has already occurred. This doesn't fix the real problem,
10940 though (See 20010220.007). AMS 20010719 */
10941 /* op_seq functionality is now replaced by op_opt */
10948 if (oldop && o->op_next) {
10949 oldop->op_next = o->op_next;
10957 /* Convert a series of PAD ops for my vars plus support into a
10958 * single padrange op. Basically
10960 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
10962 * becomes, depending on circumstances, one of
10964 * padrange ----------------------------------> (list) -> rest
10965 * padrange --------------------------------------------> rest
10967 * where all the pad indexes are sequential and of the same type
10969 * We convert the pushmark into a padrange op, then skip
10970 * any other pad ops, and possibly some trailing ops.
10971 * Note that we don't null() the skipped ops, to make it
10972 * easier for Deparse to undo this optimisation (and none of
10973 * the skipped ops are holding any resourses). It also makes
10974 * it easier for find_uninit_var(), as it can just ignore
10975 * padrange, and examine the original pad ops.
10979 OP *followop = NULL; /* the op that will follow the padrange op */
10982 PADOFFSET base = 0; /* init only to stop compiler whining */
10983 U8 gimme = 0; /* init only to stop compiler whining */
10984 bool defav = 0; /* seen (...) = @_ */
10985 bool reuse = 0; /* reuse an existing padrange op */
10987 /* look for a pushmark -> gv[_] -> rv2av */
10993 if ( p->op_type == OP_GV
10994 && (gv = cGVOPx_gv(p))
10995 && GvNAMELEN_get(gv) == 1
10996 && *GvNAME_get(gv) == '_'
10997 && GvSTASH(gv) == PL_defstash
10998 && (rv2av = p->op_next)
10999 && rv2av->op_type == OP_RV2AV
11000 && !(rv2av->op_flags & OPf_REF)
11001 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11002 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11003 && o->op_sibling == rv2av /* these two for Deparse */
11004 && cUNOPx(rv2av)->op_first == p
11006 q = rv2av->op_next;
11007 if (q->op_type == OP_NULL)
11009 if (q->op_type == OP_PUSHMARK) {
11016 /* To allow Deparse to pessimise this, it needs to be able
11017 * to restore the pushmark's original op_next, which it
11018 * will assume to be the same as op_sibling. */
11019 if (o->op_next != o->op_sibling)
11024 /* scan for PAD ops */
11026 for (p = p->op_next; p; p = p->op_next) {
11027 if (p->op_type == OP_NULL)
11030 if (( p->op_type != OP_PADSV
11031 && p->op_type != OP_PADAV
11032 && p->op_type != OP_PADHV
11034 /* any private flag other than INTRO? e.g. STATE */
11035 || (p->op_private & ~OPpLVAL_INTRO)
11039 /* let $a[N] potentially be optimised into ALEMFAST_LEX
11041 if ( p->op_type == OP_PADAV
11043 && p->op_next->op_type == OP_CONST
11044 && p->op_next->op_next
11045 && p->op_next->op_next->op_type == OP_AELEM
11049 /* for 1st padop, note what type it is and the range
11050 * start; for the others, check that it's the same type
11051 * and that the targs are contiguous */
11053 intro = (p->op_private & OPpLVAL_INTRO);
11055 gimme = (p->op_flags & OPf_WANT);
11058 if ((p->op_private & OPpLVAL_INTRO) != intro)
11060 /* Note that you'd normally expect targs to be
11061 * contiguous in my($a,$b,$c), but that's not the case
11062 * when external modules start doing things, e.g.
11063 i* Function::Parameters */
11064 if (p->op_targ != base + count)
11066 assert(p->op_targ == base + count);
11067 /* all the padops should be in the same context */
11068 if (gimme != (p->op_flags & OPf_WANT))
11072 /* for AV, HV, only when we're not flattening */
11073 if ( p->op_type != OP_PADSV
11074 && gimme != OPf_WANT_VOID
11075 && !(p->op_flags & OPf_REF)
11079 if (count >= OPpPADRANGE_COUNTMASK)
11082 /* there's a biggest base we can fit into a
11083 * SAVEt_CLEARPADRANGE in pp_padrange */
11084 if (intro && base >
11085 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11088 /* Success! We've got another valid pad op to optimise away */
11090 followop = p->op_next;
11096 /* pp_padrange in specifically compile-time void context
11097 * skips pushing a mark and lexicals; in all other contexts
11098 * (including unknown till runtime) it pushes a mark and the
11099 * lexicals. We must be very careful then, that the ops we
11100 * optimise away would have exactly the same effect as the
11102 * In particular in void context, we can only optimise to
11103 * a padrange if see see the complete sequence
11104 * pushmark, pad*v, ...., list, nextstate
11105 * which has the net effect of of leaving the stack empty
11106 * (for now we leave the nextstate in the execution chain, for
11107 * its other side-effects).
11110 if (gimme == OPf_WANT_VOID) {
11111 if (followop->op_type == OP_LIST
11112 && gimme == (followop->op_flags & OPf_WANT)
11113 && ( followop->op_next->op_type == OP_NEXTSTATE
11114 || followop->op_next->op_type == OP_DBSTATE))
11116 followop = followop->op_next; /* skip OP_LIST */
11118 /* consolidate two successive my(...);'s */
11121 && oldoldop->op_type == OP_PADRANGE
11122 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11123 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11124 && !(oldoldop->op_flags & OPf_SPECIAL)
11127 assert(oldoldop->op_next == oldop);
11128 assert( oldop->op_type == OP_NEXTSTATE
11129 || oldop->op_type == OP_DBSTATE);
11130 assert(oldop->op_next == o);
11133 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11134 assert(oldoldop->op_targ + old_count == base);
11136 if (old_count < OPpPADRANGE_COUNTMASK - count) {
11137 base = oldoldop->op_targ;
11138 count += old_count;
11143 /* if there's any immediately following singleton
11144 * my var's; then swallow them and the associated
11146 * my ($a,$b); my $c; my $d;
11148 * my ($a,$b,$c,$d);
11151 while ( ((p = followop->op_next))
11152 && ( p->op_type == OP_PADSV
11153 || p->op_type == OP_PADAV
11154 || p->op_type == OP_PADHV)
11155 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11156 && (p->op_private & OPpLVAL_INTRO) == intro
11158 && ( p->op_next->op_type == OP_NEXTSTATE
11159 || p->op_next->op_type == OP_DBSTATE)
11160 && count < OPpPADRANGE_COUNTMASK
11162 assert(base + count == p->op_targ);
11164 followop = p->op_next;
11172 assert(oldoldop->op_type == OP_PADRANGE);
11173 oldoldop->op_next = followop;
11174 oldoldop->op_private = (intro | count);
11180 /* Convert the pushmark into a padrange.
11181 * To make Deparse easier, we guarantee that a padrange was
11182 * *always* formerly a pushmark */
11183 assert(o->op_type == OP_PUSHMARK);
11184 o->op_next = followop;
11185 o->op_type = OP_PADRANGE;
11186 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11188 /* bit 7: INTRO; bit 6..0: count */
11189 o->op_private = (intro | count);
11190 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11191 | gimme | (defav ? OPf_SPECIAL : 0));
11198 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11199 OP* const pop = (o->op_type == OP_PADAV) ?
11200 o->op_next : o->op_next->op_next;
11202 if (pop && pop->op_type == OP_CONST &&
11203 ((PL_op = pop->op_next)) &&
11204 pop->op_next->op_type == OP_AELEM &&
11205 !(pop->op_next->op_private &
11206 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11207 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
11210 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11211 no_bareword_allowed(pop);
11212 if (o->op_type == OP_GV)
11213 op_null(o->op_next);
11214 op_null(pop->op_next);
11216 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11217 o->op_next = pop->op_next->op_next;
11218 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11219 o->op_private = (U8)i;
11220 if (o->op_type == OP_GV) {
11223 o->op_type = OP_AELEMFAST;
11226 o->op_type = OP_AELEMFAST_LEX;
11231 if (o->op_next->op_type == OP_RV2SV) {
11232 if (!(o->op_next->op_private & OPpDEREF)) {
11233 op_null(o->op_next);
11234 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11236 o->op_next = o->op_next->op_next;
11237 o->op_type = OP_GVSV;
11238 o->op_ppaddr = PL_ppaddr[OP_GVSV];
11241 else if (o->op_next->op_type == OP_READLINE
11242 && o->op_next->op_next->op_type == OP_CONCAT
11243 && (o->op_next->op_next->op_flags & OPf_STACKED))
11245 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11246 o->op_type = OP_RCATLINE;
11247 o->op_flags |= OPf_STACKED;
11248 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11249 op_null(o->op_next->op_next);
11250 op_null(o->op_next);
11259 #define HV_OR_SCALARHV(op) \
11260 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11262 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11263 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11264 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11265 ? cUNOPx(op)->op_first \
11269 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11270 fop->op_private |= OPpTRUEBOOL;
11276 fop = cLOGOP->op_first;
11277 sop = fop->op_sibling;
11278 while (cLOGOP->op_other->op_type == OP_NULL)
11279 cLOGOP->op_other = cLOGOP->op_other->op_next;
11280 while (o->op_next && ( o->op_type == o->op_next->op_type
11281 || o->op_next->op_type == OP_NULL))
11282 o->op_next = o->op_next->op_next;
11283 DEFER(cLOGOP->op_other);
11286 fop = HV_OR_SCALARHV(fop);
11287 if (sop) sop = HV_OR_SCALARHV(sop);
11292 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11293 while (nop && nop->op_next) {
11294 switch (nop->op_next->op_type) {
11299 lop = nop = nop->op_next;
11302 nop = nop->op_next;
11311 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11312 || o->op_type == OP_AND )
11313 fop->op_private |= OPpTRUEBOOL;
11314 else if (!(lop->op_flags & OPf_WANT))
11315 fop->op_private |= OPpMAYBE_TRUEBOOL;
11317 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11319 sop->op_private |= OPpTRUEBOOL;
11326 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11327 fop->op_private |= OPpTRUEBOOL;
11328 #undef HV_OR_SCALARHV
11339 while (cLOGOP->op_other->op_type == OP_NULL)
11340 cLOGOP->op_other = cLOGOP->op_other->op_next;
11341 DEFER(cLOGOP->op_other);
11346 while (cLOOP->op_redoop->op_type == OP_NULL)
11347 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11348 while (cLOOP->op_nextop->op_type == OP_NULL)
11349 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11350 while (cLOOP->op_lastop->op_type == OP_NULL)
11351 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11352 /* a while(1) loop doesn't have an op_next that escapes the
11353 * loop, so we have to explicitly follow the op_lastop to
11354 * process the rest of the code */
11355 DEFER(cLOOP->op_lastop);
11359 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11360 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11361 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11362 cPMOP->op_pmstashstartu.op_pmreplstart
11363 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11364 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11370 if (o->op_flags & OPf_STACKED) {
11372 cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
11373 if (kid->op_type == OP_SCOPE
11374 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
11375 DEFER(kLISTOP->op_first);
11378 /* check that RHS of sort is a single plain array */
11379 oright = cUNOPo->op_first;
11380 if (!oright || oright->op_type != OP_PUSHMARK)
11383 if (o->op_private & OPpSORT_INPLACE)
11386 /* reverse sort ... can be optimised. */
11387 if (!cUNOPo->op_sibling) {
11388 /* Nothing follows us on the list. */
11389 OP * const reverse = o->op_next;
11391 if (reverse->op_type == OP_REVERSE &&
11392 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11393 OP * const pushmark = cUNOPx(reverse)->op_first;
11394 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11395 && (cUNOPx(pushmark)->op_sibling == o)) {
11396 /* reverse -> pushmark -> sort */
11397 o->op_private |= OPpSORT_REVERSE;
11399 pushmark->op_next = oright->op_next;
11409 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11411 LISTOP *enter, *exlist;
11413 if (o->op_private & OPpSORT_INPLACE)
11416 enter = (LISTOP *) o->op_next;
11419 if (enter->op_type == OP_NULL) {
11420 enter = (LISTOP *) enter->op_next;
11424 /* for $a (...) will have OP_GV then OP_RV2GV here.
11425 for (...) just has an OP_GV. */
11426 if (enter->op_type == OP_GV) {
11427 gvop = (OP *) enter;
11428 enter = (LISTOP *) enter->op_next;
11431 if (enter->op_type == OP_RV2GV) {
11432 enter = (LISTOP *) enter->op_next;
11438 if (enter->op_type != OP_ENTERITER)
11441 iter = enter->op_next;
11442 if (!iter || iter->op_type != OP_ITER)
11445 expushmark = enter->op_first;
11446 if (!expushmark || expushmark->op_type != OP_NULL
11447 || expushmark->op_targ != OP_PUSHMARK)
11450 exlist = (LISTOP *) expushmark->op_sibling;
11451 if (!exlist || exlist->op_type != OP_NULL
11452 || exlist->op_targ != OP_LIST)
11455 if (exlist->op_last != o) {
11456 /* Mmm. Was expecting to point back to this op. */
11459 theirmark = exlist->op_first;
11460 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
11463 if (theirmark->op_sibling != o) {
11464 /* There's something between the mark and the reverse, eg
11465 for (1, reverse (...))
11470 ourmark = ((LISTOP *)o)->op_first;
11471 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
11474 ourlast = ((LISTOP *)o)->op_last;
11475 if (!ourlast || ourlast->op_next != o)
11478 rv2av = ourmark->op_sibling;
11479 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
11480 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
11481 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
11482 /* We're just reversing a single array. */
11483 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
11484 enter->op_flags |= OPf_STACKED;
11487 /* We don't have control over who points to theirmark, so sacrifice
11489 theirmark->op_next = ourmark->op_next;
11490 theirmark->op_flags = ourmark->op_flags;
11491 ourlast->op_next = gvop ? gvop : (OP *) enter;
11494 enter->op_private |= OPpITER_REVERSED;
11495 iter->op_private |= OPpITER_REVERSED;
11502 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
11503 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
11508 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
11510 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
11512 sv = newRV((SV *)PL_compcv);
11516 o->op_type = OP_CONST;
11517 o->op_ppaddr = PL_ppaddr[OP_CONST];
11518 o->op_flags |= OPf_SPECIAL;
11519 cSVOPo->op_sv = sv;
11524 if (OP_GIMME(o,0) == G_VOID) {
11525 OP *right = cBINOP->op_first;
11527 OP *left = right->op_sibling;
11528 if (left->op_type == OP_SUBSTR
11529 && (left->op_private & 7) < 4) {
11531 cBINOP->op_first = left;
11532 right->op_sibling =
11533 cBINOPx(left)->op_first->op_sibling;
11534 cBINOPx(left)->op_first->op_sibling = right;
11535 left->op_private |= OPpSUBSTR_REPL_FIRST;
11537 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11544 Perl_cpeep_t cpeep =
11545 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
11547 cpeep(aTHX_ o, oldop);
11559 Perl_peep(pTHX_ OP *o)
11565 =head1 Custom Operators
11567 =for apidoc Ao||custom_op_xop
11568 Return the XOP structure for a given custom op. This function should be
11569 considered internal to OP_NAME and the other access macros: use them instead.
11575 Perl_custom_op_xop(pTHX_ const OP *o)
11581 static const XOP xop_null = { 0, 0, 0, 0, 0 };
11583 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
11584 assert(o->op_type == OP_CUSTOM);
11586 /* This is wrong. It assumes a function pointer can be cast to IV,
11587 * which isn't guaranteed, but this is what the old custom OP code
11588 * did. In principle it should be safer to Copy the bytes of the
11589 * pointer into a PV: since the new interface is hidden behind
11590 * functions, this can be changed later if necessary. */
11591 /* Change custom_op_xop if this ever happens */
11592 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
11595 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
11597 /* assume noone will have just registered a desc */
11598 if (!he && PL_custom_op_names &&
11599 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
11604 /* XXX does all this need to be shared mem? */
11605 Newxz(xop, 1, XOP);
11606 pv = SvPV(HeVAL(he), l);
11607 XopENTRY_set(xop, xop_name, savepvn(pv, l));
11608 if (PL_custom_op_descs &&
11609 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
11611 pv = SvPV(HeVAL(he), l);
11612 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
11614 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
11618 if (!he) return &xop_null;
11620 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
11625 =for apidoc Ao||custom_op_register
11626 Register a custom op. See L<perlguts/"Custom Operators">.
11632 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
11636 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
11638 /* see the comment in custom_op_xop */
11639 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
11641 if (!PL_custom_ops)
11642 PL_custom_ops = newHV();
11644 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
11645 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
11649 =head1 Functions in file op.c
11651 =for apidoc core_prototype
11652 This function assigns the prototype of the named core function to C<sv>, or
11653 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
11654 NULL if the core function has no prototype. C<code> is a code as returned
11655 by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
11661 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
11664 int i = 0, n = 0, seen_question = 0, defgv = 0;
11666 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
11667 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
11668 bool nullret = FALSE;
11670 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
11672 assert (code && code != -KEY_CORE);
11674 if (!sv) sv = sv_newmortal();
11676 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
11678 switch (code < 0 ? -code : code) {
11679 case KEY_and : case KEY_chop: case KEY_chomp:
11680 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
11681 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
11682 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
11683 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
11684 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
11685 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
11686 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
11687 case KEY_x : case KEY_xor :
11688 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
11689 case KEY_glob: retsetpvs("_;", OP_GLOB);
11690 case KEY_keys: retsetpvs("+", OP_KEYS);
11691 case KEY_values: retsetpvs("+", OP_VALUES);
11692 case KEY_each: retsetpvs("+", OP_EACH);
11693 case KEY_push: retsetpvs("+@", OP_PUSH);
11694 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11695 case KEY_pop: retsetpvs(";+", OP_POP);
11696 case KEY_shift: retsetpvs(";+", OP_SHIFT);
11697 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
11699 retsetpvs("+;$$@", OP_SPLICE);
11700 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
11702 case KEY_evalbytes:
11703 name = "entereval"; break;
11711 while (i < MAXO) { /* The slow way. */
11712 if (strEQ(name, PL_op_name[i])
11713 || strEQ(name, PL_op_desc[i]))
11715 if (nullret) { assert(opnum); *opnum = i; return NULL; }
11722 defgv = PL_opargs[i] & OA_DEFGV;
11723 oa = PL_opargs[i] >> OASHIFT;
11725 if (oa & OA_OPTIONAL && !seen_question && (
11726 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
11731 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11732 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11733 /* But globs are already references (kinda) */
11734 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11738 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11739 && !scalar_mod_type(NULL, i)) {
11744 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
11748 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
11749 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11750 str[n-1] = '_'; defgv = 0;
11754 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
11756 sv_setpvn(sv, str, n - 1);
11757 if (opnum) *opnum = i;
11762 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11765 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
11768 PERL_ARGS_ASSERT_CORESUB_OP;
11772 return op_append_elem(OP_LINESEQ,
11775 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
11779 case OP_SELECT: /* which represents OP_SSELECT as well */
11784 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11785 newSVOP(OP_CONST, 0, newSVuv(1))
11787 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11789 coresub_op(coreargssv, 0, OP_SELECT)
11793 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11795 return op_append_elem(
11798 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11799 ? OPpOFFBYONE << 8 : 0)
11801 case OA_BASEOP_OR_UNOP:
11802 if (opnum == OP_ENTEREVAL) {
11803 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11804 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11806 else o = newUNOP(opnum,0,argop);
11807 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11810 if (is_handle_constructor(o, 1))
11811 argop->op_private |= OPpCOREARGS_DEREF1;
11812 if (scalar_mod_type(NULL, opnum))
11813 argop->op_private |= OPpCOREARGS_SCALARMOD;
11817 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
11818 if (is_handle_constructor(o, 2))
11819 argop->op_private |= OPpCOREARGS_DEREF2;
11820 if (opnum == OP_SUBSTR) {
11821 o->op_private |= OPpMAYBE_LVSUB;
11830 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11831 SV * const *new_const_svp)
11833 const char *hvname;
11834 bool is_const = !!CvCONST(old_cv);
11835 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11837 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11839 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11841 /* They are 2 constant subroutines generated from
11842 the same constant. This probably means that
11843 they are really the "same" proxy subroutine
11844 instantiated in 2 places. Most likely this is
11845 when a constant is exported twice. Don't warn.
11848 (ckWARN(WARN_REDEFINE)
11850 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11851 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11852 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11853 strEQ(hvname, "autouse"))
11857 && ckWARN_d(WARN_REDEFINE)
11858 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11861 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11863 ? "Constant subroutine %"SVf" redefined"
11864 : "Subroutine %"SVf" redefined",
11869 =head1 Hook manipulation
11871 These functions provide convenient and thread-safe means of manipulating
11878 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11880 Puts a C function into the chain of check functions for a specified op
11881 type. This is the preferred way to manipulate the L</PL_check> array.
11882 I<opcode> specifies which type of op is to be affected. I<new_checker>
11883 is a pointer to the C function that is to be added to that opcode's
11884 check chain, and I<old_checker_p> points to the storage location where a
11885 pointer to the next function in the chain will be stored. The value of
11886 I<new_pointer> is written into the L</PL_check> array, while the value
11887 previously stored there is written to I<*old_checker_p>.
11889 L</PL_check> is global to an entire process, and a module wishing to
11890 hook op checking may find itself invoked more than once per process,
11891 typically in different threads. To handle that situation, this function
11892 is idempotent. The location I<*old_checker_p> must initially (once
11893 per process) contain a null pointer. A C variable of static duration
11894 (declared at file scope, typically also marked C<static> to give
11895 it internal linkage) will be implicitly initialised appropriately,
11896 if it does not have an explicit initialiser. This function will only
11897 actually modify the check chain if it finds I<*old_checker_p> to be null.
11898 This function is also thread safe on the small scale. It uses appropriate
11899 locking to avoid race conditions in accessing L</PL_check>.
11901 When this function is called, the function referenced by I<new_checker>
11902 must be ready to be called, except for I<*old_checker_p> being unfilled.
11903 In a threading situation, I<new_checker> may be called immediately,
11904 even before this function has returned. I<*old_checker_p> will always
11905 be appropriately set before I<new_checker> is called. If I<new_checker>
11906 decides not to do anything special with an op that it is given (which
11907 is the usual case for most uses of op check hooking), it must chain the
11908 check function referenced by I<*old_checker_p>.
11910 If you want to influence compilation of calls to a specific subroutine,
11911 then use L</cv_set_call_checker> rather than hooking checking of all
11918 Perl_wrap_op_checker(pTHX_ Optype opcode,
11919 Perl_check_t new_checker, Perl_check_t *old_checker_p)
11923 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11924 if (*old_checker_p) return;
11925 OP_CHECK_MUTEX_LOCK;
11926 if (!*old_checker_p) {
11927 *old_checker_p = PL_check[opcode];
11928 PL_check[opcode] = new_checker;
11930 OP_CHECK_MUTEX_UNLOCK;
11935 /* Efficient sub that returns a constant scalar value. */
11937 const_sv_xsub(pTHX_ CV* cv)
11941 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
11945 /* diag_listed_as: SKIPME */
11946 Perl_croak(aTHX_ "usage: %s::%s()",
11947 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
11960 * c-indentation-style: bsd
11961 * c-basic-offset: 4
11962 * indent-tabs-mode: nil
11965 * ex: set ts=8 sts=4 sw=4 et: