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 /* Used to avoid recursion through the op tree in scalarvoid() and
116 #define DEFERRED_OP_STEP 100
117 #define DEFER_OP(o) \
119 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
120 defer_stack_alloc += DEFERRED_OP_STEP; \
121 assert(defer_stack_alloc > 0); \
122 Renew(defer_stack, defer_stack_alloc, OP *); \
124 defer_stack[++defer_ix] = o; \
127 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
129 /* remove any leading "empty" ops from the op_next chain whose first
130 * node's address is stored in op_p. Store the updated address of the
131 * first node in op_p.
135 S_prune_chain_head(OP** op_p)
138 && ( (*op_p)->op_type == OP_NULL
139 || (*op_p)->op_type == OP_SCOPE
140 || (*op_p)->op_type == OP_SCALAR
141 || (*op_p)->op_type == OP_LINESEQ)
143 *op_p = (*op_p)->op_next;
147 /* See the explanatory comments above struct opslab in op.h. */
149 #ifdef PERL_DEBUG_READONLY_OPS
150 # define PERL_SLAB_SIZE 128
151 # define PERL_MAX_SLAB_SIZE 4096
152 # include <sys/mman.h>
155 #ifndef PERL_SLAB_SIZE
156 # define PERL_SLAB_SIZE 64
158 #ifndef PERL_MAX_SLAB_SIZE
159 # define PERL_MAX_SLAB_SIZE 2048
162 /* rounds up to nearest pointer */
163 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
164 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
167 S_new_slab(pTHX_ size_t sz)
169 #ifdef PERL_DEBUG_READONLY_OPS
170 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
171 PROT_READ|PROT_WRITE,
172 MAP_ANON|MAP_PRIVATE, -1, 0);
173 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
174 (unsigned long) sz, slab));
175 if (slab == MAP_FAILED) {
176 perror("mmap failed");
179 slab->opslab_size = (U16)sz;
181 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
184 /* The context is unused in non-Windows */
187 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
191 /* requires double parens and aTHX_ */
192 #define DEBUG_S_warn(args) \
194 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
198 Perl_Slab_Alloc(pTHX_ size_t sz)
206 /* We only allocate ops from the slab during subroutine compilation.
207 We find the slab via PL_compcv, hence that must be non-NULL. It could
208 also be pointing to a subroutine which is now fully set up (CvROOT()
209 pointing to the top of the optree for that sub), or a subroutine
210 which isn't using the slab allocator. If our sanity checks aren't met,
211 don't use a slab, but allocate the OP directly from the heap. */
212 if (!PL_compcv || CvROOT(PL_compcv)
213 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
215 o = (OP*)PerlMemShared_calloc(1, sz);
219 /* While the subroutine is under construction, the slabs are accessed via
220 CvSTART(), to avoid needing to expand PVCV by one pointer for something
221 unneeded at runtime. Once a subroutine is constructed, the slabs are
222 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
223 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
225 if (!CvSTART(PL_compcv)) {
227 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
228 CvSLABBED_on(PL_compcv);
229 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
231 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
233 opsz = SIZE_TO_PSIZE(sz);
234 sz = opsz + OPSLOT_HEADER_P;
236 /* The slabs maintain a free list of OPs. In particular, constant folding
237 will free up OPs, so it makes sense to re-use them where possible. A
238 freed up slot is used in preference to a new allocation. */
239 if (slab->opslab_freed) {
240 OP **too = &slab->opslab_freed;
242 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
243 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
244 DEBUG_S_warn((aTHX_ "Alas! too small"));
245 o = *(too = &o->op_next);
246 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
250 Zero(o, opsz, I32 *);
256 #define INIT_OPSLOT \
257 slot->opslot_slab = slab; \
258 slot->opslot_next = slab2->opslab_first; \
259 slab2->opslab_first = slot; \
260 o = &slot->opslot_op; \
263 /* The partially-filled slab is next in the chain. */
264 slab2 = slab->opslab_next ? slab->opslab_next : slab;
265 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
266 /* Remaining space is too small. */
268 /* If we can fit a BASEOP, add it to the free chain, so as not
270 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
271 slot = &slab2->opslab_slots;
273 o->op_type = OP_FREED;
274 o->op_next = slab->opslab_freed;
275 slab->opslab_freed = o;
278 /* Create a new slab. Make this one twice as big. */
279 slot = slab2->opslab_first;
280 while (slot->opslot_next) slot = slot->opslot_next;
281 slab2 = S_new_slab(aTHX_
282 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
284 : (DIFF(slab2, slot)+1)*2);
285 slab2->opslab_next = slab->opslab_next;
286 slab->opslab_next = slab2;
288 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
290 /* Create a new op slot */
291 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
292 assert(slot >= &slab2->opslab_slots);
293 if (DIFF(&slab2->opslab_slots, slot)
294 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
295 slot = &slab2->opslab_slots;
297 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
300 /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
302 assert(!o->op_sibling);
309 #ifdef PERL_DEBUG_READONLY_OPS
311 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
313 PERL_ARGS_ASSERT_SLAB_TO_RO;
315 if (slab->opslab_readonly) return;
316 slab->opslab_readonly = 1;
317 for (; slab; slab = slab->opslab_next) {
318 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
319 (unsigned long) slab->opslab_size, slab));*/
320 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
321 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
322 (unsigned long)slab->opslab_size, errno);
327 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
331 PERL_ARGS_ASSERT_SLAB_TO_RW;
333 if (!slab->opslab_readonly) return;
335 for (; slab2; slab2 = slab2->opslab_next) {
336 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
337 (unsigned long) size, slab2));*/
338 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
339 PROT_READ|PROT_WRITE)) {
340 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
341 (unsigned long)slab2->opslab_size, errno);
344 slab->opslab_readonly = 0;
348 # define Slab_to_rw(op) NOOP
351 /* This cannot possibly be right, but it was copied from the old slab
352 allocator, to which it was originally added, without explanation, in
355 # define PerlMemShared PerlMem
359 Perl_Slab_Free(pTHX_ void *op)
361 OP * const o = (OP *)op;
364 PERL_ARGS_ASSERT_SLAB_FREE;
366 if (!o->op_slabbed) {
368 PerlMemShared_free(op);
373 /* If this op is already freed, our refcount will get screwy. */
374 assert(o->op_type != OP_FREED);
375 o->op_type = OP_FREED;
376 o->op_next = slab->opslab_freed;
377 slab->opslab_freed = o;
378 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
379 OpslabREFCNT_dec_padok(slab);
383 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
385 const bool havepad = !!PL_comppad;
386 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
389 PAD_SAVE_SETNULLPAD();
396 Perl_opslab_free(pTHX_ OPSLAB *slab)
399 PERL_ARGS_ASSERT_OPSLAB_FREE;
401 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
402 assert(slab->opslab_refcnt == 1);
403 for (; slab; slab = slab2) {
404 slab2 = slab->opslab_next;
406 slab->opslab_refcnt = ~(size_t)0;
408 #ifdef PERL_DEBUG_READONLY_OPS
409 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
411 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
412 perror("munmap failed");
416 PerlMemShared_free(slab);
422 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
427 size_t savestack_count = 0;
429 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
432 for (slot = slab2->opslab_first;
434 slot = slot->opslot_next) {
435 if (slot->opslot_op.op_type != OP_FREED
436 && !(slot->opslot_op.op_savefree
442 assert(slot->opslot_op.op_slabbed);
443 op_free(&slot->opslot_op);
444 if (slab->opslab_refcnt == 1) goto free;
447 } while ((slab2 = slab2->opslab_next));
448 /* > 1 because the CV still holds a reference count. */
449 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
451 assert(savestack_count == slab->opslab_refcnt-1);
453 /* Remove the CV’s reference count. */
454 slab->opslab_refcnt--;
461 #ifdef PERL_DEBUG_READONLY_OPS
463 Perl_op_refcnt_inc(pTHX_ OP *o)
466 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
467 if (slab && slab->opslab_readonly) {
480 Perl_op_refcnt_dec(pTHX_ OP *o)
483 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
485 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
487 if (slab && slab->opslab_readonly) {
489 result = --o->op_targ;
492 result = --o->op_targ;
498 * In the following definition, the ", (OP*)0" is just to make the compiler
499 * think the expression is of the right type: croak actually does a Siglongjmp.
501 #define CHECKOP(type,o) \
502 ((PL_op_mask && PL_op_mask[type]) \
503 ? ( op_free((OP*)o), \
504 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
506 : PL_check[type](aTHX_ (OP*)o))
508 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
510 #define CHANGE_TYPE(o,type) \
512 o->op_type = (OPCODE)type; \
513 o->op_ppaddr = PL_ppaddr[type]; \
517 S_no_fh_allowed(pTHX_ OP *o)
519 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
521 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
527 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
529 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
530 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
535 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
537 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
539 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
544 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
546 PERL_ARGS_ASSERT_BAD_TYPE_PV;
548 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
549 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
552 /* remove flags var, its unused in all callers, move to to right end since gv
553 and kid are always the same */
555 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
557 SV * const namesv = cv_name((CV *)gv, NULL, 0);
558 PERL_ARGS_ASSERT_BAD_TYPE_GV;
560 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
561 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
565 S_no_bareword_allowed(pTHX_ OP *o)
567 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
569 qerror(Perl_mess(aTHX_
570 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
572 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
575 /* "register" allocation */
578 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
581 const bool is_our = (PL_parser->in_my == KEY_our);
583 PERL_ARGS_ASSERT_ALLOCMY;
585 if (flags & ~SVf_UTF8)
586 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
589 /* complain about "my $<special_var>" etc etc */
593 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
594 (name[1] == '_' && (*name == '$' || len > 2))))
596 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
598 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
599 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
600 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
601 PL_parser->in_my == KEY_state ? "state" : "my"));
603 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
604 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
607 else if (len == 2 && name[1] == '_' && !is_our)
608 /* diag_listed_as: Use of my $_ is experimental */
609 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
610 "Use of %s $_ is experimental",
611 PL_parser->in_my == KEY_state
615 /* allocate a spare slot and store the name in that slot */
617 off = pad_add_name_pvn(name, len,
618 (is_our ? padadd_OUR :
619 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
620 PL_parser->in_my_stash,
622 /* $_ is always in main::, even with our */
623 ? (PL_curstash && !memEQs(name,len,"$_")
629 /* anon sub prototypes contains state vars should always be cloned,
630 * otherwise the state var would be shared between anon subs */
632 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
633 CvCLONE_on(PL_compcv);
639 =head1 Optree Manipulation Functions
641 =for apidoc alloccopstash
643 Available only under threaded builds, this function allocates an entry in
644 C<PL_stashpad> for the stash passed to it.
651 Perl_alloccopstash(pTHX_ HV *hv)
653 PADOFFSET off = 0, o = 1;
654 bool found_slot = FALSE;
656 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
658 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
660 for (; o < PL_stashpadmax; ++o) {
661 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
662 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
663 found_slot = TRUE, off = o;
666 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
667 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
668 off = PL_stashpadmax;
669 PL_stashpadmax += 10;
672 PL_stashpad[PL_stashpadix = off] = hv;
677 /* free the body of an op without examining its contents.
678 * Always use this rather than FreeOp directly */
681 S_op_destroy(pTHX_ OP *o)
689 =for apidoc Am|void|op_free|OP *o
691 Free an op. Only use this when an op is no longer linked to from any
698 Perl_op_free(pTHX_ OP *o)
702 SSize_t defer_ix = -1;
703 SSize_t defer_stack_alloc = 0;
704 OP **defer_stack = NULL;
708 /* Though ops may be freed twice, freeing the op after its slab is a
710 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
711 /* During the forced freeing of ops after compilation failure, kidops
712 may be freed before their parents. */
713 if (!o || o->op_type == OP_FREED)
718 /* an op should only ever acquire op_private flags that we know about.
719 * If this fails, you may need to fix something in regen/op_private */
720 if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
721 assert(!(o->op_private & ~PL_op_private_valid[type]));
724 if (o->op_private & OPpREFCOUNTED) {
735 refcnt = OpREFCNT_dec(o);
738 /* Need to find and remove any pattern match ops from the list
739 we maintain for reset(). */
740 find_and_forget_pmops(o);
750 /* Call the op_free hook if it has been set. Do it now so that it's called
751 * at the right time for refcounted ops, but still before all of the kids
755 if (o->op_flags & OPf_KIDS) {
757 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
758 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
759 if (!kid || kid->op_type == OP_FREED)
760 /* During the forced freeing of ops after
761 compilation failure, kidops may be freed before
764 if (!(kid->op_flags & OPf_KIDS))
765 /* If it has no kids, just free it now */
772 type = (OPCODE)o->op_targ;
775 Slab_to_rw(OpSLAB(o));
777 /* COP* is not cleared by op_clear() so that we may track line
778 * numbers etc even after null() */
779 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
785 #ifdef DEBUG_LEAKING_SCALARS
789 } while ( (o = POP_DEFERRED_OP()) );
791 Safefree(defer_stack);
794 /* S_op_clear_gv(): free a GV attached to an OP */
797 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
799 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
803 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
804 || o->op_type == OP_MULTIDEREF)
807 ? ((GV*)PAD_SVl(*ixp)) : NULL;
809 ? (GV*)(*svp) : NULL;
811 /* It's possible during global destruction that the GV is freed
812 before the optree. Whilst the SvREFCNT_inc is happy to bump from
813 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
814 will trigger an assertion failure, because the entry to sv_clear
815 checks that the scalar is not already freed. A check of for
816 !SvIS_FREED(gv) turns out to be invalid, because during global
817 destruction the reference count can be forced down to zero
818 (with SVf_BREAK set). In which case raising to 1 and then
819 dropping to 0 triggers cleanup before it should happen. I
820 *think* that this might actually be a general, systematic,
821 weakness of the whole idea of SVf_BREAK, in that code *is*
822 allowed to raise and lower references during global destruction,
823 so any *valid* code that happens to do this during global
824 destruction might well trigger premature cleanup. */
825 bool still_valid = gv && SvREFCNT(gv);
828 SvREFCNT_inc_simple_void(gv);
831 pad_swipe(*ixp, TRUE);
839 int try_downgrade = SvREFCNT(gv) == 2;
842 gv_try_downgrade(gv);
848 Perl_op_clear(pTHX_ OP *o)
853 PERL_ARGS_ASSERT_OP_CLEAR;
855 switch (o->op_type) {
856 case OP_NULL: /* Was holding old type, if any. */
859 case OP_ENTEREVAL: /* Was holding hints. */
863 if (!(o->op_flags & OPf_REF)
864 || (PL_check[o->op_type] != Perl_ck_ftst))
871 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
873 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
876 case OP_METHOD_REDIR:
877 case OP_METHOD_REDIR_SUPER:
879 if (cMETHOPx(o)->op_rclass_targ) {
880 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
881 cMETHOPx(o)->op_rclass_targ = 0;
884 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
885 cMETHOPx(o)->op_rclass_sv = NULL;
887 case OP_METHOD_NAMED:
888 case OP_METHOD_SUPER:
889 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
890 cMETHOPx(o)->op_u.op_meth_sv = NULL;
893 pad_swipe(o->op_targ, 1);
900 SvREFCNT_dec(cSVOPo->op_sv);
901 cSVOPo->op_sv = NULL;
904 Even if op_clear does a pad_free for the target of the op,
905 pad_free doesn't actually remove the sv that exists in the pad;
906 instead it lives on. This results in that it could be reused as
907 a target later on when the pad was reallocated.
910 pad_swipe(o->op_targ,1);
920 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
925 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
926 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
928 if (cPADOPo->op_padix > 0) {
929 pad_swipe(cPADOPo->op_padix, TRUE);
930 cPADOPo->op_padix = 0;
933 SvREFCNT_dec(cSVOPo->op_sv);
934 cSVOPo->op_sv = NULL;
938 PerlMemShared_free(cPVOPo->op_pv);
939 cPVOPo->op_pv = NULL;
943 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
947 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
948 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
951 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
957 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
958 op_free(cPMOPo->op_code_list);
959 cPMOPo->op_code_list = NULL;
961 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
962 /* we use the same protection as the "SAFE" version of the PM_ macros
963 * here since sv_clean_all might release some PMOPs
964 * after PL_regex_padav has been cleared
965 * and the clearing of PL_regex_padav needs to
966 * happen before sv_clean_all
969 if(PL_regex_pad) { /* We could be in destruction */
970 const IV offset = (cPMOPo)->op_pmoffset;
971 ReREFCNT_dec(PM_GETRE(cPMOPo));
972 PL_regex_pad[offset] = &PL_sv_undef;
973 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
977 ReREFCNT_dec(PM_GETRE(cPMOPo));
978 PM_SETRE(cPMOPo, NULL);
985 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
986 UV actions = items->uv;
988 bool is_hash = FALSE;
991 switch (actions & MDEREF_ACTION_MASK) {
994 actions = (++items)->uv;
997 case MDEREF_HV_padhv_helem:
999 case MDEREF_AV_padav_aelem:
1000 pad_free((++items)->pad_offset);
1003 case MDEREF_HV_gvhv_helem:
1005 case MDEREF_AV_gvav_aelem:
1007 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1009 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1013 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1015 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1017 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1019 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1021 goto do_vivify_rv2xv_elem;
1023 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1025 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1026 pad_free((++items)->pad_offset);
1027 goto do_vivify_rv2xv_elem;
1029 case MDEREF_HV_pop_rv2hv_helem:
1030 case MDEREF_HV_vivify_rv2hv_helem:
1032 do_vivify_rv2xv_elem:
1033 case MDEREF_AV_pop_rv2av_aelem:
1034 case MDEREF_AV_vivify_rv2av_aelem:
1036 switch (actions & MDEREF_INDEX_MASK) {
1037 case MDEREF_INDEX_none:
1040 case MDEREF_INDEX_const:
1044 pad_swipe((++items)->pad_offset, 1);
1046 SvREFCNT_dec((++items)->sv);
1052 case MDEREF_INDEX_padsv:
1053 pad_free((++items)->pad_offset);
1055 case MDEREF_INDEX_gvsv:
1057 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1059 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1064 if (actions & MDEREF_FLAG_last)
1077 actions >>= MDEREF_SHIFT;
1080 /* start of malloc is at op_aux[-1], where the length is
1082 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1087 if (o->op_targ > 0) {
1088 pad_free(o->op_targ);
1094 S_cop_free(pTHX_ COP* cop)
1096 PERL_ARGS_ASSERT_COP_FREE;
1099 if (! specialWARN(cop->cop_warnings))
1100 PerlMemShared_free(cop->cop_warnings);
1101 cophh_free(CopHINTHASH_get(cop));
1102 if (PL_curcop == cop)
1107 S_forget_pmop(pTHX_ PMOP *const o
1110 HV * const pmstash = PmopSTASH(o);
1112 PERL_ARGS_ASSERT_FORGET_PMOP;
1114 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1115 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1117 PMOP **const array = (PMOP**) mg->mg_ptr;
1118 U32 count = mg->mg_len / sizeof(PMOP**);
1122 if (array[i] == o) {
1123 /* Found it. Move the entry at the end to overwrite it. */
1124 array[i] = array[--count];
1125 mg->mg_len = count * sizeof(PMOP**);
1126 /* Could realloc smaller at this point always, but probably
1127 not worth it. Probably worth free()ing if we're the
1130 Safefree(mg->mg_ptr);
1143 S_find_and_forget_pmops(pTHX_ OP *o)
1145 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1147 if (o->op_flags & OPf_KIDS) {
1148 OP *kid = cUNOPo->op_first;
1150 switch (kid->op_type) {
1155 forget_pmop((PMOP*)kid);
1157 find_and_forget_pmops(kid);
1158 kid = OpSIBLING(kid);
1164 =for apidoc Am|void|op_null|OP *o
1166 Neutralizes an op when it is no longer needed, but is still linked to from
1173 Perl_op_null(pTHX_ OP *o)
1177 PERL_ARGS_ASSERT_OP_NULL;
1179 if (o->op_type == OP_NULL)
1182 o->op_targ = o->op_type;
1183 CHANGE_TYPE(o, OP_NULL);
1187 Perl_op_refcnt_lock(pTHX)
1192 PERL_UNUSED_CONTEXT;
1197 Perl_op_refcnt_unlock(pTHX)
1202 PERL_UNUSED_CONTEXT;
1208 =for apidoc op_sibling_splice
1210 A general function for editing the structure of an existing chain of
1211 op_sibling nodes. By analogy with the perl-level splice() function, allows
1212 you to delete zero or more sequential nodes, replacing them with zero or
1213 more different nodes. Performs the necessary op_first/op_last
1214 housekeeping on the parent node and op_sibling manipulation on the
1215 children. The last deleted node will be marked as as the last node by
1216 updating the op_sibling or op_lastsib field as appropriate.
1218 Note that op_next is not manipulated, and nodes are not freed; that is the
1219 responsibility of the caller. It also won't create a new list op for an
1220 empty list etc; use higher-level functions like op_append_elem() for that.
1222 parent is the parent node of the sibling chain.
1224 start is the node preceding the first node to be spliced. Node(s)
1225 following it will be deleted, and ops will be inserted after it. If it is
1226 NULL, the first node onwards is deleted, and nodes are inserted at the
1229 del_count is the number of nodes to delete. If zero, no nodes are deleted.
1230 If -1 or greater than or equal to the number of remaining kids, all
1231 remaining kids are deleted.
1233 insert is the first of a chain of nodes to be inserted in place of the nodes.
1234 If NULL, no nodes are inserted.
1236 The head of the chain of deleted ops is returned, or NULL if no ops were
1241 action before after returns
1242 ------ ----- ----- -------
1245 splice(P, A, 2, X-Y-Z) | | B-C
1249 splice(P, NULL, 1, X-Y) | | A
1253 splice(P, NULL, 3, NULL) | | A-B-C
1257 splice(P, B, 0, X-Y) | | NULL
1264 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1266 OP *first = start ? OpSIBLING(start) : cLISTOPx(parent)->op_first;
1268 OP *last_del = NULL;
1269 OP *last_ins = NULL;
1271 PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1273 assert(del_count >= -1);
1275 if (del_count && first) {
1277 while (--del_count && OpHAS_SIBLING(last_del))
1278 last_del = OpSIBLING(last_del);
1279 rest = OpSIBLING(last_del);
1280 OpSIBLING_set(last_del, NULL);
1281 last_del->op_lastsib = 1;
1288 while (OpHAS_SIBLING(last_ins))
1289 last_ins = OpSIBLING(last_ins);
1290 OpSIBLING_set(last_ins, rest);
1291 last_ins->op_lastsib = rest ? 0 : 1;
1297 OpSIBLING_set(start, insert);
1298 start->op_lastsib = insert ? 0 : 1;
1301 cLISTOPx(parent)->op_first = insert;
1303 parent->op_flags |= OPf_KIDS;
1305 parent->op_flags &= ~OPf_KIDS;
1309 /* update op_last etc */
1310 U32 type = parent->op_type;
1313 if (type == OP_NULL)
1314 type = parent->op_targ;
1315 type = PL_opargs[type] & OA_CLASS_MASK;
1317 lastop = last_ins ? last_ins : start ? start : NULL;
1318 if ( type == OA_BINOP
1319 || type == OA_LISTOP
1323 cLISTOPx(parent)->op_last = lastop;
1326 lastop->op_lastsib = 1;
1327 #ifdef PERL_OP_PARENT
1328 lastop->op_sibling = parent;
1332 return last_del ? first : NULL;
1336 =for apidoc op_parent
1338 returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1339 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1346 Perl_op_parent(OP *o)
1348 PERL_ARGS_ASSERT_OP_PARENT;
1349 #ifdef PERL_OP_PARENT
1350 while (OpHAS_SIBLING(o))
1352 return o->op_sibling;
1360 /* replace the sibling following start with a new UNOP, which becomes
1361 * the parent of the original sibling; e.g.
1363 * op_sibling_newUNOP(P, A, unop-args...)
1371 * where U is the new UNOP.
1373 * parent and start args are the same as for op_sibling_splice();
1374 * type and flags args are as newUNOP().
1376 * Returns the new UNOP.
1380 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1384 kid = op_sibling_splice(parent, start, 1, NULL);
1385 newop = newUNOP(type, flags, kid);
1386 op_sibling_splice(parent, start, 0, newop);
1391 /* lowest-level newLOGOP-style function - just allocates and populates
1392 * the struct. Higher-level stuff should be done by S_new_logop() /
1393 * newLOGOP(). This function exists mainly to avoid op_first assignment
1394 * being spread throughout this file.
1398 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1403 NewOp(1101, logop, 1, LOGOP);
1404 CHANGE_TYPE(logop, type);
1405 logop->op_first = first;
1406 logop->op_other = other;
1407 logop->op_flags = OPf_KIDS;
1408 while (kid && OpHAS_SIBLING(kid))
1409 kid = OpSIBLING(kid);
1411 kid->op_lastsib = 1;
1412 #ifdef PERL_OP_PARENT
1413 kid->op_sibling = (OP*)logop;
1420 /* Contextualizers */
1423 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1425 Applies a syntactic context to an op tree representing an expression.
1426 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1427 or C<G_VOID> to specify the context to apply. The modified op tree
1434 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1436 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1438 case G_SCALAR: return scalar(o);
1439 case G_ARRAY: return list(o);
1440 case G_VOID: return scalarvoid(o);
1442 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1449 =for apidoc Am|OP*|op_linklist|OP *o
1450 This function is the implementation of the L</LINKLIST> macro. It should
1451 not be called directly.
1457 Perl_op_linklist(pTHX_ OP *o)
1461 PERL_ARGS_ASSERT_OP_LINKLIST;
1466 /* establish postfix order */
1467 first = cUNOPo->op_first;
1470 o->op_next = LINKLIST(first);
1473 OP *sibl = OpSIBLING(kid);
1475 kid->op_next = LINKLIST(sibl);
1490 S_scalarkids(pTHX_ OP *o)
1492 if (o && o->op_flags & OPf_KIDS) {
1494 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1501 S_scalarboolean(pTHX_ OP *o)
1503 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1505 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1506 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1507 if (ckWARN(WARN_SYNTAX)) {
1508 const line_t oldline = CopLINE(PL_curcop);
1510 if (PL_parser && PL_parser->copline != NOLINE) {
1511 /* This ensures that warnings are reported at the first line
1512 of the conditional, not the last. */
1513 CopLINE_set(PL_curcop, PL_parser->copline);
1515 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1516 CopLINE_set(PL_curcop, oldline);
1523 S_op_varname(pTHX_ const OP *o)
1526 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1527 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1529 const char funny = o->op_type == OP_PADAV
1530 || o->op_type == OP_RV2AV ? '@' : '%';
1531 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1533 if (cUNOPo->op_first->op_type != OP_GV
1534 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1536 return varname(gv, funny, 0, NULL, 0, 1);
1539 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1544 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1545 { /* or not so pretty :-) */
1546 if (o->op_type == OP_CONST) {
1548 if (SvPOK(*retsv)) {
1550 *retsv = sv_newmortal();
1551 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1552 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1554 else if (!SvOK(*retsv))
1557 else *retpv = "...";
1561 S_scalar_slice_warning(pTHX_ const OP *o)
1565 o->op_type == OP_HSLICE ? '{' : '[';
1567 o->op_type == OP_HSLICE ? '}' : ']';
1569 SV *keysv = NULL; /* just to silence compiler warnings */
1570 const char *key = NULL;
1572 if (!(o->op_private & OPpSLICEWARNING))
1574 if (PL_parser && PL_parser->error_count)
1575 /* This warning can be nonsensical when there is a syntax error. */
1578 kid = cLISTOPo->op_first;
1579 kid = OpSIBLING(kid); /* get past pushmark */
1580 /* weed out false positives: any ops that can return lists */
1581 switch (kid->op_type) {
1610 /* Don't warn if we have a nulled list either. */
1611 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1614 assert(OpSIBLING(kid));
1615 name = S_op_varname(aTHX_ OpSIBLING(kid));
1616 if (!name) /* XS module fiddling with the op tree */
1618 S_op_pretty(aTHX_ kid, &keysv, &key);
1619 assert(SvPOK(name));
1620 sv_chop(name,SvPVX(name)+1);
1622 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1623 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1624 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1626 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1627 lbrack, key, rbrack);
1629 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1630 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1631 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1633 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1634 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1638 Perl_scalar(pTHX_ OP *o)
1642 /* assumes no premature commitment */
1643 if (!o || (PL_parser && PL_parser->error_count)
1644 || (o->op_flags & OPf_WANT)
1645 || o->op_type == OP_RETURN)
1650 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1652 switch (o->op_type) {
1654 scalar(cBINOPo->op_first);
1655 if (o->op_private & OPpREPEAT_DOLIST) {
1656 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1657 assert(kid->op_type == OP_PUSHMARK);
1658 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1659 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1660 o->op_private &=~ OPpREPEAT_DOLIST;
1667 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1677 if (o->op_flags & OPf_KIDS) {
1678 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1684 kid = cLISTOPo->op_first;
1686 kid = OpSIBLING(kid);
1689 OP *sib = OpSIBLING(kid);
1690 if (sib && kid->op_type != OP_LEAVEWHEN
1691 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1692 || ( sib->op_targ != OP_NEXTSTATE
1693 && sib->op_targ != OP_DBSTATE )))
1699 PL_curcop = &PL_compiling;
1704 kid = cLISTOPo->op_first;
1707 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1712 /* Warn about scalar context */
1713 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1714 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1717 const char *key = NULL;
1719 /* This warning can be nonsensical when there is a syntax error. */
1720 if (PL_parser && PL_parser->error_count)
1723 if (!ckWARN(WARN_SYNTAX)) break;
1725 kid = cLISTOPo->op_first;
1726 kid = OpSIBLING(kid); /* get past pushmark */
1727 assert(OpSIBLING(kid));
1728 name = S_op_varname(aTHX_ OpSIBLING(kid));
1729 if (!name) /* XS module fiddling with the op tree */
1731 S_op_pretty(aTHX_ kid, &keysv, &key);
1732 assert(SvPOK(name));
1733 sv_chop(name,SvPVX(name)+1);
1735 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1736 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1737 "%%%"SVf"%c%s%c in scalar context better written "
1739 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1740 lbrack, key, rbrack);
1742 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1743 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1744 "%%%"SVf"%c%"SVf"%c in scalar context better "
1745 "written as $%"SVf"%c%"SVf"%c",
1746 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1747 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1754 Perl_scalarvoid(pTHX_ OP *arg)
1760 SSize_t defer_stack_alloc = 0;
1761 SSize_t defer_ix = -1;
1762 OP **defer_stack = NULL;
1765 PERL_ARGS_ASSERT_SCALARVOID;
1768 SV *useless_sv = NULL;
1769 const char* useless = NULL;
1771 if (o->op_type == OP_NEXTSTATE
1772 || o->op_type == OP_DBSTATE
1773 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1774 || o->op_targ == OP_DBSTATE)))
1775 PL_curcop = (COP*)o; /* for warning below */
1777 /* assumes no premature commitment */
1778 want = o->op_flags & OPf_WANT;
1779 if ((want && want != OPf_WANT_SCALAR)
1780 || (PL_parser && PL_parser->error_count)
1781 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1786 if ((o->op_private & OPpTARGET_MY)
1787 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1789 /* newASSIGNOP has already applied scalar context, which we
1790 leave, as if this op is inside SASSIGN. */
1794 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1796 switch (o->op_type) {
1798 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1802 if (o->op_flags & OPf_STACKED)
1804 if (o->op_type == OP_REPEAT)
1805 scalar(cBINOPo->op_first);
1808 if (o->op_private == 4)
1843 case OP_GETSOCKNAME:
1844 case OP_GETPEERNAME:
1849 case OP_GETPRIORITY:
1874 useless = OP_DESC(o);
1884 case OP_AELEMFAST_LEX:
1888 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1889 /* Otherwise it's "Useless use of grep iterator" */
1890 useless = OP_DESC(o);
1894 kid = cLISTOPo->op_first;
1895 if (kid && kid->op_type == OP_PUSHRE
1897 && !(o->op_flags & OPf_STACKED)
1899 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1901 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
1904 useless = OP_DESC(o);
1908 kid = cUNOPo->op_first;
1909 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1910 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1913 useless = "negative pattern binding (!~)";
1917 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1918 useless = "non-destructive substitution (s///r)";
1922 useless = "non-destructive transliteration (tr///r)";
1929 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1930 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
1931 useless = "a variable";
1936 if (cSVOPo->op_private & OPpCONST_STRICT)
1937 no_bareword_allowed(o);
1939 if (ckWARN(WARN_VOID)) {
1941 /* don't warn on optimised away booleans, eg
1942 * use constant Foo, 5; Foo || print; */
1943 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1945 /* the constants 0 and 1 are permitted as they are
1946 conventionally used as dummies in constructs like
1947 1 while some_condition_with_side_effects; */
1948 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1950 else if (SvPOK(sv)) {
1951 SV * const dsv = newSVpvs("");
1953 = Perl_newSVpvf(aTHX_
1955 pv_pretty(dsv, SvPVX_const(sv),
1956 SvCUR(sv), 32, NULL, NULL,
1958 | PERL_PV_ESCAPE_NOCLEAR
1959 | PERL_PV_ESCAPE_UNI_DETECT));
1960 SvREFCNT_dec_NN(dsv);
1962 else if (SvOK(sv)) {
1963 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1966 useless = "a constant (undef)";
1969 op_null(o); /* don't execute or even remember it */
1973 CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
1977 CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
1981 CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
1985 CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
1990 UNOP *refgen, *rv2cv;
1993 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1996 rv2gv = ((BINOP *)o)->op_last;
1997 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2000 refgen = (UNOP *)((BINOP *)o)->op_first;
2002 if (!refgen || (refgen->op_type != OP_REFGEN
2003 && refgen->op_type != OP_SREFGEN))
2006 exlist = (LISTOP *)refgen->op_first;
2007 if (!exlist || exlist->op_type != OP_NULL
2008 || exlist->op_targ != OP_LIST)
2011 if (exlist->op_first->op_type != OP_PUSHMARK
2012 && exlist->op_first != exlist->op_last)
2015 rv2cv = (UNOP*)exlist->op_last;
2017 if (rv2cv->op_type != OP_RV2CV)
2020 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2021 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2022 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2024 o->op_private |= OPpASSIGN_CV_TO_GV;
2025 rv2gv->op_private |= OPpDONT_INIT_GV;
2026 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2038 kid = cLOGOPo->op_first;
2039 if (kid->op_type == OP_NOT
2040 && (kid->op_flags & OPf_KIDS)) {
2041 if (o->op_type == OP_AND) {
2042 CHANGE_TYPE(o, OP_OR);
2044 CHANGE_TYPE(o, OP_AND);
2054 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2055 if (!(kid->op_flags & OPf_KIDS))
2062 if (o->op_flags & OPf_STACKED)
2069 if (!(o->op_flags & OPf_KIDS))
2080 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2081 if (!(kid->op_flags & OPf_KIDS))
2087 /* If the first kid after pushmark is something that the padrange
2088 optimisation would reject, then null the list and the pushmark.
2090 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2091 && ( !(kid = OpSIBLING(kid))
2092 || ( kid->op_type != OP_PADSV
2093 && kid->op_type != OP_PADAV
2094 && kid->op_type != OP_PADHV)
2095 || kid->op_private & ~OPpLVAL_INTRO
2096 || !(kid = OpSIBLING(kid))
2097 || ( kid->op_type != OP_PADSV
2098 && kid->op_type != OP_PADAV
2099 && kid->op_type != OP_PADHV)
2100 || kid->op_private & ~OPpLVAL_INTRO)
2102 op_null(cUNOPo->op_first); /* NULL the pushmark */
2103 op_null(o); /* NULL the list */
2115 /* mortalise it, in case warnings are fatal. */
2116 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2117 "Useless use of %"SVf" in void context",
2118 SVfARG(sv_2mortal(useless_sv)));
2121 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2122 "Useless use of %s in void context",
2125 } while ( (o = POP_DEFERRED_OP()) );
2127 Safefree(defer_stack);
2133 S_listkids(pTHX_ OP *o)
2135 if (o && o->op_flags & OPf_KIDS) {
2137 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2144 Perl_list(pTHX_ OP *o)
2148 /* assumes no premature commitment */
2149 if (!o || (o->op_flags & OPf_WANT)
2150 || (PL_parser && PL_parser->error_count)
2151 || o->op_type == OP_RETURN)
2156 if ((o->op_private & OPpTARGET_MY)
2157 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2159 return o; /* As if inside SASSIGN */
2162 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2164 switch (o->op_type) {
2166 list(cBINOPo->op_first);
2169 if (o->op_private & OPpREPEAT_DOLIST
2170 && !(o->op_flags & OPf_STACKED))
2172 list(cBINOPo->op_first);
2173 kid = cBINOPo->op_last;
2174 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2175 && SvIVX(kSVOP_sv) == 1)
2177 op_null(o); /* repeat */
2178 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2180 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2187 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2195 if (!(o->op_flags & OPf_KIDS))
2197 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2198 list(cBINOPo->op_first);
2199 return gen_constant_list(o);
2205 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2206 op_null(cUNOPo->op_first); /* NULL the pushmark */
2207 op_null(o); /* NULL the list */
2212 kid = cLISTOPo->op_first;
2214 kid = OpSIBLING(kid);
2217 OP *sib = OpSIBLING(kid);
2218 if (sib && kid->op_type != OP_LEAVEWHEN)
2224 PL_curcop = &PL_compiling;
2228 kid = cLISTOPo->op_first;
2235 S_scalarseq(pTHX_ OP *o)
2238 const OPCODE type = o->op_type;
2240 if (type == OP_LINESEQ || type == OP_SCOPE ||
2241 type == OP_LEAVE || type == OP_LEAVETRY)
2244 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2245 if ((sib = OpSIBLING(kid))
2246 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2247 || ( sib->op_targ != OP_NEXTSTATE
2248 && sib->op_targ != OP_DBSTATE )))
2253 PL_curcop = &PL_compiling;
2255 o->op_flags &= ~OPf_PARENS;
2256 if (PL_hints & HINT_BLOCK_SCOPE)
2257 o->op_flags |= OPf_PARENS;
2260 o = newOP(OP_STUB, 0);
2265 S_modkids(pTHX_ OP *o, I32 type)
2267 if (o && o->op_flags & OPf_KIDS) {
2269 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2270 op_lvalue(kid, type);
2276 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2277 * const fields. Also, convert CONST keys to HEK-in-SVs.
2278 * rop is the op that retrieves the hash;
2279 * key_op is the first key
2283 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2289 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2291 if (rop->op_first->op_type == OP_PADSV)
2292 /* @$hash{qw(keys here)} */
2293 rop = (UNOP*)rop->op_first;
2295 /* @{$hash}{qw(keys here)} */
2296 if (rop->op_first->op_type == OP_SCOPE
2297 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2299 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2306 lexname = NULL; /* just to silence compiler warnings */
2307 fields = NULL; /* just to silence compiler warnings */
2311 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2312 SvPAD_TYPED(lexname))
2313 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2314 && isGV(*fields) && GvHV(*fields);
2316 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2318 if (key_op->op_type != OP_CONST)
2320 svp = cSVOPx_svp(key_op);
2322 /* Make the CONST have a shared SV */
2323 if ( !SvIsCOW_shared_hash(sv = *svp)
2324 && SvTYPE(sv) < SVt_PVMG
2329 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2330 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2331 SvREFCNT_dec_NN(sv);
2336 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2338 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2339 "in variable %"PNf" of type %"HEKf,
2340 SVfARG(*svp), PNfARG(lexname),
2341 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2348 =for apidoc finalize_optree
2350 This function finalizes the optree. Should be called directly after
2351 the complete optree is built. It does some additional
2352 checking which can't be done in the normal ck_xxx functions and makes
2353 the tree thread-safe.
2358 Perl_finalize_optree(pTHX_ OP* o)
2360 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2363 SAVEVPTR(PL_curcop);
2371 /* Relocate sv to the pad for thread safety.
2372 * Despite being a "constant", the SV is written to,
2373 * for reference counts, sv_upgrade() etc. */
2374 PERL_STATIC_INLINE void
2375 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2378 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2380 ix = pad_alloc(OP_CONST, SVf_READONLY);
2381 SvREFCNT_dec(PAD_SVl(ix));
2382 PAD_SETSV(ix, *svp);
2383 /* XXX I don't know how this isn't readonly already. */
2384 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2392 S_finalize_op(pTHX_ OP* o)
2394 PERL_ARGS_ASSERT_FINALIZE_OP;
2397 switch (o->op_type) {
2400 PL_curcop = ((COP*)o); /* for warnings */
2403 if (OpHAS_SIBLING(o)) {
2404 OP *sib = OpSIBLING(o);
2405 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2406 && ckWARN(WARN_EXEC)
2407 && OpHAS_SIBLING(sib))
2409 const OPCODE type = OpSIBLING(sib)->op_type;
2410 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2411 const line_t oldline = CopLINE(PL_curcop);
2412 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2413 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2414 "Statement unlikely to be reached");
2415 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2416 "\t(Maybe you meant system() when you said exec()?)\n");
2417 CopLINE_set(PL_curcop, oldline);
2424 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2425 GV * const gv = cGVOPo_gv;
2426 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2427 /* XXX could check prototype here instead of just carping */
2428 SV * const sv = sv_newmortal();
2429 gv_efullname3(sv, gv, NULL);
2430 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2431 "%"SVf"() called too early to check prototype",
2438 if (cSVOPo->op_private & OPpCONST_STRICT)
2439 no_bareword_allowed(o);
2443 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2448 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2449 case OP_METHOD_NAMED:
2450 case OP_METHOD_SUPER:
2451 case OP_METHOD_REDIR:
2452 case OP_METHOD_REDIR_SUPER:
2453 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2462 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2465 rop = (UNOP*)((BINOP*)o)->op_first;
2470 S_scalar_slice_warning(aTHX_ o);
2474 kid = OpSIBLING(cLISTOPo->op_first);
2475 if (/* I bet there's always a pushmark... */
2476 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2477 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2482 key_op = (SVOP*)(kid->op_type == OP_CONST
2484 : OpSIBLING(kLISTOP->op_first));
2486 rop = (UNOP*)((LISTOP*)o)->op_last;
2489 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2491 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2495 S_scalar_slice_warning(aTHX_ o);
2499 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2500 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2507 if (o->op_flags & OPf_KIDS) {
2511 /* check that op_last points to the last sibling, and that
2512 * the last op_sibling field points back to the parent, and
2513 * that the only ops with KIDS are those which are entitled to
2515 U32 type = o->op_type;
2519 if (type == OP_NULL) {
2521 /* ck_glob creates a null UNOP with ex-type GLOB
2522 * (which is a list op. So pretend it wasn't a listop */
2523 if (type == OP_GLOB)
2526 family = PL_opargs[type] & OA_CLASS_MASK;
2528 has_last = ( family == OA_BINOP
2529 || family == OA_LISTOP
2530 || family == OA_PMOP
2531 || family == OA_LOOP
2533 assert( has_last /* has op_first and op_last, or ...
2534 ... has (or may have) op_first: */
2535 || family == OA_UNOP
2536 || family == OA_UNOP_AUX
2537 || family == OA_LOGOP
2538 || family == OA_BASEOP_OR_UNOP
2539 || family == OA_FILESTATOP
2540 || family == OA_LOOPEXOP
2541 || family == OA_METHOP
2542 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2543 || type == OP_SASSIGN
2544 || type == OP_CUSTOM
2545 || type == OP_NULL /* new_logop does this */
2548 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2549 # ifdef PERL_OP_PARENT
2550 if (!OpHAS_SIBLING(kid)) {
2552 assert(kid == cLISTOPo->op_last);
2553 assert(kid->op_sibling == o);
2556 if (OpHAS_SIBLING(kid)) {
2557 assert(!kid->op_lastsib);
2560 assert(kid->op_lastsib);
2562 assert(kid == cLISTOPo->op_last);
2568 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2574 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2576 Propagate lvalue ("modifiable") context to an op and its children.
2577 I<type> represents the context type, roughly based on the type of op that
2578 would do the modifying, although C<local()> is represented by OP_NULL,
2579 because it has no op type of its own (it is signalled by a flag on
2582 This function detects things that can't be modified, such as C<$x+1>, and
2583 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2584 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2586 It also flags things that need to behave specially in an lvalue context,
2587 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2593 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2596 PadnameLVALUE_on(pn);
2597 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2600 assert(CvPADLIST(cv));
2602 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2603 assert(PadnameLEN(pn));
2604 PadnameLVALUE_on(pn);
2609 S_vivifies(const OPCODE type)
2612 case OP_RV2AV: case OP_ASLICE:
2613 case OP_RV2HV: case OP_KVASLICE:
2614 case OP_RV2SV: case OP_HSLICE:
2615 case OP_AELEMFAST: case OP_KVHSLICE:
2624 S_lvref(pTHX_ OP *o, I32 type)
2628 switch (o->op_type) {
2630 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2631 kid = OpSIBLING(kid))
2632 S_lvref(aTHX_ kid, type);
2637 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2638 o->op_flags |= OPf_STACKED;
2639 if (o->op_flags & OPf_PARENS) {
2640 if (o->op_private & OPpLVAL_INTRO) {
2641 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2642 "localized parenthesized array in list assignment"));
2646 CHANGE_TYPE(o, OP_LVAVREF);
2647 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2648 o->op_flags |= OPf_MOD|OPf_REF;
2651 o->op_private |= OPpLVREF_AV;
2654 kid = cUNOPo->op_first;
2655 if (kid->op_type == OP_NULL)
2656 kid = cUNOPx(kUNOP->op_first->op_sibling)
2658 o->op_private = OPpLVREF_CV;
2659 if (kid->op_type == OP_GV)
2660 o->op_flags |= OPf_STACKED;
2661 else if (kid->op_type == OP_PADCV) {
2662 o->op_targ = kid->op_targ;
2664 op_free(cUNOPo->op_first);
2665 cUNOPo->op_first = NULL;
2666 o->op_flags &=~ OPf_KIDS;
2671 if (o->op_flags & OPf_PARENS) {
2673 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2674 "parenthesized hash in list assignment"));
2677 o->op_private |= OPpLVREF_HV;
2681 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2682 o->op_flags |= OPf_STACKED;
2685 if (o->op_flags & OPf_PARENS) goto parenhash;
2686 o->op_private |= OPpLVREF_HV;
2689 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2692 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2693 if (o->op_flags & OPf_PARENS) goto slurpy;
2694 o->op_private |= OPpLVREF_AV;
2698 o->op_private |= OPpLVREF_ELEM;
2699 o->op_flags |= OPf_STACKED;
2703 CHANGE_TYPE(o, OP_LVREFSLICE);
2704 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2707 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2709 else if (!(o->op_flags & OPf_KIDS))
2711 if (o->op_targ != OP_LIST) {
2712 S_lvref(aTHX_ cBINOPo->op_first, type);
2717 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2718 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2719 S_lvref(aTHX_ kid, type);
2723 if (o->op_flags & OPf_PARENS)
2728 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2729 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2730 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2736 CHANGE_TYPE(o, OP_LVREF);
2738 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2739 if (type == OP_ENTERLOOP)
2740 o->op_private |= OPpLVREF_ITER;
2744 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2748 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2751 if (!o || (PL_parser && PL_parser->error_count))
2754 if ((o->op_private & OPpTARGET_MY)
2755 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2760 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2762 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2764 switch (o->op_type) {
2769 if ((o->op_flags & OPf_PARENS))
2773 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2774 !(o->op_flags & OPf_STACKED)) {
2775 CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
2776 assert(cUNOPo->op_first->op_type == OP_NULL);
2777 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2780 else { /* lvalue subroutine call */
2781 o->op_private |= OPpLVAL_INTRO;
2782 PL_modcount = RETURN_UNLIMITED_NUMBER;
2783 if (type == OP_GREPSTART || type == OP_ENTERSUB
2784 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
2785 /* Potential lvalue context: */
2786 o->op_private |= OPpENTERSUB_INARGS;
2789 else { /* Compile-time error message: */
2790 OP *kid = cUNOPo->op_first;
2794 if (kid->op_type != OP_PUSHMARK) {
2795 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2797 "panic: unexpected lvalue entersub "
2798 "args: type/targ %ld:%"UVuf,
2799 (long)kid->op_type, (UV)kid->op_targ);
2800 kid = kLISTOP->op_first;
2802 while (OpHAS_SIBLING(kid))
2803 kid = OpSIBLING(kid);
2804 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2805 break; /* Postpone until runtime */
2808 kid = kUNOP->op_first;
2809 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2810 kid = kUNOP->op_first;
2811 if (kid->op_type == OP_NULL)
2813 "Unexpected constant lvalue entersub "
2814 "entry via type/targ %ld:%"UVuf,
2815 (long)kid->op_type, (UV)kid->op_targ);
2816 if (kid->op_type != OP_GV) {
2823 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2824 ? MUTABLE_CV(SvRV(gv))
2835 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2836 /* grep, foreach, subcalls, refgen */
2837 if (type == OP_GREPSTART || type == OP_ENTERSUB
2838 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2840 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2841 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2843 : (o->op_type == OP_ENTERSUB
2844 ? "non-lvalue subroutine call"
2846 type ? PL_op_desc[type] : "local"));
2859 case OP_RIGHT_SHIFT:
2868 if (!(o->op_flags & OPf_STACKED))
2874 if (o->op_flags & OPf_STACKED) {
2878 if (!(o->op_private & OPpREPEAT_DOLIST))
2881 const I32 mods = PL_modcount;
2882 modkids(cBINOPo->op_first, type);
2883 if (type != OP_AASSIGN)
2885 kid = cBINOPo->op_last;
2886 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
2887 const IV iv = SvIV(kSVOP_sv);
2888 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
2890 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
2893 PL_modcount = RETURN_UNLIMITED_NUMBER;
2899 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2900 op_lvalue(kid, type);
2905 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2906 PL_modcount = RETURN_UNLIMITED_NUMBER;
2907 return o; /* Treat \(@foo) like ordinary list. */
2911 if (scalar_mod_type(o, type))
2913 ref(cUNOPo->op_first, o->op_type);
2920 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2921 if (type == OP_LEAVESUBLV && (
2922 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2923 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2925 o->op_private |= OPpMAYBE_LVSUB;
2929 PL_modcount = RETURN_UNLIMITED_NUMBER;
2933 if (type == OP_LEAVESUBLV)
2934 o->op_private |= OPpMAYBE_LVSUB;
2937 PL_hints |= HINT_BLOCK_SCOPE;
2938 if (type == OP_LEAVESUBLV)
2939 o->op_private |= OPpMAYBE_LVSUB;
2943 ref(cUNOPo->op_first, o->op_type);
2947 PL_hints |= HINT_BLOCK_SCOPE;
2957 case OP_AELEMFAST_LEX:
2964 PL_modcount = RETURN_UNLIMITED_NUMBER;
2965 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2966 return o; /* Treat \(@foo) like ordinary list. */
2967 if (scalar_mod_type(o, type))
2969 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2970 && type == OP_LEAVESUBLV)
2971 o->op_private |= OPpMAYBE_LVSUB;
2975 if (!type) /* local() */
2976 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
2977 PNfARG(PAD_COMPNAME(o->op_targ)));
2978 if (!(o->op_private & OPpLVAL_INTRO)
2979 || ( type != OP_SASSIGN && type != OP_AASSIGN
2980 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
2981 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
2990 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2994 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3000 if (type == OP_LEAVESUBLV)
3001 o->op_private |= OPpMAYBE_LVSUB;
3002 if (o->op_flags & OPf_KIDS)
3003 op_lvalue(OpSIBLING(cBINOPo->op_first), type);
3008 ref(cBINOPo->op_first, o->op_type);
3009 if (type == OP_ENTERSUB &&
3010 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3011 o->op_private |= OPpLVAL_DEFER;
3012 if (type == OP_LEAVESUBLV)
3013 o->op_private |= OPpMAYBE_LVSUB;
3020 o->op_private |= OPpLVALUE;
3026 if (o->op_flags & OPf_KIDS)
3027 op_lvalue(cLISTOPo->op_last, type);
3032 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3034 else if (!(o->op_flags & OPf_KIDS))
3036 if (o->op_targ != OP_LIST) {
3037 op_lvalue(cBINOPo->op_first, type);
3043 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3044 /* elements might be in void context because the list is
3045 in scalar context or because they are attribute sub calls */
3046 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3047 op_lvalue(kid, type);
3055 if (type == OP_LEAVESUBLV
3056 || !S_vivifies(cLOGOPo->op_first->op_type))
3057 op_lvalue(cLOGOPo->op_first, type);
3058 if (type == OP_LEAVESUBLV
3059 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3060 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3064 if (type != OP_AASSIGN && type != OP_SASSIGN
3065 && type != OP_ENTERLOOP)
3067 /* Don’t bother applying lvalue context to the ex-list. */
3068 kid = cUNOPx(cUNOPo->op_first)->op_first;
3069 assert (!OpHAS_SIBLING(kid));
3072 if (type != OP_AASSIGN) goto nomod;
3073 kid = cUNOPo->op_first;
3076 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3077 S_lvref(aTHX_ kid, type);
3078 if (!PL_parser || PL_parser->error_count == ec) {
3079 if (!FEATURE_REFALIASING_IS_ENABLED)
3081 "Experimental aliasing via reference not enabled");
3082 Perl_ck_warner_d(aTHX_
3083 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3084 "Aliasing via reference is experimental");
3087 if (o->op_type == OP_REFGEN)
3088 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3093 kid = cLISTOPo->op_first;
3094 if (kid && kid->op_type == OP_PUSHRE &&
3096 || o->op_flags & OPf_STACKED
3098 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3100 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3103 /* This is actually @array = split. */
3104 PL_modcount = RETURN_UNLIMITED_NUMBER;
3110 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3114 /* [20011101.069] File test operators interpret OPf_REF to mean that
3115 their argument is a filehandle; thus \stat(".") should not set
3117 if (type == OP_REFGEN &&
3118 PL_check[o->op_type] == Perl_ck_ftst)
3121 if (type != OP_LEAVESUBLV)
3122 o->op_flags |= OPf_MOD;
3124 if (type == OP_AASSIGN || type == OP_SASSIGN)
3125 o->op_flags |= OPf_SPECIAL|OPf_REF;
3126 else if (!type) { /* local() */
3129 o->op_private |= OPpLVAL_INTRO;
3130 o->op_flags &= ~OPf_SPECIAL;
3131 PL_hints |= HINT_BLOCK_SCOPE;
3136 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3137 "Useless localization of %s", OP_DESC(o));
3140 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3141 && type != OP_LEAVESUBLV)
3142 o->op_flags |= OPf_REF;
3147 S_scalar_mod_type(const OP *o, I32 type)
3152 if (o && o->op_type == OP_RV2GV)
3176 case OP_RIGHT_SHIFT:
3197 S_is_handle_constructor(const OP *o, I32 numargs)
3199 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3201 switch (o->op_type) {
3209 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3222 S_refkids(pTHX_ OP *o, I32 type)
3224 if (o && o->op_flags & OPf_KIDS) {
3226 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3233 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3238 PERL_ARGS_ASSERT_DOREF;
3240 if (!o || (PL_parser && PL_parser->error_count))
3243 switch (o->op_type) {
3245 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3246 !(o->op_flags & OPf_STACKED)) {
3247 CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
3248 assert(cUNOPo->op_first->op_type == OP_NULL);
3249 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3250 o->op_flags |= OPf_SPECIAL;
3252 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3253 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3254 : type == OP_RV2HV ? OPpDEREF_HV
3256 o->op_flags |= OPf_MOD;
3262 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3263 doref(kid, type, set_op_ref);
3266 if (type == OP_DEFINED)
3267 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3268 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3271 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3272 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3273 : type == OP_RV2HV ? OPpDEREF_HV
3275 o->op_flags |= OPf_MOD;
3282 o->op_flags |= OPf_REF;
3285 if (type == OP_DEFINED)
3286 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3287 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3293 o->op_flags |= OPf_REF;
3298 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3300 doref(cBINOPo->op_first, type, set_op_ref);
3304 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3305 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3306 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3307 : type == OP_RV2HV ? OPpDEREF_HV
3309 o->op_flags |= OPf_MOD;
3319 if (!(o->op_flags & OPf_KIDS))
3321 doref(cLISTOPo->op_last, type, set_op_ref);
3331 S_dup_attrlist(pTHX_ OP *o)
3335 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3337 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3338 * where the first kid is OP_PUSHMARK and the remaining ones
3339 * are OP_CONST. We need to push the OP_CONST values.
3341 if (o->op_type == OP_CONST)
3342 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3344 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3346 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3347 if (o->op_type == OP_CONST)
3348 rop = op_append_elem(OP_LIST, rop,
3349 newSVOP(OP_CONST, o->op_flags,
3350 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3357 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3359 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3361 PERL_ARGS_ASSERT_APPLY_ATTRS;
3363 /* fake up C<use attributes $pkg,$rv,@attrs> */
3365 #define ATTRSMODULE "attributes"
3366 #define ATTRSMODULE_PM "attributes.pm"
3368 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3369 newSVpvs(ATTRSMODULE),
3371 op_prepend_elem(OP_LIST,
3372 newSVOP(OP_CONST, 0, stashsv),
3373 op_prepend_elem(OP_LIST,
3374 newSVOP(OP_CONST, 0,
3376 dup_attrlist(attrs))));
3380 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3382 OP *pack, *imop, *arg;
3383 SV *meth, *stashsv, **svp;
3385 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3390 assert(target->op_type == OP_PADSV ||
3391 target->op_type == OP_PADHV ||
3392 target->op_type == OP_PADAV);
3394 /* Ensure that attributes.pm is loaded. */
3395 /* Don't force the C<use> if we don't need it. */
3396 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3397 if (svp && *svp != &PL_sv_undef)
3398 NOOP; /* already in %INC */
3400 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3401 newSVpvs(ATTRSMODULE), NULL);
3403 /* Need package name for method call. */
3404 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3406 /* Build up the real arg-list. */
3407 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3409 arg = newOP(OP_PADSV, 0);
3410 arg->op_targ = target->op_targ;
3411 arg = op_prepend_elem(OP_LIST,
3412 newSVOP(OP_CONST, 0, stashsv),
3413 op_prepend_elem(OP_LIST,
3414 newUNOP(OP_REFGEN, 0,
3415 op_lvalue(arg, OP_REFGEN)),
3416 dup_attrlist(attrs)));
3418 /* Fake up a method call to import */
3419 meth = newSVpvs_share("import");
3420 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3421 op_append_elem(OP_LIST,
3422 op_prepend_elem(OP_LIST, pack, arg),
3423 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3425 /* Combine the ops. */
3426 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3430 =notfor apidoc apply_attrs_string
3432 Attempts to apply a list of attributes specified by the C<attrstr> and
3433 C<len> arguments to the subroutine identified by the C<cv> argument which
3434 is expected to be associated with the package identified by the C<stashpv>
3435 argument (see L<attributes>). It gets this wrong, though, in that it
3436 does not correctly identify the boundaries of the individual attribute
3437 specifications within C<attrstr>. This is not really intended for the
3438 public API, but has to be listed here for systems such as AIX which
3439 need an explicit export list for symbols. (It's called from XS code
3440 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3441 to respect attribute syntax properly would be welcome.
3447 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3448 const char *attrstr, STRLEN len)
3452 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3455 len = strlen(attrstr);
3459 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3461 const char * const sstr = attrstr;
3462 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3463 attrs = op_append_elem(OP_LIST, attrs,
3464 newSVOP(OP_CONST, 0,
3465 newSVpvn(sstr, attrstr-sstr)));
3469 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3470 newSVpvs(ATTRSMODULE),
3471 NULL, op_prepend_elem(OP_LIST,
3472 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3473 op_prepend_elem(OP_LIST,
3474 newSVOP(OP_CONST, 0,
3475 newRV(MUTABLE_SV(cv))),
3480 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3482 OP *new_proto = NULL;
3487 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3493 if (o->op_type == OP_CONST) {
3494 pv = SvPV(cSVOPo_sv, pvlen);
3495 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3496 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3497 SV ** const tmpo = cSVOPx_svp(o);
3498 SvREFCNT_dec(cSVOPo_sv);
3503 } else if (o->op_type == OP_LIST) {
3505 assert(o->op_flags & OPf_KIDS);
3506 lasto = cLISTOPo->op_first;
3507 assert(lasto->op_type == OP_PUSHMARK);
3508 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3509 if (o->op_type == OP_CONST) {
3510 pv = SvPV(cSVOPo_sv, pvlen);
3511 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3512 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3513 SV ** const tmpo = cSVOPx_svp(o);
3514 SvREFCNT_dec(cSVOPo_sv);
3516 if (new_proto && ckWARN(WARN_MISC)) {
3518 const char * newp = SvPV(cSVOPo_sv, new_len);
3519 Perl_warner(aTHX_ packWARN(WARN_MISC),
3520 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3521 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3527 /* excise new_proto from the list */
3528 op_sibling_splice(*attrs, lasto, 1, NULL);
3535 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3536 would get pulled in with no real need */
3537 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3546 svname = sv_newmortal();
3547 gv_efullname3(svname, name, NULL);
3549 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3550 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3552 svname = (SV *)name;
3553 if (ckWARN(WARN_ILLEGALPROTO))
3554 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3555 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3556 STRLEN old_len, new_len;
3557 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3558 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3560 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3561 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3563 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3564 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3574 S_cant_declare(pTHX_ OP *o)
3576 if (o->op_type == OP_NULL
3577 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3578 o = cUNOPo->op_first;
3579 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3580 o->op_type == OP_NULL
3581 && o->op_flags & OPf_SPECIAL
3584 PL_parser->in_my == KEY_our ? "our" :
3585 PL_parser->in_my == KEY_state ? "state" :
3590 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3593 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3595 PERL_ARGS_ASSERT_MY_KID;
3597 if (!o || (PL_parser && PL_parser->error_count))
3602 if (type == OP_LIST) {
3604 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3605 my_kid(kid, attrs, imopsp);
3607 } else if (type == OP_UNDEF || type == OP_STUB) {
3609 } else if (type == OP_RV2SV || /* "our" declaration */
3611 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3612 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3613 S_cant_declare(aTHX_ o);
3615 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3617 PL_parser->in_my = FALSE;
3618 PL_parser->in_my_stash = NULL;
3619 apply_attrs(GvSTASH(gv),
3620 (type == OP_RV2SV ? GvSV(gv) :
3621 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3622 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3625 o->op_private |= OPpOUR_INTRO;
3628 else if (type != OP_PADSV &&
3631 type != OP_PUSHMARK)
3633 S_cant_declare(aTHX_ o);
3636 else if (attrs && type != OP_PUSHMARK) {
3640 PL_parser->in_my = FALSE;
3641 PL_parser->in_my_stash = NULL;
3643 /* check for C<my Dog $spot> when deciding package */
3644 stash = PAD_COMPNAME_TYPE(o->op_targ);
3646 stash = PL_curstash;
3647 apply_attrs_my(stash, o, attrs, imopsp);
3649 o->op_flags |= OPf_MOD;
3650 o->op_private |= OPpLVAL_INTRO;
3652 o->op_private |= OPpPAD_STATE;
3657 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3660 int maybe_scalar = 0;
3662 PERL_ARGS_ASSERT_MY_ATTRS;
3664 /* [perl #17376]: this appears to be premature, and results in code such as
3665 C< our(%x); > executing in list mode rather than void mode */
3667 if (o->op_flags & OPf_PARENS)
3677 o = my_kid(o, attrs, &rops);
3679 if (maybe_scalar && o->op_type == OP_PADSV) {
3680 o = scalar(op_append_list(OP_LIST, rops, o));
3681 o->op_private |= OPpLVAL_INTRO;
3684 /* The listop in rops might have a pushmark at the beginning,
3685 which will mess up list assignment. */
3686 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3687 if (rops->op_type == OP_LIST &&
3688 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3690 OP * const pushmark = lrops->op_first;
3691 /* excise pushmark */
3692 op_sibling_splice(rops, NULL, 1, NULL);
3695 o = op_append_list(OP_LIST, o, rops);
3698 PL_parser->in_my = FALSE;
3699 PL_parser->in_my_stash = NULL;
3704 Perl_sawparens(pTHX_ OP *o)
3706 PERL_UNUSED_CONTEXT;
3708 o->op_flags |= OPf_PARENS;
3713 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3717 const OPCODE ltype = left->op_type;
3718 const OPCODE rtype = right->op_type;
3720 PERL_ARGS_ASSERT_BIND_MATCH;
3722 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3723 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3725 const char * const desc
3727 rtype == OP_SUBST || rtype == OP_TRANS
3728 || rtype == OP_TRANSR
3730 ? (int)rtype : OP_MATCH];
3731 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3733 S_op_varname(aTHX_ left);
3735 Perl_warner(aTHX_ packWARN(WARN_MISC),
3736 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3737 desc, SVfARG(name), SVfARG(name));
3739 const char * const sample = (isary
3740 ? "@array" : "%hash");
3741 Perl_warner(aTHX_ packWARN(WARN_MISC),
3742 "Applying %s to %s will act on scalar(%s)",
3743 desc, sample, sample);
3747 if (rtype == OP_CONST &&
3748 cSVOPx(right)->op_private & OPpCONST_BARE &&
3749 cSVOPx(right)->op_private & OPpCONST_STRICT)
3751 no_bareword_allowed(right);
3754 /* !~ doesn't make sense with /r, so error on it for now */
3755 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3757 /* diag_listed_as: Using !~ with %s doesn't make sense */
3758 yyerror("Using !~ with s///r doesn't make sense");
3759 if (rtype == OP_TRANSR && type == OP_NOT)
3760 /* diag_listed_as: Using !~ with %s doesn't make sense */
3761 yyerror("Using !~ with tr///r doesn't make sense");
3763 ismatchop = (rtype == OP_MATCH ||
3764 rtype == OP_SUBST ||
3765 rtype == OP_TRANS || rtype == OP_TRANSR)
3766 && !(right->op_flags & OPf_SPECIAL);
3767 if (ismatchop && right->op_private & OPpTARGET_MY) {
3769 right->op_private &= ~OPpTARGET_MY;
3771 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3772 if (left->op_type == OP_PADSV
3773 && !(left->op_private & OPpLVAL_INTRO))
3775 right->op_targ = left->op_targ;
3780 right->op_flags |= OPf_STACKED;
3781 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3782 ! (rtype == OP_TRANS &&
3783 right->op_private & OPpTRANS_IDENTICAL) &&
3784 ! (rtype == OP_SUBST &&
3785 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3786 left = op_lvalue(left, rtype);
3787 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3788 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3790 o = op_prepend_elem(rtype, scalar(left), right);
3793 return newUNOP(OP_NOT, 0, scalar(o));
3797 return bind_match(type, left,
3798 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3802 Perl_invert(pTHX_ OP *o)
3806 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3810 =for apidoc Amx|OP *|op_scope|OP *o
3812 Wraps up an op tree with some additional ops so that at runtime a dynamic
3813 scope will be created. The original ops run in the new dynamic scope,
3814 and then, provided that they exit normally, the scope will be unwound.
3815 The additional ops used to create and unwind the dynamic scope will
3816 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3817 instead if the ops are simple enough to not need the full dynamic scope
3824 Perl_op_scope(pTHX_ OP *o)
3828 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3829 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3830 CHANGE_TYPE(o, OP_LEAVE);
3832 else if (o->op_type == OP_LINESEQ) {
3834 CHANGE_TYPE(o, OP_SCOPE);
3835 kid = ((LISTOP*)o)->op_first;
3836 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3839 /* The following deals with things like 'do {1 for 1}' */
3840 kid = OpSIBLING(kid);
3842 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3847 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3853 Perl_op_unscope(pTHX_ OP *o)
3855 if (o && o->op_type == OP_LINESEQ) {
3856 OP *kid = cLISTOPo->op_first;
3857 for(; kid; kid = OpSIBLING(kid))
3858 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3865 =for apidoc Am|int|block_start|int full
3867 Handles compile-time scope entry.
3868 Arranges for hints to be restored on block
3869 exit and also handles pad sequence numbers to make lexical variables scope
3870 right. Returns a savestack index for use with C<block_end>.
3876 Perl_block_start(pTHX_ int full)
3878 const int retval = PL_savestack_ix;
3880 PL_compiling.cop_seq = PL_cop_seqmax;
3882 pad_block_start(full);
3884 PL_hints &= ~HINT_BLOCK_SCOPE;
3885 SAVECOMPILEWARNINGS();
3886 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3887 SAVEI32(PL_compiling.cop_seq);
3888 PL_compiling.cop_seq = 0;
3890 CALL_BLOCK_HOOKS(bhk_start, full);
3896 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
3898 Handles compile-time scope exit. I<floor>
3899 is the savestack index returned by
3900 C<block_start>, and I<seq> is the body of the block. Returns the block,
3907 Perl_block_end(pTHX_ I32 floor, OP *seq)
3909 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3910 OP* retval = scalarseq(seq);
3913 /* XXX Is the null PL_parser check necessary here? */
3914 assert(PL_parser); /* Let’s find out under debugging builds. */
3915 if (PL_parser && PL_parser->parsed_sub) {
3916 o = newSTATEOP(0, NULL, NULL);
3918 retval = op_append_elem(OP_LINESEQ, retval, o);
3921 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3925 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3929 /* pad_leavemy has created a sequence of introcv ops for all my
3930 subs declared in the block. We have to replicate that list with
3931 clonecv ops, to deal with this situation:
3936 sub s1 { state sub foo { \&s2 } }
3939 Originally, I was going to have introcv clone the CV and turn
3940 off the stale flag. Since &s1 is declared before &s2, the
3941 introcv op for &s1 is executed (on sub entry) before the one for
3942 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3943 cloned, since it is a state sub) closes over &s2 and expects
3944 to see it in its outer CV’s pad. If the introcv op clones &s1,
3945 then &s2 is still marked stale. Since &s1 is not active, and
3946 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3947 ble will not stay shared’ warning. Because it is the same stub
3948 that will be used when the introcv op for &s2 is executed, clos-
3949 ing over it is safe. Hence, we have to turn off the stale flag
3950 on all lexical subs in the block before we clone any of them.
3951 Hence, having introcv clone the sub cannot work. So we create a
3952 list of ops like this:
3976 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3977 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3978 for (;; kid = OpSIBLING(kid)) {
3979 OP *newkid = newOP(OP_CLONECV, 0);
3980 newkid->op_targ = kid->op_targ;
3981 o = op_append_elem(OP_LINESEQ, o, newkid);
3982 if (kid == last) break;
3984 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3987 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3993 =head1 Compile-time scope hooks
3995 =for apidoc Aox||blockhook_register
3997 Register a set of hooks to be called when the Perl lexical scope changes
3998 at compile time. See L<perlguts/"Compile-time scope hooks">.
4004 Perl_blockhook_register(pTHX_ BHK *hk)
4006 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4008 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4012 Perl_newPROG(pTHX_ OP *o)
4014 PERL_ARGS_ASSERT_NEWPROG;
4021 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4022 ((PL_in_eval & EVAL_KEEPERR)
4023 ? OPf_SPECIAL : 0), o);
4025 cx = &cxstack[cxstack_ix];
4026 assert(CxTYPE(cx) == CXt_EVAL);
4028 if ((cx->blk_gimme & G_WANT) == G_VOID)
4029 scalarvoid(PL_eval_root);
4030 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4033 scalar(PL_eval_root);
4035 PL_eval_start = op_linklist(PL_eval_root);
4036 PL_eval_root->op_private |= OPpREFCOUNTED;
4037 OpREFCNT_set(PL_eval_root, 1);
4038 PL_eval_root->op_next = 0;
4039 i = PL_savestack_ix;
4042 CALL_PEEP(PL_eval_start);
4043 finalize_optree(PL_eval_root);
4044 S_prune_chain_head(&PL_eval_start);
4046 PL_savestack_ix = i;
4049 if (o->op_type == OP_STUB) {
4050 /* This block is entered if nothing is compiled for the main
4051 program. This will be the case for an genuinely empty main
4052 program, or one which only has BEGIN blocks etc, so already
4055 Historically (5.000) the guard above was !o. However, commit
4056 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4057 c71fccf11fde0068, changed perly.y so that newPROG() is now
4058 called with the output of block_end(), which returns a new
4059 OP_STUB for the case of an empty optree. ByteLoader (and
4060 maybe other things) also take this path, because they set up
4061 PL_main_start and PL_main_root directly, without generating an
4064 If the parsing the main program aborts (due to parse errors,
4065 or due to BEGIN or similar calling exit), then newPROG()
4066 isn't even called, and hence this code path and its cleanups
4067 are skipped. This shouldn't make a make a difference:
4068 * a non-zero return from perl_parse is a failure, and
4069 perl_destruct() should be called immediately.
4070 * however, if exit(0) is called during the parse, then
4071 perl_parse() returns 0, and perl_run() is called. As
4072 PL_main_start will be NULL, perl_run() will return
4073 promptly, and the exit code will remain 0.
4076 PL_comppad_name = 0;
4078 S_op_destroy(aTHX_ o);
4081 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4082 PL_curcop = &PL_compiling;
4083 PL_main_start = LINKLIST(PL_main_root);
4084 PL_main_root->op_private |= OPpREFCOUNTED;
4085 OpREFCNT_set(PL_main_root, 1);
4086 PL_main_root->op_next = 0;
4087 CALL_PEEP(PL_main_start);
4088 finalize_optree(PL_main_root);
4089 S_prune_chain_head(&PL_main_start);
4090 cv_forget_slab(PL_compcv);
4093 /* Register with debugger */
4095 CV * const cv = get_cvs("DB::postponed", 0);
4099 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4101 call_sv(MUTABLE_SV(cv), G_DISCARD);
4108 Perl_localize(pTHX_ OP *o, I32 lex)
4110 PERL_ARGS_ASSERT_LOCALIZE;
4112 if (o->op_flags & OPf_PARENS)
4113 /* [perl #17376]: this appears to be premature, and results in code such as
4114 C< our(%x); > executing in list mode rather than void mode */
4121 if ( PL_parser->bufptr > PL_parser->oldbufptr
4122 && PL_parser->bufptr[-1] == ','
4123 && ckWARN(WARN_PARENTHESIS))
4125 char *s = PL_parser->bufptr;
4128 /* some heuristics to detect a potential error */
4129 while (*s && (strchr(", \t\n", *s)))
4133 if (*s && strchr("@$%*", *s) && *++s
4134 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4137 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4139 while (*s && (strchr(", \t\n", *s)))
4145 if (sigil && (*s == ';' || *s == '=')) {
4146 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4147 "Parentheses missing around \"%s\" list",
4149 ? (PL_parser->in_my == KEY_our
4151 : PL_parser->in_my == KEY_state
4161 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4162 PL_parser->in_my = FALSE;
4163 PL_parser->in_my_stash = NULL;
4168 Perl_jmaybe(pTHX_ OP *o)
4170 PERL_ARGS_ASSERT_JMAYBE;
4172 if (o->op_type == OP_LIST) {
4174 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4175 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4180 PERL_STATIC_INLINE OP *
4181 S_op_std_init(pTHX_ OP *o)
4183 I32 type = o->op_type;
4185 PERL_ARGS_ASSERT_OP_STD_INIT;
4187 if (PL_opargs[type] & OA_RETSCALAR)
4189 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4190 o->op_targ = pad_alloc(type, SVs_PADTMP);
4195 PERL_STATIC_INLINE OP *
4196 S_op_integerize(pTHX_ OP *o)
4198 I32 type = o->op_type;
4200 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4202 /* integerize op. */
4203 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4206 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4209 if (type == OP_NEGATE)
4210 /* XXX might want a ck_negate() for this */
4211 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4217 S_fold_constants(pTHX_ OP *o)
4222 VOL I32 type = o->op_type;
4228 SV * const oldwarnhook = PL_warnhook;
4229 SV * const olddiehook = PL_diehook;
4231 U8 oldwarn = PL_dowarn;
4234 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4236 if (!(PL_opargs[type] & OA_FOLDCONST))
4245 #ifdef USE_LOCALE_CTYPE
4246 if (IN_LC_COMPILETIME(LC_CTYPE))
4255 #ifdef USE_LOCALE_COLLATE
4256 if (IN_LC_COMPILETIME(LC_COLLATE))
4261 /* XXX what about the numeric ops? */
4262 #ifdef USE_LOCALE_NUMERIC
4263 if (IN_LC_COMPILETIME(LC_NUMERIC))
4268 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4269 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4272 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4273 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4275 const char *s = SvPVX_const(sv);
4276 while (s < SvEND(sv)) {
4277 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4284 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4287 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4288 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4292 if (PL_parser && PL_parser->error_count)
4293 goto nope; /* Don't try to run w/ errors */
4295 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4296 const OPCODE type = curop->op_type;
4297 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
4299 type != OP_SCALAR &&
4301 type != OP_PUSHMARK)
4307 curop = LINKLIST(o);
4308 old_next = o->op_next;
4312 oldscope = PL_scopestack_ix;
4313 create_eval_scope(G_FAKINGEVAL);
4315 /* Verify that we don't need to save it: */
4316 assert(PL_curcop == &PL_compiling);
4317 StructCopy(&PL_compiling, ¬_compiling, COP);
4318 PL_curcop = ¬_compiling;
4319 /* The above ensures that we run with all the correct hints of the
4320 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4321 assert(IN_PERL_RUNTIME);
4322 PL_warnhook = PERL_WARNHOOK_FATAL;
4326 /* Effective $^W=1. */
4327 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4328 PL_dowarn |= G_WARN_ON;
4333 sv = *(PL_stack_sp--);
4334 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4335 pad_swipe(o->op_targ, FALSE);
4337 else if (SvTEMP(sv)) { /* grab mortal temp? */
4338 SvREFCNT_inc_simple_void(sv);
4341 else { assert(SvIMMORTAL(sv)); }
4344 /* Something tried to die. Abandon constant folding. */
4345 /* Pretend the error never happened. */
4347 o->op_next = old_next;
4351 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4352 PL_warnhook = oldwarnhook;
4353 PL_diehook = olddiehook;
4354 /* XXX note that this croak may fail as we've already blown away
4355 * the stack - eg any nested evals */
4356 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4359 PL_dowarn = oldwarn;
4360 PL_warnhook = oldwarnhook;
4361 PL_diehook = olddiehook;
4362 PL_curcop = &PL_compiling;
4364 if (PL_scopestack_ix > oldscope)
4365 delete_eval_scope();
4370 /* OP_STRINGIFY and constant folding are used to implement qq.
4371 Here the constant folding is an implementation detail that we
4372 want to hide. If the stringify op is itself already marked
4373 folded, however, then it is actually a folded join. */
4374 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4379 else if (!SvIMMORTAL(sv)) {
4383 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4384 if (!is_stringify) newop->op_folded = 1;
4392 S_gen_constant_list(pTHX_ OP *o)
4396 const SSize_t oldtmps_floor = PL_tmps_floor;
4401 if (PL_parser && PL_parser->error_count)
4402 return o; /* Don't attempt to run with errors */
4404 curop = LINKLIST(o);
4407 S_prune_chain_head(&curop);
4409 Perl_pp_pushmark(aTHX);
4412 assert (!(curop->op_flags & OPf_SPECIAL));
4413 assert(curop->op_type == OP_RANGE);
4414 Perl_pp_anonlist(aTHX);
4415 PL_tmps_floor = oldtmps_floor;
4417 CHANGE_TYPE(o, OP_RV2AV);
4418 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4419 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4420 o->op_opt = 0; /* needs to be revisited in rpeep() */
4421 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4423 /* replace subtree with an OP_CONST */
4424 curop = ((UNOP*)o)->op_first;
4425 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4428 if (AvFILLp(av) != -1)
4429 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4432 SvREADONLY_on(*svp);
4439 =head1 Optree Manipulation Functions
4442 /* List constructors */
4445 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4447 Append an item to the list of ops contained directly within a list-type
4448 op, returning the lengthened list. I<first> is the list-type op,
4449 and I<last> is the op to append to the list. I<optype> specifies the
4450 intended opcode for the list. If I<first> is not already a list of the
4451 right type, it will be upgraded into one. If either I<first> or I<last>
4452 is null, the other is returned unchanged.
4458 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4466 if (first->op_type != (unsigned)type
4467 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4469 return newLISTOP(type, 0, first, last);
4472 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4473 first->op_flags |= OPf_KIDS;
4478 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4480 Concatenate the lists of ops contained directly within two list-type ops,
4481 returning the combined list. I<first> and I<last> are the list-type ops
4482 to concatenate. I<optype> specifies the intended opcode for the list.
4483 If either I<first> or I<last> is not already a list of the right type,
4484 it will be upgraded into one. If either I<first> or I<last> is null,
4485 the other is returned unchanged.
4491 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4499 if (first->op_type != (unsigned)type)
4500 return op_prepend_elem(type, first, last);
4502 if (last->op_type != (unsigned)type)
4503 return op_append_elem(type, first, last);
4505 ((LISTOP*)first)->op_last->op_lastsib = 0;
4506 OpSIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4507 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4508 ((LISTOP*)first)->op_last->op_lastsib = 1;
4509 #ifdef PERL_OP_PARENT
4510 ((LISTOP*)first)->op_last->op_sibling = first;
4512 first->op_flags |= (last->op_flags & OPf_KIDS);
4515 S_op_destroy(aTHX_ last);
4521 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4523 Prepend an item to the list of ops contained directly within a list-type
4524 op, returning the lengthened list. I<first> is the op to prepend to the
4525 list, and I<last> is the list-type op. I<optype> specifies the intended
4526 opcode for the list. If I<last> is not already a list of the right type,
4527 it will be upgraded into one. If either I<first> or I<last> is null,
4528 the other is returned unchanged.
4534 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4542 if (last->op_type == (unsigned)type) {
4543 if (type == OP_LIST) { /* already a PUSHMARK there */
4544 /* insert 'first' after pushmark */
4545 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4546 if (!(first->op_flags & OPf_PARENS))
4547 last->op_flags &= ~OPf_PARENS;
4550 op_sibling_splice(last, NULL, 0, first);
4551 last->op_flags |= OPf_KIDS;
4555 return newLISTOP(type, 0, first, last);
4559 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4561 Converts I<o> into a list op if it is not one already, and then converts it
4562 into the specified I<type>, calling its check function, allocating a target if
4563 it needs one, and folding constants.
4565 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4566 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4567 C<op_convert_list> to make it the right type.
4573 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4576 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4577 if (!o || o->op_type != OP_LIST)
4578 o = force_list(o, 0);
4580 o->op_flags &= ~OPf_WANT;
4582 if (!(PL_opargs[type] & OA_MARK))
4583 op_null(cLISTOPo->op_first);
4585 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4586 if (kid2 && kid2->op_type == OP_COREARGS) {
4587 op_null(cLISTOPo->op_first);
4588 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4592 CHANGE_TYPE(o, type);
4593 o->op_flags |= flags;
4594 if (flags & OPf_FOLDED)
4597 o = CHECKOP(type, o);
4598 if (o->op_type != (unsigned)type)
4601 return fold_constants(op_integerize(op_std_init(o)));
4608 =head1 Optree construction
4610 =for apidoc Am|OP *|newNULLLIST
4612 Constructs, checks, and returns a new C<stub> op, which represents an
4613 empty list expression.
4619 Perl_newNULLLIST(pTHX)
4621 return newOP(OP_STUB, 0);
4624 /* promote o and any siblings to be a list if its not already; i.e.
4632 * pushmark - o - A - B
4634 * If nullit it true, the list op is nulled.
4638 S_force_list(pTHX_ OP *o, bool nullit)
4640 if (!o || o->op_type != OP_LIST) {
4643 /* manually detach any siblings then add them back later */
4644 rest = OpSIBLING(o);
4645 OpSIBLING_set(o, NULL);
4648 o = newLISTOP(OP_LIST, 0, o, NULL);
4650 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4658 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4660 Constructs, checks, and returns an op of any list type. I<type> is
4661 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4662 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4663 supply up to two ops to be direct children of the list op; they are
4664 consumed by this function and become part of the constructed op tree.
4666 For most list operators, the check function expects all the kid ops to be
4667 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.,) is not
4668 appropriate. What you want to do in that case is create an op of type
4669 OP_LIST, append more children to it, and then call L</op_convert_list>.
4670 See L</op_convert_list> for more information.
4677 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4682 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4683 || type == OP_CUSTOM);
4685 NewOp(1101, listop, 1, LISTOP);
4687 CHANGE_TYPE(listop, type);
4690 listop->op_flags = (U8)flags;
4694 else if (!first && last)
4697 OpSIBLING_set(first, last);
4698 listop->op_first = first;
4699 listop->op_last = last;
4700 if (type == OP_LIST) {
4701 OP* const pushop = newOP(OP_PUSHMARK, 0);
4702 pushop->op_lastsib = 0;
4703 OpSIBLING_set(pushop, first);
4704 listop->op_first = pushop;
4705 listop->op_flags |= OPf_KIDS;
4707 listop->op_last = pushop;
4710 first->op_lastsib = 0;
4711 if (listop->op_last) {
4712 listop->op_last->op_lastsib = 1;
4713 #ifdef PERL_OP_PARENT
4714 listop->op_last->op_sibling = (OP*)listop;
4718 return CHECKOP(type, listop);
4722 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4724 Constructs, checks, and returns an op of any base type (any type that
4725 has no extra fields). I<type> is the opcode. I<flags> gives the
4726 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4733 Perl_newOP(pTHX_ I32 type, I32 flags)
4738 if (type == -OP_ENTEREVAL) {
4739 type = OP_ENTEREVAL;
4740 flags |= OPpEVAL_BYTES<<8;
4743 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4744 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4745 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4746 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4748 NewOp(1101, o, 1, OP);
4749 CHANGE_TYPE(o, type);
4750 o->op_flags = (U8)flags;
4753 o->op_private = (U8)(0 | (flags >> 8));
4754 if (PL_opargs[type] & OA_RETSCALAR)
4756 if (PL_opargs[type] & OA_TARGET)
4757 o->op_targ = pad_alloc(type, SVs_PADTMP);
4758 return CHECKOP(type, o);
4762 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4764 Constructs, checks, and returns an op of any unary type. I<type> is
4765 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4766 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4767 bits, the eight bits of C<op_private>, except that the bit with value 1
4768 is automatically set. I<first> supplies an optional op to be the direct
4769 child of the unary op; it is consumed by this function and become part
4770 of the constructed op tree.
4776 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4781 if (type == -OP_ENTEREVAL) {
4782 type = OP_ENTEREVAL;
4783 flags |= OPpEVAL_BYTES<<8;
4786 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4787 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4788 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4789 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4790 || type == OP_SASSIGN
4791 || type == OP_ENTERTRY
4792 || type == OP_CUSTOM
4793 || type == OP_NULL );
4796 first = newOP(OP_STUB, 0);
4797 if (PL_opargs[type] & OA_MARK)
4798 first = force_list(first, 1);
4800 NewOp(1101, unop, 1, UNOP);
4801 CHANGE_TYPE(unop, type);
4802 unop->op_first = first;
4803 unop->op_flags = (U8)(flags | OPf_KIDS);
4804 unop->op_private = (U8)(1 | (flags >> 8));
4806 #ifdef PERL_OP_PARENT
4807 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4808 first->op_sibling = (OP*)unop;
4811 unop = (UNOP*) CHECKOP(type, unop);
4815 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4819 =for apidoc newUNOP_AUX
4821 Similar to C<newUNOP>, but creates an UNOP_AUX struct instead, with op_aux
4828 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
4833 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
4834 || type == OP_CUSTOM);
4836 NewOp(1101, unop, 1, UNOP_AUX);
4837 unop->op_type = (OPCODE)type;
4838 unop->op_ppaddr = PL_ppaddr[type];
4839 unop->op_first = first;
4840 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
4841 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
4844 #ifdef PERL_OP_PARENT
4845 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
4846 first->op_sibling = (OP*)unop;
4849 unop = (UNOP_AUX*) CHECKOP(type, unop);
4851 return op_std_init((OP *) unop);
4855 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4857 Constructs, checks, and returns an op of method type with a method name
4858 evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
4859 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4860 and, shifted up eight bits, the eight bits of C<op_private>, except that
4861 the bit with value 1 is automatically set. I<dynamic_meth> supplies an
4862 op which evaluates method name; it is consumed by this function and
4863 become part of the constructed op tree.
4864 Supported optypes: OP_METHOD.
4870 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4874 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
4875 || type == OP_CUSTOM);
4877 NewOp(1101, methop, 1, METHOP);
4879 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4880 methop->op_flags = (U8)(flags | OPf_KIDS);
4881 methop->op_u.op_first = dynamic_meth;
4882 methop->op_private = (U8)(1 | (flags >> 8));
4884 #ifdef PERL_OP_PARENT
4885 if (!OpHAS_SIBLING(dynamic_meth))
4886 dynamic_meth->op_sibling = (OP*)methop;
4891 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4892 methop->op_u.op_meth_sv = const_meth;
4893 methop->op_private = (U8)(0 | (flags >> 8));
4894 methop->op_next = (OP*)methop;
4898 methop->op_rclass_targ = 0;
4900 methop->op_rclass_sv = NULL;
4903 CHANGE_TYPE(methop, type);
4904 return CHECKOP(type, methop);
4908 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4909 PERL_ARGS_ASSERT_NEWMETHOP;
4910 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4914 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4916 Constructs, checks, and returns an op of method type with a constant
4917 method name. I<type> is the opcode. I<flags> gives the eight bits of
4918 C<op_flags>, and, shifted up eight bits, the eight bits of
4919 C<op_private>. I<const_meth> supplies a constant method name;
4920 it must be a shared COW string.
4921 Supported optypes: OP_METHOD_NAMED.
4927 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4928 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4929 return newMETHOP_internal(type, flags, NULL, const_meth);
4933 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4935 Constructs, checks, and returns an op of any binary type. I<type>
4936 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4937 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4938 the eight bits of C<op_private>, except that the bit with value 1 or
4939 2 is automatically set as required. I<first> and I<last> supply up to
4940 two ops to be the direct children of the binary op; they are consumed
4941 by this function and become part of the constructed op tree.
4947 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4952 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4953 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
4955 NewOp(1101, binop, 1, BINOP);
4958 first = newOP(OP_NULL, 0);
4960 CHANGE_TYPE(binop, type);
4961 binop->op_first = first;
4962 binop->op_flags = (U8)(flags | OPf_KIDS);
4965 binop->op_private = (U8)(1 | (flags >> 8));
4968 binop->op_private = (U8)(2 | (flags >> 8));
4969 OpSIBLING_set(first, last);
4970 first->op_lastsib = 0;
4973 #ifdef PERL_OP_PARENT
4974 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
4975 last->op_sibling = (OP*)binop;
4978 binop->op_last = OpSIBLING(binop->op_first);
4979 #ifdef PERL_OP_PARENT
4981 binop->op_last->op_sibling = (OP*)binop;
4984 binop = (BINOP*)CHECKOP(type, binop);
4985 if (binop->op_next || binop->op_type != (OPCODE)type)
4988 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4991 static int uvcompare(const void *a, const void *b)
4992 __attribute__nonnull__(1)
4993 __attribute__nonnull__(2)
4994 __attribute__pure__;
4995 static int uvcompare(const void *a, const void *b)
4997 if (*((const UV *)a) < (*(const UV *)b))
4999 if (*((const UV *)a) > (*(const UV *)b))
5001 if (*((const UV *)a+1) < (*(const UV *)b+1))
5003 if (*((const UV *)a+1) > (*(const UV *)b+1))
5009 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5011 SV * const tstr = ((SVOP*)expr)->op_sv;
5013 ((SVOP*)repl)->op_sv;
5016 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5017 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5023 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5024 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5025 I32 del = o->op_private & OPpTRANS_DELETE;
5028 PERL_ARGS_ASSERT_PMTRANS;
5030 PL_hints |= HINT_BLOCK_SCOPE;
5033 o->op_private |= OPpTRANS_FROM_UTF;
5036 o->op_private |= OPpTRANS_TO_UTF;
5038 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5039 SV* const listsv = newSVpvs("# comment\n");
5041 const U8* tend = t + tlen;
5042 const U8* rend = r + rlen;
5058 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5059 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5062 const U32 flags = UTF8_ALLOW_DEFAULT;
5066 t = tsave = bytes_to_utf8(t, &len);
5069 if (!to_utf && rlen) {
5071 r = rsave = bytes_to_utf8(r, &len);
5075 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5076 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5080 U8 tmpbuf[UTF8_MAXBYTES+1];
5083 Newx(cp, 2*tlen, UV);
5085 transv = newSVpvs("");
5087 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5089 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5091 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5095 cp[2*i+1] = cp[2*i];
5099 qsort(cp, i, 2*sizeof(UV), uvcompare);
5100 for (j = 0; j < i; j++) {
5102 diff = val - nextmin;
5104 t = uvchr_to_utf8(tmpbuf,nextmin);
5105 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5107 U8 range_mark = ILLEGAL_UTF8_BYTE;
5108 t = uvchr_to_utf8(tmpbuf, val - 1);
5109 sv_catpvn(transv, (char *)&range_mark, 1);
5110 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5117 t = uvchr_to_utf8(tmpbuf,nextmin);
5118 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5120 U8 range_mark = ILLEGAL_UTF8_BYTE;
5121 sv_catpvn(transv, (char *)&range_mark, 1);
5123 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5124 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5125 t = (const U8*)SvPVX_const(transv);
5126 tlen = SvCUR(transv);
5130 else if (!rlen && !del) {
5131 r = t; rlen = tlen; rend = tend;
5134 if ((!rlen && !del) || t == r ||
5135 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5137 o->op_private |= OPpTRANS_IDENTICAL;
5141 while (t < tend || tfirst <= tlast) {
5142 /* see if we need more "t" chars */
5143 if (tfirst > tlast) {
5144 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5146 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5148 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5155 /* now see if we need more "r" chars */
5156 if (rfirst > rlast) {
5158 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5160 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5162 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5171 rfirst = rlast = 0xffffffff;
5175 /* now see which range will peter our first, if either. */
5176 tdiff = tlast - tfirst;
5177 rdiff = rlast - rfirst;
5178 tcount += tdiff + 1;
5179 rcount += rdiff + 1;
5186 if (rfirst == 0xffffffff) {
5187 diff = tdiff; /* oops, pretend rdiff is infinite */
5189 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5190 (long)tfirst, (long)tlast);
5192 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5196 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5197 (long)tfirst, (long)(tfirst + diff),
5200 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5201 (long)tfirst, (long)rfirst);
5203 if (rfirst + diff > max)
5204 max = rfirst + diff;
5206 grows = (tfirst < rfirst &&
5207 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
5219 else if (max > 0xff)
5224 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5226 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5227 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5228 PAD_SETSV(cPADOPo->op_padix, swash);
5230 SvREADONLY_on(swash);
5232 cSVOPo->op_sv = swash;
5234 SvREFCNT_dec(listsv);
5235 SvREFCNT_dec(transv);
5237 if (!del && havefinal && rlen)
5238 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5239 newSVuv((UV)final), 0);
5248 else if (rlast == 0xffffffff)
5254 tbl = (short*)PerlMemShared_calloc(
5255 (o->op_private & OPpTRANS_COMPLEMENT) &&
5256 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5258 cPVOPo->op_pv = (char*)tbl;
5260 for (i = 0; i < (I32)tlen; i++)
5262 for (i = 0, j = 0; i < 256; i++) {
5264 if (j >= (I32)rlen) {
5273 if (i < 128 && r[j] >= 128)
5283 o->op_private |= OPpTRANS_IDENTICAL;
5285 else if (j >= (I32)rlen)
5290 PerlMemShared_realloc(tbl,
5291 (0x101+rlen-j) * sizeof(short));
5292 cPVOPo->op_pv = (char*)tbl;
5294 tbl[0x100] = (short)(rlen - j);
5295 for (i=0; i < (I32)rlen - j; i++)
5296 tbl[0x101+i] = r[j+i];
5300 if (!rlen && !del) {
5303 o->op_private |= OPpTRANS_IDENTICAL;
5305 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5306 o->op_private |= OPpTRANS_IDENTICAL;
5308 for (i = 0; i < 256; i++)
5310 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5311 if (j >= (I32)rlen) {
5313 if (tbl[t[i]] == -1)
5319 if (tbl[t[i]] == -1) {
5320 if (t[i] < 128 && r[j] >= 128)
5328 if(del && rlen == tlen) {
5329 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5330 } else if(rlen > tlen && !complement) {
5331 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5335 o->op_private |= OPpTRANS_GROWS;
5343 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5345 Constructs, checks, and returns an op of any pattern matching type.
5346 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
5347 and, shifted up eight bits, the eight bits of C<op_private>.
5353 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5358 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5359 || type == OP_CUSTOM);
5361 NewOp(1101, pmop, 1, PMOP);
5362 CHANGE_TYPE(pmop, type);
5363 pmop->op_flags = (U8)flags;
5364 pmop->op_private = (U8)(0 | (flags >> 8));
5365 if (PL_opargs[type] & OA_RETSCALAR)
5368 if (PL_hints & HINT_RE_TAINT)
5369 pmop->op_pmflags |= PMf_RETAINT;
5370 #ifdef USE_LOCALE_CTYPE
5371 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5372 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5377 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5379 if (PL_hints & HINT_RE_FLAGS) {
5380 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5381 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5383 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5384 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5385 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5387 if (reflags && SvOK(reflags)) {
5388 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5394 assert(SvPOK(PL_regex_pad[0]));
5395 if (SvCUR(PL_regex_pad[0])) {
5396 /* Pop off the "packed" IV from the end. */
5397 SV *const repointer_list = PL_regex_pad[0];
5398 const char *p = SvEND(repointer_list) - sizeof(IV);
5399 const IV offset = *((IV*)p);
5401 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5403 SvEND_set(repointer_list, p);
5405 pmop->op_pmoffset = offset;
5406 /* This slot should be free, so assert this: */
5407 assert(PL_regex_pad[offset] == &PL_sv_undef);
5409 SV * const repointer = &PL_sv_undef;
5410 av_push(PL_regex_padav, repointer);
5411 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5412 PL_regex_pad = AvARRAY(PL_regex_padav);
5416 return CHECKOP(type, pmop);
5424 /* Any pad names in scope are potentially lvalues. */
5425 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5426 PADNAME *pn = PAD_COMPNAME_SV(i);
5427 if (!pn || !PadnameLEN(pn))
5429 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5430 S_mark_padname_lvalue(aTHX_ pn);
5434 /* Given some sort of match op o, and an expression expr containing a
5435 * pattern, either compile expr into a regex and attach it to o (if it's
5436 * constant), or convert expr into a runtime regcomp op sequence (if it's
5439 * isreg indicates that the pattern is part of a regex construct, eg
5440 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5441 * split "pattern", which aren't. In the former case, expr will be a list
5442 * if the pattern contains more than one term (eg /a$b/).
5444 * When the pattern has been compiled within a new anon CV (for
5445 * qr/(?{...})/ ), then floor indicates the savestack level just before
5446 * the new sub was created
5450 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5454 I32 repl_has_vars = 0;
5455 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5456 bool is_compiletime;
5459 PERL_ARGS_ASSERT_PMRUNTIME;
5462 return pmtrans(o, expr, repl);
5465 /* find whether we have any runtime or code elements;
5466 * at the same time, temporarily set the op_next of each DO block;
5467 * then when we LINKLIST, this will cause the DO blocks to be excluded
5468 * from the op_next chain (and from having LINKLIST recursively
5469 * applied to them). We fix up the DOs specially later */
5473 if (expr->op_type == OP_LIST) {
5475 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5476 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5478 assert(!o->op_next);
5479 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5480 assert(PL_parser && PL_parser->error_count);
5481 /* This can happen with qr/ (?{(^{})/. Just fake up
5482 the op we were expecting to see, to avoid crashing
5484 op_sibling_splice(expr, o, 0,
5485 newSVOP(OP_CONST, 0, &PL_sv_no));
5487 o->op_next = OpSIBLING(o);
5489 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5493 else if (expr->op_type != OP_CONST)
5498 /* fix up DO blocks; treat each one as a separate little sub;
5499 * also, mark any arrays as LIST/REF */
5501 if (expr->op_type == OP_LIST) {
5503 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5505 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5506 assert( !(o->op_flags & OPf_WANT));
5507 /* push the array rather than its contents. The regex
5508 * engine will retrieve and join the elements later */
5509 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5513 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5515 o->op_next = NULL; /* undo temporary hack from above */
5518 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5519 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5521 assert(leaveop->op_first->op_type == OP_ENTER);
5522 assert(OpHAS_SIBLING(leaveop->op_first));
5523 o->op_next = OpSIBLING(leaveop->op_first);
5525 assert(leaveop->op_flags & OPf_KIDS);
5526 assert(leaveop->op_last->op_next == (OP*)leaveop);
5527 leaveop->op_next = NULL; /* stop on last op */
5528 op_null((OP*)leaveop);
5532 OP *scope = cLISTOPo->op_first;
5533 assert(scope->op_type == OP_SCOPE);
5534 assert(scope->op_flags & OPf_KIDS);
5535 scope->op_next = NULL; /* stop on last op */
5538 /* have to peep the DOs individually as we've removed it from
5539 * the op_next chain */
5541 S_prune_chain_head(&(o->op_next));
5543 /* runtime finalizes as part of finalizing whole tree */
5547 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5548 assert( !(expr->op_flags & OPf_WANT));
5549 /* push the array rather than its contents. The regex
5550 * engine will retrieve and join the elements later */
5551 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5554 PL_hints |= HINT_BLOCK_SCOPE;
5556 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5558 if (is_compiletime) {
5559 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5560 regexp_engine const *eng = current_re_engine();
5562 if (o->op_flags & OPf_SPECIAL)
5563 rx_flags |= RXf_SPLIT;
5565 if (!has_code || !eng->op_comp) {
5566 /* compile-time simple constant pattern */
5568 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5569 /* whoops! we guessed that a qr// had a code block, but we
5570 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5571 * that isn't required now. Note that we have to be pretty
5572 * confident that nothing used that CV's pad while the
5573 * regex was parsed, except maybe op targets for \Q etc.
5574 * If there were any op targets, though, they should have
5575 * been stolen by constant folding.
5579 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5580 while (++i <= AvFILLp(PL_comppad)) {
5581 assert(!PL_curpad[i]);
5584 /* But we know that one op is using this CV's slab. */
5585 cv_forget_slab(PL_compcv);
5587 pm->op_pmflags &= ~PMf_HAS_CV;
5592 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5593 rx_flags, pm->op_pmflags)
5594 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5595 rx_flags, pm->op_pmflags)
5600 /* compile-time pattern that includes literal code blocks */
5601 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5604 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5607 if (pm->op_pmflags & PMf_HAS_CV) {
5609 /* this QR op (and the anon sub we embed it in) is never
5610 * actually executed. It's just a placeholder where we can
5611 * squirrel away expr in op_code_list without the peephole
5612 * optimiser etc processing it for a second time */
5613 OP *qr = newPMOP(OP_QR, 0);
5614 ((PMOP*)qr)->op_code_list = expr;
5616 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5617 SvREFCNT_inc_simple_void(PL_compcv);
5618 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5619 ReANY(re)->qr_anoncv = cv;
5621 /* attach the anon CV to the pad so that
5622 * pad_fixup_inner_anons() can find it */
5623 (void)pad_add_anon(cv, o->op_type);
5624 SvREFCNT_inc_simple_void(cv);
5627 pm->op_code_list = expr;
5632 /* runtime pattern: build chain of regcomp etc ops */
5634 PADOFFSET cv_targ = 0;
5636 reglist = isreg && expr->op_type == OP_LIST;
5641 pm->op_code_list = expr;
5642 /* don't free op_code_list; its ops are embedded elsewhere too */
5643 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5646 if (o->op_flags & OPf_SPECIAL)
5647 pm->op_pmflags |= PMf_SPLIT;
5649 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5650 * to allow its op_next to be pointed past the regcomp and
5651 * preceding stacking ops;
5652 * OP_REGCRESET is there to reset taint before executing the
5654 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5655 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5657 if (pm->op_pmflags & PMf_HAS_CV) {
5658 /* we have a runtime qr with literal code. This means
5659 * that the qr// has been wrapped in a new CV, which
5660 * means that runtime consts, vars etc will have been compiled
5661 * against a new pad. So... we need to execute those ops
5662 * within the environment of the new CV. So wrap them in a call
5663 * to a new anon sub. i.e. for
5667 * we build an anon sub that looks like
5669 * sub { "a", $b, '(?{...})' }
5671 * and call it, passing the returned list to regcomp.
5672 * Or to put it another way, the list of ops that get executed
5676 * ------ -------------------
5677 * pushmark (for regcomp)
5678 * pushmark (for entersub)
5682 * regcreset regcreset
5684 * const("a") const("a")
5686 * const("(?{...})") const("(?{...})")
5691 SvREFCNT_inc_simple_void(PL_compcv);
5692 CvLVALUE_on(PL_compcv);
5693 /* these lines are just an unrolled newANONATTRSUB */
5694 expr = newSVOP(OP_ANONCODE, 0,
5695 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5696 cv_targ = expr->op_targ;
5697 expr = newUNOP(OP_REFGEN, 0, expr);
5699 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5702 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5703 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5704 | (reglist ? OPf_STACKED : 0);
5705 rcop->op_targ = cv_targ;
5707 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5708 if (PL_hints & HINT_RE_EVAL)
5709 S_set_haseval(aTHX);
5711 /* establish postfix order */
5712 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5714 rcop->op_next = expr;
5715 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5718 rcop->op_next = LINKLIST(expr);
5719 expr->op_next = (OP*)rcop;
5722 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5728 /* If we are looking at s//.../e with a single statement, get past
5729 the implicit do{}. */
5730 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5731 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5732 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5735 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5736 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5737 && !OpHAS_SIBLING(sib))
5740 if (curop->op_type == OP_CONST)
5742 else if (( (curop->op_type == OP_RV2SV ||
5743 curop->op_type == OP_RV2AV ||
5744 curop->op_type == OP_RV2HV ||
5745 curop->op_type == OP_RV2GV)
5746 && cUNOPx(curop)->op_first
5747 && cUNOPx(curop)->op_first->op_type == OP_GV )
5748 || curop->op_type == OP_PADSV
5749 || curop->op_type == OP_PADAV
5750 || curop->op_type == OP_PADHV
5751 || curop->op_type == OP_PADANY) {
5759 || !RX_PRELEN(PM_GETRE(pm))
5760 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5762 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5763 op_prepend_elem(o->op_type, scalar(repl), o);
5766 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5767 rcop->op_private = 1;
5769 /* establish postfix order */
5770 rcop->op_next = LINKLIST(repl);
5771 repl->op_next = (OP*)rcop;
5773 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5774 assert(!(pm->op_pmflags & PMf_ONCE));
5775 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5784 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5786 Constructs, checks, and returns an op of any type that involves an
5787 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
5788 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
5789 takes ownership of one reference to it.
5795 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5800 PERL_ARGS_ASSERT_NEWSVOP;
5802 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5803 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5804 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5805 || type == OP_CUSTOM);
5807 NewOp(1101, svop, 1, SVOP);
5808 CHANGE_TYPE(svop, type);
5810 svop->op_next = (OP*)svop;
5811 svop->op_flags = (U8)flags;
5812 svop->op_private = (U8)(0 | (flags >> 8));
5813 if (PL_opargs[type] & OA_RETSCALAR)
5815 if (PL_opargs[type] & OA_TARGET)
5816 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5817 return CHECKOP(type, svop);
5821 =for apidoc Am|OP *|newDEFSVOP|
5823 Constructs and returns an op to access C<$_>, either as a lexical
5824 variable (if declared as C<my $_>) in the current scope, or the
5831 Perl_newDEFSVOP(pTHX)
5833 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5834 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5835 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5838 OP * const o = newOP(OP_PADSV, 0);
5839 o->op_targ = offset;
5847 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5849 Constructs, checks, and returns an op of any type that involves a
5850 reference to a pad element. I<type> is the opcode. I<flags> gives the
5851 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5852 is populated with I<sv>; this function takes ownership of one reference
5855 This function only exists if Perl has been compiled to use ithreads.
5861 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5866 PERL_ARGS_ASSERT_NEWPADOP;
5868 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5869 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5870 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5871 || type == OP_CUSTOM);
5873 NewOp(1101, padop, 1, PADOP);
5874 CHANGE_TYPE(padop, type);
5876 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5877 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5878 PAD_SETSV(padop->op_padix, sv);
5880 padop->op_next = (OP*)padop;
5881 padop->op_flags = (U8)flags;
5882 if (PL_opargs[type] & OA_RETSCALAR)
5884 if (PL_opargs[type] & OA_TARGET)
5885 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5886 return CHECKOP(type, padop);
5889 #endif /* USE_ITHREADS */
5892 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5894 Constructs, checks, and returns an op of any type that involves an
5895 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5896 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5897 reference; calling this function does not transfer ownership of any
5904 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5906 PERL_ARGS_ASSERT_NEWGVOP;
5909 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5911 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5916 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5918 Constructs, checks, and returns an op of any type that involves an
5919 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5920 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
5921 must have been allocated using C<PerlMemShared_malloc>; the memory will
5922 be freed when the op is destroyed.
5928 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5931 const bool utf8 = cBOOL(flags & SVf_UTF8);
5936 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5937 || type == OP_RUNCV || type == OP_CUSTOM
5938 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5940 NewOp(1101, pvop, 1, PVOP);
5941 CHANGE_TYPE(pvop, type);
5943 pvop->op_next = (OP*)pvop;
5944 pvop->op_flags = (U8)flags;
5945 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5946 if (PL_opargs[type] & OA_RETSCALAR)
5948 if (PL_opargs[type] & OA_TARGET)
5949 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5950 return CHECKOP(type, pvop);
5954 Perl_package(pTHX_ OP *o)
5956 SV *const sv = cSVOPo->op_sv;
5958 PERL_ARGS_ASSERT_PACKAGE;
5960 SAVEGENERICSV(PL_curstash);
5961 save_item(PL_curstname);
5963 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5965 sv_setsv(PL_curstname, sv);
5967 PL_hints |= HINT_BLOCK_SCOPE;
5968 PL_parser->copline = NOLINE;
5974 Perl_package_version( pTHX_ OP *v )
5976 U32 savehints = PL_hints;
5977 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5978 PL_hints &= ~HINT_STRICT_VARS;
5979 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5980 PL_hints = savehints;
5985 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5990 SV *use_version = NULL;
5992 PERL_ARGS_ASSERT_UTILIZE;
5994 if (idop->op_type != OP_CONST)
5995 Perl_croak(aTHX_ "Module name must be constant");
6000 SV * const vesv = ((SVOP*)version)->op_sv;
6002 if (!arg && !SvNIOKp(vesv)) {
6009 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6010 Perl_croak(aTHX_ "Version number must be a constant number");
6012 /* Make copy of idop so we don't free it twice */
6013 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6015 /* Fake up a method call to VERSION */
6016 meth = newSVpvs_share("VERSION");
6017 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6018 op_append_elem(OP_LIST,
6019 op_prepend_elem(OP_LIST, pack, version),
6020 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6024 /* Fake up an import/unimport */
6025 if (arg && arg->op_type == OP_STUB) {
6026 imop = arg; /* no import on explicit () */
6028 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6029 imop = NULL; /* use 5.0; */
6031 use_version = ((SVOP*)idop)->op_sv;
6033 idop->op_private |= OPpCONST_NOVER;
6038 /* Make copy of idop so we don't free it twice */
6039 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6041 /* Fake up a method call to import/unimport */
6043 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6044 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6045 op_append_elem(OP_LIST,
6046 op_prepend_elem(OP_LIST, pack, arg),
6047 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6051 /* Fake up the BEGIN {}, which does its thing immediately. */
6053 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6056 op_append_elem(OP_LINESEQ,
6057 op_append_elem(OP_LINESEQ,
6058 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6059 newSTATEOP(0, NULL, veop)),
6060 newSTATEOP(0, NULL, imop) ));
6064 * feature bundle that corresponds to the required version. */
6065 use_version = sv_2mortal(new_version(use_version));
6066 S_enable_feature_bundle(aTHX_ use_version);
6068 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6069 if (vcmp(use_version,
6070 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6071 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6072 PL_hints |= HINT_STRICT_REFS;
6073 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6074 PL_hints |= HINT_STRICT_SUBS;
6075 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6076 PL_hints |= HINT_STRICT_VARS;
6078 /* otherwise they are off */
6080 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6081 PL_hints &= ~HINT_STRICT_REFS;
6082 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6083 PL_hints &= ~HINT_STRICT_SUBS;
6084 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6085 PL_hints &= ~HINT_STRICT_VARS;
6089 /* The "did you use incorrect case?" warning used to be here.
6090 * The problem is that on case-insensitive filesystems one
6091 * might get false positives for "use" (and "require"):
6092 * "use Strict" or "require CARP" will work. This causes
6093 * portability problems for the script: in case-strict
6094 * filesystems the script will stop working.
6096 * The "incorrect case" warning checked whether "use Foo"
6097 * imported "Foo" to your namespace, but that is wrong, too:
6098 * there is no requirement nor promise in the language that
6099 * a Foo.pm should or would contain anything in package "Foo".
6101 * There is very little Configure-wise that can be done, either:
6102 * the case-sensitivity of the build filesystem of Perl does not
6103 * help in guessing the case-sensitivity of the runtime environment.
6106 PL_hints |= HINT_BLOCK_SCOPE;
6107 PL_parser->copline = NOLINE;
6108 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6112 =head1 Embedding Functions
6114 =for apidoc load_module
6116 Loads the module whose name is pointed to by the string part of name.
6117 Note that the actual module name, not its filename, should be given.
6118 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6119 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
6120 (or 0 for no flags). ver, if specified
6121 and not NULL, provides version semantics
6122 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6123 arguments can be used to specify arguments to the module's import()
6124 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6125 terminated with a final NULL pointer. Note that this list can only
6126 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
6127 Otherwise at least a single NULL pointer to designate the default
6128 import list is required.
6130 The reference count for each specified C<SV*> parameter is decremented.
6135 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6139 PERL_ARGS_ASSERT_LOAD_MODULE;
6141 va_start(args, ver);
6142 vload_module(flags, name, ver, &args);
6146 #ifdef PERL_IMPLICIT_CONTEXT
6148 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6152 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6153 va_start(args, ver);
6154 vload_module(flags, name, ver, &args);
6160 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6163 OP * const modname = newSVOP(OP_CONST, 0, name);
6165 PERL_ARGS_ASSERT_VLOAD_MODULE;
6167 modname->op_private |= OPpCONST_BARE;
6169 veop = newSVOP(OP_CONST, 0, ver);
6173 if (flags & PERL_LOADMOD_NOIMPORT) {
6174 imop = sawparens(newNULLLIST());
6176 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6177 imop = va_arg(*args, OP*);
6182 sv = va_arg(*args, SV*);
6184 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6185 sv = va_arg(*args, SV*);
6189 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6190 * that it has a PL_parser to play with while doing that, and also
6191 * that it doesn't mess with any existing parser, by creating a tmp
6192 * new parser with lex_start(). This won't actually be used for much,
6193 * since pp_require() will create another parser for the real work.
6194 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6197 SAVEVPTR(PL_curcop);
6198 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6199 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6200 veop, modname, imop);
6204 PERL_STATIC_INLINE OP *
6205 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6207 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6208 newLISTOP(OP_LIST, 0, arg,
6209 newUNOP(OP_RV2CV, 0,
6210 newGVOP(OP_GV, 0, gv))));
6214 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6219 PERL_ARGS_ASSERT_DOFILE;
6221 if (!force_builtin && (gv = gv_override("do", 2))) {
6222 doop = S_new_entersubop(aTHX_ gv, term);
6225 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6231 =head1 Optree construction
6233 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6235 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
6236 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6237 be set automatically, and, shifted up eight bits, the eight bits of
6238 C<op_private>, except that the bit with value 1 or 2 is automatically
6239 set as required. I<listval> and I<subscript> supply the parameters of
6240 the slice; they are consumed by this function and become part of the
6241 constructed op tree.
6247 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6249 return newBINOP(OP_LSLICE, flags,
6250 list(force_list(subscript, 1)),
6251 list(force_list(listval, 1)) );
6254 #define ASSIGN_LIST 1
6255 #define ASSIGN_REF 2
6258 S_assignment_type(pTHX_ const OP *o)
6267 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6268 o = cUNOPo->op_first;
6270 flags = o->op_flags;
6272 if (type == OP_COND_EXPR) {
6273 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6274 const I32 t = assignment_type(sib);
6275 const I32 f = assignment_type(OpSIBLING(sib));
6277 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6279 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6280 yyerror("Assignment to both a list and a scalar");
6284 if (type == OP_SREFGEN)
6286 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6287 type = kid->op_type;
6288 flags |= kid->op_flags;
6289 if (!(flags & OPf_PARENS)
6290 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6291 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6297 if (type == OP_LIST &&
6298 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6299 o->op_private & OPpLVAL_INTRO)
6302 if (type == OP_LIST || flags & OPf_PARENS ||
6303 type == OP_RV2AV || type == OP_RV2HV ||
6304 type == OP_ASLICE || type == OP_HSLICE ||
6305 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6308 if (type == OP_PADAV || type == OP_PADHV)
6311 if (type == OP_RV2SV)
6318 Helper function for newASSIGNOP to detect commonality between the
6319 lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
6320 flags the op and the peephole optimizer calls this helper function
6321 if the flag is set.) Marks all variables with PL_generation. If it
6322 returns TRUE the assignment must be able to handle common variables.
6324 PL_generation sorcery:
6325 An assignment like ($a,$b) = ($c,$d) is easier than
6326 ($a,$b) = ($c,$a), since there is no need for temporary vars.
6327 To detect whether there are common vars, the global var
6328 PL_generation is incremented for each assign op we compile.
6329 Then, while compiling the assign op, we run through all the
6330 variables on both sides of the assignment, setting a spare slot
6331 in each of them to PL_generation. If any of them already have
6332 that value, we know we've got commonality. Also, if the
6333 generation number is already set to PERL_INT_MAX, then
6334 the variable is involved in aliasing, so we also have
6335 potential commonality in that case. We could use a
6336 single bit marker, but then we'd have to make 2 passes, first
6337 to clear the flag, then to test and set it. And that
6338 wouldn't help with aliasing, either. To find somewhere
6339 to store these values, evil chicanery is done with SvUVX().
6341 PERL_STATIC_INLINE bool
6342 S_aassign_common_vars(pTHX_ OP* o)
6345 for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6346 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
6347 if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
6348 || curop->op_type == OP_AELEMFAST) {
6349 GV *gv = cGVOPx_gv(curop);
6351 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6353 GvASSIGN_GENERATION_set(gv, PL_generation);
6355 else if (curop->op_type == OP_PADSV ||
6356 curop->op_type == OP_PADAV ||
6357 curop->op_type == OP_PADHV ||
6358 curop->op_type == OP_AELEMFAST_LEX ||
6359 curop->op_type == OP_PADANY)
6362 if (PAD_COMPNAME_GEN(curop->op_targ)
6363 == (STRLEN)PL_generation
6364 || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6366 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
6369 else if (curop->op_type == OP_RV2CV)
6371 else if (curop->op_type == OP_RV2SV ||
6372 curop->op_type == OP_RV2AV ||
6373 curop->op_type == OP_RV2HV ||
6374 curop->op_type == OP_RV2GV) {
6375 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
6378 else if (curop->op_type == OP_PUSHRE) {
6381 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
6382 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
6385 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
6389 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
6391 GvASSIGN_GENERATION_set(gv, PL_generation);
6393 else if (curop->op_targ)
6396 else if (curop->op_type == OP_PADRANGE)
6397 /* Ignore padrange; checking its siblings is sufficient. */
6402 else if (PL_opargs[curop->op_type] & OA_TARGLEX
6403 && curop->op_private & OPpTARGET_MY)
6406 if (curop->op_flags & OPf_KIDS) {
6407 if (aassign_common_vars(curop))
6414 /* This variant only handles lexical aliases. It is called when
6415 newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6416 ases trump that decision. */
6417 PERL_STATIC_INLINE bool
6418 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6421 for (curop = cUNOPo->op_first; curop; curop = OpSIBLING(curop)) {
6422 if ((curop->op_type == OP_PADSV ||
6423 curop->op_type == OP_PADAV ||
6424 curop->op_type == OP_PADHV ||
6425 curop->op_type == OP_AELEMFAST_LEX ||
6426 curop->op_type == OP_PADANY ||
6427 ( PL_opargs[curop->op_type] & OA_TARGLEX
6428 && curop->op_private & OPpTARGET_MY ))
6429 && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6432 if (curop->op_type == OP_PUSHRE && curop->op_targ
6433 && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6436 if (curop->op_flags & OPf_KIDS) {
6437 if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6445 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6447 Constructs, checks, and returns an assignment op. I<left> and I<right>
6448 supply the parameters of the assignment; they are consumed by this
6449 function and become part of the constructed op tree.
6451 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6452 a suitable conditional optree is constructed. If I<optype> is the opcode
6453 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6454 performs the binary operation and assigns the result to the left argument.
6455 Either way, if I<optype> is non-zero then I<flags> has no effect.
6457 If I<optype> is zero, then a plain scalar or list assignment is
6458 constructed. Which type of assignment it is is automatically determined.
6459 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6460 will be set automatically, and, shifted up eight bits, the eight bits
6461 of C<op_private>, except that the bit with value 1 or 2 is automatically
6468 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6474 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6475 return newLOGOP(optype, 0,
6476 op_lvalue(scalar(left), optype),
6477 newUNOP(OP_SASSIGN, 0, scalar(right)));
6480 return newBINOP(optype, OPf_STACKED,
6481 op_lvalue(scalar(left), optype), scalar(right));
6485 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6486 static const char no_list_state[] = "Initialization of state variables"
6487 " in list context currently forbidden";
6489 bool maybe_common_vars = TRUE;
6491 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6492 left->op_private &= ~ OPpSLICEWARNING;
6495 left = op_lvalue(left, OP_AASSIGN);
6496 curop = list(force_list(left, 1));
6497 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6498 o->op_private = (U8)(0 | (flags >> 8));
6500 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6502 OP* lop = ((LISTOP*)left)->op_first;
6503 maybe_common_vars = FALSE;
6505 if (lop->op_type == OP_PADSV ||
6506 lop->op_type == OP_PADAV ||
6507 lop->op_type == OP_PADHV ||
6508 lop->op_type == OP_PADANY) {
6509 if (!(lop->op_private & OPpLVAL_INTRO))
6510 maybe_common_vars = TRUE;
6512 if (lop->op_private & OPpPAD_STATE) {
6513 if (left->op_private & OPpLVAL_INTRO) {
6514 /* Each variable in state($a, $b, $c) = ... */
6517 /* Each state variable in
6518 (state $a, my $b, our $c, $d, undef) = ... */
6520 yyerror(no_list_state);
6522 /* Each my variable in
6523 (state $a, my $b, our $c, $d, undef) = ... */
6525 } else if (lop->op_type == OP_UNDEF ||
6526 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6527 /* undef may be interesting in
6528 (state $a, undef, state $c) */
6530 /* Other ops in the list. */
6531 maybe_common_vars = TRUE;
6533 lop = OpSIBLING(lop);
6536 else if ((left->op_private & OPpLVAL_INTRO)
6537 && ( left->op_type == OP_PADSV
6538 || left->op_type == OP_PADAV
6539 || left->op_type == OP_PADHV
6540 || left->op_type == OP_PADANY))
6542 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6543 if (left->op_private & OPpPAD_STATE) {
6544 /* All single variable list context state assignments, hence
6554 yyerror(no_list_state);
6558 if (maybe_common_vars) {
6559 /* The peephole optimizer will do the full check and pos-
6560 sibly turn this off. */
6561 o->op_private |= OPpASSIGN_COMMON;
6564 if (right && right->op_type == OP_SPLIT
6565 && !(right->op_flags & OPf_STACKED)) {
6566 OP* tmpop = ((LISTOP*)right)->op_first;
6567 PMOP * const pm = (PMOP*)tmpop;
6568 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6571 !pm->op_pmreplrootu.op_pmtargetoff
6573 !pm->op_pmreplrootu.op_pmtargetgv
6577 if (!(left->op_private & OPpLVAL_INTRO) &&
6578 ( (left->op_type == OP_RV2AV &&
6579 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6580 || left->op_type == OP_PADAV )
6582 if (tmpop != (OP *)pm) {
6584 pm->op_pmreplrootu.op_pmtargetoff
6585 = cPADOPx(tmpop)->op_padix;
6586 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6588 pm->op_pmreplrootu.op_pmtargetgv
6589 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6590 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6592 right->op_private |=
6593 left->op_private & OPpOUR_INTRO;
6596 pm->op_targ = left->op_targ;
6597 left->op_targ = 0; /* filch it */
6600 tmpop = cUNOPo->op_first; /* to list (nulled) */
6601 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6602 /* detach rest of siblings from o subtree,
6603 * and free subtree */
6604 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6605 op_free(o); /* blow off assign */
6606 right->op_flags &= ~OPf_WANT;
6607 /* "I don't know and I don't care." */
6610 else if (left->op_type == OP_RV2AV
6611 || left->op_type == OP_PADAV)
6613 /* Detach the array. */
6617 op_sibling_splice(cBINOPo->op_last,
6618 cUNOPx(cBINOPo->op_last)
6619 ->op_first, 1, NULL);
6620 assert(ary == left);
6621 /* Attach it to the split. */
6622 op_sibling_splice(right, cLISTOPx(right)->op_last,
6624 right->op_flags |= OPf_STACKED;
6625 /* Detach split and expunge aassign as above. */
6628 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6629 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6632 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6633 SV * const sv = *svp;
6634 if (SvIOK(sv) && SvIVX(sv) == 0)
6636 if (right->op_private & OPpSPLIT_IMPLIM) {
6637 /* our own SV, created in ck_split */
6639 sv_setiv(sv, PL_modcount+1);
6642 /* SV may belong to someone else */
6644 *svp = newSViv(PL_modcount+1);
6652 if (assign_type == ASSIGN_REF)
6653 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6655 right = newOP(OP_UNDEF, 0);
6656 if (right->op_type == OP_READLINE) {
6657 right->op_flags |= OPf_STACKED;
6658 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6662 o = newBINOP(OP_SASSIGN, flags,
6663 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6669 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6671 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6672 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6673 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6674 If I<label> is non-null, it supplies the name of a label to attach to
6675 the state op; this function takes ownership of the memory pointed at by
6676 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
6679 If I<o> is null, the state op is returned. Otherwise the state op is
6680 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
6681 is consumed by this function and becomes part of the returned op tree.
6687 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6690 const U32 seq = intro_my();
6691 const U32 utf8 = flags & SVf_UTF8;
6694 PL_parser->parsed_sub = 0;
6698 NewOp(1101, cop, 1, COP);
6699 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6700 CHANGE_TYPE(cop, OP_DBSTATE);
6703 CHANGE_TYPE(cop, OP_NEXTSTATE);
6705 cop->op_flags = (U8)flags;
6706 CopHINTS_set(cop, PL_hints);
6708 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6710 cop->op_next = (OP*)cop;
6713 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6714 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6716 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6718 PL_hints |= HINT_BLOCK_SCOPE;
6719 /* It seems that we need to defer freeing this pointer, as other parts
6720 of the grammar end up wanting to copy it after this op has been
6725 if (PL_parser->preambling != NOLINE) {
6726 CopLINE_set(cop, PL_parser->preambling);
6727 PL_parser->copline = NOLINE;
6729 else if (PL_parser->copline == NOLINE)
6730 CopLINE_set(cop, CopLINE(PL_curcop));
6732 CopLINE_set(cop, PL_parser->copline);
6733 PL_parser->copline = NOLINE;
6736 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6738 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6740 CopSTASH_set(cop, PL_curstash);
6742 if (cop->op_type == OP_DBSTATE) {
6743 /* this line can have a breakpoint - store the cop in IV */
6744 AV *av = CopFILEAVx(PL_curcop);
6746 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6747 if (svp && *svp != &PL_sv_undef ) {
6748 (void)SvIOK_on(*svp);
6749 SvIV_set(*svp, PTR2IV(cop));
6754 if (flags & OPf_SPECIAL)
6756 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6760 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6762 Constructs, checks, and returns a logical (flow control) op. I<type>
6763 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
6764 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6765 the eight bits of C<op_private>, except that the bit with value 1 is
6766 automatically set. I<first> supplies the expression controlling the
6767 flow, and I<other> supplies the side (alternate) chain of ops; they are
6768 consumed by this function and become part of the constructed op tree.
6774 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6776 PERL_ARGS_ASSERT_NEWLOGOP;
6778 return new_logop(type, flags, &first, &other);
6782 S_search_const(pTHX_ OP *o)
6784 PERL_ARGS_ASSERT_SEARCH_CONST;
6786 switch (o->op_type) {
6790 if (o->op_flags & OPf_KIDS)
6791 return search_const(cUNOPo->op_first);
6798 if (!(o->op_flags & OPf_KIDS))
6800 kid = cLISTOPo->op_first;
6802 switch (kid->op_type) {
6806 kid = OpSIBLING(kid);
6809 if (kid != cLISTOPo->op_last)
6815 kid = cLISTOPo->op_last;
6817 return search_const(kid);
6825 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6833 int prepend_not = 0;
6835 PERL_ARGS_ASSERT_NEW_LOGOP;
6840 /* [perl #59802]: Warn about things like "return $a or $b", which
6841 is parsed as "(return $a) or $b" rather than "return ($a or
6842 $b)". NB: This also applies to xor, which is why we do it
6845 switch (first->op_type) {
6849 /* XXX: Perhaps we should emit a stronger warning for these.
6850 Even with the high-precedence operator they don't seem to do
6853 But until we do, fall through here.
6859 /* XXX: Currently we allow people to "shoot themselves in the
6860 foot" by explicitly writing "(return $a) or $b".
6862 Warn unless we are looking at the result from folding or if
6863 the programmer explicitly grouped the operators like this.
6864 The former can occur with e.g.
6866 use constant FEATURE => ( $] >= ... );
6867 sub { not FEATURE and return or do_stuff(); }
6869 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6870 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6871 "Possible precedence issue with control flow operator");
6872 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6878 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6879 return newBINOP(type, flags, scalar(first), scalar(other));
6881 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6882 || type == OP_CUSTOM);
6884 scalarboolean(first);
6885 /* optimize AND and OR ops that have NOTs as children */
6886 if (first->op_type == OP_NOT
6887 && (first->op_flags & OPf_KIDS)
6888 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6889 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6891 if (type == OP_AND || type == OP_OR) {
6897 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6899 prepend_not = 1; /* prepend a NOT op later */
6903 /* search for a constant op that could let us fold the test */
6904 if ((cstop = search_const(first))) {
6905 if (cstop->op_private & OPpCONST_STRICT)
6906 no_bareword_allowed(cstop);
6907 else if ((cstop->op_private & OPpCONST_BARE))
6908 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6909 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6910 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6911 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6913 if (other->op_type == OP_CONST)
6914 other->op_private |= OPpCONST_SHORTCIRCUIT;
6916 if (other->op_type == OP_LEAVE)
6917 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6918 else if (other->op_type == OP_MATCH
6919 || other->op_type == OP_SUBST
6920 || other->op_type == OP_TRANSR
6921 || other->op_type == OP_TRANS)
6922 /* Mark the op as being unbindable with =~ */
6923 other->op_flags |= OPf_SPECIAL;
6925 other->op_folded = 1;
6929 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6930 const OP *o2 = other;
6931 if ( ! (o2->op_type == OP_LIST
6932 && (( o2 = cUNOPx(o2)->op_first))
6933 && o2->op_type == OP_PUSHMARK
6934 && (( o2 = OpSIBLING(o2))) )
6937 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6938 || o2->op_type == OP_PADHV)
6939 && o2->op_private & OPpLVAL_INTRO
6940 && !(o2->op_private & OPpPAD_STATE))
6942 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6943 "Deprecated use of my() in false conditional");
6947 if (cstop->op_type == OP_CONST)
6948 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6953 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6954 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6956 const OP * const k1 = ((UNOP*)first)->op_first;
6957 const OP * const k2 = OpSIBLING(k1);
6959 switch (first->op_type)
6962 if (k2 && k2->op_type == OP_READLINE
6963 && (k2->op_flags & OPf_STACKED)
6964 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6966 warnop = k2->op_type;
6971 if (k1->op_type == OP_READDIR
6972 || k1->op_type == OP_GLOB
6973 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6974 || k1->op_type == OP_EACH
6975 || k1->op_type == OP_AEACH)
6977 warnop = ((k1->op_type == OP_NULL)
6978 ? (OPCODE)k1->op_targ : k1->op_type);
6983 const line_t oldline = CopLINE(PL_curcop);
6984 /* This ensures that warnings are reported at the first line
6985 of the construction, not the last. */
6986 CopLINE_set(PL_curcop, PL_parser->copline);
6987 Perl_warner(aTHX_ packWARN(WARN_MISC),
6988 "Value of %s%s can be \"0\"; test with defined()",
6990 ((warnop == OP_READLINE || warnop == OP_GLOB)
6991 ? " construct" : "() operator"));
6992 CopLINE_set(PL_curcop, oldline);
6999 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
7000 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
7002 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
7003 logop->op_flags |= (U8)flags;
7004 logop->op_private = (U8)(1 | (flags >> 8));
7006 /* establish postfix order */
7007 logop->op_next = LINKLIST(first);
7008 first->op_next = (OP*)logop;
7009 assert(!OpHAS_SIBLING(first));
7010 op_sibling_splice((OP*)logop, first, 0, other);
7012 CHECKOP(type,logop);
7014 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7015 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7023 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7025 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7026 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7027 will be set automatically, and, shifted up eight bits, the eight bits of
7028 C<op_private>, except that the bit with value 1 is automatically set.
7029 I<first> supplies the expression selecting between the two branches,
7030 and I<trueop> and I<falseop> supply the branches; they are consumed by
7031 this function and become part of the constructed op tree.
7037 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7045 PERL_ARGS_ASSERT_NEWCONDOP;
7048 return newLOGOP(OP_AND, 0, first, trueop);
7050 return newLOGOP(OP_OR, 0, first, falseop);
7052 scalarboolean(first);
7053 if ((cstop = search_const(first))) {
7054 /* Left or right arm of the conditional? */
7055 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7056 OP *live = left ? trueop : falseop;
7057 OP *const dead = left ? falseop : trueop;
7058 if (cstop->op_private & OPpCONST_BARE &&
7059 cstop->op_private & OPpCONST_STRICT) {
7060 no_bareword_allowed(cstop);
7064 if (live->op_type == OP_LEAVE)
7065 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7066 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7067 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7068 /* Mark the op as being unbindable with =~ */
7069 live->op_flags |= OPf_SPECIAL;
7070 live->op_folded = 1;
7073 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
7074 logop->op_flags |= (U8)flags;
7075 logop->op_private = (U8)(1 | (flags >> 8));
7076 logop->op_next = LINKLIST(falseop);
7078 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7081 /* establish postfix order */
7082 start = LINKLIST(first);
7083 first->op_next = (OP*)logop;
7085 /* make first, trueop, falseop siblings */
7086 op_sibling_splice((OP*)logop, first, 0, trueop);
7087 op_sibling_splice((OP*)logop, trueop, 0, falseop);
7089 o = newUNOP(OP_NULL, 0, (OP*)logop);
7091 trueop->op_next = falseop->op_next = o;
7098 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7100 Constructs and returns a C<range> op, with subordinate C<flip> and
7101 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
7102 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7103 for both the C<flip> and C<range> ops, except that the bit with value
7104 1 is automatically set. I<left> and I<right> supply the expressions
7105 controlling the endpoints of the range; they are consumed by this function
7106 and become part of the constructed op tree.
7112 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7120 PERL_ARGS_ASSERT_NEWRANGE;
7122 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7123 range->op_flags = OPf_KIDS;
7124 leftstart = LINKLIST(left);
7125 range->op_private = (U8)(1 | (flags >> 8));
7127 /* make left and right siblings */
7128 op_sibling_splice((OP*)range, left, 0, right);
7130 range->op_next = (OP*)range;
7131 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7132 flop = newUNOP(OP_FLOP, 0, flip);
7133 o = newUNOP(OP_NULL, 0, flop);
7135 range->op_next = leftstart;
7137 left->op_next = flip;
7138 right->op_next = flop;
7141 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7142 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7144 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7145 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7146 SvPADTMP_on(PAD_SV(flip->op_targ));
7148 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7149 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7151 /* check barewords before they might be optimized aways */
7152 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7153 no_bareword_allowed(left);
7154 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7155 no_bareword_allowed(right);
7158 if (!flip->op_private || !flop->op_private)
7159 LINKLIST(o); /* blow off optimizer unless constant */
7165 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7167 Constructs, checks, and returns an op tree expressing a loop. This is
7168 only a loop in the control flow through the op tree; it does not have
7169 the heavyweight loop structure that allows exiting the loop by C<last>
7170 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
7171 top-level op, except that some bits will be set automatically as required.
7172 I<expr> supplies the expression controlling loop iteration, and I<block>
7173 supplies the body of the loop; they are consumed by this function and
7174 become part of the constructed op tree. I<debuggable> is currently
7175 unused and should always be 1.
7181 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7185 const bool once = block && block->op_flags & OPf_SPECIAL &&
7186 block->op_type == OP_NULL;
7188 PERL_UNUSED_ARG(debuggable);
7192 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7193 || ( expr->op_type == OP_NOT
7194 && cUNOPx(expr)->op_first->op_type == OP_CONST
7195 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7198 /* Return the block now, so that S_new_logop does not try to
7200 return block; /* do {} while 0 does once */
7201 if (expr->op_type == OP_READLINE
7202 || expr->op_type == OP_READDIR
7203 || expr->op_type == OP_GLOB
7204 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7205 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7206 expr = newUNOP(OP_DEFINED, 0,
7207 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7208 } else if (expr->op_flags & OPf_KIDS) {
7209 const OP * const k1 = ((UNOP*)expr)->op_first;
7210 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7211 switch (expr->op_type) {
7213 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7214 && (k2->op_flags & OPf_STACKED)
7215 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7216 expr = newUNOP(OP_DEFINED, 0, expr);
7220 if (k1 && (k1->op_type == OP_READDIR
7221 || k1->op_type == OP_GLOB
7222 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7223 || k1->op_type == OP_EACH
7224 || k1->op_type == OP_AEACH))
7225 expr = newUNOP(OP_DEFINED, 0, expr);
7231 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7232 * op, in listop. This is wrong. [perl #27024] */
7234 block = newOP(OP_NULL, 0);
7235 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7236 o = new_logop(OP_AND, 0, &expr, &listop);
7243 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7245 if (once && o != listop)
7247 assert(cUNOPo->op_first->op_type == OP_AND
7248 || cUNOPo->op_first->op_type == OP_OR);
7249 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7253 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7255 o->op_flags |= flags;
7257 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
7262 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7264 Constructs, checks, and returns an op tree expressing a C<while> loop.
7265 This is a heavyweight loop, with structure that allows exiting the loop
7266 by C<last> and suchlike.
7268 I<loop> is an optional preconstructed C<enterloop> op to use in the
7269 loop; if it is null then a suitable op will be constructed automatically.
7270 I<expr> supplies the loop's controlling expression. I<block> supplies the
7271 main body of the loop, and I<cont> optionally supplies a C<continue> block
7272 that operates as a second half of the body. All of these optree inputs
7273 are consumed by this function and become part of the constructed op tree.
7275 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7276 op and, shifted up eight bits, the eight bits of C<op_private> for
7277 the C<leaveloop> op, except that (in both cases) some bits will be set
7278 automatically. I<debuggable> is currently unused and should always be 1.
7279 I<has_my> can be supplied as true to force the
7280 loop body to be enclosed in its own scope.
7286 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7287 OP *expr, OP *block, OP *cont, I32 has_my)
7296 PERL_UNUSED_ARG(debuggable);
7299 if (expr->op_type == OP_READLINE
7300 || expr->op_type == OP_READDIR
7301 || expr->op_type == OP_GLOB
7302 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7303 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7304 expr = newUNOP(OP_DEFINED, 0,
7305 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7306 } else if (expr->op_flags & OPf_KIDS) {
7307 const OP * const k1 = ((UNOP*)expr)->op_first;
7308 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7309 switch (expr->op_type) {
7311 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7312 && (k2->op_flags & OPf_STACKED)
7313 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7314 expr = newUNOP(OP_DEFINED, 0, expr);
7318 if (k1 && (k1->op_type == OP_READDIR
7319 || k1->op_type == OP_GLOB
7320 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7321 || k1->op_type == OP_EACH
7322 || k1->op_type == OP_AEACH))
7323 expr = newUNOP(OP_DEFINED, 0, expr);
7330 block = newOP(OP_NULL, 0);
7331 else if (cont || has_my) {
7332 block = op_scope(block);
7336 next = LINKLIST(cont);
7339 OP * const unstack = newOP(OP_UNSTACK, 0);
7342 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7346 listop = op_append_list(OP_LINESEQ, block, cont);
7348 redo = LINKLIST(listop);
7352 o = new_logop(OP_AND, 0, &expr, &listop);
7353 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7355 return expr; /* listop already freed by new_logop */
7358 ((LISTOP*)listop)->op_last->op_next =
7359 (o == listop ? redo : LINKLIST(o));
7365 NewOp(1101,loop,1,LOOP);
7366 CHANGE_TYPE(loop, OP_ENTERLOOP);
7367 loop->op_private = 0;
7368 loop->op_next = (OP*)loop;
7371 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7373 loop->op_redoop = redo;
7374 loop->op_lastop = o;
7375 o->op_private |= loopflags;
7378 loop->op_nextop = next;
7380 loop->op_nextop = o;
7382 o->op_flags |= flags;
7383 o->op_private |= (flags >> 8);
7388 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7390 Constructs, checks, and returns an op tree expressing a C<foreach>
7391 loop (iteration through a list of values). This is a heavyweight loop,
7392 with structure that allows exiting the loop by C<last> and suchlike.
7394 I<sv> optionally supplies the variable that will be aliased to each
7395 item in turn; if null, it defaults to C<$_> (either lexical or global).
7396 I<expr> supplies the list of values to iterate over. I<block> supplies
7397 the main body of the loop, and I<cont> optionally supplies a C<continue>
7398 block that operates as a second half of the body. All of these optree
7399 inputs are consumed by this function and become part of the constructed
7402 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7403 op and, shifted up eight bits, the eight bits of C<op_private> for
7404 the C<leaveloop> op, except that (in both cases) some bits will be set
7411 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7416 PADOFFSET padoff = 0;
7420 PERL_ARGS_ASSERT_NEWFOROP;
7423 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7424 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7425 CHANGE_TYPE(sv, OP_RV2GV);
7427 /* The op_type check is needed to prevent a possible segfault
7428 * if the loop variable is undeclared and 'strict vars' is in
7429 * effect. This is illegal but is nonetheless parsed, so we
7430 * may reach this point with an OP_CONST where we're expecting
7433 if (cUNOPx(sv)->op_first->op_type == OP_GV
7434 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7435 iterpflags |= OPpITER_DEF;
7437 else if (sv->op_type == OP_PADSV) { /* private variable */
7438 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7439 padoff = sv->op_targ;
7443 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7445 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7448 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7450 PADNAME * const pn = PAD_COMPNAME(padoff);
7451 const char * const name = PadnamePV(pn);
7453 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7454 iterpflags |= OPpITER_DEF;
7458 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
7459 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7460 sv = newGVOP(OP_GV, 0, PL_defgv);
7465 iterpflags |= OPpITER_DEF;
7468 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7469 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7470 iterflags |= OPf_STACKED;
7472 else if (expr->op_type == OP_NULL &&
7473 (expr->op_flags & OPf_KIDS) &&
7474 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7476 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7477 * set the STACKED flag to indicate that these values are to be
7478 * treated as min/max values by 'pp_enteriter'.
7480 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7481 LOGOP* const range = (LOGOP*) flip->op_first;
7482 OP* const left = range->op_first;
7483 OP* const right = OpSIBLING(left);
7486 range->op_flags &= ~OPf_KIDS;
7487 /* detach range's children */
7488 op_sibling_splice((OP*)range, NULL, -1, NULL);
7490 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7491 listop->op_first->op_next = range->op_next;
7492 left->op_next = range->op_other;
7493 right->op_next = (OP*)listop;
7494 listop->op_next = listop->op_first;
7497 expr = (OP*)(listop);
7499 iterflags |= OPf_STACKED;
7502 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7505 loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
7506 op_append_elem(OP_LIST, expr, scalar(sv))));
7507 assert(!loop->op_next);
7508 /* for my $x () sets OPpLVAL_INTRO;
7509 * for our $x () sets OPpOUR_INTRO */
7510 loop->op_private = (U8)iterpflags;
7511 if (loop->op_slabbed
7512 && DIFF(loop, OpSLOT(loop)->opslot_next)
7513 < SIZE_TO_PSIZE(sizeof(LOOP)))
7516 NewOp(1234,tmp,1,LOOP);
7517 Copy(loop,tmp,1,LISTOP);
7518 #ifdef PERL_OP_PARENT
7519 assert(loop->op_last->op_sibling == (OP*)loop);
7520 loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
7522 S_op_destroy(aTHX_ (OP*)loop);
7525 else if (!loop->op_slabbed)
7527 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7528 #ifdef PERL_OP_PARENT
7529 loop->op_last->op_sibling = (OP *)loop;
7532 loop->op_targ = padoff;
7533 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7538 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7540 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7541 or C<last>). I<type> is the opcode. I<label> supplies the parameter
7542 determining the target of the op; it is consumed by this function and
7543 becomes part of the constructed op tree.
7549 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7553 PERL_ARGS_ASSERT_NEWLOOPEX;
7555 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7556 || type == OP_CUSTOM);
7558 if (type != OP_GOTO) {
7559 /* "last()" means "last" */
7560 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7561 o = newOP(type, OPf_SPECIAL);
7565 /* Check whether it's going to be a goto &function */
7566 if (label->op_type == OP_ENTERSUB
7567 && !(label->op_flags & OPf_STACKED))
7568 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7571 /* Check for a constant argument */
7572 if (label->op_type == OP_CONST) {
7573 SV * const sv = ((SVOP *)label)->op_sv;
7575 const char *s = SvPV_const(sv,l);
7576 if (l == strlen(s)) {
7578 SvUTF8(((SVOP*)label)->op_sv),
7580 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7584 /* If we have already created an op, we do not need the label. */
7587 else o = newUNOP(type, OPf_STACKED, label);
7589 PL_hints |= HINT_BLOCK_SCOPE;
7593 /* if the condition is a literal array or hash
7594 (or @{ ... } etc), make a reference to it.
7597 S_ref_array_or_hash(pTHX_ OP *cond)
7600 && (cond->op_type == OP_RV2AV
7601 || cond->op_type == OP_PADAV
7602 || cond->op_type == OP_RV2HV
7603 || cond->op_type == OP_PADHV))
7605 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7608 && (cond->op_type == OP_ASLICE
7609 || cond->op_type == OP_KVASLICE
7610 || cond->op_type == OP_HSLICE
7611 || cond->op_type == OP_KVHSLICE)) {
7613 /* anonlist now needs a list from this op, was previously used in
7615 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
7616 cond->op_flags |= OPf_WANT_LIST;
7618 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7625 /* These construct the optree fragments representing given()
7628 entergiven and enterwhen are LOGOPs; the op_other pointer
7629 points up to the associated leave op. We need this so we
7630 can put it in the context and make break/continue work.
7631 (Also, of course, pp_enterwhen will jump straight to
7632 op_other if the match fails.)
7636 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7637 I32 enter_opcode, I32 leave_opcode,
7638 PADOFFSET entertarg)
7644 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7646 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7647 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
7648 enterop->op_private = 0;
7650 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7653 /* prepend cond if we have one */
7654 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7656 o->op_next = LINKLIST(cond);
7657 cond->op_next = (OP *) enterop;
7660 /* This is a default {} block */
7661 enterop->op_flags |= OPf_SPECIAL;
7662 o ->op_flags |= OPf_SPECIAL;
7664 o->op_next = (OP *) enterop;
7667 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7668 entergiven and enterwhen both
7671 enterop->op_next = LINKLIST(block);
7672 block->op_next = enterop->op_other = o;
7677 /* Does this look like a boolean operation? For these purposes
7678 a boolean operation is:
7679 - a subroutine call [*]
7680 - a logical connective
7681 - a comparison operator
7682 - a filetest operator, with the exception of -s -M -A -C
7683 - defined(), exists() or eof()
7684 - /$re/ or $foo =~ /$re/
7686 [*] possibly surprising
7689 S_looks_like_bool(pTHX_ const OP *o)
7691 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7693 switch(o->op_type) {
7696 return looks_like_bool(cLOGOPo->op_first);
7700 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7703 looks_like_bool(cLOGOPo->op_first)
7704 && looks_like_bool(sibl));
7710 o->op_flags & OPf_KIDS
7711 && looks_like_bool(cUNOPo->op_first));
7715 case OP_NOT: case OP_XOR:
7717 case OP_EQ: case OP_NE: case OP_LT:
7718 case OP_GT: case OP_LE: case OP_GE:
7720 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7721 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7723 case OP_SEQ: case OP_SNE: case OP_SLT:
7724 case OP_SGT: case OP_SLE: case OP_SGE:
7728 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7729 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7730 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7731 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7732 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7733 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7734 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7735 case OP_FTTEXT: case OP_FTBINARY:
7737 case OP_DEFINED: case OP_EXISTS:
7738 case OP_MATCH: case OP_EOF:
7745 /* Detect comparisons that have been optimized away */
7746 if (cSVOPo->op_sv == &PL_sv_yes
7747 || cSVOPo->op_sv == &PL_sv_no)
7760 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7762 Constructs, checks, and returns an op tree expressing a C<given> block.
7763 I<cond> supplies the expression that will be locally assigned to a lexical
7764 variable, and I<block> supplies the body of the C<given> construct; they
7765 are consumed by this function and become part of the constructed op tree.
7766 I<defsv_off> is the pad offset of the scalar lexical variable that will
7767 be affected. If it is 0, the global $_ will be used.
7773 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7775 PERL_ARGS_ASSERT_NEWGIVENOP;
7776 return newGIVWHENOP(
7777 ref_array_or_hash(cond),
7779 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7784 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7786 Constructs, checks, and returns an op tree expressing a C<when> block.
7787 I<cond> supplies the test expression, and I<block> supplies the block
7788 that will be executed if the test evaluates to true; they are consumed
7789 by this function and become part of the constructed op tree. I<cond>
7790 will be interpreted DWIMically, often as a comparison against C<$_>,
7791 and may be null to generate a C<default> block.
7797 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7799 const bool cond_llb = (!cond || looks_like_bool(cond));
7802 PERL_ARGS_ASSERT_NEWWHENOP;
7807 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7809 scalar(ref_array_or_hash(cond)));
7812 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7815 /* must not conflict with SVf_UTF8 */
7816 #define CV_CKPROTO_CURSTASH 0x1
7819 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7820 const STRLEN len, const U32 flags)
7822 SV *name = NULL, *msg;
7823 const char * cvp = SvROK(cv)
7824 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7825 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7828 STRLEN clen = CvPROTOLEN(cv), plen = len;
7830 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7832 if (p == NULL && cvp == NULL)
7835 if (!ckWARN_d(WARN_PROTOTYPE))
7839 p = S_strip_spaces(aTHX_ p, &plen);
7840 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7841 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7842 if (plen == clen && memEQ(cvp, p, plen))
7845 if (flags & SVf_UTF8) {
7846 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7850 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7856 msg = sv_newmortal();
7861 gv_efullname3(name = sv_newmortal(), gv, NULL);
7862 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7863 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7864 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7865 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7866 sv_catpvs(name, "::");
7868 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7869 assert (CvNAMED(SvRV_const(gv)));
7870 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7872 else sv_catsv(name, (SV *)gv);
7874 else name = (SV *)gv;
7876 sv_setpvs(msg, "Prototype mismatch:");
7878 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7880 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7881 UTF8fARG(SvUTF8(cv),clen,cvp)
7884 sv_catpvs(msg, ": none");
7885 sv_catpvs(msg, " vs ");
7887 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7889 sv_catpvs(msg, "none");
7890 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7893 static void const_sv_xsub(pTHX_ CV* cv);
7894 static void const_av_xsub(pTHX_ CV* cv);
7898 =head1 Optree Manipulation Functions
7900 =for apidoc cv_const_sv
7902 If C<cv> is a constant sub eligible for inlining, returns the constant
7903 value returned by the sub. Otherwise, returns NULL.
7905 Constant subs can be created with C<newCONSTSUB> or as described in
7906 L<perlsub/"Constant Functions">.
7911 Perl_cv_const_sv(const CV *const cv)
7916 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7918 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7919 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7924 Perl_cv_const_sv_or_av(const CV * const cv)
7928 if (SvROK(cv)) return SvRV((SV *)cv);
7929 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7930 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7933 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7934 * Can be called in 2 ways:
7937 * look for a single OP_CONST with attached value: return the value
7939 * allow_lex && !CvCONST(cv);
7941 * examine the clone prototype, and if contains only a single
7942 * OP_CONST, return the value; or if it contains a single PADSV ref-
7943 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7944 * a candidate for "constizing" at clone time, and return NULL.
7948 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7956 for (; o; o = o->op_next) {
7957 const OPCODE type = o->op_type;
7959 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7961 || type == OP_PUSHMARK)
7963 if (type == OP_DBSTATE)
7965 if (type == OP_LEAVESUB)
7969 if (type == OP_CONST && cSVOPo->op_sv)
7971 else if (type == OP_UNDEF && !o->op_private) {
7975 else if (allow_lex && type == OP_PADSV) {
7976 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7978 sv = &PL_sv_undef; /* an arbitrary non-null value */
7996 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7997 PADNAME * const name, SV ** const const_svp)
8004 if (CvFLAGS(PL_compcv)) {
8005 /* might have had built-in attrs applied */
8006 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8007 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8008 && ckWARN(WARN_MISC))
8010 /* protect against fatal warnings leaking compcv */
8011 SAVEFREESV(PL_compcv);
8012 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8013 SvREFCNT_inc_simple_void_NN(PL_compcv);
8016 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8017 & ~(CVf_LVALUE * pureperl));
8022 /* redundant check for speed: */
8023 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8024 const line_t oldline = CopLINE(PL_curcop);
8027 : sv_2mortal(newSVpvn_utf8(
8028 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8030 if (PL_parser && PL_parser->copline != NOLINE)
8031 /* This ensures that warnings are reported at the first
8032 line of a redefinition, not the last. */
8033 CopLINE_set(PL_curcop, PL_parser->copline);
8034 /* protect against fatal warnings leaking compcv */
8035 SAVEFREESV(PL_compcv);
8036 report_redefined_cv(namesv, cv, const_svp);
8037 SvREFCNT_inc_simple_void_NN(PL_compcv);
8038 CopLINE_set(PL_curcop, oldline);
8045 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8050 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8053 CV *compcv = PL_compcv;
8056 PADOFFSET pax = o->op_targ;
8057 CV *outcv = CvOUTSIDE(PL_compcv);
8060 bool reusable = FALSE;
8062 #ifdef PERL_DEBUG_READONLY_OPS
8063 OPSLAB *slab = NULL;
8066 PERL_ARGS_ASSERT_NEWMYSUB;
8068 /* Find the pad slot for storing the new sub.
8069 We cannot use PL_comppad, as it is the pad owned by the new sub. We
8070 need to look in CvOUTSIDE and find the pad belonging to the enclos-
8071 ing sub. And then we need to dig deeper if this is a lexical from
8073 my sub foo; sub { sub foo { } }
8076 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8077 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8078 pax = PARENT_PAD_INDEX(name);
8079 outcv = CvOUTSIDE(outcv);
8084 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8085 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8086 spot = (CV **)svspot;
8088 if (!(PL_parser && PL_parser->error_count))
8089 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8092 assert(proto->op_type == OP_CONST);
8093 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8094 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8104 if (PL_parser && PL_parser->error_count) {
8106 SvREFCNT_dec(PL_compcv);
8111 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8113 svspot = (SV **)(spot = &clonee);
8115 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8118 assert (SvTYPE(*spot) == SVt_PVCV);
8120 hek = CvNAME_HEK(*spot);
8124 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8125 CvNAME_HEK_set(*spot, hek =
8128 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8132 CvLEXICAL_on(*spot);
8134 cv = PadnamePROTOCV(name);
8135 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8139 /* This makes sub {}; work as expected. */
8140 if (block->op_type == OP_STUB) {
8141 const line_t l = PL_parser->copline;
8143 block = newSTATEOP(0, NULL, 0);
8144 PL_parser->copline = l;
8146 block = CvLVALUE(compcv)
8147 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8148 ? newUNOP(OP_LEAVESUBLV, 0,
8149 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8150 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8151 start = LINKLIST(block);
8155 if (!block || !ps || *ps || attrs
8160 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8163 const bool exists = CvROOT(cv) || CvXSUB(cv);
8165 /* if the subroutine doesn't exist and wasn't pre-declared
8166 * with a prototype, assume it will be AUTOLOADed,
8167 * skipping the prototype check
8169 if (exists || SvPOK(cv))
8170 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8172 /* already defined? */
8174 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8177 if (attrs) goto attrs;
8178 /* just a "sub foo;" when &foo is already defined */
8183 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8189 SvREFCNT_inc_simple_void_NN(const_sv);
8190 SvFLAGS(const_sv) |= SVs_PADTMP;
8192 assert(!CvROOT(cv) && !CvCONST(cv));
8196 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8197 CvFILE_set_from_cop(cv, PL_curcop);
8198 CvSTASH_set(cv, PL_curstash);
8201 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8202 CvXSUBANY(cv).any_ptr = const_sv;
8203 CvXSUB(cv) = const_sv_xsub;
8207 CvFLAGS(cv) |= CvMETHOD(compcv);
8209 SvREFCNT_dec(compcv);
8213 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8214 determine whether this sub definition is in the same scope as its
8215 declaration. If this sub definition is inside an inner named pack-
8216 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8217 the package sub. So check PadnameOUTER(name) too.
8219 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8220 assert(!CvWEAKOUTSIDE(compcv));
8221 SvREFCNT_dec(CvOUTSIDE(compcv));
8222 CvWEAKOUTSIDE_on(compcv);
8224 /* XXX else do we have a circular reference? */
8225 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8226 /* transfer PL_compcv to cv */
8229 cv_flags_t preserved_flags =
8230 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8231 PADLIST *const temp_padl = CvPADLIST(cv);
8232 CV *const temp_cv = CvOUTSIDE(cv);
8233 const cv_flags_t other_flags =
8234 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8235 OP * const cvstart = CvSTART(cv);
8239 CvFLAGS(compcv) | preserved_flags;
8240 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8241 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8242 CvPADLIST_set(cv, CvPADLIST(compcv));
8243 CvOUTSIDE(compcv) = temp_cv;
8244 CvPADLIST_set(compcv, temp_padl);
8245 CvSTART(cv) = CvSTART(compcv);
8246 CvSTART(compcv) = cvstart;
8247 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8248 CvFLAGS(compcv) |= other_flags;
8250 if (CvFILE(cv) && CvDYNFILE(cv)) {
8251 Safefree(CvFILE(cv));
8254 /* inner references to compcv must be fixed up ... */
8255 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8256 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8257 ++PL_sub_generation;
8260 /* Might have had built-in attributes applied -- propagate them. */
8261 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8263 /* ... before we throw it away */
8264 SvREFCNT_dec(compcv);
8265 PL_compcv = compcv = cv;
8273 if (!CvNAME_HEK(cv)) {
8274 if (hek) (void)share_hek_hek(hek);
8278 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8279 hek = share_hek(PadnamePV(name)+1,
8280 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8283 CvNAME_HEK_set(cv, hek);
8285 if (const_sv) goto clone;
8287 CvFILE_set_from_cop(cv, PL_curcop);
8288 CvSTASH_set(cv, PL_curstash);
8291 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8292 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8298 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8299 the debugger could be able to set a breakpoint in, so signal to
8300 pp_entereval that it should not throw away any saved lines at scope
8303 PL_breakable_sub_gen++;
8305 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8306 OpREFCNT_set(CvROOT(cv), 1);
8307 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8308 itself has a refcount. */
8310 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8311 #ifdef PERL_DEBUG_READONLY_OPS
8312 slab = (OPSLAB *)CvSTART(cv);
8314 CvSTART(cv) = start;
8316 finalize_optree(CvROOT(cv));
8317 S_prune_chain_head(&CvSTART(cv));
8319 /* now that optimizer has done its work, adjust pad values */
8321 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8325 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8326 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8330 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8331 SV * const tmpstr = sv_newmortal();
8332 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8333 GV_ADDMULTI, SVt_PVHV);
8335 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8338 (long)CopLINE(PL_curcop));
8339 if (HvNAME_HEK(PL_curstash)) {
8340 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8341 sv_catpvs(tmpstr, "::");
8343 else sv_setpvs(tmpstr, "__ANON__::");
8344 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8345 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8346 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8347 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8348 hv = GvHVn(db_postponed);
8349 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8350 CV * const pcv = GvCV(db_postponed);
8356 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8364 assert(CvDEPTH(outcv));
8366 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8367 if (reusable) cv_clone_into(clonee, *spot);
8368 else *spot = cv_clone(clonee);
8369 SvREFCNT_dec_NN(clonee);
8372 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8373 PADOFFSET depth = CvDEPTH(outcv);
8376 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8378 *svspot = SvREFCNT_inc_simple_NN(cv);
8379 SvREFCNT_dec(oldcv);
8385 PL_parser->copline = NOLINE;
8387 #ifdef PERL_DEBUG_READONLY_OPS
8397 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8398 OP *block, bool o_is_gv)
8402 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8406 const bool ec = PL_parser && PL_parser->error_count;
8407 /* If the subroutine has no body, no attributes, and no builtin attributes
8408 then it's just a sub declaration, and we may be able to get away with
8409 storing with a placeholder scalar in the symbol table, rather than a
8410 full CV. If anything is present then it will take a full CV to
8412 const I32 gv_fetch_flags
8413 = ec ? GV_NOADD_NOINIT :
8414 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8415 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8417 const char * const name =
8418 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8420 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8421 bool evanescent = FALSE;
8423 #ifdef PERL_DEBUG_READONLY_OPS
8424 OPSLAB *slab = NULL;
8432 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8433 hek and CvSTASH pointer together can imply the GV. If the name
8434 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8435 CvSTASH, so forego the optimisation if we find any.
8436 Also, we may be called from load_module at run time, so
8437 PL_curstash (which sets CvSTASH) may not point to the stash the
8438 sub is stored in. */
8440 ec ? GV_NOADD_NOINIT
8441 : PL_curstash != CopSTASH(PL_curcop)
8442 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8444 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8445 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8447 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8448 SV * const sv = sv_newmortal();
8449 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8450 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8451 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8452 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8454 } else if (PL_curstash) {
8455 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8458 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8462 move_proto_attr(&proto, &attrs,
8463 isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
8466 assert(proto->op_type == OP_CONST);
8467 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8468 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8482 if (name) SvREFCNT_dec(PL_compcv);
8483 else cv = PL_compcv;
8485 if (name && block) {
8486 const char *s = strrchr(name, ':');
8488 if (strEQ(s, "BEGIN")) {
8489 if (PL_in_eval & EVAL_KEEPERR)
8490 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8492 SV * const errsv = ERRSV;
8493 /* force display of errors found but not reported */
8494 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8495 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8502 if (!block && SvTYPE(gv) != SVt_PVGV) {
8503 /* If we are not defining a new sub and the existing one is not a
8505 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8506 /* We are applying attributes to an existing sub, so we need it
8507 upgraded if it is a constant. */
8508 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8509 gv_init_pvn(gv, PL_curstash, name, namlen,
8510 SVf_UTF8 * name_is_utf8);
8512 else { /* Maybe prototype now, and had at maximum
8513 a prototype or const/sub ref before. */
8514 if (SvTYPE(gv) > SVt_NULL) {
8515 cv_ckproto_len_flags((const CV *)gv,
8516 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8521 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8522 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8525 sv_setiv(MUTABLE_SV(gv), -1);
8528 SvREFCNT_dec(PL_compcv);
8529 cv = PL_compcv = NULL;
8534 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8538 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8543 /* This makes sub {}; work as expected. */
8544 if (block->op_type == OP_STUB) {
8545 const line_t l = PL_parser->copline;
8547 block = newSTATEOP(0, NULL, 0);
8548 PL_parser->copline = l;
8550 block = CvLVALUE(PL_compcv)
8551 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8552 && (!isGV(gv) || !GvASSUMECV(gv)))
8553 ? newUNOP(OP_LEAVESUBLV, 0,
8554 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8555 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8556 start = LINKLIST(block);
8560 if (!block || !ps || *ps || attrs
8561 || CvLVALUE(PL_compcv)
8566 S_op_const_sv(aTHX_ start, PL_compcv, cBOOL(CvCLONE(PL_compcv)));
8568 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8570 cv_ckproto_len_flags((const CV *)gv,
8571 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8572 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8574 /* All the other code for sub redefinition warnings expects the
8575 clobbered sub to be a CV. Instead of making all those code
8576 paths more complex, just inline the RV version here. */
8577 const line_t oldline = CopLINE(PL_curcop);
8578 assert(IN_PERL_COMPILETIME);
8579 if (PL_parser && PL_parser->copline != NOLINE)
8580 /* This ensures that warnings are reported at the first
8581 line of a redefinition, not the last. */
8582 CopLINE_set(PL_curcop, PL_parser->copline);
8583 /* protect against fatal warnings leaking compcv */
8584 SAVEFREESV(PL_compcv);
8586 if (ckWARN(WARN_REDEFINE)
8587 || ( ckWARN_d(WARN_REDEFINE)
8588 && ( !const_sv || SvRV(gv) == const_sv
8589 || sv_cmp(SvRV(gv), const_sv) )))
8590 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8591 "Constant subroutine %"SVf" redefined",
8592 SVfARG(cSVOPo->op_sv));
8594 SvREFCNT_inc_simple_void_NN(PL_compcv);
8595 CopLINE_set(PL_curcop, oldline);
8596 SvREFCNT_dec(SvRV(gv));
8601 const bool exists = CvROOT(cv) || CvXSUB(cv);
8603 /* if the subroutine doesn't exist and wasn't pre-declared
8604 * with a prototype, assume it will be AUTOLOADed,
8605 * skipping the prototype check
8607 if (exists || SvPOK(cv))
8608 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8609 /* already defined (or promised)? */
8610 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8611 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8614 if (attrs) goto attrs;
8615 /* just a "sub foo;" when &foo is already defined */
8616 SAVEFREESV(PL_compcv);
8622 SvREFCNT_inc_simple_void_NN(const_sv);
8623 SvFLAGS(const_sv) |= SVs_PADTMP;
8625 assert(!CvROOT(cv) && !CvCONST(cv));
8627 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8628 CvXSUBANY(cv).any_ptr = const_sv;
8629 CvXSUB(cv) = const_sv_xsub;
8633 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8636 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8637 if (name && isGV(gv))
8639 cv = newCONSTSUB_flags(
8640 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8643 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8647 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8648 prepare_SV_for_RV((SV *)gv);
8652 SvRV_set(gv, const_sv);
8656 SvREFCNT_dec(PL_compcv);
8660 if (cv) { /* must reuse cv if autoloaded */
8661 /* transfer PL_compcv to cv */
8664 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8665 PADLIST *const temp_av = CvPADLIST(cv);
8666 CV *const temp_cv = CvOUTSIDE(cv);
8667 const cv_flags_t other_flags =
8668 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8669 OP * const cvstart = CvSTART(cv);
8673 assert(!CvCVGV_RC(cv));
8674 assert(CvGV(cv) == gv);
8679 PERL_HASH(hash, name, namlen);
8689 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8691 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8692 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8693 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8694 CvOUTSIDE(PL_compcv) = temp_cv;
8695 CvPADLIST_set(PL_compcv, temp_av);
8696 CvSTART(cv) = CvSTART(PL_compcv);
8697 CvSTART(PL_compcv) = cvstart;
8698 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8699 CvFLAGS(PL_compcv) |= other_flags;
8701 if (CvFILE(cv) && CvDYNFILE(cv)) {
8702 Safefree(CvFILE(cv));
8704 CvFILE_set_from_cop(cv, PL_curcop);
8705 CvSTASH_set(cv, PL_curstash);
8707 /* inner references to PL_compcv must be fixed up ... */
8708 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8709 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8710 ++PL_sub_generation;
8713 /* Might have had built-in attributes applied -- propagate them. */
8714 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8716 /* ... before we throw it away */
8717 SvREFCNT_dec(PL_compcv);
8722 if (name && isGV(gv)) {
8725 if (HvENAME_HEK(GvSTASH(gv)))
8726 /* sub Foo::bar { (shift)+1 } */
8727 gv_method_changed(gv);
8731 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8732 prepare_SV_for_RV((SV *)gv);
8736 SvRV_set(gv, (SV *)cv);
8740 if (isGV(gv)) CvGV_set(cv, gv);
8744 PERL_HASH(hash, name, namlen);
8745 CvNAME_HEK_set(cv, share_hek(name,
8751 CvFILE_set_from_cop(cv, PL_curcop);
8752 CvSTASH_set(cv, PL_curstash);
8756 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8757 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8763 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8764 the debugger could be able to set a breakpoint in, so signal to
8765 pp_entereval that it should not throw away any saved lines at scope
8768 PL_breakable_sub_gen++;
8770 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8771 OpREFCNT_set(CvROOT(cv), 1);
8772 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8773 itself has a refcount. */
8775 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8776 #ifdef PERL_DEBUG_READONLY_OPS
8777 slab = (OPSLAB *)CvSTART(cv);
8779 CvSTART(cv) = start;
8781 finalize_optree(CvROOT(cv));
8782 S_prune_chain_head(&CvSTART(cv));
8784 /* now that optimizer has done its work, adjust pad values */
8786 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8790 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8791 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8794 if (!name) SAVEFREESV(cv);
8795 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8796 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8799 if (block && has_name) {
8800 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8801 SV * const tmpstr = cv_name(cv,NULL,0);
8802 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8803 GV_ADDMULTI, SVt_PVHV);
8805 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8808 (long)CopLINE(PL_curcop));
8809 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8810 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8811 hv = GvHVn(db_postponed);
8812 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8813 CV * const pcv = GvCV(db_postponed);
8819 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8825 if (PL_parser && PL_parser->error_count)
8826 clear_special_blocks(name, gv, cv);
8829 process_special_blocks(floor, name, gv, cv);
8835 PL_parser->copline = NOLINE;
8838 #ifdef PERL_DEBUG_READONLY_OPS
8842 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8843 pad_add_weakref(cv);
8849 S_clear_special_blocks(pTHX_ const char *const fullname,
8850 GV *const gv, CV *const cv) {
8854 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8856 colon = strrchr(fullname,':');
8857 name = colon ? colon + 1 : fullname;
8859 if ((*name == 'B' && strEQ(name, "BEGIN"))
8860 || (*name == 'E' && strEQ(name, "END"))
8861 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8862 || (*name == 'C' && strEQ(name, "CHECK"))
8863 || (*name == 'I' && strEQ(name, "INIT"))) {
8869 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8873 /* Returns true if the sub has been freed. */
8875 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8879 const char *const colon = strrchr(fullname,':');
8880 const char *const name = colon ? colon + 1 : fullname;
8882 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8885 if (strEQ(name, "BEGIN")) {
8886 const I32 oldscope = PL_scopestack_ix;
8889 if (floor) LEAVE_SCOPE(floor);
8891 PUSHSTACKi(PERLSI_REQUIRE);
8892 SAVECOPFILE(&PL_compiling);
8893 SAVECOPLINE(&PL_compiling);
8894 SAVEVPTR(PL_curcop);
8896 DEBUG_x( dump_sub(gv) );
8897 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8898 GvCV_set(gv,0); /* cv has been hijacked */
8899 call_list(oldscope, PL_beginav);
8903 return !PL_savebegin;
8909 if strEQ(name, "END") {
8910 DEBUG_x( dump_sub(gv) );
8911 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8914 } else if (*name == 'U') {
8915 if (strEQ(name, "UNITCHECK")) {
8916 /* It's never too late to run a unitcheck block */
8917 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8921 } else if (*name == 'C') {
8922 if (strEQ(name, "CHECK")) {
8924 /* diag_listed_as: Too late to run %s block */
8925 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8926 "Too late to run CHECK block");
8927 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8931 } else if (*name == 'I') {
8932 if (strEQ(name, "INIT")) {
8934 /* diag_listed_as: Too late to run %s block */
8935 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8936 "Too late to run INIT block");
8937 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8943 DEBUG_x( dump_sub(gv) );
8945 GvCV_set(gv,0); /* cv has been hijacked */
8951 =for apidoc newCONSTSUB
8953 See L</newCONSTSUB_flags>.
8959 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8961 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8965 =for apidoc newCONSTSUB_flags
8967 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8968 eligible for inlining at compile-time.
8970 Currently, the only useful value for C<flags> is SVf_UTF8.
8972 The newly created subroutine takes ownership of a reference to the passed in
8975 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8976 which won't be called if used as a destructor, but will suppress the overhead
8977 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8984 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8988 const char *const file = CopFILE(PL_curcop);
8992 if (IN_PERL_RUNTIME) {
8993 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8994 * an op shared between threads. Use a non-shared COP for our
8996 SAVEVPTR(PL_curcop);
8997 SAVECOMPILEWARNINGS();
8998 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8999 PL_curcop = &PL_compiling;
9001 SAVECOPLINE(PL_curcop);
9002 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9005 PL_hints &= ~HINT_BLOCK_SCOPE;
9008 SAVEGENERICSV(PL_curstash);
9009 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9012 /* Protect sv against leakage caused by fatal warnings. */
9013 if (sv) SAVEFREESV(sv);
9015 /* file becomes the CvFILE. For an XS, it's usually static storage,
9016 and so doesn't get free()d. (It's expected to be from the C pre-
9017 processor __FILE__ directive). But we need a dynamically allocated one,
9018 and we need it to get freed. */
9019 cv = newXS_len_flags(name, len,
9020 sv && SvTYPE(sv) == SVt_PVAV
9023 file ? file : "", "",
9024 &sv, XS_DYNAMIC_FILENAME | flags);
9025 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9034 =for apidoc U||newXS
9036 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
9037 static storage, as it is used directly as CvFILE(), without a copy being made.
9043 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9045 PERL_ARGS_ASSERT_NEWXS;
9046 return newXS_len_flags(
9047 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9052 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9053 const char *const filename, const char *const proto,
9056 PERL_ARGS_ASSERT_NEWXS_FLAGS;
9057 return newXS_len_flags(
9058 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9063 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9065 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9066 return newXS_len_flags(
9067 name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
9072 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9073 XSUBADDR_t subaddr, const char *const filename,
9074 const char *const proto, SV **const_svp,
9078 bool interleave = FALSE;
9080 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9082 Perl_croak_nocontext("panic: no address for '%s' in '%s'",
9083 name, filename ? filename : PL_xsubfilename);
9085 GV * const gv = gv_fetchpvn(
9086 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9087 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9088 sizeof("__ANON__::__ANON__") - 1,
9089 GV_ADDMULTI | flags, SVt_PVCV);
9091 if ((cv = (name ? GvCV(gv) : NULL))) {
9093 /* just a cached method */
9097 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9098 /* already defined (or promised) */
9099 /* Redundant check that allows us to avoid creating an SV
9100 most of the time: */
9101 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9102 report_redefined_cv(newSVpvn_flags(
9103 name,len,(flags&SVf_UTF8)|SVs_TEMP
9114 if (cv) /* must reuse cv if autoloaded */
9117 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9121 if (HvENAME_HEK(GvSTASH(gv)))
9122 gv_method_changed(gv); /* newXS */
9128 (void)gv_fetchfile(filename);
9129 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9130 if (flags & XS_DYNAMIC_FILENAME) {
9132 CvFILE(cv) = savepv(filename);
9134 /* NOTE: not copied, as it is expected to be an external constant string */
9135 CvFILE(cv) = (char *)filename;
9138 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9139 CvFILE(cv) = (char*)PL_xsubfilename;
9142 CvXSUB(cv) = subaddr;
9143 #ifndef PERL_IMPLICIT_CONTEXT
9144 CvHSCXT(cv) = &PL_stack_sp;
9150 process_special_blocks(0, name, gv, cv);
9153 } /* <- not a conditional branch */
9156 sv_setpv(MUTABLE_SV(cv), proto);
9157 if (interleave) LEAVE;
9162 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9164 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9166 PERL_ARGS_ASSERT_NEWSTUB;
9170 if (!fake && HvENAME_HEK(GvSTASH(gv)))
9171 gv_method_changed(gv);
9173 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9178 CvFILE_set_from_cop(cv, PL_curcop);
9179 CvSTASH_set(cv, PL_curstash);
9185 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9191 if (PL_parser && PL_parser->error_count) {
9197 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9198 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9201 if ((cv = GvFORM(gv))) {
9202 if (ckWARN(WARN_REDEFINE)) {
9203 const line_t oldline = CopLINE(PL_curcop);
9204 if (PL_parser && PL_parser->copline != NOLINE)
9205 CopLINE_set(PL_curcop, PL_parser->copline);
9207 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9208 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9210 /* diag_listed_as: Format %s redefined */
9211 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9212 "Format STDOUT redefined");
9214 CopLINE_set(PL_curcop, oldline);
9219 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9221 CvFILE_set_from_cop(cv, PL_curcop);
9224 pad_tidy(padtidy_FORMAT);
9225 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9226 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9227 OpREFCNT_set(CvROOT(cv), 1);
9228 CvSTART(cv) = LINKLIST(CvROOT(cv));
9229 CvROOT(cv)->op_next = 0;
9230 CALL_PEEP(CvSTART(cv));
9231 finalize_optree(CvROOT(cv));
9232 S_prune_chain_head(&CvSTART(cv));
9238 PL_parser->copline = NOLINE;
9240 PL_compiling.cop_seq = 0;
9244 Perl_newANONLIST(pTHX_ OP *o)
9246 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9250 Perl_newANONHASH(pTHX_ OP *o)
9252 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9256 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9258 return newANONATTRSUB(floor, proto, NULL, block);
9262 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9264 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9266 newSVOP(OP_ANONCODE, 0,
9268 if (CvANONCONST(cv))
9269 anoncode = newUNOP(OP_ANONCONST, 0,
9270 op_convert_list(OP_ENTERSUB,
9271 OPf_STACKED|OPf_WANT_SCALAR,
9273 return newUNOP(OP_REFGEN, 0, anoncode);
9277 Perl_oopsAV(pTHX_ OP *o)
9281 PERL_ARGS_ASSERT_OOPSAV;
9283 switch (o->op_type) {
9286 CHANGE_TYPE(o, OP_PADAV);
9287 return ref(o, OP_RV2AV);
9291 CHANGE_TYPE(o, OP_RV2AV);
9296 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9303 Perl_oopsHV(pTHX_ OP *o)
9307 PERL_ARGS_ASSERT_OOPSHV;
9309 switch (o->op_type) {
9312 CHANGE_TYPE(o, OP_PADHV);
9313 return ref(o, OP_RV2HV);
9317 CHANGE_TYPE(o, OP_RV2HV);
9322 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9329 Perl_newAVREF(pTHX_ OP *o)
9333 PERL_ARGS_ASSERT_NEWAVREF;
9335 if (o->op_type == OP_PADANY) {
9336 CHANGE_TYPE(o, OP_PADAV);
9339 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9340 Perl_croak(aTHX_ "Can't use an array as a reference");
9342 return newUNOP(OP_RV2AV, 0, scalar(o));
9346 Perl_newGVREF(pTHX_ I32 type, OP *o)
9348 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9349 return newUNOP(OP_NULL, 0, o);
9350 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9354 Perl_newHVREF(pTHX_ OP *o)
9358 PERL_ARGS_ASSERT_NEWHVREF;
9360 if (o->op_type == OP_PADANY) {
9361 CHANGE_TYPE(o, OP_PADHV);
9364 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9365 Perl_croak(aTHX_ "Can't use a hash as a reference");
9367 return newUNOP(OP_RV2HV, 0, scalar(o));
9371 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9373 if (o->op_type == OP_PADANY) {
9375 CHANGE_TYPE(o, OP_PADCV);
9377 return newUNOP(OP_RV2CV, flags, scalar(o));
9381 Perl_newSVREF(pTHX_ OP *o)
9385 PERL_ARGS_ASSERT_NEWSVREF;
9387 if (o->op_type == OP_PADANY) {
9388 CHANGE_TYPE(o, OP_PADSV);
9392 return newUNOP(OP_RV2SV, 0, scalar(o));
9395 /* Check routines. See the comments at the top of this file for details
9396 * on when these are called */
9399 Perl_ck_anoncode(pTHX_ OP *o)
9401 PERL_ARGS_ASSERT_CK_ANONCODE;
9403 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9404 cSVOPo->op_sv = NULL;
9409 S_io_hints(pTHX_ OP *o)
9411 #if O_BINARY != 0 || O_TEXT != 0
9413 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9415 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9418 const char *d = SvPV_const(*svp, len);
9419 const I32 mode = mode_from_discipline(d, len);
9420 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9422 if (mode & O_BINARY)
9423 o->op_private |= OPpOPEN_IN_RAW;
9427 o->op_private |= OPpOPEN_IN_CRLF;
9431 svp = hv_fetchs(table, "open_OUT", FALSE);
9434 const char *d = SvPV_const(*svp, len);
9435 const I32 mode = mode_from_discipline(d, len);
9436 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9438 if (mode & O_BINARY)
9439 o->op_private |= OPpOPEN_OUT_RAW;
9443 o->op_private |= OPpOPEN_OUT_CRLF;
9448 PERL_UNUSED_CONTEXT;
9454 Perl_ck_backtick(pTHX_ OP *o)
9459 PERL_ARGS_ASSERT_CK_BACKTICK;
9460 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9461 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9462 && (gv = gv_override("readpipe",8)))
9464 /* detach rest of siblings from o and its first child */
9465 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9466 newop = S_new_entersubop(aTHX_ gv, sibl);
9468 else if (!(o->op_flags & OPf_KIDS))
9469 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9474 S_io_hints(aTHX_ o);
9479 Perl_ck_bitop(pTHX_ OP *o)
9481 PERL_ARGS_ASSERT_CK_BITOP;
9483 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9484 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9485 && (o->op_type == OP_BIT_OR
9486 || o->op_type == OP_BIT_AND
9487 || o->op_type == OP_BIT_XOR))
9489 const OP * const left = cBINOPo->op_first;
9490 const OP * const right = OpSIBLING(left);
9491 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9492 (left->op_flags & OPf_PARENS) == 0) ||
9493 (OP_IS_NUMCOMPARE(right->op_type) &&
9494 (right->op_flags & OPf_PARENS) == 0))
9495 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9496 "Possible precedence problem on bitwise %c operator",
9497 o->op_type == OP_BIT_OR ? '|'
9498 : o->op_type == OP_BIT_AND ? '&' : '^'
9504 PERL_STATIC_INLINE bool
9505 is_dollar_bracket(pTHX_ const OP * const o)
9508 PERL_UNUSED_CONTEXT;
9509 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9510 && (kid = cUNOPx(o)->op_first)
9511 && kid->op_type == OP_GV
9512 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9516 Perl_ck_cmp(pTHX_ OP *o)
9518 PERL_ARGS_ASSERT_CK_CMP;
9519 if (ckWARN(WARN_SYNTAX)) {
9520 const OP *kid = cUNOPo->op_first;
9523 ( is_dollar_bracket(aTHX_ kid)
9524 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9526 || ( kid->op_type == OP_CONST
9527 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9531 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9532 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9538 Perl_ck_concat(pTHX_ OP *o)
9540 const OP * const kid = cUNOPo->op_first;
9542 PERL_ARGS_ASSERT_CK_CONCAT;
9543 PERL_UNUSED_CONTEXT;
9545 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9546 !(kUNOP->op_first->op_flags & OPf_MOD))
9547 o->op_flags |= OPf_STACKED;
9552 Perl_ck_spair(pTHX_ OP *o)
9556 PERL_ARGS_ASSERT_CK_SPAIR;
9558 if (o->op_flags & OPf_KIDS) {
9562 const OPCODE type = o->op_type;
9563 o = modkids(ck_fun(o), type);
9564 kid = cUNOPo->op_first;
9565 kidkid = kUNOP->op_first;
9566 newop = OpSIBLING(kidkid);
9568 const OPCODE type = newop->op_type;
9569 if (OpHAS_SIBLING(newop))
9571 if (o->op_type == OP_REFGEN
9572 && ( type == OP_RV2CV
9573 || ( !(newop->op_flags & OPf_PARENS)
9574 && ( type == OP_RV2AV || type == OP_PADAV
9575 || type == OP_RV2HV || type == OP_PADHV))))
9576 NOOP; /* OK (allow srefgen for \@a and \%h) */
9577 else if (OP_GIMME(newop,0) != G_SCALAR)
9580 /* excise first sibling */
9581 op_sibling_splice(kid, NULL, 1, NULL);
9584 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9585 * and OP_CHOMP into OP_SCHOMP */
9586 o->op_ppaddr = PL_ppaddr[++o->op_type];
9591 Perl_ck_delete(pTHX_ OP *o)
9593 PERL_ARGS_ASSERT_CK_DELETE;
9597 if (o->op_flags & OPf_KIDS) {
9598 OP * const kid = cUNOPo->op_first;
9599 switch (kid->op_type) {
9601 o->op_flags |= OPf_SPECIAL;
9604 o->op_private |= OPpSLICE;
9607 o->op_flags |= OPf_SPECIAL;
9612 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9613 " use array slice");
9615 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9618 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9619 "element or slice");
9621 if (kid->op_private & OPpLVAL_INTRO)
9622 o->op_private |= OPpLVAL_INTRO;
9629 Perl_ck_eof(pTHX_ OP *o)
9631 PERL_ARGS_ASSERT_CK_EOF;
9633 if (o->op_flags & OPf_KIDS) {
9635 if (cLISTOPo->op_first->op_type == OP_STUB) {
9637 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9642 kid = cLISTOPo->op_first;
9643 if (kid->op_type == OP_RV2GV)
9644 kid->op_private |= OPpALLOW_FAKE;
9650 Perl_ck_eval(pTHX_ OP *o)
9654 PERL_ARGS_ASSERT_CK_EVAL;
9656 PL_hints |= HINT_BLOCK_SCOPE;
9657 if (o->op_flags & OPf_KIDS) {
9658 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9661 if (o->op_type == OP_ENTERTRY) {
9664 /* cut whole sibling chain free from o */
9665 op_sibling_splice(o, NULL, -1, NULL);
9668 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9670 /* establish postfix order */
9671 enter->op_next = (OP*)enter;
9673 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9674 CHANGE_TYPE(o, OP_LEAVETRY);
9675 enter->op_other = o;
9680 S_set_haseval(aTHX);
9684 const U8 priv = o->op_private;
9686 /* the newUNOP will recursively call ck_eval(), which will handle
9687 * all the stuff at the end of this function, like adding
9690 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9692 o->op_targ = (PADOFFSET)PL_hints;
9693 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9694 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9695 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9696 /* Store a copy of %^H that pp_entereval can pick up. */
9697 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9698 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9699 /* append hhop to only child */
9700 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9702 o->op_private |= OPpEVAL_HAS_HH;
9704 if (!(o->op_private & OPpEVAL_BYTES)
9705 && FEATURE_UNIEVAL_IS_ENABLED)
9706 o->op_private |= OPpEVAL_UNICODE;
9711 Perl_ck_exec(pTHX_ OP *o)
9713 PERL_ARGS_ASSERT_CK_EXEC;
9715 if (o->op_flags & OPf_STACKED) {
9718 kid = OpSIBLING(cUNOPo->op_first);
9719 if (kid->op_type == OP_RV2GV)
9728 Perl_ck_exists(pTHX_ OP *o)
9730 PERL_ARGS_ASSERT_CK_EXISTS;
9733 if (o->op_flags & OPf_KIDS) {
9734 OP * const kid = cUNOPo->op_first;
9735 if (kid->op_type == OP_ENTERSUB) {
9736 (void) ref(kid, o->op_type);
9737 if (kid->op_type != OP_RV2CV
9738 && !(PL_parser && PL_parser->error_count))
9740 "exists argument is not a subroutine name");
9741 o->op_private |= OPpEXISTS_SUB;
9743 else if (kid->op_type == OP_AELEM)
9744 o->op_flags |= OPf_SPECIAL;
9745 else if (kid->op_type != OP_HELEM)
9746 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9747 "element or a subroutine");
9754 Perl_ck_rvconst(pTHX_ OP *o)
9757 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9759 PERL_ARGS_ASSERT_CK_RVCONST;
9761 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9763 if (kid->op_type == OP_CONST) {
9766 SV * const kidsv = kid->op_sv;
9768 /* Is it a constant from cv_const_sv()? */
9769 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9772 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9773 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9774 const char *badthing;
9775 switch (o->op_type) {
9777 badthing = "a SCALAR";
9780 badthing = "an ARRAY";
9783 badthing = "a HASH";
9791 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9792 SVfARG(kidsv), badthing);
9795 * This is a little tricky. We only want to add the symbol if we
9796 * didn't add it in the lexer. Otherwise we get duplicate strict
9797 * warnings. But if we didn't add it in the lexer, we must at
9798 * least pretend like we wanted to add it even if it existed before,
9799 * or we get possible typo warnings. OPpCONST_ENTERED says
9800 * whether the lexer already added THIS instance of this symbol.
9802 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9803 gv = gv_fetchsv(kidsv,
9804 o->op_type == OP_RV2CV
9805 && o->op_private & OPpMAY_RETURN_CONSTANT
9807 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9810 : o->op_type == OP_RV2SV
9812 : o->op_type == OP_RV2AV
9814 : o->op_type == OP_RV2HV
9821 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9822 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9823 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9825 CHANGE_TYPE(kid, OP_GV);
9826 SvREFCNT_dec(kid->op_sv);
9828 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9829 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9830 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9831 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9832 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9834 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9836 kid->op_private = 0;
9837 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9845 Perl_ck_ftst(pTHX_ OP *o)
9848 const I32 type = o->op_type;
9850 PERL_ARGS_ASSERT_CK_FTST;
9852 if (o->op_flags & OPf_REF) {
9855 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9856 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9857 const OPCODE kidtype = kid->op_type;
9859 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9860 && !kid->op_folded) {
9861 OP * const newop = newGVOP(type, OPf_REF,
9862 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9866 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9867 o->op_private |= OPpFT_ACCESS;
9868 if (PL_check[kidtype] == Perl_ck_ftst
9869 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9870 o->op_private |= OPpFT_STACKED;
9871 kid->op_private |= OPpFT_STACKING;
9872 if (kidtype == OP_FTTTY && (
9873 !(kid->op_private & OPpFT_STACKED)
9874 || kid->op_private & OPpFT_AFTER_t
9876 o->op_private |= OPpFT_AFTER_t;
9881 if (type == OP_FTTTY)
9882 o = newGVOP(type, OPf_REF, PL_stdingv);
9884 o = newUNOP(type, 0, newDEFSVOP());
9890 Perl_ck_fun(pTHX_ OP *o)
9892 const int type = o->op_type;
9893 I32 oa = PL_opargs[type] >> OASHIFT;
9895 PERL_ARGS_ASSERT_CK_FUN;
9897 if (o->op_flags & OPf_STACKED) {
9898 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9901 return no_fh_allowed(o);
9904 if (o->op_flags & OPf_KIDS) {
9905 OP *prev_kid = NULL;
9906 OP *kid = cLISTOPo->op_first;
9908 bool seen_optional = FALSE;
9910 if (kid->op_type == OP_PUSHMARK ||
9911 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9914 kid = OpSIBLING(kid);
9916 if (kid && kid->op_type == OP_COREARGS) {
9917 bool optional = FALSE;
9920 if (oa & OA_OPTIONAL) optional = TRUE;
9923 if (optional) o->op_private |= numargs;
9928 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9929 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9931 /* append kid to chain */
9932 op_sibling_splice(o, prev_kid, 0, kid);
9934 seen_optional = TRUE;
9941 /* list seen where single (scalar) arg expected? */
9942 if (numargs == 1 && !(oa >> 4)
9943 && kid->op_type == OP_LIST && type != OP_SCALAR)
9945 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9947 if (type != OP_DELETE) scalar(kid);
9958 if ((type == OP_PUSH || type == OP_UNSHIFT)
9959 && !OpHAS_SIBLING(kid))
9960 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9961 "Useless use of %s with no values",
9964 if (kid->op_type == OP_CONST
9965 && ( !SvROK(cSVOPx_sv(kid))
9966 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9968 bad_type_pv(numargs, "array", o, kid);
9969 /* Defer checks to run-time if we have a scalar arg */
9970 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9971 op_lvalue(kid, type);
9974 /* diag_listed_as: push on reference is experimental */
9975 Perl_ck_warner_d(aTHX_
9976 packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9977 "%s on reference is experimental",
9982 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9983 bad_type_pv(numargs, "hash", o, kid);
9984 op_lvalue(kid, type);
9988 /* replace kid with newop in chain */
9990 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9991 newop->op_next = newop;
9996 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9997 if (kid->op_type == OP_CONST &&
9998 (kid->op_private & OPpCONST_BARE))
10000 OP * const newop = newGVOP(OP_GV, 0,
10001 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10002 /* replace kid with newop in chain */
10003 op_sibling_splice(o, prev_kid, 1, newop);
10007 else if (kid->op_type == OP_READLINE) {
10008 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10009 bad_type_pv(numargs, "HANDLE", o, kid);
10012 I32 flags = OPf_SPECIAL;
10014 PADOFFSET targ = 0;
10016 /* is this op a FH constructor? */
10017 if (is_handle_constructor(o,numargs)) {
10018 const char *name = NULL;
10021 bool want_dollar = TRUE;
10024 /* Set a flag to tell rv2gv to vivify
10025 * need to "prove" flag does not mean something
10026 * else already - NI-S 1999/05/07
10029 if (kid->op_type == OP_PADSV) {
10031 = PAD_COMPNAME_SV(kid->op_targ);
10032 name = PadnamePV (pn);
10033 len = PadnameLEN(pn);
10034 name_utf8 = PadnameUTF8(pn);
10036 else if (kid->op_type == OP_RV2SV
10037 && kUNOP->op_first->op_type == OP_GV)
10039 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10041 len = GvNAMELEN(gv);
10042 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10044 else if (kid->op_type == OP_AELEM
10045 || kid->op_type == OP_HELEM)
10048 OP *op = ((BINOP*)kid)->op_first;
10052 const char * const a =
10053 kid->op_type == OP_AELEM ?
10055 if (((op->op_type == OP_RV2AV) ||
10056 (op->op_type == OP_RV2HV)) &&
10057 (firstop = ((UNOP*)op)->op_first) &&
10058 (firstop->op_type == OP_GV)) {
10059 /* packagevar $a[] or $h{} */
10060 GV * const gv = cGVOPx_gv(firstop);
10063 Perl_newSVpvf(aTHX_
10068 else if (op->op_type == OP_PADAV
10069 || op->op_type == OP_PADHV) {
10070 /* lexicalvar $a[] or $h{} */
10071 const char * const padname =
10072 PAD_COMPNAME_PV(op->op_targ);
10075 Perl_newSVpvf(aTHX_
10081 name = SvPV_const(tmpstr, len);
10082 name_utf8 = SvUTF8(tmpstr);
10083 sv_2mortal(tmpstr);
10087 name = "__ANONIO__";
10089 want_dollar = FALSE;
10091 op_lvalue(kid, type);
10095 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10096 namesv = PAD_SVl(targ);
10097 if (want_dollar && *name != '$')
10098 sv_setpvs(namesv, "$");
10100 sv_setpvs(namesv, "");
10101 sv_catpvn(namesv, name, len);
10102 if ( name_utf8 ) SvUTF8_on(namesv);
10106 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10108 kid->op_targ = targ;
10109 kid->op_private |= priv;
10115 if ((type == OP_UNDEF || type == OP_POS)
10116 && numargs == 1 && !(oa >> 4)
10117 && kid->op_type == OP_LIST)
10118 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10119 op_lvalue(scalar(kid), type);
10124 kid = OpSIBLING(kid);
10126 /* FIXME - should the numargs or-ing move after the too many
10127 * arguments check? */
10128 o->op_private |= numargs;
10130 return too_many_arguments_pv(o,OP_DESC(o), 0);
10133 else if (PL_opargs[type] & OA_DEFGV) {
10134 /* Ordering of these two is important to keep f_map.t passing. */
10136 return newUNOP(type, 0, newDEFSVOP());
10140 while (oa & OA_OPTIONAL)
10142 if (oa && oa != OA_LIST)
10143 return too_few_arguments_pv(o,OP_DESC(o), 0);
10149 Perl_ck_glob(pTHX_ OP *o)
10153 PERL_ARGS_ASSERT_CK_GLOB;
10156 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10157 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10159 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10163 * \ null - const(wildcard)
10168 * \ mark - glob - rv2cv
10169 * | \ gv(CORE::GLOBAL::glob)
10171 * \ null - const(wildcard)
10173 o->op_flags |= OPf_SPECIAL;
10174 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10175 o = S_new_entersubop(aTHX_ gv, o);
10176 o = newUNOP(OP_NULL, 0, o);
10177 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10180 else o->op_flags &= ~OPf_SPECIAL;
10181 #if !defined(PERL_EXTERNAL_GLOB)
10182 if (!PL_globhook) {
10184 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10185 newSVpvs("File::Glob"), NULL, NULL, NULL);
10188 #endif /* !PERL_EXTERNAL_GLOB */
10189 gv = (GV *)newSV(0);
10190 gv_init(gv, 0, "", 0, 0);
10192 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10193 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10199 Perl_ck_grep(pTHX_ OP *o)
10203 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10206 PERL_ARGS_ASSERT_CK_GREP;
10208 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10210 if (o->op_flags & OPf_STACKED) {
10211 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10212 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10213 return no_fh_allowed(o);
10214 o->op_flags &= ~OPf_STACKED;
10216 kid = OpSIBLING(cLISTOPo->op_first);
10217 if (type == OP_MAPWHILE)
10222 if (PL_parser && PL_parser->error_count)
10224 kid = OpSIBLING(cLISTOPo->op_first);
10225 if (kid->op_type != OP_NULL)
10226 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10227 kid = kUNOP->op_first;
10229 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10230 kid->op_next = (OP*)gwop;
10231 offset = pad_findmy_pvs("$_", 0);
10232 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
10233 o->op_private = gwop->op_private = 0;
10234 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10237 o->op_private = gwop->op_private = OPpGREP_LEX;
10238 gwop->op_targ = o->op_targ = offset;
10241 kid = OpSIBLING(cLISTOPo->op_first);
10242 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10243 op_lvalue(kid, OP_GREPSTART);
10249 Perl_ck_index(pTHX_ OP *o)
10251 PERL_ARGS_ASSERT_CK_INDEX;
10253 if (o->op_flags & OPf_KIDS) {
10254 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10256 kid = OpSIBLING(kid); /* get past "big" */
10257 if (kid && kid->op_type == OP_CONST) {
10258 const bool save_taint = TAINT_get;
10259 SV *sv = kSVOP->op_sv;
10260 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10262 sv_copypv(sv, kSVOP->op_sv);
10263 SvREFCNT_dec_NN(kSVOP->op_sv);
10266 if (SvOK(sv)) fbm_compile(sv, 0);
10267 TAINT_set(save_taint);
10268 #ifdef NO_TAINT_SUPPORT
10269 PERL_UNUSED_VAR(save_taint);
10277 Perl_ck_lfun(pTHX_ OP *o)
10279 const OPCODE type = o->op_type;
10281 PERL_ARGS_ASSERT_CK_LFUN;
10283 return modkids(ck_fun(o), type);
10287 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10289 PERL_ARGS_ASSERT_CK_DEFINED;
10291 if ((o->op_flags & OPf_KIDS)) {
10292 switch (cUNOPo->op_first->op_type) {
10295 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10296 " (Maybe you should just omit the defined()?)");
10300 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10301 " (Maybe you should just omit the defined()?)");
10312 Perl_ck_readline(pTHX_ OP *o)
10314 PERL_ARGS_ASSERT_CK_READLINE;
10316 if (o->op_flags & OPf_KIDS) {
10317 OP *kid = cLISTOPo->op_first;
10318 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10322 = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
10330 Perl_ck_rfun(pTHX_ OP *o)
10332 const OPCODE type = o->op_type;
10334 PERL_ARGS_ASSERT_CK_RFUN;
10336 return refkids(ck_fun(o), type);
10340 Perl_ck_listiob(pTHX_ OP *o)
10344 PERL_ARGS_ASSERT_CK_LISTIOB;
10346 kid = cLISTOPo->op_first;
10348 o = force_list(o, 1);
10349 kid = cLISTOPo->op_first;
10351 if (kid->op_type == OP_PUSHMARK)
10352 kid = OpSIBLING(kid);
10353 if (kid && o->op_flags & OPf_STACKED)
10354 kid = OpSIBLING(kid);
10355 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10356 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10357 && !kid->op_folded) {
10358 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10360 /* replace old const op with new OP_RV2GV parent */
10361 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10362 OP_RV2GV, OPf_REF);
10363 kid = OpSIBLING(kid);
10368 op_append_elem(o->op_type, o, newDEFSVOP());
10370 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10371 return listkids(o);
10375 Perl_ck_smartmatch(pTHX_ OP *o)
10378 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10379 if (0 == (o->op_flags & OPf_SPECIAL)) {
10380 OP *first = cBINOPo->op_first;
10381 OP *second = OpSIBLING(first);
10383 /* Implicitly take a reference to an array or hash */
10385 /* remove the original two siblings, then add back the
10386 * (possibly different) first and second sibs.
10388 op_sibling_splice(o, NULL, 1, NULL);
10389 op_sibling_splice(o, NULL, 1, NULL);
10390 first = ref_array_or_hash(first);
10391 second = ref_array_or_hash(second);
10392 op_sibling_splice(o, NULL, 0, second);
10393 op_sibling_splice(o, NULL, 0, first);
10395 /* Implicitly take a reference to a regular expression */
10396 if (first->op_type == OP_MATCH) {
10397 CHANGE_TYPE(first, OP_QR);
10399 if (second->op_type == OP_MATCH) {
10400 CHANGE_TYPE(second, OP_QR);
10409 S_maybe_targlex(pTHX_ OP *o)
10411 OP * const kid = cLISTOPo->op_first;
10412 /* has a disposable target? */
10413 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10414 && !(kid->op_flags & OPf_STACKED)
10415 /* Cannot steal the second time! */
10416 && !(kid->op_private & OPpTARGET_MY)
10419 OP * const kkid = OpSIBLING(kid);
10421 /* Can just relocate the target. */
10422 if (kkid && kkid->op_type == OP_PADSV
10423 && (!(kkid->op_private & OPpLVAL_INTRO)
10424 || kkid->op_private & OPpPAD_STATE))
10426 kid->op_targ = kkid->op_targ;
10428 /* Now we do not need PADSV and SASSIGN.
10429 * Detach kid and free the rest. */
10430 op_sibling_splice(o, NULL, 1, NULL);
10432 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10440 Perl_ck_sassign(pTHX_ OP *o)
10443 OP * const kid = cLISTOPo->op_first;
10445 PERL_ARGS_ASSERT_CK_SASSIGN;
10447 if (OpHAS_SIBLING(kid)) {
10448 OP *kkid = OpSIBLING(kid);
10449 /* For state variable assignment with attributes, kkid is a list op
10450 whose op_last is a padsv. */
10451 if ((kkid->op_type == OP_PADSV ||
10452 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10453 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10456 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10457 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10458 const PADOFFSET target = kkid->op_targ;
10459 OP *const other = newOP(OP_PADSV,
10461 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10462 OP *const first = newOP(OP_NULL, 0);
10464 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10465 OP *const condop = first->op_next;
10467 CHANGE_TYPE(condop, OP_ONCE);
10468 other->op_targ = target;
10469 nullop->op_flags |= OPf_WANT_SCALAR;
10471 /* Store the initializedness of state vars in a separate
10474 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10475 /* hijacking PADSTALE for uninitialized state variables */
10476 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10481 return S_maybe_targlex(aTHX_ o);
10485 Perl_ck_match(pTHX_ OP *o)
10487 PERL_ARGS_ASSERT_CK_MATCH;
10489 if (o->op_type != OP_QR && PL_compcv) {
10490 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
10491 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
10492 o->op_targ = offset;
10493 o->op_private |= OPpTARGET_MY;
10496 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10497 o->op_private |= OPpRUNTIME;
10502 Perl_ck_method(pTHX_ OP *o)
10504 SV *sv, *methsv, *rclass;
10505 const char* method;
10508 STRLEN len, nsplit = 0, i;
10510 OP * const kid = cUNOPo->op_first;
10512 PERL_ARGS_ASSERT_CK_METHOD;
10513 if (kid->op_type != OP_CONST) return o;
10517 /* replace ' with :: */
10518 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10520 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10523 method = SvPVX_const(sv);
10525 utf8 = SvUTF8(sv) ? -1 : 1;
10527 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10532 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10534 if (!nsplit) { /* $proto->method() */
10536 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10539 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10541 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10544 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10545 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10546 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10547 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10549 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10550 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10552 #ifdef USE_ITHREADS
10553 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10555 cMETHOPx(new_op)->op_rclass_sv = rclass;
10562 Perl_ck_null(pTHX_ OP *o)
10564 PERL_ARGS_ASSERT_CK_NULL;
10565 PERL_UNUSED_CONTEXT;
10570 Perl_ck_open(pTHX_ OP *o)
10572 PERL_ARGS_ASSERT_CK_OPEN;
10574 S_io_hints(aTHX_ o);
10576 /* In case of three-arg dup open remove strictness
10577 * from the last arg if it is a bareword. */
10578 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10579 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10583 if ((last->op_type == OP_CONST) && /* The bareword. */
10584 (last->op_private & OPpCONST_BARE) &&
10585 (last->op_private & OPpCONST_STRICT) &&
10586 (oa = OpSIBLING(first)) && /* The fh. */
10587 (oa = OpSIBLING(oa)) && /* The mode. */
10588 (oa->op_type == OP_CONST) &&
10589 SvPOK(((SVOP*)oa)->op_sv) &&
10590 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10591 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10592 (last == OpSIBLING(oa))) /* The bareword. */
10593 last->op_private &= ~OPpCONST_STRICT;
10599 Perl_ck_prototype(pTHX_ OP *o)
10601 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10602 if (!(o->op_flags & OPf_KIDS)) {
10604 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10610 Perl_ck_refassign(pTHX_ OP *o)
10612 OP * const right = cLISTOPo->op_first;
10613 OP * const left = OpSIBLING(right);
10614 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10617 PERL_ARGS_ASSERT_CK_REFASSIGN;
10619 assert (left->op_type == OP_SREFGEN);
10621 o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
10623 switch (varop->op_type) {
10625 o->op_private |= OPpLVREF_AV;
10628 o->op_private |= OPpLVREF_HV;
10631 o->op_targ = varop->op_targ;
10632 varop->op_targ = 0;
10633 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10636 o->op_private |= OPpLVREF_AV;
10639 o->op_private |= OPpLVREF_HV;
10642 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10644 /* Point varop to its GV kid, detached. */
10645 varop = op_sibling_splice(varop, NULL, -1, NULL);
10649 OP * const kidparent =
10650 cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
10651 OP * const kid = cUNOPx(kidparent)->op_first;
10652 o->op_private |= OPpLVREF_CV;
10653 if (kid->op_type == OP_GV) {
10655 goto detach_and_stack;
10657 if (kid->op_type != OP_PADCV) goto bad;
10658 o->op_targ = kid->op_targ;
10664 o->op_private |= OPpLVREF_ELEM;
10667 /* Detach varop. */
10668 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10672 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10673 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10678 if (!FEATURE_REFALIASING_IS_ENABLED)
10680 "Experimental aliasing via reference not enabled");
10681 Perl_ck_warner_d(aTHX_
10682 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10683 "Aliasing via reference is experimental");
10685 o->op_flags |= OPf_STACKED;
10686 op_sibling_splice(o, right, 1, varop);
10689 o->op_flags &=~ OPf_STACKED;
10690 op_sibling_splice(o, right, 1, NULL);
10697 Perl_ck_repeat(pTHX_ OP *o)
10699 PERL_ARGS_ASSERT_CK_REPEAT;
10701 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10703 o->op_private |= OPpREPEAT_DOLIST;
10704 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10705 kids = force_list(kids, 1); /* promote it to a list */
10706 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10714 Perl_ck_require(pTHX_ OP *o)
10718 PERL_ARGS_ASSERT_CK_REQUIRE;
10720 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10721 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10726 if (kid->op_type == OP_CONST) {
10727 SV * const sv = kid->op_sv;
10728 U32 const was_readonly = SvREADONLY(sv);
10729 if (kid->op_private & OPpCONST_BARE) {
10733 if (was_readonly) {
10734 SvREADONLY_off(sv);
10736 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10741 for (; s < end; s++) {
10742 if (*s == ':' && s[1] == ':') {
10744 Move(s+2, s+1, end - s - 1, char);
10748 SvEND_set(sv, end);
10749 sv_catpvs(sv, ".pm");
10750 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10751 hek = share_hek(SvPVX(sv),
10752 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10754 sv_sethek(sv, hek);
10756 SvFLAGS(sv) |= was_readonly;
10758 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
10760 if (SvREFCNT(sv) > 1) {
10761 kid->op_sv = newSVpvn_share(
10762 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10763 SvREFCNT_dec_NN(sv);
10767 if (was_readonly) SvREADONLY_off(sv);
10768 PERL_HASH(hash, s, len);
10770 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10772 sv_sethek(sv, hek);
10774 SvFLAGS(sv) |= was_readonly;
10780 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10781 /* handle override, if any */
10782 && (gv = gv_override("require", 7))) {
10784 if (o->op_flags & OPf_KIDS) {
10785 kid = cUNOPo->op_first;
10786 op_sibling_splice(o, NULL, -1, NULL);
10789 kid = newDEFSVOP();
10792 newop = S_new_entersubop(aTHX_ gv, kid);
10800 Perl_ck_return(pTHX_ OP *o)
10804 PERL_ARGS_ASSERT_CK_RETURN;
10806 kid = OpSIBLING(cLISTOPo->op_first);
10807 if (CvLVALUE(PL_compcv)) {
10808 for (; kid; kid = OpSIBLING(kid))
10809 op_lvalue(kid, OP_LEAVESUBLV);
10816 Perl_ck_select(pTHX_ OP *o)
10821 PERL_ARGS_ASSERT_CK_SELECT;
10823 if (o->op_flags & OPf_KIDS) {
10824 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10825 if (kid && OpHAS_SIBLING(kid)) {
10826 CHANGE_TYPE(o, OP_SSELECT);
10828 return fold_constants(op_integerize(op_std_init(o)));
10832 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10833 if (kid && kid->op_type == OP_RV2GV)
10834 kid->op_private &= ~HINT_STRICT_REFS;
10839 Perl_ck_shift(pTHX_ OP *o)
10841 const I32 type = o->op_type;
10843 PERL_ARGS_ASSERT_CK_SHIFT;
10845 if (!(o->op_flags & OPf_KIDS)) {
10848 if (!CvUNIQUE(PL_compcv)) {
10849 o->op_flags |= OPf_SPECIAL;
10853 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10855 return newUNOP(type, 0, scalar(argop));
10857 return scalar(ck_fun(o));
10861 Perl_ck_sort(pTHX_ OP *o)
10865 HV * const hinthv =
10866 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10869 PERL_ARGS_ASSERT_CK_SORT;
10872 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10874 const I32 sorthints = (I32)SvIV(*svp);
10875 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10876 o->op_private |= OPpSORT_QSORT;
10877 if ((sorthints & HINT_SORT_STABLE) != 0)
10878 o->op_private |= OPpSORT_STABLE;
10882 if (o->op_flags & OPf_STACKED)
10884 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10886 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10887 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10889 /* if the first arg is a code block, process it and mark sort as
10891 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10893 if (kid->op_type == OP_LEAVE)
10894 op_null(kid); /* wipe out leave */
10895 /* Prevent execution from escaping out of the sort block. */
10898 /* provide scalar context for comparison function/block */
10899 kid = scalar(firstkid);
10900 kid->op_next = kid;
10901 o->op_flags |= OPf_SPECIAL;
10903 else if (kid->op_type == OP_CONST
10904 && kid->op_private & OPpCONST_BARE) {
10908 const char * const name = SvPV(kSVOP_sv, len);
10910 assert (len < 256);
10911 Copy(name, tmpbuf+1, len, char);
10912 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10913 if (off != NOT_IN_PAD) {
10914 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10916 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10917 sv_catpvs(fq, "::");
10918 sv_catsv(fq, kSVOP_sv);
10919 SvREFCNT_dec_NN(kSVOP_sv);
10923 OP * const padop = newOP(OP_PADCV, 0);
10924 padop->op_targ = off;
10925 cUNOPx(firstkid)->op_first = padop;
10926 #ifdef PERL_OP_PARENT
10927 padop->op_sibling = firstkid;
10934 firstkid = OpSIBLING(firstkid);
10937 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10938 /* provide list context for arguments */
10941 op_lvalue(kid, OP_GREPSTART);
10947 /* for sort { X } ..., where X is one of
10948 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10949 * elide the second child of the sort (the one containing X),
10950 * and set these flags as appropriate
10954 * Also, check and warn on lexical $a, $b.
10958 S_simplify_sort(pTHX_ OP *o)
10960 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10964 const char *gvname;
10967 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10969 kid = kUNOP->op_first; /* get past null */
10970 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10971 && kid->op_type != OP_LEAVE)
10973 kid = kLISTOP->op_last; /* get past scope */
10974 switch(kid->op_type) {
10978 if (!have_scopeop) goto padkids;
10983 k = kid; /* remember this node*/
10984 if (kBINOP->op_first->op_type != OP_RV2SV
10985 || kBINOP->op_last ->op_type != OP_RV2SV)
10988 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10989 then used in a comparison. This catches most, but not
10990 all cases. For instance, it catches
10991 sort { my($a); $a <=> $b }
10993 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10994 (although why you'd do that is anyone's guess).
10998 if (!ckWARN(WARN_SYNTAX)) return;
10999 kid = kBINOP->op_first;
11001 if (kid->op_type == OP_PADSV) {
11002 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11003 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11004 && ( PadnamePV(name)[1] == 'a'
11005 || PadnamePV(name)[1] == 'b' ))
11006 /* diag_listed_as: "my %s" used in sort comparison */
11007 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11008 "\"%s %s\" used in sort comparison",
11009 PadnameIsSTATE(name)
11014 } while ((kid = OpSIBLING(kid)));
11017 kid = kBINOP->op_first; /* get past cmp */
11018 if (kUNOP->op_first->op_type != OP_GV)
11020 kid = kUNOP->op_first; /* get past rv2sv */
11022 if (GvSTASH(gv) != PL_curstash)
11024 gvname = GvNAME(gv);
11025 if (*gvname == 'a' && gvname[1] == '\0')
11027 else if (*gvname == 'b' && gvname[1] == '\0')
11032 kid = k; /* back to cmp */
11033 /* already checked above that it is rv2sv */
11034 kid = kBINOP->op_last; /* down to 2nd arg */
11035 if (kUNOP->op_first->op_type != OP_GV)
11037 kid = kUNOP->op_first; /* get past rv2sv */
11039 if (GvSTASH(gv) != PL_curstash)
11041 gvname = GvNAME(gv);
11043 ? !(*gvname == 'a' && gvname[1] == '\0')
11044 : !(*gvname == 'b' && gvname[1] == '\0'))
11046 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11048 o->op_private |= OPpSORT_DESCEND;
11049 if (k->op_type == OP_NCMP)
11050 o->op_private |= OPpSORT_NUMERIC;
11051 if (k->op_type == OP_I_NCMP)
11052 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11053 kid = OpSIBLING(cLISTOPo->op_first);
11054 /* cut out and delete old block (second sibling) */
11055 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11060 Perl_ck_split(pTHX_ OP *o)
11065 PERL_ARGS_ASSERT_CK_SPLIT;
11067 if (o->op_flags & OPf_STACKED)
11068 return no_fh_allowed(o);
11070 kid = cLISTOPo->op_first;
11071 if (kid->op_type != OP_NULL)
11072 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11073 /* delete leading NULL node, then add a CONST if no other nodes */
11074 op_sibling_splice(o, NULL, 1,
11075 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11077 kid = cLISTOPo->op_first;
11079 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11080 /* remove kid, and replace with new optree */
11081 op_sibling_splice(o, NULL, 1, NULL);
11082 /* OPf_SPECIAL is used to trigger split " " behavior */
11083 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11084 op_sibling_splice(o, NULL, 0, kid);
11086 CHANGE_TYPE(kid, OP_PUSHRE);
11088 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11089 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11090 "Use of /g modifier is meaningless in split");
11093 if (!OpHAS_SIBLING(kid))
11094 op_append_elem(OP_SPLIT, o, newDEFSVOP());
11096 kid = OpSIBLING(kid);
11100 if (!OpHAS_SIBLING(kid))
11102 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11103 o->op_private |= OPpSPLIT_IMPLIM;
11105 assert(OpHAS_SIBLING(kid));
11107 kid = OpSIBLING(kid);
11110 if (OpHAS_SIBLING(kid))
11111 return too_many_arguments_pv(o,OP_DESC(o), 0);
11117 Perl_ck_stringify(pTHX_ OP *o)
11119 OP * const kid = OpSIBLING(cUNOPo->op_first);
11120 PERL_ARGS_ASSERT_CK_STRINGIFY;
11121 if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11122 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11123 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11125 assert(!OpHAS_SIBLING(kid));
11126 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11134 Perl_ck_join(pTHX_ OP *o)
11136 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11138 PERL_ARGS_ASSERT_CK_JOIN;
11140 if (kid && kid->op_type == OP_MATCH) {
11141 if (ckWARN(WARN_SYNTAX)) {
11142 const REGEXP *re = PM_GETRE(kPMOP);
11144 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11145 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11146 : newSVpvs_flags( "STRING", SVs_TEMP );
11147 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11148 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11149 SVfARG(msg), SVfARG(msg));
11153 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11154 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11155 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11156 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11158 const OP * const bairn = OpSIBLING(kid); /* the list */
11159 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11160 && OP_GIMME(bairn,0) == G_SCALAR)
11162 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11163 op_sibling_splice(o, kid, 1, NULL));
11173 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11175 Examines an op, which is expected to identify a subroutine at runtime,
11176 and attempts to determine at compile time which subroutine it identifies.
11177 This is normally used during Perl compilation to determine whether
11178 a prototype can be applied to a function call. I<cvop> is the op
11179 being considered, normally an C<rv2cv> op. A pointer to the identified
11180 subroutine is returned, if it could be determined statically, and a null
11181 pointer is returned if it was not possible to determine statically.
11183 Currently, the subroutine can be identified statically if the RV that the
11184 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11185 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11186 suitable if the constant value must be an RV pointing to a CV. Details of
11187 this process may change in future versions of Perl. If the C<rv2cv> op
11188 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11189 the subroutine statically: this flag is used to suppress compile-time
11190 magic on a subroutine call, forcing it to use default runtime behaviour.
11192 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11193 of a GV reference is modified. If a GV was examined and its CV slot was
11194 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11195 If the op is not optimised away, and the CV slot is later populated with
11196 a subroutine having a prototype, that flag eventually triggers the warning
11197 "called too early to check prototype".
11199 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11200 of returning a pointer to the subroutine it returns a pointer to the
11201 GV giving the most appropriate name for the subroutine in this context.
11202 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11203 (C<CvANON>) subroutine that is referenced through a GV it will be the
11204 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11205 A null pointer is returned as usual if there is no statically-determinable
11211 /* shared by toke.c:yylex */
11213 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11215 PADNAME *name = PAD_COMPNAME(off);
11216 CV *compcv = PL_compcv;
11217 while (PadnameOUTER(name)) {
11218 assert(PARENT_PAD_INDEX(name));
11219 compcv = CvOUTSIDE(PL_compcv);
11220 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11221 [off = PARENT_PAD_INDEX(name)];
11223 assert(!PadnameIsOUR(name));
11224 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11225 return PadnamePROTOCV(name);
11227 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11231 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11236 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11237 if (flags & ~RV2CVOPCV_FLAG_MASK)
11238 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11239 if (cvop->op_type != OP_RV2CV)
11241 if (cvop->op_private & OPpENTERSUB_AMPER)
11243 if (!(cvop->op_flags & OPf_KIDS))
11245 rvop = cUNOPx(cvop)->op_first;
11246 switch (rvop->op_type) {
11248 gv = cGVOPx_gv(rvop);
11250 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11251 cv = MUTABLE_CV(SvRV(gv));
11255 if (flags & RV2CVOPCV_RETURN_STUB)
11261 if (flags & RV2CVOPCV_MARK_EARLY)
11262 rvop->op_private |= OPpEARLY_CV;
11267 SV *rv = cSVOPx_sv(rvop);
11270 cv = (CV*)SvRV(rv);
11274 cv = find_lexical_cv(rvop->op_targ);
11279 } NOT_REACHED; /* NOTREACHED */
11281 if (SvTYPE((SV*)cv) != SVt_PVCV)
11283 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11284 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11285 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11294 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11296 Performs the default fixup of the arguments part of an C<entersub>
11297 op tree. This consists of applying list context to each of the
11298 argument ops. This is the standard treatment used on a call marked
11299 with C<&>, or a method call, or a call through a subroutine reference,
11300 or any other call where the callee can't be identified at compile time,
11301 or a call where the callee has no prototype.
11307 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11310 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11311 aop = cUNOPx(entersubop)->op_first;
11312 if (!OpHAS_SIBLING(aop))
11313 aop = cUNOPx(aop)->op_first;
11314 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11316 op_lvalue(aop, OP_ENTERSUB);
11322 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11324 Performs the fixup of the arguments part of an C<entersub> op tree
11325 based on a subroutine prototype. This makes various modifications to
11326 the argument ops, from applying context up to inserting C<refgen> ops,
11327 and checking the number and syntactic types of arguments, as directed by
11328 the prototype. This is the standard treatment used on a subroutine call,
11329 not marked with C<&>, where the callee can be identified at compile time
11330 and has a prototype.
11332 I<protosv> supplies the subroutine prototype to be applied to the call.
11333 It may be a normal defined scalar, of which the string value will be used.
11334 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11335 that has been cast to C<SV*>) which has a prototype. The prototype
11336 supplied, in whichever form, does not need to match the actual callee
11337 referenced by the op tree.
11339 If the argument ops disagree with the prototype, for example by having
11340 an unacceptable number of arguments, a valid op tree is returned anyway.
11341 The error is reflected in the parser state, normally resulting in a single
11342 exception at the top level of parsing which covers all the compilation
11343 errors that occurred. In the error message, the callee is referred to
11344 by the name defined by the I<namegv> parameter.
11350 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11353 const char *proto, *proto_end;
11354 OP *aop, *prev, *cvop, *parent;
11357 I32 contextclass = 0;
11358 const char *e = NULL;
11359 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11360 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11361 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11362 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11363 if (SvTYPE(protosv) == SVt_PVCV)
11364 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11365 else proto = SvPV(protosv, proto_len);
11366 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11367 proto_end = proto + proto_len;
11368 parent = entersubop;
11369 aop = cUNOPx(entersubop)->op_first;
11370 if (!OpHAS_SIBLING(aop)) {
11372 aop = cUNOPx(aop)->op_first;
11375 aop = OpSIBLING(aop);
11376 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11377 while (aop != cvop) {
11380 if (proto >= proto_end)
11382 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11383 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11384 SVfARG(namesv)), SvUTF8(namesv));
11394 /* _ must be at the end */
11395 if (proto[1] && !strchr(";@%", proto[1]))
11411 if (o3->op_type != OP_SREFGEN
11412 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11414 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11416 bad_type_gv(arg, namegv, o3,
11417 arg == 1 ? "block or sub {}" : "sub {}");
11420 /* '*' allows any scalar type, including bareword */
11423 if (o3->op_type == OP_RV2GV)
11424 goto wrapref; /* autoconvert GLOB -> GLOBref */
11425 else if (o3->op_type == OP_CONST)
11426 o3->op_private &= ~OPpCONST_STRICT;
11432 if (o3->op_type == OP_RV2AV ||
11433 o3->op_type == OP_PADAV ||
11434 o3->op_type == OP_RV2HV ||
11435 o3->op_type == OP_PADHV
11441 case '[': case ']':
11448 switch (*proto++) {
11450 if (contextclass++ == 0) {
11451 e = strchr(proto, ']');
11452 if (!e || e == proto)
11460 if (contextclass) {
11461 const char *p = proto;
11462 const char *const end = proto;
11464 while (*--p != '[')
11465 /* \[$] accepts any scalar lvalue */
11467 && Perl_op_lvalue_flags(aTHX_
11469 OP_READ, /* not entersub */
11472 bad_type_gv(arg, namegv, o3,
11473 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11478 if (o3->op_type == OP_RV2GV)
11481 bad_type_gv(arg, namegv, o3, "symbol");
11484 if (o3->op_type == OP_ENTERSUB
11485 && !(o3->op_flags & OPf_STACKED))
11488 bad_type_gv(arg, namegv, o3, "subroutine");
11491 if (o3->op_type == OP_RV2SV ||
11492 o3->op_type == OP_PADSV ||
11493 o3->op_type == OP_HELEM ||
11494 o3->op_type == OP_AELEM)
11496 if (!contextclass) {
11497 /* \$ accepts any scalar lvalue */
11498 if (Perl_op_lvalue_flags(aTHX_
11500 OP_READ, /* not entersub */
11503 bad_type_gv(arg, namegv, o3, "scalar");
11507 if (o3->op_type == OP_RV2AV ||
11508 o3->op_type == OP_PADAV)
11510 o3->op_flags &=~ OPf_PARENS;
11514 bad_type_gv(arg, namegv, o3, "array");
11517 if (o3->op_type == OP_RV2HV ||
11518 o3->op_type == OP_PADHV)
11520 o3->op_flags &=~ OPf_PARENS;
11524 bad_type_gv(arg, namegv, o3, "hash");
11527 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11529 if (contextclass && e) {
11534 default: goto oops;
11544 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11545 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11550 op_lvalue(aop, OP_ENTERSUB);
11552 aop = OpSIBLING(aop);
11554 if (aop == cvop && *proto == '_') {
11555 /* generate an access to $_ */
11556 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11558 if (!optional && proto_end > proto &&
11559 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11561 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11562 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11563 SVfARG(namesv)), SvUTF8(namesv));
11569 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11571 Performs the fixup of the arguments part of an C<entersub> op tree either
11572 based on a subroutine prototype or using default list-context processing.
11573 This is the standard treatment used on a subroutine call, not marked
11574 with C<&>, where the callee can be identified at compile time.
11576 I<protosv> supplies the subroutine prototype to be applied to the call,
11577 or indicates that there is no prototype. It may be a normal scalar,
11578 in which case if it is defined then the string value will be used
11579 as a prototype, and if it is undefined then there is no prototype.
11580 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11581 that has been cast to C<SV*>), of which the prototype will be used if it
11582 has one. The prototype (or lack thereof) supplied, in whichever form,
11583 does not need to match the actual callee referenced by the op tree.
11585 If the argument ops disagree with the prototype, for example by having
11586 an unacceptable number of arguments, a valid op tree is returned anyway.
11587 The error is reflected in the parser state, normally resulting in a single
11588 exception at the top level of parsing which covers all the compilation
11589 errors that occurred. In the error message, the callee is referred to
11590 by the name defined by the I<namegv> parameter.
11596 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11597 GV *namegv, SV *protosv)
11599 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11600 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11601 return ck_entersub_args_proto(entersubop, namegv, protosv);
11603 return ck_entersub_args_list(entersubop);
11607 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11609 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11610 OP *aop = cUNOPx(entersubop)->op_first;
11612 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11616 if (!OpHAS_SIBLING(aop))
11617 aop = cUNOPx(aop)->op_first;
11618 aop = OpSIBLING(aop);
11619 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11621 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11623 op_free(entersubop);
11624 switch(GvNAME(namegv)[2]) {
11625 case 'F': return newSVOP(OP_CONST, 0,
11626 newSVpv(CopFILE(PL_curcop),0));
11627 case 'L': return newSVOP(
11629 Perl_newSVpvf(aTHX_
11630 "%"IVdf, (IV)CopLINE(PL_curcop)
11633 case 'P': return newSVOP(OP_CONST, 0,
11635 ? newSVhek(HvNAME_HEK(PL_curstash))
11643 OP *prev, *cvop, *first, *parent;
11646 parent = entersubop;
11647 if (!OpHAS_SIBLING(aop)) {
11649 aop = cUNOPx(aop)->op_first;
11652 first = prev = aop;
11653 aop = OpSIBLING(aop);
11654 /* find last sibling */
11656 OpHAS_SIBLING(cvop);
11657 prev = cvop, cvop = OpSIBLING(cvop))
11659 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11660 /* Usually, OPf_SPECIAL on an op with no args means that it had
11661 * parens, but these have their own meaning for that flag: */
11662 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11663 && opnum != OP_DELETE && opnum != OP_EXISTS)
11664 flags |= OPf_SPECIAL;
11665 /* excise cvop from end of sibling chain */
11666 op_sibling_splice(parent, prev, 1, NULL);
11668 if (aop == cvop) aop = NULL;
11670 /* detach remaining siblings from the first sibling, then
11671 * dispose of original optree */
11674 op_sibling_splice(parent, first, -1, NULL);
11675 op_free(entersubop);
11677 if (opnum == OP_ENTEREVAL
11678 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11679 flags |= OPpEVAL_BYTES <<8;
11681 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11683 case OA_BASEOP_OR_UNOP:
11684 case OA_FILESTATOP:
11685 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11688 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11691 return opnum == OP_RUNCV
11692 ? newPVOP(OP_RUNCV,0,NULL)
11695 return op_convert_list(opnum,0,aop);
11703 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11705 Retrieves the function that will be used to fix up a call to I<cv>.
11706 Specifically, the function is applied to an C<entersub> op tree for a
11707 subroutine call, not marked with C<&>, where the callee can be identified
11708 at compile time as I<cv>.
11710 The C-level function pointer is returned in I<*ckfun_p>, and an SV
11711 argument for it is returned in I<*ckobj_p>. The function is intended
11712 to be called in this manner:
11714 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11716 In this call, I<entersubop> is a pointer to the C<entersub> op,
11717 which may be replaced by the check function, and I<namegv> is a GV
11718 supplying the name that should be used by the check function to refer
11719 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11720 It is permitted to apply the check function in non-standard situations,
11721 such as to a call to a different subroutine or to a method call.
11723 By default, the function is
11724 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11725 and the SV parameter is I<cv> itself. This implements standard
11726 prototype processing. It can be changed, for a particular subroutine,
11727 by L</cv_set_call_checker>.
11733 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11737 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11739 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11740 *ckobj_p = callmg->mg_obj;
11741 if (flagsp) *flagsp = callmg->mg_flags;
11743 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11744 *ckobj_p = (SV*)cv;
11745 if (flagsp) *flagsp = 0;
11750 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11752 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11753 PERL_UNUSED_CONTEXT;
11754 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11758 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11760 Sets the function that will be used to fix up a call to I<cv>.
11761 Specifically, the function is applied to an C<entersub> op tree for a
11762 subroutine call, not marked with C<&>, where the callee can be identified
11763 at compile time as I<cv>.
11765 The C-level function pointer is supplied in I<ckfun>, and an SV argument
11766 for it is supplied in I<ckobj>. The function should be defined like this:
11768 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11770 It is intended to be called in this manner:
11772 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11774 In this call, I<entersubop> is a pointer to the C<entersub> op,
11775 which may be replaced by the check function, and I<namegv> supplies
11776 the name that should be used by the check function to refer
11777 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11778 It is permitted to apply the check function in non-standard situations,
11779 such as to a call to a different subroutine or to a method call.
11781 I<namegv> may not actually be a GV. For efficiency, perl may pass a
11782 CV or other SV instead. Whatever is passed can be used as the first
11783 argument to L</cv_name>. You can force perl to pass a GV by including
11784 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
11786 The current setting for a particular CV can be retrieved by
11787 L</cv_get_call_checker>.
11789 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11791 The original form of L</cv_set_call_checker_flags>, which passes it the
11792 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11798 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11800 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11801 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11805 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11806 SV *ckobj, U32 flags)
11808 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11809 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11810 if (SvMAGICAL((SV*)cv))
11811 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11814 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11815 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11817 if (callmg->mg_flags & MGf_REFCOUNTED) {
11818 SvREFCNT_dec(callmg->mg_obj);
11819 callmg->mg_flags &= ~MGf_REFCOUNTED;
11821 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11822 callmg->mg_obj = ckobj;
11823 if (ckobj != (SV*)cv) {
11824 SvREFCNT_inc_simple_void_NN(ckobj);
11825 callmg->mg_flags |= MGf_REFCOUNTED;
11827 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11828 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11833 S_entersub_alloc_targ(pTHX_ OP * const o)
11835 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11836 o->op_private |= OPpENTERSUB_HASTARG;
11840 Perl_ck_subr(pTHX_ OP *o)
11845 SV **const_class = NULL;
11847 PERL_ARGS_ASSERT_CK_SUBR;
11849 aop = cUNOPx(o)->op_first;
11850 if (!OpHAS_SIBLING(aop))
11851 aop = cUNOPx(aop)->op_first;
11852 aop = OpSIBLING(aop);
11853 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11854 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11855 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11857 o->op_private &= ~1;
11858 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11859 if (PERLDB_SUB && PL_curstash != PL_debstash)
11860 o->op_private |= OPpENTERSUB_DB;
11861 switch (cvop->op_type) {
11863 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11867 case OP_METHOD_NAMED:
11868 case OP_METHOD_SUPER:
11869 case OP_METHOD_REDIR:
11870 case OP_METHOD_REDIR_SUPER:
11871 if (aop->op_type == OP_CONST) {
11872 aop->op_private &= ~OPpCONST_STRICT;
11873 const_class = &cSVOPx(aop)->op_sv;
11875 else if (aop->op_type == OP_LIST) {
11876 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11877 if (sib && sib->op_type == OP_CONST) {
11878 sib->op_private &= ~OPpCONST_STRICT;
11879 const_class = &cSVOPx(sib)->op_sv;
11882 /* make class name a shared cow string to speedup method calls */
11883 /* constant string might be replaced with object, f.e. bigint */
11884 if (const_class && SvPOK(*const_class)) {
11886 const char* str = SvPV(*const_class, len);
11888 SV* const shared = newSVpvn_share(
11889 str, SvUTF8(*const_class)
11890 ? -(SSize_t)len : (SSize_t)len,
11893 SvREFCNT_dec(*const_class);
11894 *const_class = shared;
11901 S_entersub_alloc_targ(aTHX_ o);
11902 return ck_entersub_args_list(o);
11904 Perl_call_checker ckfun;
11907 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11908 if (CvISXSUB(cv) || !CvROOT(cv))
11909 S_entersub_alloc_targ(aTHX_ o);
11911 /* The original call checker API guarantees that a GV will be
11912 be provided with the right name. So, if the old API was
11913 used (or the REQUIRE_GV flag was passed), we have to reify
11914 the CV’s GV, unless this is an anonymous sub. This is not
11915 ideal for lexical subs, as its stringification will include
11916 the package. But it is the best we can do. */
11917 if (flags & MGf_REQUIRE_GV) {
11918 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11921 else namegv = MUTABLE_GV(cv);
11922 /* After a syntax error in a lexical sub, the cv that
11923 rv2cv_op_cv returns may be a nameless stub. */
11924 if (!namegv) return ck_entersub_args_list(o);
11927 return ckfun(aTHX_ o, namegv, ckobj);
11932 Perl_ck_svconst(pTHX_ OP *o)
11934 SV * const sv = cSVOPo->op_sv;
11935 PERL_ARGS_ASSERT_CK_SVCONST;
11936 PERL_UNUSED_CONTEXT;
11937 #ifdef PERL_OLD_COPY_ON_WRITE
11938 if (SvIsCOW(sv)) sv_force_normal(sv);
11939 #elif defined(PERL_NEW_COPY_ON_WRITE)
11940 /* Since the read-only flag may be used to protect a string buffer, we
11941 cannot do copy-on-write with existing read-only scalars that are not
11942 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11943 that constant, mark the constant as COWable here, if it is not
11944 already read-only. */
11945 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11948 # ifdef PERL_DEBUG_READONLY_COW
11958 Perl_ck_trunc(pTHX_ OP *o)
11960 PERL_ARGS_ASSERT_CK_TRUNC;
11962 if (o->op_flags & OPf_KIDS) {
11963 SVOP *kid = (SVOP*)cUNOPo->op_first;
11965 if (kid->op_type == OP_NULL)
11966 kid = (SVOP*)OpSIBLING(kid);
11967 if (kid && kid->op_type == OP_CONST &&
11968 (kid->op_private & OPpCONST_BARE) &&
11971 o->op_flags |= OPf_SPECIAL;
11972 kid->op_private &= ~OPpCONST_STRICT;
11979 Perl_ck_substr(pTHX_ OP *o)
11981 PERL_ARGS_ASSERT_CK_SUBSTR;
11984 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11985 OP *kid = cLISTOPo->op_first;
11987 if (kid->op_type == OP_NULL)
11988 kid = OpSIBLING(kid);
11990 kid->op_flags |= OPf_MOD;
11997 Perl_ck_tell(pTHX_ OP *o)
11999 PERL_ARGS_ASSERT_CK_TELL;
12001 if (o->op_flags & OPf_KIDS) {
12002 OP *kid = cLISTOPo->op_first;
12003 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12004 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12010 Perl_ck_each(pTHX_ OP *o)
12013 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12014 const unsigned orig_type = o->op_type;
12015 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
12016 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
12017 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
12018 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
12020 PERL_ARGS_ASSERT_CK_EACH;
12023 switch (kid->op_type) {
12029 CHANGE_TYPE(o, array_type);
12032 if (kid->op_private == OPpCONST_BARE
12033 || !SvROK(cSVOPx_sv(kid))
12034 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12035 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
12037 /* we let ck_fun handle it */
12040 CHANGE_TYPE(o, ref_type);
12044 /* if treating as a reference, defer additional checks to runtime */
12045 if (o->op_type == ref_type) {
12046 /* diag_listed_as: keys on reference is experimental */
12047 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
12048 "%s is experimental", PL_op_desc[ref_type]);
12055 Perl_ck_length(pTHX_ OP *o)
12057 PERL_ARGS_ASSERT_CK_LENGTH;
12061 if (ckWARN(WARN_SYNTAX)) {
12062 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12066 const bool hash = kid->op_type == OP_PADHV
12067 || kid->op_type == OP_RV2HV;
12068 switch (kid->op_type) {
12073 name = S_op_varname(aTHX_ kid);
12079 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12080 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12082 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12085 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12086 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12087 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12089 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12090 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12091 "length() used on @array (did you mean \"scalar(@array)\"?)");
12098 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12099 and modify the optree to make them work inplace */
12102 S_inplace_aassign(pTHX_ OP *o) {
12104 OP *modop, *modop_pushmark;
12106 OP *oleft, *oleft_pushmark;
12108 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12110 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12112 assert(cUNOPo->op_first->op_type == OP_NULL);
12113 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12114 assert(modop_pushmark->op_type == OP_PUSHMARK);
12115 modop = OpSIBLING(modop_pushmark);
12117 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12120 /* no other operation except sort/reverse */
12121 if (OpHAS_SIBLING(modop))
12124 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12125 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12127 if (modop->op_flags & OPf_STACKED) {
12128 /* skip sort subroutine/block */
12129 assert(oright->op_type == OP_NULL);
12130 oright = OpSIBLING(oright);
12133 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12134 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12135 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12136 oleft = OpSIBLING(oleft_pushmark);
12138 /* Check the lhs is an array */
12140 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12141 || OpHAS_SIBLING(oleft)
12142 || (oleft->op_private & OPpLVAL_INTRO)
12146 /* Only one thing on the rhs */
12147 if (OpHAS_SIBLING(oright))
12150 /* check the array is the same on both sides */
12151 if (oleft->op_type == OP_RV2AV) {
12152 if (oright->op_type != OP_RV2AV
12153 || !cUNOPx(oright)->op_first
12154 || cUNOPx(oright)->op_first->op_type != OP_GV
12155 || cUNOPx(oleft )->op_first->op_type != OP_GV
12156 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12157 cGVOPx_gv(cUNOPx(oright)->op_first)
12161 else if (oright->op_type != OP_PADAV
12162 || oright->op_targ != oleft->op_targ
12166 /* This actually is an inplace assignment */
12168 modop->op_private |= OPpSORT_INPLACE;
12170 /* transfer MODishness etc from LHS arg to RHS arg */
12171 oright->op_flags = oleft->op_flags;
12173 /* remove the aassign op and the lhs */
12175 op_null(oleft_pushmark);
12176 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12177 op_null(cUNOPx(oleft)->op_first);
12183 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12184 * that potentially represent a series of one or more aggregate derefs
12185 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12186 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12187 * additional ops left in too).
12189 * The caller will have already verified that the first few ops in the
12190 * chain following 'start' indicate a multideref candidate, and will have
12191 * set 'orig_o' to the point further on in the chain where the first index
12192 * expression (if any) begins. 'orig_action' specifies what type of
12193 * beginning has already been determined by the ops between start..orig_o
12194 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12196 * 'hints' contains any hints flags that need adding (currently just
12197 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12201 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12205 UNOP_AUX_item *arg_buf = NULL;
12206 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12207 int index_skip = -1; /* don't output index arg on this action */
12209 /* similar to regex compiling, do two passes; the first pass
12210 * determines whether the op chain is convertible and calculates the
12211 * buffer size; the second pass populates the buffer and makes any
12212 * changes necessary to ops (such as moving consts to the pad on
12215 for (pass = 0; pass < 2; pass++) {
12217 UV action = orig_action;
12218 OP *first_elem_op = NULL; /* first seen aelem/helem */
12219 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12220 int action_count = 0; /* number of actions seen so far */
12221 int action_ix = 0; /* action_count % (actions per IV) */
12222 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12223 bool is_last = FALSE; /* no more derefs to follow */
12224 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12225 UNOP_AUX_item *arg = arg_buf;
12226 UNOP_AUX_item *action_ptr = arg_buf;
12229 action_ptr->uv = 0;
12233 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12234 case MDEREF_HV_gvhv_helem:
12235 next_is_hash = TRUE;
12237 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12238 case MDEREF_AV_gvav_aelem:
12240 #ifdef USE_ITHREADS
12241 arg->pad_offset = cPADOPx(start)->op_padix;
12242 /* stop it being swiped when nulled */
12243 cPADOPx(start)->op_padix = 0;
12245 arg->sv = cSVOPx(start)->op_sv;
12246 cSVOPx(start)->op_sv = NULL;
12252 case MDEREF_HV_padhv_helem:
12253 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12254 next_is_hash = TRUE;
12256 case MDEREF_AV_padav_aelem:
12257 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12259 arg->pad_offset = start->op_targ;
12260 /* we skip setting op_targ = 0 for now, since the intact
12261 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12262 reset_start_targ = TRUE;
12267 case MDEREF_HV_pop_rv2hv_helem:
12268 next_is_hash = TRUE;
12270 case MDEREF_AV_pop_rv2av_aelem:
12279 /* look for another (rv2av/hv; get index;
12280 * aelem/helem/exists/delele) sequence */
12285 UV index_type = MDEREF_INDEX_none;
12287 if (action_count) {
12288 /* if this is not the first lookup, consume the rv2av/hv */
12290 /* for N levels of aggregate lookup, we normally expect
12291 * that the first N-1 [ah]elem ops will be flagged as
12292 * /DEREF (so they autovivifiy if necessary), and the last
12293 * lookup op not to be.
12294 * For other things (like @{$h{k1}{k2}}) extra scope or
12295 * leave ops can appear, so abandon the effort in that
12297 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12300 /* rv2av or rv2hv sKR/1 */
12302 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12303 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12304 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12307 /* at this point, we wouldn't expect any of these
12308 * possible private flags:
12309 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12310 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12312 ASSUME(!(o->op_private &
12313 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12315 hints = (o->op_private & OPpHINT_STRICT_REFS);
12317 /* make sure the type of the previous /DEREF matches the
12318 * type of the next lookup */
12319 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12322 action = next_is_hash
12323 ? MDEREF_HV_vivify_rv2hv_helem
12324 : MDEREF_AV_vivify_rv2av_aelem;
12328 /* if this is the second pass, and we're at the depth where
12329 * previously we encountered a non-simple index expression,
12330 * stop processing the index at this point */
12331 if (action_count != index_skip) {
12333 /* look for one or more simple ops that return an array
12334 * index or hash key */
12336 switch (o->op_type) {
12338 /* it may be a lexical var index */
12339 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12340 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12341 ASSUME(!(o->op_private &
12342 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12344 if ( OP_GIMME(o,0) == G_SCALAR
12345 && !(o->op_flags & (OPf_REF|OPf_MOD))
12346 && o->op_private == 0)
12349 arg->pad_offset = o->op_targ;
12351 index_type = MDEREF_INDEX_padsv;
12357 if (next_is_hash) {
12358 /* it's a constant hash index */
12359 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12360 /* "use constant foo => FOO; $h{+foo}" for
12361 * some weird FOO, can leave you with constants
12362 * that aren't simple strings. It's not worth
12363 * the extra hassle for those edge cases */
12368 OP * helem_op = o->op_next;
12370 ASSUME( helem_op->op_type == OP_HELEM
12371 || helem_op->op_type == OP_NULL);
12372 if (helem_op->op_type == OP_HELEM) {
12373 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12374 if ( helem_op->op_private & OPpLVAL_INTRO
12375 || rop->op_type != OP_RV2HV
12379 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12381 #ifdef USE_ITHREADS
12382 /* Relocate sv to the pad for thread safety */
12383 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12384 arg->pad_offset = o->op_targ;
12387 arg->sv = cSVOPx_sv(o);
12392 /* it's a constant array index */
12394 SV *ix_sv = cSVOPo->op_sv;
12399 if ( action_count == 0
12402 && ( action == MDEREF_AV_padav_aelem
12403 || action == MDEREF_AV_gvav_aelem)
12405 maybe_aelemfast = TRUE;
12409 SvREFCNT_dec_NN(cSVOPo->op_sv);
12413 /* we've taken ownership of the SV */
12414 cSVOPo->op_sv = NULL;
12416 index_type = MDEREF_INDEX_const;
12421 /* it may be a package var index */
12423 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12424 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12425 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12426 || o->op_private != 0
12431 if (kid->op_type != OP_RV2SV)
12434 ASSUME(!(kid->op_flags &
12435 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12436 |OPf_SPECIAL|OPf_PARENS)));
12437 ASSUME(!(kid->op_private &
12439 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12440 |OPpDEREF|OPpLVAL_INTRO)));
12441 if( (kid->op_flags &~ OPf_PARENS)
12442 != (OPf_WANT_SCALAR|OPf_KIDS)
12443 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12448 #ifdef USE_ITHREADS
12449 arg->pad_offset = cPADOPx(o)->op_padix;
12450 /* stop it being swiped when nulled */
12451 cPADOPx(o)->op_padix = 0;
12453 arg->sv = cSVOPx(o)->op_sv;
12454 cSVOPo->op_sv = NULL;
12458 index_type = MDEREF_INDEX_gvsv;
12463 } /* action_count != index_skip */
12465 action |= index_type;
12468 /* at this point we have either:
12469 * * detected what looks like a simple index expression,
12470 * and expect the next op to be an [ah]elem, or
12471 * an nulled [ah]elem followed by a delete or exists;
12472 * * found a more complex expression, so something other
12473 * than the above follows.
12476 /* possibly an optimised away [ah]elem (where op_next is
12477 * exists or delete) */
12478 if (o->op_type == OP_NULL)
12481 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12482 * OP_EXISTS or OP_DELETE */
12484 /* if something like arybase (a.k.a $[ ) is in scope,
12485 * abandon optimisation attempt */
12486 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12487 && PL_check[o->op_type] != Perl_ck_null)
12490 if ( o->op_type != OP_AELEM
12491 || (o->op_private &
12492 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12494 maybe_aelemfast = FALSE;
12496 /* look for aelem/helem/exists/delete. If it's not the last elem
12497 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12498 * flags; if it's the last, then it mustn't have
12499 * OPpDEREF_AV/HV, but may have lots of other flags, like
12500 * OPpLVAL_INTRO etc
12503 if ( index_type == MDEREF_INDEX_none
12504 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12505 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12509 /* we have aelem/helem/exists/delete with valid simple index */
12511 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12512 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12513 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12516 ASSUME(!(o->op_flags &
12517 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12518 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12520 ok = (o->op_flags &~ OPf_PARENS)
12521 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12522 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12524 else if (o->op_type == OP_EXISTS) {
12525 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12526 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12527 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12528 ok = !(o->op_private & ~OPpARG1_MASK);
12530 else if (o->op_type == OP_DELETE) {
12531 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12532 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12533 ASSUME(!(o->op_private &
12534 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12535 /* don't handle slices or 'local delete'; the latter
12536 * is fairly rare, and has a complex runtime */
12537 ok = !(o->op_private & ~OPpARG1_MASK);
12538 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12539 /* skip handling run-tome error */
12540 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
12543 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
12544 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
12545 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
12546 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
12547 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
12548 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
12553 if (!first_elem_op)
12557 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
12562 action |= MDEREF_FLAG_last;
12566 /* at this point we have something that started
12567 * promisingly enough (with rv2av or whatever), but failed
12568 * to find a simple index followed by an
12569 * aelem/helem/exists/delete. If this is the first action,
12570 * give up; but if we've already seen at least one
12571 * aelem/helem, then keep them and add a new action with
12572 * MDEREF_INDEX_none, which causes it to do the vivify
12573 * from the end of the previous lookup, and do the deref,
12574 * but stop at that point. So $a[0][expr] will do one
12575 * av_fetch, vivify and deref, then continue executing at
12580 index_skip = action_count;
12581 action |= MDEREF_FLAG_last;
12585 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
12588 /* if there's no space for the next action, create a new slot
12589 * for it *before* we start adding args for that action */
12590 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
12597 } /* while !is_last */
12605 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
12606 if (index_skip == -1) {
12607 mderef->op_flags = o->op_flags
12608 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
12609 if (o->op_type == OP_EXISTS)
12610 mderef->op_private = OPpMULTIDEREF_EXISTS;
12611 else if (o->op_type == OP_DELETE)
12612 mderef->op_private = OPpMULTIDEREF_DELETE;
12614 mderef->op_private = o->op_private
12615 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
12617 /* accumulate strictness from every level (although I don't think
12618 * they can actually vary) */
12619 mderef->op_private |= hints;
12621 /* integrate the new multideref op into the optree and the
12624 * In general an op like aelem or helem has two child
12625 * sub-trees: the aggregate expression (a_expr) and the
12626 * index expression (i_expr):
12632 * The a_expr returns an AV or HV, while the i-expr returns an
12633 * index. In general a multideref replaces most or all of a
12634 * multi-level tree, e.g.
12650 * With multideref, all the i_exprs will be simple vars or
12651 * constants, except that i_expr1 may be arbitrary in the case
12652 * of MDEREF_INDEX_none.
12654 * The bottom-most a_expr will be either:
12655 * 1) a simple var (so padXv or gv+rv2Xv);
12656 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
12657 * so a simple var with an extra rv2Xv;
12658 * 3) or an arbitrary expression.
12660 * 'start', the first op in the execution chain, will point to
12661 * 1),2): the padXv or gv op;
12662 * 3): the rv2Xv which forms the last op in the a_expr
12663 * execution chain, and the top-most op in the a_expr
12666 * For all cases, the 'start' node is no longer required,
12667 * but we can't free it since one or more external nodes
12668 * may point to it. E.g. consider
12669 * $h{foo} = $a ? $b : $c
12670 * Here, both the op_next and op_other branches of the
12671 * cond_expr point to the gv[*h] of the hash expression, so
12672 * we can't free the 'start' op.
12674 * For expr->[...], we need to save the subtree containing the
12675 * expression; for the other cases, we just need to save the
12677 * So in all cases, we null the start op and keep it around by
12678 * making it the child of the multideref op; for the expr->
12679 * case, the expr will be a subtree of the start node.
12681 * So in the simple 1,2 case the optree above changes to
12687 * ex-gv (or ex-padxv)
12689 * with the op_next chain being
12691 * -> ex-gv -> multideref -> op-following-ex-exists ->
12693 * In the 3 case, we have
12706 * -> rest-of-a_expr subtree ->
12707 * ex-rv2xv -> multideref -> op-following-ex-exists ->
12710 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
12711 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
12712 * multideref attached as the child, e.g.
12718 * ex-rv2av - i_expr1
12726 /* if we free this op, don't free the pad entry */
12727 if (reset_start_targ)
12728 start->op_targ = 0;
12731 /* Cut the bit we need to save out of the tree and attach to
12732 * the multideref op, then free the rest of the tree */
12734 /* find parent of node to be detached (for use by splice) */
12736 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
12737 || orig_action == MDEREF_HV_pop_rv2hv_helem)
12739 /* there is an arbitrary expression preceding us, e.g.
12740 * expr->[..]? so we need to save the 'expr' subtree */
12741 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
12742 p = cUNOPx(p)->op_first;
12743 ASSUME( start->op_type == OP_RV2AV
12744 || start->op_type == OP_RV2HV);
12747 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
12748 * above for exists/delete. */
12749 while ( (p->op_flags & OPf_KIDS)
12750 && cUNOPx(p)->op_first != start
12752 p = cUNOPx(p)->op_first;
12754 ASSUME(cUNOPx(p)->op_first == start);
12756 /* detach from main tree, and re-attach under the multideref */
12757 op_sibling_splice(mderef, NULL, 0,
12758 op_sibling_splice(p, NULL, 1, NULL));
12761 start->op_next = mderef;
12763 mderef->op_next = index_skip == -1 ? o->op_next : o;
12765 /* excise and free the original tree, and replace with
12766 * the multideref op */
12767 op_free(op_sibling_splice(top_op, NULL, -1, mderef));
12771 Size_t size = arg - arg_buf;
12773 if (maybe_aelemfast && action_count == 1)
12776 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
12777 sizeof(UNOP_AUX_item) * (size + 1));
12778 /* for dumping etc: store the length in a hidden first slot;
12779 * we set the op_aux pointer to the second slot */
12780 arg_buf->uv = size;
12783 } /* for (pass = ...) */
12788 /* mechanism for deferring recursion in rpeep() */
12790 #define MAX_DEFERRED 4
12794 if (defer_ix == (MAX_DEFERRED-1)) { \
12795 OP **defer = defer_queue[defer_base]; \
12796 CALL_RPEEP(*defer); \
12797 S_prune_chain_head(defer); \
12798 defer_base = (defer_base + 1) % MAX_DEFERRED; \
12801 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
12804 #define IS_AND_OP(o) (o->op_type == OP_AND)
12805 #define IS_OR_OP(o) (o->op_type == OP_OR)
12808 /* A peephole optimizer. We visit the ops in the order they're to execute.
12809 * See the comments at the top of this file for more details about when
12810 * peep() is called */
12813 Perl_rpeep(pTHX_ OP *o)
12817 OP* oldoldop = NULL;
12818 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
12819 int defer_base = 0;
12824 if (!o || o->op_opt)
12828 SAVEVPTR(PL_curcop);
12829 for (;; o = o->op_next) {
12830 if (o && o->op_opt)
12833 while (defer_ix >= 0) {
12835 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
12836 CALL_RPEEP(*defer);
12837 S_prune_chain_head(defer);
12843 /* By default, this op has now been optimised. A couple of cases below
12844 clear this again. */
12848 /* look for a series of 1 or more aggregate derefs, e.g.
12849 * $a[1]{foo}[$i]{$k}
12850 * and replace with a single OP_MULTIDEREF op.
12851 * Each index must be either a const, or a simple variable,
12853 * First, look for likely combinations of starting ops,
12854 * corresponding to (global and lexical variants of)
12856 * $r->[...] $r->{...}
12857 * (preceding expression)->[...]
12858 * (preceding expression)->{...}
12859 * and if so, call maybe_multideref() to do a full inspection
12860 * of the op chain and if appropriate, replace with an
12868 switch (o2->op_type) {
12870 /* $pkg[..] : gv[*pkg]
12871 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
12873 /* Fail if there are new op flag combinations that we're
12874 * not aware of, rather than:
12875 * * silently failing to optimise, or
12876 * * silently optimising the flag away.
12877 * If this ASSUME starts failing, examine what new flag
12878 * has been added to the op, and decide whether the
12879 * optimisation should still occur with that flag, then
12880 * update the code accordingly. This applies to all the
12881 * other ASSUMEs in the block of code too.
12883 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_SPECIAL)));
12884 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
12888 if (o2->op_type == OP_RV2AV) {
12889 action = MDEREF_AV_gvav_aelem;
12893 if (o2->op_type == OP_RV2HV) {
12894 action = MDEREF_HV_gvhv_helem;
12898 if (o2->op_type != OP_RV2SV)
12901 /* at this point we've seen gv,rv2sv, so the only valid
12902 * construct left is $pkg->[] or $pkg->{} */
12904 ASSUME(!(o2->op_flags & OPf_STACKED));
12905 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12906 != (OPf_WANT_SCALAR|OPf_MOD))
12909 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
12910 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
12911 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
12913 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
12914 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
12918 if (o2->op_type == OP_RV2AV) {
12919 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
12922 if (o2->op_type == OP_RV2HV) {
12923 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
12929 /* $lex->[...]: padsv[$lex] sM/DREFAV */
12931 ASSUME(!(o2->op_flags &
12932 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
12933 if ((o2->op_flags &
12934 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12935 != (OPf_WANT_SCALAR|OPf_MOD))
12938 ASSUME(!(o2->op_private &
12939 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12940 /* skip if state or intro, or not a deref */
12941 if ( o2->op_private != OPpDEREF_AV
12942 && o2->op_private != OPpDEREF_HV)
12946 if (o2->op_type == OP_RV2AV) {
12947 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
12950 if (o2->op_type == OP_RV2HV) {
12951 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
12958 /* $lex[..]: padav[@lex:1,2] sR *
12959 * or $lex{..}: padhv[%lex:1,2] sR */
12960 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
12961 OPf_REF|OPf_SPECIAL)));
12962 if ((o2->op_flags &
12963 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
12964 != (OPf_WANT_SCALAR|OPf_REF))
12966 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
12968 /* OPf_PARENS isn't currently used in this case;
12969 * if that changes, let us know! */
12970 ASSUME(!(o2->op_flags & OPf_PARENS));
12972 /* at this point, we wouldn't expect any of the remaining
12973 * possible private flags:
12974 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
12975 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
12977 * OPpSLICEWARNING shouldn't affect runtime
12979 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
12981 action = o2->op_type == OP_PADAV
12982 ? MDEREF_AV_padav_aelem
12983 : MDEREF_HV_padhv_helem;
12985 S_maybe_multideref(aTHX_ o, o2, action, 0);
12991 action = o2->op_type == OP_RV2AV
12992 ? MDEREF_AV_pop_rv2av_aelem
12993 : MDEREF_HV_pop_rv2hv_helem;
12996 /* (expr)->[...]: rv2av sKR/1;
12997 * (expr)->{...}: rv2hv sKR/1; */
12999 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13001 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13002 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13003 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13006 /* at this point, we wouldn't expect any of these
13007 * possible private flags:
13008 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13009 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13011 ASSUME(!(o2->op_private &
13012 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13014 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13018 S_maybe_multideref(aTHX_ o, o2, action, hints);
13027 switch (o->op_type) {
13029 PL_curcop = ((COP*)o); /* for warnings */
13032 PL_curcop = ((COP*)o); /* for warnings */
13034 /* Optimise a "return ..." at the end of a sub to just be "...".
13035 * This saves 2 ops. Before:
13036 * 1 <;> nextstate(main 1 -e:1) v ->2
13037 * 4 <@> return K ->5
13038 * 2 <0> pushmark s ->3
13039 * - <1> ex-rv2sv sK/1 ->4
13040 * 3 <#> gvsv[*cat] s ->4
13043 * - <@> return K ->-
13044 * - <0> pushmark s ->2
13045 * - <1> ex-rv2sv sK/1 ->-
13046 * 2 <$> gvsv(*cat) s ->3
13049 OP *next = o->op_next;
13050 OP *sibling = OpSIBLING(o);
13051 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13052 && OP_TYPE_IS(sibling, OP_RETURN)
13053 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13054 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13055 ||OP_TYPE_IS(sibling->op_next->op_next,
13057 && cUNOPx(sibling)->op_first == next
13058 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13061 /* Look through the PUSHMARK's siblings for one that
13062 * points to the RETURN */
13063 OP *top = OpSIBLING(next);
13064 while (top && top->op_next) {
13065 if (top->op_next == sibling) {
13066 top->op_next = sibling->op_next;
13067 o->op_next = next->op_next;
13070 top = OpSIBLING(top);
13075 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13077 * This latter form is then suitable for conversion into padrange
13078 * later on. Convert:
13080 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13084 * nextstate1 -> listop -> nextstate3
13086 * pushmark -> padop1 -> padop2
13088 if (o->op_next && (
13089 o->op_next->op_type == OP_PADSV
13090 || o->op_next->op_type == OP_PADAV
13091 || o->op_next->op_type == OP_PADHV
13093 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13094 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13095 && o->op_next->op_next->op_next && (
13096 o->op_next->op_next->op_next->op_type == OP_PADSV
13097 || o->op_next->op_next->op_next->op_type == OP_PADAV
13098 || o->op_next->op_next->op_next->op_type == OP_PADHV
13100 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13101 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13102 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13103 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13105 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13108 ns2 = pad1->op_next;
13109 pad2 = ns2->op_next;
13110 ns3 = pad2->op_next;
13112 /* we assume here that the op_next chain is the same as
13113 * the op_sibling chain */
13114 assert(OpSIBLING(o) == pad1);
13115 assert(OpSIBLING(pad1) == ns2);
13116 assert(OpSIBLING(ns2) == pad2);
13117 assert(OpSIBLING(pad2) == ns3);
13119 /* create new listop, with children consisting of:
13120 * a new pushmark, pad1, pad2. */
13121 OpSIBLING_set(pad2, NULL);
13122 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13123 newop->op_flags |= OPf_PARENS;
13124 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13125 newpm = cUNOPx(newop)->op_first; /* pushmark */
13127 /* Kill nextstate2 between padop1/padop2 */
13130 o ->op_next = newpm;
13131 newpm->op_next = pad1;
13132 pad1 ->op_next = pad2;
13133 pad2 ->op_next = newop; /* listop */
13134 newop->op_next = ns3;
13136 OpSIBLING_set(o, newop);
13137 OpSIBLING_set(newop, ns3);
13138 newop->op_lastsib = 0;
13140 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13142 /* Ensure pushmark has this flag if padops do */
13143 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13144 o->op_next->op_flags |= OPf_MOD;
13150 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13151 to carry two labels. For now, take the easier option, and skip
13152 this optimisation if the first NEXTSTATE has a label. */
13153 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13154 OP *nextop = o->op_next;
13155 while (nextop && nextop->op_type == OP_NULL)
13156 nextop = nextop->op_next;
13158 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13161 oldop->op_next = nextop;
13162 /* Skip (old)oldop assignment since the current oldop's
13163 op_next already points to the next op. */
13170 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13171 if (o->op_next->op_private & OPpTARGET_MY) {
13172 if (o->op_flags & OPf_STACKED) /* chained concats */
13173 break; /* ignore_optimization */
13175 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13176 o->op_targ = o->op_next->op_targ;
13177 o->op_next->op_targ = 0;
13178 o->op_private |= OPpTARGET_MY;
13181 op_null(o->op_next);
13185 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13186 break; /* Scalar stub must produce undef. List stub is noop */
13190 if (o->op_targ == OP_NEXTSTATE
13191 || o->op_targ == OP_DBSTATE)
13193 PL_curcop = ((COP*)o);
13195 /* XXX: We avoid setting op_seq here to prevent later calls
13196 to rpeep() from mistakenly concluding that optimisation
13197 has already occurred. This doesn't fix the real problem,
13198 though (See 20010220.007). AMS 20010719 */
13199 /* op_seq functionality is now replaced by op_opt */
13207 oldop->op_next = o->op_next;
13221 convert repeat into a stub with no kids.
13223 if (o->op_next->op_type == OP_CONST
13224 || ( o->op_next->op_type == OP_PADSV
13225 && !(o->op_next->op_private & OPpLVAL_INTRO))
13226 || ( o->op_next->op_type == OP_GV
13227 && o->op_next->op_next->op_type == OP_RV2SV
13228 && !(o->op_next->op_next->op_private
13229 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13231 const OP *kid = o->op_next->op_next;
13232 if (o->op_next->op_type == OP_GV)
13233 kid = kid->op_next;
13234 /* kid is now the ex-list. */
13235 if (kid->op_type == OP_NULL
13236 && (kid = kid->op_next)->op_type == OP_CONST
13237 /* kid is now the repeat count. */
13238 && kid->op_next->op_type == OP_REPEAT
13239 && kid->op_next->op_private & OPpREPEAT_DOLIST
13240 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13241 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13243 o = kid->op_next; /* repeat */
13245 oldop->op_next = o;
13246 op_free(cBINOPo->op_first);
13247 op_free(cBINOPo->op_last );
13248 o->op_flags &=~ OPf_KIDS;
13249 /* stub is a baseop; repeat is a binop */
13250 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13251 CHANGE_TYPE(o, OP_STUB);
13257 /* Convert a series of PAD ops for my vars plus support into a
13258 * single padrange op. Basically
13260 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13262 * becomes, depending on circumstances, one of
13264 * padrange ----------------------------------> (list) -> rest
13265 * padrange --------------------------------------------> rest
13267 * where all the pad indexes are sequential and of the same type
13269 * We convert the pushmark into a padrange op, then skip
13270 * any other pad ops, and possibly some trailing ops.
13271 * Note that we don't null() the skipped ops, to make it
13272 * easier for Deparse to undo this optimisation (and none of
13273 * the skipped ops are holding any resourses). It also makes
13274 * it easier for find_uninit_var(), as it can just ignore
13275 * padrange, and examine the original pad ops.
13279 OP *followop = NULL; /* the op that will follow the padrange op */
13282 PADOFFSET base = 0; /* init only to stop compiler whining */
13283 bool gvoid = 0; /* init only to stop compiler whining */
13284 bool defav = 0; /* seen (...) = @_ */
13285 bool reuse = 0; /* reuse an existing padrange op */
13287 /* look for a pushmark -> gv[_] -> rv2av */
13292 if ( p->op_type == OP_GV
13293 && cGVOPx_gv(p) == PL_defgv
13294 && (rv2av = p->op_next)
13295 && rv2av->op_type == OP_RV2AV
13296 && !(rv2av->op_flags & OPf_REF)
13297 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13298 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13300 q = rv2av->op_next;
13301 if (q->op_type == OP_NULL)
13303 if (q->op_type == OP_PUSHMARK) {
13313 /* scan for PAD ops */
13315 for (p = p->op_next; p; p = p->op_next) {
13316 if (p->op_type == OP_NULL)
13319 if (( p->op_type != OP_PADSV
13320 && p->op_type != OP_PADAV
13321 && p->op_type != OP_PADHV
13323 /* any private flag other than INTRO? e.g. STATE */
13324 || (p->op_private & ~OPpLVAL_INTRO)
13328 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13330 if ( p->op_type == OP_PADAV
13332 && p->op_next->op_type == OP_CONST
13333 && p->op_next->op_next
13334 && p->op_next->op_next->op_type == OP_AELEM
13338 /* for 1st padop, note what type it is and the range
13339 * start; for the others, check that it's the same type
13340 * and that the targs are contiguous */
13342 intro = (p->op_private & OPpLVAL_INTRO);
13344 gvoid = OP_GIMME(p,0) == G_VOID;
13347 if ((p->op_private & OPpLVAL_INTRO) != intro)
13349 /* Note that you'd normally expect targs to be
13350 * contiguous in my($a,$b,$c), but that's not the case
13351 * when external modules start doing things, e.g.
13352 i* Function::Parameters */
13353 if (p->op_targ != base + count)
13355 assert(p->op_targ == base + count);
13356 /* Either all the padops or none of the padops should
13357 be in void context. Since we only do the optimisa-
13358 tion for av/hv when the aggregate itself is pushed
13359 on to the stack (one item), there is no need to dis-
13360 tinguish list from scalar context. */
13361 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13365 /* for AV, HV, only when we're not flattening */
13366 if ( p->op_type != OP_PADSV
13368 && !(p->op_flags & OPf_REF)
13372 if (count >= OPpPADRANGE_COUNTMASK)
13375 /* there's a biggest base we can fit into a
13376 * SAVEt_CLEARPADRANGE in pp_padrange */
13377 if (intro && base >
13378 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
13381 /* Success! We've got another valid pad op to optimise away */
13383 followop = p->op_next;
13386 if (count < 1 || (count == 1 && !defav))
13389 /* pp_padrange in specifically compile-time void context
13390 * skips pushing a mark and lexicals; in all other contexts
13391 * (including unknown till runtime) it pushes a mark and the
13392 * lexicals. We must be very careful then, that the ops we
13393 * optimise away would have exactly the same effect as the
13395 * In particular in void context, we can only optimise to
13396 * a padrange if see see the complete sequence
13397 * pushmark, pad*v, ...., list
13398 * which has the net effect of of leaving the markstack as it
13399 * was. Not pushing on to the stack (whereas padsv does touch
13400 * the stack) makes no difference in void context.
13404 if (followop->op_type == OP_LIST
13405 && OP_GIMME(followop,0) == G_VOID
13408 followop = followop->op_next; /* skip OP_LIST */
13410 /* consolidate two successive my(...);'s */
13413 && oldoldop->op_type == OP_PADRANGE
13414 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13415 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13416 && !(oldoldop->op_flags & OPf_SPECIAL)
13419 assert(oldoldop->op_next == oldop);
13420 assert( oldop->op_type == OP_NEXTSTATE
13421 || oldop->op_type == OP_DBSTATE);
13422 assert(oldop->op_next == o);
13425 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13427 /* Do not assume pad offsets for $c and $d are con-
13432 if ( oldoldop->op_targ + old_count == base
13433 && old_count < OPpPADRANGE_COUNTMASK - count) {
13434 base = oldoldop->op_targ;
13435 count += old_count;
13440 /* if there's any immediately following singleton
13441 * my var's; then swallow them and the associated
13443 * my ($a,$b); my $c; my $d;
13445 * my ($a,$b,$c,$d);
13448 while ( ((p = followop->op_next))
13449 && ( p->op_type == OP_PADSV
13450 || p->op_type == OP_PADAV
13451 || p->op_type == OP_PADHV)
13452 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13453 && (p->op_private & OPpLVAL_INTRO) == intro
13454 && !(p->op_private & ~OPpLVAL_INTRO)
13456 && ( p->op_next->op_type == OP_NEXTSTATE
13457 || p->op_next->op_type == OP_DBSTATE)
13458 && count < OPpPADRANGE_COUNTMASK
13459 && base + count == p->op_targ
13462 followop = p->op_next;
13470 assert(oldoldop->op_type == OP_PADRANGE);
13471 oldoldop->op_next = followop;
13472 oldoldop->op_private = (intro | count);
13478 /* Convert the pushmark into a padrange.
13479 * To make Deparse easier, we guarantee that a padrange was
13480 * *always* formerly a pushmark */
13481 assert(o->op_type == OP_PUSHMARK);
13482 o->op_next = followop;
13483 CHANGE_TYPE(o, OP_PADRANGE);
13485 /* bit 7: INTRO; bit 6..0: count */
13486 o->op_private = (intro | count);
13487 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13488 | gvoid * OPf_WANT_VOID
13489 | (defav ? OPf_SPECIAL : 0));
13497 /* Skip over state($x) in void context. */
13498 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13499 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13501 oldop->op_next = o->op_next;
13502 goto redo_nextstate;
13504 if (o->op_type != OP_PADAV)
13508 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13509 OP* const pop = (o->op_type == OP_PADAV) ?
13510 o->op_next : o->op_next->op_next;
13512 if (pop && pop->op_type == OP_CONST &&
13513 ((PL_op = pop->op_next)) &&
13514 pop->op_next->op_type == OP_AELEM &&
13515 !(pop->op_next->op_private &
13516 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
13517 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
13520 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
13521 no_bareword_allowed(pop);
13522 if (o->op_type == OP_GV)
13523 op_null(o->op_next);
13524 op_null(pop->op_next);
13526 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
13527 o->op_next = pop->op_next->op_next;
13528 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
13529 o->op_private = (U8)i;
13530 if (o->op_type == OP_GV) {
13533 o->op_type = OP_AELEMFAST;
13536 o->op_type = OP_AELEMFAST_LEX;
13538 if (o->op_type != OP_GV)
13542 /* Remove $foo from the op_next chain in void context. */
13544 && ( o->op_next->op_type == OP_RV2SV
13545 || o->op_next->op_type == OP_RV2AV
13546 || o->op_next->op_type == OP_RV2HV )
13547 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13548 && !(o->op_next->op_private & OPpLVAL_INTRO))
13550 oldop->op_next = o->op_next->op_next;
13551 /* Reprocess the previous op if it is a nextstate, to
13552 allow double-nextstate optimisation. */
13554 if (oldop->op_type == OP_NEXTSTATE) {
13563 else if (o->op_next->op_type == OP_RV2SV) {
13564 if (!(o->op_next->op_private & OPpDEREF)) {
13565 op_null(o->op_next);
13566 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
13568 o->op_next = o->op_next->op_next;
13569 CHANGE_TYPE(o, OP_GVSV);
13572 else if (o->op_next->op_type == OP_READLINE
13573 && o->op_next->op_next->op_type == OP_CONCAT
13574 && (o->op_next->op_next->op_flags & OPf_STACKED))
13576 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
13577 CHANGE_TYPE(o, OP_RCATLINE);
13578 o->op_flags |= OPf_STACKED;
13579 op_null(o->op_next->op_next);
13580 op_null(o->op_next);
13585 #define HV_OR_SCALARHV(op) \
13586 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
13588 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
13589 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
13590 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
13591 ? cUNOPx(op)->op_first \
13595 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
13596 fop->op_private |= OPpTRUEBOOL;
13602 fop = cLOGOP->op_first;
13603 sop = OpSIBLING(fop);
13604 while (cLOGOP->op_other->op_type == OP_NULL)
13605 cLOGOP->op_other = cLOGOP->op_other->op_next;
13606 while (o->op_next && ( o->op_type == o->op_next->op_type
13607 || o->op_next->op_type == OP_NULL))
13608 o->op_next = o->op_next->op_next;
13610 /* if we're an OR and our next is a AND in void context, we'll
13611 follow it's op_other on short circuit, same for reverse.
13612 We can't do this with OP_DOR since if it's true, its return
13613 value is the underlying value which must be evaluated
13617 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
13618 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
13620 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
13622 o->op_next = ((LOGOP*)o->op_next)->op_other;
13624 DEFER(cLOGOP->op_other);
13627 fop = HV_OR_SCALARHV(fop);
13628 if (sop) sop = HV_OR_SCALARHV(sop);
13633 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
13634 while (nop && nop->op_next) {
13635 switch (nop->op_next->op_type) {
13640 lop = nop = nop->op_next;
13643 nop = nop->op_next;
13652 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13653 || o->op_type == OP_AND )
13654 fop->op_private |= OPpTRUEBOOL;
13655 else if (!(lop->op_flags & OPf_WANT))
13656 fop->op_private |= OPpMAYBE_TRUEBOOL;
13658 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
13660 sop->op_private |= OPpTRUEBOOL;
13667 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
13668 fop->op_private |= OPpTRUEBOOL;
13669 #undef HV_OR_SCALARHV
13670 /* GERONIMO! */ /* FALLTHROUGH */
13679 while (cLOGOP->op_other->op_type == OP_NULL)
13680 cLOGOP->op_other = cLOGOP->op_other->op_next;
13681 DEFER(cLOGOP->op_other);
13686 while (cLOOP->op_redoop->op_type == OP_NULL)
13687 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
13688 while (cLOOP->op_nextop->op_type == OP_NULL)
13689 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
13690 while (cLOOP->op_lastop->op_type == OP_NULL)
13691 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
13692 /* a while(1) loop doesn't have an op_next that escapes the
13693 * loop, so we have to explicitly follow the op_lastop to
13694 * process the rest of the code */
13695 DEFER(cLOOP->op_lastop);
13699 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
13700 DEFER(cLOGOPo->op_other);
13704 assert(!(cPMOP->op_pmflags & PMf_ONCE));
13705 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
13706 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
13707 cPMOP->op_pmstashstartu.op_pmreplstart
13708 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
13709 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
13715 if (o->op_flags & OPf_SPECIAL) {
13716 /* first arg is a code block */
13717 OP * const nullop = OpSIBLING(cLISTOP->op_first);
13718 OP * kid = cUNOPx(nullop)->op_first;
13720 assert(nullop->op_type == OP_NULL);
13721 assert(kid->op_type == OP_SCOPE
13722 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
13723 /* since OP_SORT doesn't have a handy op_other-style
13724 * field that can point directly to the start of the code
13725 * block, store it in the otherwise-unused op_next field
13726 * of the top-level OP_NULL. This will be quicker at
13727 * run-time, and it will also allow us to remove leading
13728 * OP_NULLs by just messing with op_nexts without
13729 * altering the basic op_first/op_sibling layout. */
13730 kid = kLISTOP->op_first;
13732 (kid->op_type == OP_NULL
13733 && ( kid->op_targ == OP_NEXTSTATE
13734 || kid->op_targ == OP_DBSTATE ))
13735 || kid->op_type == OP_STUB
13736 || kid->op_type == OP_ENTER);
13737 nullop->op_next = kLISTOP->op_next;
13738 DEFER(nullop->op_next);
13741 /* check that RHS of sort is a single plain array */
13742 oright = cUNOPo->op_first;
13743 if (!oright || oright->op_type != OP_PUSHMARK)
13746 if (o->op_private & OPpSORT_INPLACE)
13749 /* reverse sort ... can be optimised. */
13750 if (!OpHAS_SIBLING(cUNOPo)) {
13751 /* Nothing follows us on the list. */
13752 OP * const reverse = o->op_next;
13754 if (reverse->op_type == OP_REVERSE &&
13755 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
13756 OP * const pushmark = cUNOPx(reverse)->op_first;
13757 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
13758 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
13759 /* reverse -> pushmark -> sort */
13760 o->op_private |= OPpSORT_REVERSE;
13762 pushmark->op_next = oright->op_next;
13772 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
13774 LISTOP *enter, *exlist;
13776 if (o->op_private & OPpSORT_INPLACE)
13779 enter = (LISTOP *) o->op_next;
13782 if (enter->op_type == OP_NULL) {
13783 enter = (LISTOP *) enter->op_next;
13787 /* for $a (...) will have OP_GV then OP_RV2GV here.
13788 for (...) just has an OP_GV. */
13789 if (enter->op_type == OP_GV) {
13790 gvop = (OP *) enter;
13791 enter = (LISTOP *) enter->op_next;
13794 if (enter->op_type == OP_RV2GV) {
13795 enter = (LISTOP *) enter->op_next;
13801 if (enter->op_type != OP_ENTERITER)
13804 iter = enter->op_next;
13805 if (!iter || iter->op_type != OP_ITER)
13808 expushmark = enter->op_first;
13809 if (!expushmark || expushmark->op_type != OP_NULL
13810 || expushmark->op_targ != OP_PUSHMARK)
13813 exlist = (LISTOP *) OpSIBLING(expushmark);
13814 if (!exlist || exlist->op_type != OP_NULL
13815 || exlist->op_targ != OP_LIST)
13818 if (exlist->op_last != o) {
13819 /* Mmm. Was expecting to point back to this op. */
13822 theirmark = exlist->op_first;
13823 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
13826 if (OpSIBLING(theirmark) != o) {
13827 /* There's something between the mark and the reverse, eg
13828 for (1, reverse (...))
13833 ourmark = ((LISTOP *)o)->op_first;
13834 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
13837 ourlast = ((LISTOP *)o)->op_last;
13838 if (!ourlast || ourlast->op_next != o)
13841 rv2av = OpSIBLING(ourmark);
13842 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
13843 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
13844 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
13845 /* We're just reversing a single array. */
13846 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
13847 enter->op_flags |= OPf_STACKED;
13850 /* We don't have control over who points to theirmark, so sacrifice
13852 theirmark->op_next = ourmark->op_next;
13853 theirmark->op_flags = ourmark->op_flags;
13854 ourlast->op_next = gvop ? gvop : (OP *) enter;
13857 enter->op_private |= OPpITER_REVERSED;
13858 iter->op_private |= OPpITER_REVERSED;
13865 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
13866 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
13871 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
13872 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
13875 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
13877 sv = newRV((SV *)PL_compcv);
13881 CHANGE_TYPE(o, OP_CONST);
13882 o->op_flags |= OPf_SPECIAL;
13883 cSVOPo->op_sv = sv;
13888 if (OP_GIMME(o,0) == G_VOID
13889 || ( o->op_next->op_type == OP_LINESEQ
13890 && ( o->op_next->op_next->op_type == OP_LEAVESUB
13891 || ( o->op_next->op_next->op_type == OP_RETURN
13892 && !CvLVALUE(PL_compcv)))))
13894 OP *right = cBINOP->op_first;
13913 OP *left = OpSIBLING(right);
13914 if (left->op_type == OP_SUBSTR
13915 && (left->op_private & 7) < 4) {
13917 /* cut out right */
13918 op_sibling_splice(o, NULL, 1, NULL);
13919 /* and insert it as second child of OP_SUBSTR */
13920 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
13922 left->op_private |= OPpSUBSTR_REPL_FIRST;
13924 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13931 /* We do the common-vars check here, rather than in newASSIGNOP
13932 (as formerly), so that all lexical vars that get aliased are
13933 marked as such before we do the check. */
13934 /* There can’t be common vars if the lhs is a stub. */
13935 if (OpSIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
13936 == cLISTOPx(cBINOPo->op_last)->op_last
13937 && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
13939 o->op_private &=~ OPpASSIGN_COMMON;
13942 if (o->op_private & OPpASSIGN_COMMON) {
13943 /* See the comment before S_aassign_common_vars concerning
13944 PL_generation sorcery. */
13946 if (!aassign_common_vars(o))
13947 o->op_private &=~ OPpASSIGN_COMMON;
13949 else if (S_aassign_common_vars_aliases_only(aTHX_ o))
13950 o->op_private |= OPpASSIGN_COMMON;
13954 Perl_cpeep_t cpeep =
13955 XopENTRYCUSTOM(o, xop_peep);
13957 cpeep(aTHX_ o, oldop);
13962 /* did we just null the current op? If so, re-process it to handle
13963 * eliding "empty" ops from the chain */
13964 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
13977 Perl_peep(pTHX_ OP *o)
13983 =head1 Custom Operators
13985 =for apidoc Ao||custom_op_xop
13986 Return the XOP structure for a given custom op. This macro should be
13987 considered internal to OP_NAME and the other access macros: use them instead.
13988 This macro does call a function. Prior
13989 to 5.19.6, this was implemented as a
13996 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14002 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14004 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14005 assert(o->op_type == OP_CUSTOM);
14007 /* This is wrong. It assumes a function pointer can be cast to IV,
14008 * which isn't guaranteed, but this is what the old custom OP code
14009 * did. In principle it should be safer to Copy the bytes of the
14010 * pointer into a PV: since the new interface is hidden behind
14011 * functions, this can be changed later if necessary. */
14012 /* Change custom_op_xop if this ever happens */
14013 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14016 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14018 /* assume noone will have just registered a desc */
14019 if (!he && PL_custom_op_names &&
14020 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14025 /* XXX does all this need to be shared mem? */
14026 Newxz(xop, 1, XOP);
14027 pv = SvPV(HeVAL(he), l);
14028 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14029 if (PL_custom_op_descs &&
14030 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14032 pv = SvPV(HeVAL(he), l);
14033 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14035 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14039 xop = (XOP *)&xop_null;
14041 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14045 if(field == XOPe_xop_ptr) {
14048 const U32 flags = XopFLAGS(xop);
14049 if(flags & field) {
14051 case XOPe_xop_name:
14052 any.xop_name = xop->xop_name;
14054 case XOPe_xop_desc:
14055 any.xop_desc = xop->xop_desc;
14057 case XOPe_xop_class:
14058 any.xop_class = xop->xop_class;
14060 case XOPe_xop_peep:
14061 any.xop_peep = xop->xop_peep;
14069 case XOPe_xop_name:
14070 any.xop_name = XOPd_xop_name;
14072 case XOPe_xop_desc:
14073 any.xop_desc = XOPd_xop_desc;
14075 case XOPe_xop_class:
14076 any.xop_class = XOPd_xop_class;
14078 case XOPe_xop_peep:
14079 any.xop_peep = XOPd_xop_peep;
14087 /* Some gcc releases emit a warning for this function:
14088 * op.c: In function 'Perl_custom_op_get_field':
14089 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14090 * Whether this is true, is currently unknown. */
14096 =for apidoc Ao||custom_op_register
14097 Register a custom op. See L<perlguts/"Custom Operators">.
14103 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14107 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14109 /* see the comment in custom_op_xop */
14110 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14112 if (!PL_custom_ops)
14113 PL_custom_ops = newHV();
14115 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14116 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14121 =for apidoc core_prototype
14123 This function assigns the prototype of the named core function to C<sv>, or
14124 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
14125 NULL if the core function has no prototype. C<code> is a code as returned
14126 by C<keyword()>. It must not be equal to 0.
14132 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14135 int i = 0, n = 0, seen_question = 0, defgv = 0;
14137 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14138 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14139 bool nullret = FALSE;
14141 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14145 if (!sv) sv = sv_newmortal();
14147 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14149 switch (code < 0 ? -code : code) {
14150 case KEY_and : case KEY_chop: case KEY_chomp:
14151 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14152 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14153 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14154 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14155 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14156 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14157 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14158 case KEY_x : case KEY_xor :
14159 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14160 case KEY_glob: retsetpvs("_;", OP_GLOB);
14161 case KEY_keys: retsetpvs("+", OP_KEYS);
14162 case KEY_values: retsetpvs("+", OP_VALUES);
14163 case KEY_each: retsetpvs("+", OP_EACH);
14164 case KEY_push: retsetpvs("+@", OP_PUSH);
14165 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
14166 case KEY_pop: retsetpvs(";+", OP_POP);
14167 case KEY_shift: retsetpvs(";+", OP_SHIFT);
14168 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14170 retsetpvs("+;$$@", OP_SPLICE);
14171 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14173 case KEY_evalbytes:
14174 name = "entereval"; break;
14182 while (i < MAXO) { /* The slow way. */
14183 if (strEQ(name, PL_op_name[i])
14184 || strEQ(name, PL_op_desc[i]))
14186 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14193 defgv = PL_opargs[i] & OA_DEFGV;
14194 oa = PL_opargs[i] >> OASHIFT;
14196 if (oa & OA_OPTIONAL && !seen_question && (
14197 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14202 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14203 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14204 /* But globs are already references (kinda) */
14205 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14209 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14210 && !scalar_mod_type(NULL, i)) {
14215 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14219 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14220 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14221 str[n-1] = '_'; defgv = 0;
14225 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14227 sv_setpvn(sv, str, n - 1);
14228 if (opnum) *opnum = i;
14233 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14236 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14239 PERL_ARGS_ASSERT_CORESUB_OP;
14243 return op_append_elem(OP_LINESEQ,
14246 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14250 case OP_SELECT: /* which represents OP_SSELECT as well */
14255 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14256 newSVOP(OP_CONST, 0, newSVuv(1))
14258 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14260 coresub_op(coreargssv, 0, OP_SELECT)
14264 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14266 return op_append_elem(
14269 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14270 ? OPpOFFBYONE << 8 : 0)
14272 case OA_BASEOP_OR_UNOP:
14273 if (opnum == OP_ENTEREVAL) {
14274 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14275 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14277 else o = newUNOP(opnum,0,argop);
14278 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14281 if (is_handle_constructor(o, 1))
14282 argop->op_private |= OPpCOREARGS_DEREF1;
14283 if (scalar_mod_type(NULL, opnum))
14284 argop->op_private |= OPpCOREARGS_SCALARMOD;
14288 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14289 if (is_handle_constructor(o, 2))
14290 argop->op_private |= OPpCOREARGS_DEREF2;
14291 if (opnum == OP_SUBSTR) {
14292 o->op_private |= OPpMAYBE_LVSUB;
14301 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14302 SV * const *new_const_svp)
14304 const char *hvname;
14305 bool is_const = !!CvCONST(old_cv);
14306 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14308 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14310 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14312 /* They are 2 constant subroutines generated from
14313 the same constant. This probably means that
14314 they are really the "same" proxy subroutine
14315 instantiated in 2 places. Most likely this is
14316 when a constant is exported twice. Don't warn.
14319 (ckWARN(WARN_REDEFINE)
14321 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14322 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14323 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14324 strEQ(hvname, "autouse"))
14328 && ckWARN_d(WARN_REDEFINE)
14329 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14332 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14334 ? "Constant subroutine %"SVf" redefined"
14335 : "Subroutine %"SVf" redefined",
14340 =head1 Hook manipulation
14342 These functions provide convenient and thread-safe means of manipulating
14349 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14351 Puts a C function into the chain of check functions for a specified op
14352 type. This is the preferred way to manipulate the L</PL_check> array.
14353 I<opcode> specifies which type of op is to be affected. I<new_checker>
14354 is a pointer to the C function that is to be added to that opcode's
14355 check chain, and I<old_checker_p> points to the storage location where a
14356 pointer to the next function in the chain will be stored. The value of
14357 I<new_pointer> is written into the L</PL_check> array, while the value
14358 previously stored there is written to I<*old_checker_p>.
14360 The function should be defined like this:
14362 static OP *new_checker(pTHX_ OP *op) { ... }
14364 It is intended to be called in this manner:
14366 new_checker(aTHX_ op)
14368 I<old_checker_p> should be defined like this:
14370 static Perl_check_t old_checker_p;
14372 L</PL_check> is global to an entire process, and a module wishing to
14373 hook op checking may find itself invoked more than once per process,
14374 typically in different threads. To handle that situation, this function
14375 is idempotent. The location I<*old_checker_p> must initially (once
14376 per process) contain a null pointer. A C variable of static duration
14377 (declared at file scope, typically also marked C<static> to give
14378 it internal linkage) will be implicitly initialised appropriately,
14379 if it does not have an explicit initialiser. This function will only
14380 actually modify the check chain if it finds I<*old_checker_p> to be null.
14381 This function is also thread safe on the small scale. It uses appropriate
14382 locking to avoid race conditions in accessing L</PL_check>.
14384 When this function is called, the function referenced by I<new_checker>
14385 must be ready to be called, except for I<*old_checker_p> being unfilled.
14386 In a threading situation, I<new_checker> may be called immediately,
14387 even before this function has returned. I<*old_checker_p> will always
14388 be appropriately set before I<new_checker> is called. If I<new_checker>
14389 decides not to do anything special with an op that it is given (which
14390 is the usual case for most uses of op check hooking), it must chain the
14391 check function referenced by I<*old_checker_p>.
14393 If you want to influence compilation of calls to a specific subroutine,
14394 then use L</cv_set_call_checker> rather than hooking checking of all
14401 Perl_wrap_op_checker(pTHX_ Optype opcode,
14402 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14406 PERL_UNUSED_CONTEXT;
14407 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14408 if (*old_checker_p) return;
14409 OP_CHECK_MUTEX_LOCK;
14410 if (!*old_checker_p) {
14411 *old_checker_p = PL_check[opcode];
14412 PL_check[opcode] = new_checker;
14414 OP_CHECK_MUTEX_UNLOCK;
14419 /* Efficient sub that returns a constant scalar value. */
14421 const_sv_xsub(pTHX_ CV* cv)
14424 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14425 PERL_UNUSED_ARG(items);
14435 const_av_xsub(pTHX_ CV* cv)
14438 AV * const av = MUTABLE_AV(XSANY.any_ptr);
14446 if (SvRMAGICAL(av))
14447 Perl_croak(aTHX_ "Magical list constants are not supported");
14448 if (GIMME_V != G_ARRAY) {
14450 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
14453 EXTEND(SP, AvFILLp(av)+1);
14454 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
14455 XSRETURN(AvFILLp(av)+1);
14460 * c-indentation-style: bsd
14461 * c-basic-offset: 4
14462 * indent-tabs-mode: nil
14465 * ex: set ts=8 sts=4 sw=4 et: