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 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
28 * A Perl program is compiled into a tree of OP nodes. Each op contains:
29 * * structural OP pointers to its children and siblings (op_sibling,
30 * op_first etc) that define the tree structure;
31 * * execution order OP pointers (op_next, plus sometimes op_other,
32 * op_lastop etc) that define the execution sequence plus variants;
33 * * a pointer to the C "pp" function that would execute the op;
34 * * any data specific to that op.
35 * For example, an OP_CONST op points to the pp_const() function and to an
36 * SV containing the constant value. When pp_const() is executed, its job
37 * is to push that SV onto the stack.
39 * OPs are mainly created by the newFOO() functions, which are mainly
40 * called from the parser (in perly.y) as the code is parsed. For example
41 * the Perl code $a + $b * $c would cause the equivalent of the following
42 * to be called (oversimplifying a bit):
44 * newBINOP(OP_ADD, flags,
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
49 * As the parser reduces low-level rules, it creates little op subtrees;
50 * as higher-level rules are resolved, these subtrees get joined together
51 * as branches on a bigger subtree, until eventually a top-level rule like
52 * a subroutine definition is reduced, at which point there is one large
55 * The execution order pointers (op_next) are generated as the subtrees
56 * are joined together. Consider this sub-expression: A*B + C/D: at the
57 * point when it's just been parsed, the op tree looks like:
65 * with the intended execution order being:
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
69 * At this point all the nodes' op_next pointers will have been set,
71 * * we don't know what the [NEXT] node will be yet;
72 * * we don't know what the [PREV] node will be yet, but when it gets
73 * created and needs its op_next set, it needs to be set to point to
74 * A, which is non-obvious.
75 * To handle both those cases, we temporarily set the top node's
76 * op_next to point to the first node to be executed in this subtree (A in
77 * this case). This means that initially a subtree's op_next chain,
78 * starting from the top node, will visit each node in execution sequence
79 * then point back at the top node.
80 * When we embed this subtree in a larger tree, its top op_next is used
81 * to get the start node, then is set to point to its new neighbour.
82 * For example the two separate [*],A,B and [/],C,D subtrees would
84 * [*] => A; A => B; B => [*]
86 * [/] => C; C => D; D => [/]
87 * When these two subtrees were joined together to make the [+] subtree,
88 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89 * set to point to [/]'s op_next, i.e. C.
91 * This op_next linking is done by the LINKLIST() macro and its underlying
92 * op_linklist() function. Given a top-level op, if its op_next is
93 * non-null, it's already been linked, so leave it. Otherwise link it with
94 * its children as described above, possibly recursively if any of the
95 * children have a null op_next.
97 * In summary: given a subtree, its top-level node's op_next will either
99 * NULL: the subtree hasn't been LINKLIST()ed yet;
100 * fake: points to the start op for this subtree;
101 * real: once the subtree has been embedded into a larger tree
106 Here's an older description from Larry.
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
112 An execution-order pass
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines. The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order. (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again). As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node. But
130 it's still not the real execution order.
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer. At that point, we can call
135 into peep() to do that code's portion of the 3rd pass. It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140 get the compile time state of %^H for that block. Storing %^H in every
141 block (or even COP) would be very expensive, so a different approach is
142 taken. The (running) state of %^H is serialised into a tree of HE-like
143 structs. Stores into %^H are chained onto the current leaf as a struct
144 refcounted_he * with the key and the value. Deletes from %^H are saved
145 with a value of PL_sv_placeholder. The state of %^H at any point can be
146 turned back into a regular HV by walking back up the tree from that point's
147 leaf, ignoring any key you've already seen (placeholder or not), storing
148 the rest into the HV structure, then removing the placeholders. Hence
149 memory is only used to store the %^H deltas from the enclosing COP, rather
150 than the entire %^H on each COP.
152 To cause actions on %^H to write out the serialisation records, it has
153 magic type 'H'. This magic (itself) does nothing, but its presence causes
154 the values to gain magic type 'h', which has entries for set and clear.
155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158 it will be correctly restored when any inner compiling scope is exited.
164 #include "keywords.h"
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
174 /* Used to avoid recursion through the op tree in scalarvoid() and
178 #define DEFERRED_OP_STEP 100
179 #define DEFER_OP(o) \
181 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
182 defer_stack_alloc += DEFERRED_OP_STEP; \
183 assert(defer_stack_alloc > 0); \
184 Renew(defer_stack, defer_stack_alloc, OP *); \
186 defer_stack[++defer_ix] = o; \
189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
191 /* remove any leading "empty" ops from the op_next chain whose first
192 * node's address is stored in op_p. Store the updated address of the
193 * first node in op_p.
197 S_prune_chain_head(OP** op_p)
200 && ( (*op_p)->op_type == OP_NULL
201 || (*op_p)->op_type == OP_SCOPE
202 || (*op_p)->op_type == OP_SCALAR
203 || (*op_p)->op_type == OP_LINESEQ)
205 *op_p = (*op_p)->op_next;
209 /* See the explanatory comments above struct opslab in op.h. */
211 #ifdef PERL_DEBUG_READONLY_OPS
212 # define PERL_SLAB_SIZE 128
213 # define PERL_MAX_SLAB_SIZE 4096
214 # include <sys/mman.h>
217 #ifndef PERL_SLAB_SIZE
218 # define PERL_SLAB_SIZE 64
220 #ifndef PERL_MAX_SLAB_SIZE
221 # define PERL_MAX_SLAB_SIZE 2048
224 /* rounds up to nearest pointer */
225 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
226 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
229 S_new_slab(pTHX_ size_t sz)
231 #ifdef PERL_DEBUG_READONLY_OPS
232 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
233 PROT_READ|PROT_WRITE,
234 MAP_ANON|MAP_PRIVATE, -1, 0);
235 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
236 (unsigned long) sz, slab));
237 if (slab == MAP_FAILED) {
238 perror("mmap failed");
241 slab->opslab_size = (U16)sz;
243 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
246 /* The context is unused in non-Windows */
249 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
253 /* requires double parens and aTHX_ */
254 #define DEBUG_S_warn(args) \
256 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
260 Perl_Slab_Alloc(pTHX_ size_t sz)
268 /* We only allocate ops from the slab during subroutine compilation.
269 We find the slab via PL_compcv, hence that must be non-NULL. It could
270 also be pointing to a subroutine which is now fully set up (CvROOT()
271 pointing to the top of the optree for that sub), or a subroutine
272 which isn't using the slab allocator. If our sanity checks aren't met,
273 don't use a slab, but allocate the OP directly from the heap. */
274 if (!PL_compcv || CvROOT(PL_compcv)
275 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
277 o = (OP*)PerlMemShared_calloc(1, sz);
281 /* While the subroutine is under construction, the slabs are accessed via
282 CvSTART(), to avoid needing to expand PVCV by one pointer for something
283 unneeded at runtime. Once a subroutine is constructed, the slabs are
284 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
285 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
287 if (!CvSTART(PL_compcv)) {
289 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
290 CvSLABBED_on(PL_compcv);
291 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
293 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
295 opsz = SIZE_TO_PSIZE(sz);
296 sz = opsz + OPSLOT_HEADER_P;
298 /* The slabs maintain a free list of OPs. In particular, constant folding
299 will free up OPs, so it makes sense to re-use them where possible. A
300 freed up slot is used in preference to a new allocation. */
301 if (slab->opslab_freed) {
302 OP **too = &slab->opslab_freed;
304 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
305 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
306 DEBUG_S_warn((aTHX_ "Alas! too small"));
307 o = *(too = &o->op_next);
308 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
312 Zero(o, opsz, I32 *);
318 #define INIT_OPSLOT \
319 slot->opslot_slab = slab; \
320 slot->opslot_next = slab2->opslab_first; \
321 slab2->opslab_first = slot; \
322 o = &slot->opslot_op; \
325 /* The partially-filled slab is next in the chain. */
326 slab2 = slab->opslab_next ? slab->opslab_next : slab;
327 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
328 /* Remaining space is too small. */
330 /* If we can fit a BASEOP, add it to the free chain, so as not
332 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
333 slot = &slab2->opslab_slots;
335 o->op_type = OP_FREED;
336 o->op_next = slab->opslab_freed;
337 slab->opslab_freed = o;
340 /* Create a new slab. Make this one twice as big. */
341 slot = slab2->opslab_first;
342 while (slot->opslot_next) slot = slot->opslot_next;
343 slab2 = S_new_slab(aTHX_
344 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
346 : (DIFF(slab2, slot)+1)*2);
347 slab2->opslab_next = slab->opslab_next;
348 slab->opslab_next = slab2;
350 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
352 /* Create a new op slot */
353 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
354 assert(slot >= &slab2->opslab_slots);
355 if (DIFF(&slab2->opslab_slots, slot)
356 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
357 slot = &slab2->opslab_slots;
359 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
362 #ifdef PERL_OP_PARENT
363 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
364 assert(!o->op_moresib);
365 assert(!o->op_sibparent);
373 #ifdef PERL_DEBUG_READONLY_OPS
375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
377 PERL_ARGS_ASSERT_SLAB_TO_RO;
379 if (slab->opslab_readonly) return;
380 slab->opslab_readonly = 1;
381 for (; slab; slab = slab->opslab_next) {
382 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
383 (unsigned long) slab->opslab_size, slab));*/
384 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
385 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
386 (unsigned long)slab->opslab_size, errno);
391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
395 PERL_ARGS_ASSERT_SLAB_TO_RW;
397 if (!slab->opslab_readonly) return;
399 for (; slab2; slab2 = slab2->opslab_next) {
400 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
401 (unsigned long) size, slab2));*/
402 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
403 PROT_READ|PROT_WRITE)) {
404 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
405 (unsigned long)slab2->opslab_size, errno);
408 slab->opslab_readonly = 0;
412 # define Slab_to_rw(op) NOOP
415 /* This cannot possibly be right, but it was copied from the old slab
416 allocator, to which it was originally added, without explanation, in
419 # define PerlMemShared PerlMem
423 Perl_Slab_Free(pTHX_ void *op)
425 OP * const o = (OP *)op;
428 PERL_ARGS_ASSERT_SLAB_FREE;
430 if (!o->op_slabbed) {
432 PerlMemShared_free(op);
437 /* If this op is already freed, our refcount will get screwy. */
438 assert(o->op_type != OP_FREED);
439 o->op_type = OP_FREED;
440 o->op_next = slab->opslab_freed;
441 slab->opslab_freed = o;
442 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
443 OpslabREFCNT_dec_padok(slab);
447 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
449 const bool havepad = !!PL_comppad;
450 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
453 PAD_SAVE_SETNULLPAD();
460 Perl_opslab_free(pTHX_ OPSLAB *slab)
463 PERL_ARGS_ASSERT_OPSLAB_FREE;
465 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
466 assert(slab->opslab_refcnt == 1);
468 slab2 = slab->opslab_next;
470 slab->opslab_refcnt = ~(size_t)0;
472 #ifdef PERL_DEBUG_READONLY_OPS
473 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
475 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
476 perror("munmap failed");
480 PerlMemShared_free(slab);
487 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
492 size_t savestack_count = 0;
494 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
497 for (slot = slab2->opslab_first;
499 slot = slot->opslot_next) {
500 if (slot->opslot_op.op_type != OP_FREED
501 && !(slot->opslot_op.op_savefree
507 assert(slot->opslot_op.op_slabbed);
508 op_free(&slot->opslot_op);
509 if (slab->opslab_refcnt == 1) goto free;
512 } while ((slab2 = slab2->opslab_next));
513 /* > 1 because the CV still holds a reference count. */
514 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
516 assert(savestack_count == slab->opslab_refcnt-1);
518 /* Remove the CV’s reference count. */
519 slab->opslab_refcnt--;
526 #ifdef PERL_DEBUG_READONLY_OPS
528 Perl_op_refcnt_inc(pTHX_ OP *o)
531 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
532 if (slab && slab->opslab_readonly) {
545 Perl_op_refcnt_dec(pTHX_ OP *o)
548 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
550 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
552 if (slab && slab->opslab_readonly) {
554 result = --o->op_targ;
557 result = --o->op_targ;
563 * In the following definition, the ", (OP*)0" is just to make the compiler
564 * think the expression is of the right type: croak actually does a Siglongjmp.
566 #define CHECKOP(type,o) \
567 ((PL_op_mask && PL_op_mask[type]) \
568 ? ( op_free((OP*)o), \
569 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
571 : PL_check[type](aTHX_ (OP*)o))
573 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
575 #define OpTYPE_set(o,type) \
577 o->op_type = (OPCODE)type; \
578 o->op_ppaddr = PL_ppaddr[type]; \
582 S_no_fh_allowed(pTHX_ OP *o)
584 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
586 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
592 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
594 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
595 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
600 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
602 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
604 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
609 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
611 PERL_ARGS_ASSERT_BAD_TYPE_PV;
613 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
614 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
617 /* remove flags var, its unused in all callers, move to to right end since gv
618 and kid are always the same */
620 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
622 SV * const namesv = cv_name((CV *)gv, NULL, 0);
623 PERL_ARGS_ASSERT_BAD_TYPE_GV;
625 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
626 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
630 S_no_bareword_allowed(pTHX_ OP *o)
632 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
634 qerror(Perl_mess(aTHX_
635 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
637 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
640 /* "register" allocation */
643 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
646 const bool is_our = (PL_parser->in_my == KEY_our);
648 PERL_ARGS_ASSERT_ALLOCMY;
650 if (flags & ~SVf_UTF8)
651 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
654 /* complain about "my $<special_var>" etc etc */
658 || ( (flags & SVf_UTF8)
659 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
660 || (name[1] == '_' && len > 2)))
662 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
664 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
665 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
666 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
667 PL_parser->in_my == KEY_state ? "state" : "my"));
669 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
670 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
674 /* allocate a spare slot and store the name in that slot */
676 off = pad_add_name_pvn(name, len,
677 (is_our ? padadd_OUR :
678 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
679 PL_parser->in_my_stash,
681 /* $_ is always in main::, even with our */
682 ? (PL_curstash && !memEQs(name,len,"$_")
688 /* anon sub prototypes contains state vars should always be cloned,
689 * otherwise the state var would be shared between anon subs */
691 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
692 CvCLONE_on(PL_compcv);
698 =head1 Optree Manipulation Functions
700 =for apidoc alloccopstash
702 Available only under threaded builds, this function allocates an entry in
703 C<PL_stashpad> for the stash passed to it.
710 Perl_alloccopstash(pTHX_ HV *hv)
712 PADOFFSET off = 0, o = 1;
713 bool found_slot = FALSE;
715 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
717 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
719 for (; o < PL_stashpadmax; ++o) {
720 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
721 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
722 found_slot = TRUE, off = o;
725 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
726 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
727 off = PL_stashpadmax;
728 PL_stashpadmax += 10;
731 PL_stashpad[PL_stashpadix = off] = hv;
736 /* free the body of an op without examining its contents.
737 * Always use this rather than FreeOp directly */
740 S_op_destroy(pTHX_ OP *o)
748 =for apidoc Am|void|op_free|OP *o
750 Free an op. Only use this when an op is no longer linked to from any
757 Perl_op_free(pTHX_ OP *o)
761 SSize_t defer_ix = -1;
762 SSize_t defer_stack_alloc = 0;
763 OP **defer_stack = NULL;
767 /* Though ops may be freed twice, freeing the op after its slab is a
769 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
770 /* During the forced freeing of ops after compilation failure, kidops
771 may be freed before their parents. */
772 if (!o || o->op_type == OP_FREED)
777 /* an op should only ever acquire op_private flags that we know about.
778 * If this fails, you may need to fix something in regen/op_private.
779 * Don't bother testing if:
780 * * the op_ppaddr doesn't match the op; someone may have
781 * overridden the op and be doing strange things with it;
782 * * we've errored, as op flags are often left in an
783 * inconsistent state then. Note that an error when
784 * compiling the main program leaves PL_parser NULL, so
785 * we can't spot faults in the main code, only
786 * evaled/required code */
788 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
790 && !PL_parser->error_count)
792 assert(!(o->op_private & ~PL_op_private_valid[type]));
796 if (o->op_private & OPpREFCOUNTED) {
807 refcnt = OpREFCNT_dec(o);
810 /* Need to find and remove any pattern match ops from the list
811 we maintain for reset(). */
812 find_and_forget_pmops(o);
822 /* Call the op_free hook if it has been set. Do it now so that it's called
823 * at the right time for refcounted ops, but still before all of the kids
827 if (o->op_flags & OPf_KIDS) {
829 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
830 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
831 if (!kid || kid->op_type == OP_FREED)
832 /* During the forced freeing of ops after
833 compilation failure, kidops may be freed before
836 if (!(kid->op_flags & OPf_KIDS))
837 /* If it has no kids, just free it now */
844 type = (OPCODE)o->op_targ;
847 Slab_to_rw(OpSLAB(o));
849 /* COP* is not cleared by op_clear() so that we may track line
850 * numbers etc even after null() */
851 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
859 } while ( (o = POP_DEFERRED_OP()) );
861 Safefree(defer_stack);
864 /* S_op_clear_gv(): free a GV attached to an OP */
868 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
870 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
874 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
875 || o->op_type == OP_MULTIDEREF)
878 ? ((GV*)PAD_SVl(*ixp)) : NULL;
880 ? (GV*)(*svp) : NULL;
882 /* It's possible during global destruction that the GV is freed
883 before the optree. Whilst the SvREFCNT_inc is happy to bump from
884 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
885 will trigger an assertion failure, because the entry to sv_clear
886 checks that the scalar is not already freed. A check of for
887 !SvIS_FREED(gv) turns out to be invalid, because during global
888 destruction the reference count can be forced down to zero
889 (with SVf_BREAK set). In which case raising to 1 and then
890 dropping to 0 triggers cleanup before it should happen. I
891 *think* that this might actually be a general, systematic,
892 weakness of the whole idea of SVf_BREAK, in that code *is*
893 allowed to raise and lower references during global destruction,
894 so any *valid* code that happens to do this during global
895 destruction might well trigger premature cleanup. */
896 bool still_valid = gv && SvREFCNT(gv);
899 SvREFCNT_inc_simple_void(gv);
902 pad_swipe(*ixp, TRUE);
910 int try_downgrade = SvREFCNT(gv) == 2;
913 gv_try_downgrade(gv);
919 Perl_op_clear(pTHX_ OP *o)
924 PERL_ARGS_ASSERT_OP_CLEAR;
926 switch (o->op_type) {
927 case OP_NULL: /* Was holding old type, if any. */
930 case OP_ENTEREVAL: /* Was holding hints. */
931 case OP_ARGDEFELEM: /* Was holding signature index. */
935 if (!(o->op_flags & OPf_REF)
936 || (PL_check[o->op_type] != Perl_ck_ftst))
943 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
945 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
948 case OP_METHOD_REDIR:
949 case OP_METHOD_REDIR_SUPER:
951 if (cMETHOPx(o)->op_rclass_targ) {
952 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
953 cMETHOPx(o)->op_rclass_targ = 0;
956 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
957 cMETHOPx(o)->op_rclass_sv = NULL;
959 case OP_METHOD_NAMED:
960 case OP_METHOD_SUPER:
961 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
962 cMETHOPx(o)->op_u.op_meth_sv = NULL;
965 pad_swipe(o->op_targ, 1);
972 SvREFCNT_dec(cSVOPo->op_sv);
973 cSVOPo->op_sv = NULL;
976 Even if op_clear does a pad_free for the target of the op,
977 pad_free doesn't actually remove the sv that exists in the pad;
978 instead it lives on. This results in that it could be reused as
979 a target later on when the pad was reallocated.
982 pad_swipe(o->op_targ,1);
992 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
997 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
998 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
1000 if (cPADOPo->op_padix > 0) {
1001 pad_swipe(cPADOPo->op_padix, TRUE);
1002 cPADOPo->op_padix = 0;
1005 SvREFCNT_dec(cSVOPo->op_sv);
1006 cSVOPo->op_sv = NULL;
1010 PerlMemShared_free(cPVOPo->op_pv);
1011 cPVOPo->op_pv = NULL;
1015 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1019 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1020 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1022 if (o->op_private & OPpSPLIT_LEX)
1023 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1026 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1028 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1035 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1036 op_free(cPMOPo->op_code_list);
1037 cPMOPo->op_code_list = NULL;
1038 forget_pmop(cPMOPo);
1039 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1040 /* we use the same protection as the "SAFE" version of the PM_ macros
1041 * here since sv_clean_all might release some PMOPs
1042 * after PL_regex_padav has been cleared
1043 * and the clearing of PL_regex_padav needs to
1044 * happen before sv_clean_all
1047 if(PL_regex_pad) { /* We could be in destruction */
1048 const IV offset = (cPMOPo)->op_pmoffset;
1049 ReREFCNT_dec(PM_GETRE(cPMOPo));
1050 PL_regex_pad[offset] = &PL_sv_undef;
1051 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1055 ReREFCNT_dec(PM_GETRE(cPMOPo));
1056 PM_SETRE(cPMOPo, NULL);
1062 PerlMemShared_free(cUNOP_AUXo->op_aux);
1067 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1068 UV actions = items->uv;
1070 bool is_hash = FALSE;
1073 switch (actions & MDEREF_ACTION_MASK) {
1076 actions = (++items)->uv;
1079 case MDEREF_HV_padhv_helem:
1081 case MDEREF_AV_padav_aelem:
1082 pad_free((++items)->pad_offset);
1085 case MDEREF_HV_gvhv_helem:
1087 case MDEREF_AV_gvav_aelem:
1089 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1091 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1095 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1097 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1099 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1101 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1103 goto do_vivify_rv2xv_elem;
1105 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1107 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1108 pad_free((++items)->pad_offset);
1109 goto do_vivify_rv2xv_elem;
1111 case MDEREF_HV_pop_rv2hv_helem:
1112 case MDEREF_HV_vivify_rv2hv_helem:
1114 do_vivify_rv2xv_elem:
1115 case MDEREF_AV_pop_rv2av_aelem:
1116 case MDEREF_AV_vivify_rv2av_aelem:
1118 switch (actions & MDEREF_INDEX_MASK) {
1119 case MDEREF_INDEX_none:
1122 case MDEREF_INDEX_const:
1126 pad_swipe((++items)->pad_offset, 1);
1128 SvREFCNT_dec((++items)->sv);
1134 case MDEREF_INDEX_padsv:
1135 pad_free((++items)->pad_offset);
1137 case MDEREF_INDEX_gvsv:
1139 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1141 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1146 if (actions & MDEREF_FLAG_last)
1159 actions >>= MDEREF_SHIFT;
1162 /* start of malloc is at op_aux[-1], where the length is
1164 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1169 if (o->op_targ > 0) {
1170 pad_free(o->op_targ);
1176 S_cop_free(pTHX_ COP* cop)
1178 PERL_ARGS_ASSERT_COP_FREE;
1181 if (! specialWARN(cop->cop_warnings))
1182 PerlMemShared_free(cop->cop_warnings);
1183 cophh_free(CopHINTHASH_get(cop));
1184 if (PL_curcop == cop)
1189 S_forget_pmop(pTHX_ PMOP *const o
1192 HV * const pmstash = PmopSTASH(o);
1194 PERL_ARGS_ASSERT_FORGET_PMOP;
1196 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1197 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1199 PMOP **const array = (PMOP**) mg->mg_ptr;
1200 U32 count = mg->mg_len / sizeof(PMOP**);
1204 if (array[i] == o) {
1205 /* Found it. Move the entry at the end to overwrite it. */
1206 array[i] = array[--count];
1207 mg->mg_len = count * sizeof(PMOP**);
1208 /* Could realloc smaller at this point always, but probably
1209 not worth it. Probably worth free()ing if we're the
1212 Safefree(mg->mg_ptr);
1225 S_find_and_forget_pmops(pTHX_ OP *o)
1227 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1229 if (o->op_flags & OPf_KIDS) {
1230 OP *kid = cUNOPo->op_first;
1232 switch (kid->op_type) {
1237 forget_pmop((PMOP*)kid);
1239 find_and_forget_pmops(kid);
1240 kid = OpSIBLING(kid);
1246 =for apidoc Am|void|op_null|OP *o
1248 Neutralizes an op when it is no longer needed, but is still linked to from
1255 Perl_op_null(pTHX_ OP *o)
1259 PERL_ARGS_ASSERT_OP_NULL;
1261 if (o->op_type == OP_NULL)
1264 o->op_targ = o->op_type;
1265 OpTYPE_set(o, OP_NULL);
1269 Perl_op_refcnt_lock(pTHX)
1270 PERL_TSA_ACQUIRE(PL_op_mutex)
1275 PERL_UNUSED_CONTEXT;
1280 Perl_op_refcnt_unlock(pTHX)
1281 PERL_TSA_RELEASE(PL_op_mutex)
1286 PERL_UNUSED_CONTEXT;
1292 =for apidoc op_sibling_splice
1294 A general function for editing the structure of an existing chain of
1295 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1296 you to delete zero or more sequential nodes, replacing them with zero or
1297 more different nodes. Performs the necessary op_first/op_last
1298 housekeeping on the parent node and op_sibling manipulation on the
1299 children. The last deleted node will be marked as as the last node by
1300 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1302 Note that op_next is not manipulated, and nodes are not freed; that is the
1303 responsibility of the caller. It also won't create a new list op for an
1304 empty list etc; use higher-level functions like op_append_elem() for that.
1306 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1307 the splicing doesn't affect the first or last op in the chain.
1309 C<start> is the node preceding the first node to be spliced. Node(s)
1310 following it will be deleted, and ops will be inserted after it. If it is
1311 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1314 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1315 If -1 or greater than or equal to the number of remaining kids, all
1316 remaining kids are deleted.
1318 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1319 If C<NULL>, no nodes are inserted.
1321 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1326 action before after returns
1327 ------ ----- ----- -------
1330 splice(P, A, 2, X-Y-Z) | | B-C
1334 splice(P, NULL, 1, X-Y) | | A
1338 splice(P, NULL, 3, NULL) | | A-B-C
1342 splice(P, B, 0, X-Y) | | NULL
1346 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1347 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1353 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1357 OP *last_del = NULL;
1358 OP *last_ins = NULL;
1361 first = OpSIBLING(start);
1365 first = cLISTOPx(parent)->op_first;
1367 assert(del_count >= -1);
1369 if (del_count && first) {
1371 while (--del_count && OpHAS_SIBLING(last_del))
1372 last_del = OpSIBLING(last_del);
1373 rest = OpSIBLING(last_del);
1374 OpLASTSIB_set(last_del, NULL);
1381 while (OpHAS_SIBLING(last_ins))
1382 last_ins = OpSIBLING(last_ins);
1383 OpMAYBESIB_set(last_ins, rest, NULL);
1389 OpMAYBESIB_set(start, insert, NULL);
1394 cLISTOPx(parent)->op_first = insert;
1396 parent->op_flags |= OPf_KIDS;
1398 parent->op_flags &= ~OPf_KIDS;
1402 /* update op_last etc */
1409 /* ought to use OP_CLASS(parent) here, but that can't handle
1410 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1412 type = parent->op_type;
1413 if (type == OP_CUSTOM) {
1415 type = XopENTRYCUSTOM(parent, xop_class);
1418 if (type == OP_NULL)
1419 type = parent->op_targ;
1420 type = PL_opargs[type] & OA_CLASS_MASK;
1423 lastop = last_ins ? last_ins : start ? start : NULL;
1424 if ( type == OA_BINOP
1425 || type == OA_LISTOP
1429 cLISTOPx(parent)->op_last = lastop;
1432 OpLASTSIB_set(lastop, parent);
1434 return last_del ? first : NULL;
1437 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1441 #ifdef PERL_OP_PARENT
1444 =for apidoc op_parent
1446 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1447 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1453 Perl_op_parent(OP *o)
1455 PERL_ARGS_ASSERT_OP_PARENT;
1456 while (OpHAS_SIBLING(o))
1458 return o->op_sibparent;
1464 /* replace the sibling following start with a new UNOP, which becomes
1465 * the parent of the original sibling; e.g.
1467 * op_sibling_newUNOP(P, A, unop-args...)
1475 * where U is the new UNOP.
1477 * parent and start args are the same as for op_sibling_splice();
1478 * type and flags args are as newUNOP().
1480 * Returns the new UNOP.
1484 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1488 kid = op_sibling_splice(parent, start, 1, NULL);
1489 newop = newUNOP(type, flags, kid);
1490 op_sibling_splice(parent, start, 0, newop);
1495 /* lowest-level newLOGOP-style function - just allocates and populates
1496 * the struct. Higher-level stuff should be done by S_new_logop() /
1497 * newLOGOP(). This function exists mainly to avoid op_first assignment
1498 * being spread throughout this file.
1502 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1507 NewOp(1101, logop, 1, LOGOP);
1508 OpTYPE_set(logop, type);
1509 logop->op_first = first;
1510 logop->op_other = other;
1511 logop->op_flags = OPf_KIDS;
1512 while (kid && OpHAS_SIBLING(kid))
1513 kid = OpSIBLING(kid);
1515 OpLASTSIB_set(kid, (OP*)logop);
1520 /* Contextualizers */
1523 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1525 Applies a syntactic context to an op tree representing an expression.
1526 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1527 or C<G_VOID> to specify the context to apply. The modified op tree
1534 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1536 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1538 case G_SCALAR: return scalar(o);
1539 case G_ARRAY: return list(o);
1540 case G_VOID: return scalarvoid(o);
1542 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1549 =for apidoc Am|OP*|op_linklist|OP *o
1550 This function is the implementation of the L</LINKLIST> macro. It should
1551 not be called directly.
1557 Perl_op_linklist(pTHX_ OP *o)
1561 PERL_ARGS_ASSERT_OP_LINKLIST;
1566 /* establish postfix order */
1567 first = cUNOPo->op_first;
1570 o->op_next = LINKLIST(first);
1573 OP *sibl = OpSIBLING(kid);
1575 kid->op_next = LINKLIST(sibl);
1590 S_scalarkids(pTHX_ OP *o)
1592 if (o && o->op_flags & OPf_KIDS) {
1594 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1601 S_scalarboolean(pTHX_ OP *o)
1603 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1605 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1606 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1607 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1608 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1609 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1610 if (ckWARN(WARN_SYNTAX)) {
1611 const line_t oldline = CopLINE(PL_curcop);
1613 if (PL_parser && PL_parser->copline != NOLINE) {
1614 /* This ensures that warnings are reported at the first line
1615 of the conditional, not the last. */
1616 CopLINE_set(PL_curcop, PL_parser->copline);
1618 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1619 CopLINE_set(PL_curcop, oldline);
1626 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1629 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1630 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1632 const char funny = o->op_type == OP_PADAV
1633 || o->op_type == OP_RV2AV ? '@' : '%';
1634 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1636 if (cUNOPo->op_first->op_type != OP_GV
1637 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1639 return varname(gv, funny, 0, NULL, 0, subscript_type);
1642 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1647 S_op_varname(pTHX_ const OP *o)
1649 return S_op_varname_subscript(aTHX_ o, 1);
1653 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1654 { /* or not so pretty :-) */
1655 if (o->op_type == OP_CONST) {
1657 if (SvPOK(*retsv)) {
1659 *retsv = sv_newmortal();
1660 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1661 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1663 else if (!SvOK(*retsv))
1666 else *retpv = "...";
1670 S_scalar_slice_warning(pTHX_ const OP *o)
1674 o->op_type == OP_HSLICE ? '{' : '[';
1676 o->op_type == OP_HSLICE ? '}' : ']';
1678 SV *keysv = NULL; /* just to silence compiler warnings */
1679 const char *key = NULL;
1681 if (!(o->op_private & OPpSLICEWARNING))
1683 if (PL_parser && PL_parser->error_count)
1684 /* This warning can be nonsensical when there is a syntax error. */
1687 kid = cLISTOPo->op_first;
1688 kid = OpSIBLING(kid); /* get past pushmark */
1689 /* weed out false positives: any ops that can return lists */
1690 switch (kid->op_type) {
1716 /* Don't warn if we have a nulled list either. */
1717 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1720 assert(OpSIBLING(kid));
1721 name = S_op_varname(aTHX_ OpSIBLING(kid));
1722 if (!name) /* XS module fiddling with the op tree */
1724 S_op_pretty(aTHX_ kid, &keysv, &key);
1725 assert(SvPOK(name));
1726 sv_chop(name,SvPVX(name)+1);
1728 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1729 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1730 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1732 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1733 lbrack, key, rbrack);
1735 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1736 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1737 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1739 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1740 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1744 Perl_scalar(pTHX_ OP *o)
1748 /* assumes no premature commitment */
1749 if (!o || (PL_parser && PL_parser->error_count)
1750 || (o->op_flags & OPf_WANT)
1751 || o->op_type == OP_RETURN)
1756 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1758 switch (o->op_type) {
1760 scalar(cBINOPo->op_first);
1761 if (o->op_private & OPpREPEAT_DOLIST) {
1762 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1763 assert(kid->op_type == OP_PUSHMARK);
1764 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1765 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1766 o->op_private &=~ OPpREPEAT_DOLIST;
1773 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1783 if (o->op_flags & OPf_KIDS) {
1784 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1790 kid = cLISTOPo->op_first;
1792 kid = OpSIBLING(kid);
1795 OP *sib = OpSIBLING(kid);
1796 if (sib && kid->op_type != OP_LEAVEWHEN
1797 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1798 || ( sib->op_targ != OP_NEXTSTATE
1799 && sib->op_targ != OP_DBSTATE )))
1805 PL_curcop = &PL_compiling;
1810 kid = cLISTOPo->op_first;
1813 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1818 /* Warn about scalar context */
1819 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1820 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1823 const char *key = NULL;
1825 /* This warning can be nonsensical when there is a syntax error. */
1826 if (PL_parser && PL_parser->error_count)
1829 if (!ckWARN(WARN_SYNTAX)) break;
1831 kid = cLISTOPo->op_first;
1832 kid = OpSIBLING(kid); /* get past pushmark */
1833 assert(OpSIBLING(kid));
1834 name = S_op_varname(aTHX_ OpSIBLING(kid));
1835 if (!name) /* XS module fiddling with the op tree */
1837 S_op_pretty(aTHX_ kid, &keysv, &key);
1838 assert(SvPOK(name));
1839 sv_chop(name,SvPVX(name)+1);
1841 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1843 "%%%" SVf "%c%s%c in scalar context better written "
1844 "as $%" SVf "%c%s%c",
1845 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1846 lbrack, key, rbrack);
1848 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1849 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1850 "%%%" SVf "%c%" SVf "%c in scalar context better "
1851 "written as $%" SVf "%c%" SVf "%c",
1852 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1853 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1860 Perl_scalarvoid(pTHX_ OP *arg)
1866 SSize_t defer_stack_alloc = 0;
1867 SSize_t defer_ix = -1;
1868 OP **defer_stack = NULL;
1871 PERL_ARGS_ASSERT_SCALARVOID;
1874 SV *useless_sv = NULL;
1875 const char* useless = NULL;
1877 if (o->op_type == OP_NEXTSTATE
1878 || o->op_type == OP_DBSTATE
1879 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1880 || o->op_targ == OP_DBSTATE)))
1881 PL_curcop = (COP*)o; /* for warning below */
1883 /* assumes no premature commitment */
1884 want = o->op_flags & OPf_WANT;
1885 if ((want && want != OPf_WANT_SCALAR)
1886 || (PL_parser && PL_parser->error_count)
1887 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1892 if ((o->op_private & OPpTARGET_MY)
1893 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1895 /* newASSIGNOP has already applied scalar context, which we
1896 leave, as if this op is inside SASSIGN. */
1900 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1902 switch (o->op_type) {
1904 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1908 if (o->op_flags & OPf_STACKED)
1910 if (o->op_type == OP_REPEAT)
1911 scalar(cBINOPo->op_first);
1914 if (o->op_private == 4)
1949 case OP_GETSOCKNAME:
1950 case OP_GETPEERNAME:
1955 case OP_GETPRIORITY:
1980 useless = OP_DESC(o);
1990 case OP_AELEMFAST_LEX:
1994 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1995 /* Otherwise it's "Useless use of grep iterator" */
1996 useless = OP_DESC(o);
2000 if (!(o->op_private & OPpSPLIT_ASSIGN))
2001 useless = OP_DESC(o);
2005 kid = cUNOPo->op_first;
2006 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2007 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2010 useless = "negative pattern binding (!~)";
2014 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2015 useless = "non-destructive substitution (s///r)";
2019 useless = "non-destructive transliteration (tr///r)";
2026 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2027 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2028 useless = "a variable";
2033 if (cSVOPo->op_private & OPpCONST_STRICT)
2034 no_bareword_allowed(o);
2036 if (ckWARN(WARN_VOID)) {
2038 /* don't warn on optimised away booleans, eg
2039 * use constant Foo, 5; Foo || print; */
2040 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2042 /* the constants 0 and 1 are permitted as they are
2043 conventionally used as dummies in constructs like
2044 1 while some_condition_with_side_effects; */
2045 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2047 else if (SvPOK(sv)) {
2048 SV * const dsv = newSVpvs("");
2050 = Perl_newSVpvf(aTHX_
2052 pv_pretty(dsv, SvPVX_const(sv),
2053 SvCUR(sv), 32, NULL, NULL,
2055 | PERL_PV_ESCAPE_NOCLEAR
2056 | PERL_PV_ESCAPE_UNI_DETECT));
2057 SvREFCNT_dec_NN(dsv);
2059 else if (SvOK(sv)) {
2060 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2063 useless = "a constant (undef)";
2066 op_null(o); /* don't execute or even remember it */
2070 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2074 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2078 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2082 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2087 UNOP *refgen, *rv2cv;
2090 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2093 rv2gv = ((BINOP *)o)->op_last;
2094 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2097 refgen = (UNOP *)((BINOP *)o)->op_first;
2099 if (!refgen || (refgen->op_type != OP_REFGEN
2100 && refgen->op_type != OP_SREFGEN))
2103 exlist = (LISTOP *)refgen->op_first;
2104 if (!exlist || exlist->op_type != OP_NULL
2105 || exlist->op_targ != OP_LIST)
2108 if (exlist->op_first->op_type != OP_PUSHMARK
2109 && exlist->op_first != exlist->op_last)
2112 rv2cv = (UNOP*)exlist->op_last;
2114 if (rv2cv->op_type != OP_RV2CV)
2117 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2118 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2119 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2121 o->op_private |= OPpASSIGN_CV_TO_GV;
2122 rv2gv->op_private |= OPpDONT_INIT_GV;
2123 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2135 kid = cLOGOPo->op_first;
2136 if (kid->op_type == OP_NOT
2137 && (kid->op_flags & OPf_KIDS)) {
2138 if (o->op_type == OP_AND) {
2139 OpTYPE_set(o, OP_OR);
2141 OpTYPE_set(o, OP_AND);
2151 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2152 if (!(kid->op_flags & OPf_KIDS))
2159 if (o->op_flags & OPf_STACKED)
2166 if (!(o->op_flags & OPf_KIDS))
2177 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2178 if (!(kid->op_flags & OPf_KIDS))
2184 /* If the first kid after pushmark is something that the padrange
2185 optimisation would reject, then null the list and the pushmark.
2187 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2188 && ( !(kid = OpSIBLING(kid))
2189 || ( kid->op_type != OP_PADSV
2190 && kid->op_type != OP_PADAV
2191 && kid->op_type != OP_PADHV)
2192 || kid->op_private & ~OPpLVAL_INTRO
2193 || !(kid = OpSIBLING(kid))
2194 || ( kid->op_type != OP_PADSV
2195 && kid->op_type != OP_PADAV
2196 && kid->op_type != OP_PADHV)
2197 || kid->op_private & ~OPpLVAL_INTRO)
2199 op_null(cUNOPo->op_first); /* NULL the pushmark */
2200 op_null(o); /* NULL the list */
2212 /* mortalise it, in case warnings are fatal. */
2213 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2214 "Useless use of %" SVf " in void context",
2215 SVfARG(sv_2mortal(useless_sv)));
2218 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2219 "Useless use of %s in void context",
2222 } while ( (o = POP_DEFERRED_OP()) );
2224 Safefree(defer_stack);
2230 S_listkids(pTHX_ OP *o)
2232 if (o && o->op_flags & OPf_KIDS) {
2234 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2241 Perl_list(pTHX_ OP *o)
2245 /* assumes no premature commitment */
2246 if (!o || (o->op_flags & OPf_WANT)
2247 || (PL_parser && PL_parser->error_count)
2248 || o->op_type == OP_RETURN)
2253 if ((o->op_private & OPpTARGET_MY)
2254 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2256 return o; /* As if inside SASSIGN */
2259 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2261 switch (o->op_type) {
2263 list(cBINOPo->op_first);
2266 if (o->op_private & OPpREPEAT_DOLIST
2267 && !(o->op_flags & OPf_STACKED))
2269 list(cBINOPo->op_first);
2270 kid = cBINOPo->op_last;
2271 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2272 && SvIVX(kSVOP_sv) == 1)
2274 op_null(o); /* repeat */
2275 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2277 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2284 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2292 if (!(o->op_flags & OPf_KIDS))
2294 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2295 list(cBINOPo->op_first);
2296 return gen_constant_list(o);
2302 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2303 op_null(cUNOPo->op_first); /* NULL the pushmark */
2304 op_null(o); /* NULL the list */
2309 kid = cLISTOPo->op_first;
2311 kid = OpSIBLING(kid);
2314 OP *sib = OpSIBLING(kid);
2315 if (sib && kid->op_type != OP_LEAVEWHEN)
2321 PL_curcop = &PL_compiling;
2325 kid = cLISTOPo->op_first;
2332 S_scalarseq(pTHX_ OP *o)
2335 const OPCODE type = o->op_type;
2337 if (type == OP_LINESEQ || type == OP_SCOPE ||
2338 type == OP_LEAVE || type == OP_LEAVETRY)
2341 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2342 if ((sib = OpSIBLING(kid))
2343 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2344 || ( sib->op_targ != OP_NEXTSTATE
2345 && sib->op_targ != OP_DBSTATE )))
2350 PL_curcop = &PL_compiling;
2352 o->op_flags &= ~OPf_PARENS;
2353 if (PL_hints & HINT_BLOCK_SCOPE)
2354 o->op_flags |= OPf_PARENS;
2357 o = newOP(OP_STUB, 0);
2362 S_modkids(pTHX_ OP *o, I32 type)
2364 if (o && o->op_flags & OPf_KIDS) {
2366 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2367 op_lvalue(kid, type);
2373 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2374 * const fields. Also, convert CONST keys to HEK-in-SVs.
2375 * rop is the op that retrieves the hash;
2376 * key_op is the first key
2380 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2386 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2388 if (rop->op_first->op_type == OP_PADSV)
2389 /* @$hash{qw(keys here)} */
2390 rop = (UNOP*)rop->op_first;
2392 /* @{$hash}{qw(keys here)} */
2393 if (rop->op_first->op_type == OP_SCOPE
2394 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2396 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2403 lexname = NULL; /* just to silence compiler warnings */
2404 fields = NULL; /* just to silence compiler warnings */
2408 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2409 SvPAD_TYPED(lexname))
2410 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2411 && isGV(*fields) && GvHV(*fields);
2413 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2415 if (key_op->op_type != OP_CONST)
2417 svp = cSVOPx_svp(key_op);
2419 /* make sure it's not a bareword under strict subs */
2420 if (key_op->op_private & OPpCONST_BARE &&
2421 key_op->op_private & OPpCONST_STRICT)
2423 no_bareword_allowed((OP*)key_op);
2426 /* Make the CONST have a shared SV */
2427 if ( !SvIsCOW_shared_hash(sv = *svp)
2428 && SvTYPE(sv) < SVt_PVMG
2433 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2434 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2435 SvREFCNT_dec_NN(sv);
2440 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2442 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2443 "in variable %" PNf " of type %" HEKf,
2444 SVfARG(*svp), PNfARG(lexname),
2445 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2452 =for apidoc finalize_optree
2454 This function finalizes the optree. Should be called directly after
2455 the complete optree is built. It does some additional
2456 checking which can't be done in the normal C<ck_>xxx functions and makes
2457 the tree thread-safe.
2462 Perl_finalize_optree(pTHX_ OP* o)
2464 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2467 SAVEVPTR(PL_curcop);
2475 /* Relocate sv to the pad for thread safety.
2476 * Despite being a "constant", the SV is written to,
2477 * for reference counts, sv_upgrade() etc. */
2478 PERL_STATIC_INLINE void
2479 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2482 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2484 ix = pad_alloc(OP_CONST, SVf_READONLY);
2485 SvREFCNT_dec(PAD_SVl(ix));
2486 PAD_SETSV(ix, *svp);
2487 /* XXX I don't know how this isn't readonly already. */
2488 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2496 S_finalize_op(pTHX_ OP* o)
2498 PERL_ARGS_ASSERT_FINALIZE_OP;
2500 assert(o->op_type != OP_FREED);
2502 switch (o->op_type) {
2505 PL_curcop = ((COP*)o); /* for warnings */
2508 if (OpHAS_SIBLING(o)) {
2509 OP *sib = OpSIBLING(o);
2510 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2511 && ckWARN(WARN_EXEC)
2512 && OpHAS_SIBLING(sib))
2514 const OPCODE type = OpSIBLING(sib)->op_type;
2515 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2516 const line_t oldline = CopLINE(PL_curcop);
2517 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2518 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2519 "Statement unlikely to be reached");
2520 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2521 "\t(Maybe you meant system() when you said exec()?)\n");
2522 CopLINE_set(PL_curcop, oldline);
2529 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2530 GV * const gv = cGVOPo_gv;
2531 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2532 /* XXX could check prototype here instead of just carping */
2533 SV * const sv = sv_newmortal();
2534 gv_efullname3(sv, gv, NULL);
2535 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2536 "%" SVf "() called too early to check prototype",
2543 if (cSVOPo->op_private & OPpCONST_STRICT)
2544 no_bareword_allowed(o);
2548 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2553 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2554 case OP_METHOD_NAMED:
2555 case OP_METHOD_SUPER:
2556 case OP_METHOD_REDIR:
2557 case OP_METHOD_REDIR_SUPER:
2558 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2567 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2570 rop = (UNOP*)((BINOP*)o)->op_first;
2575 S_scalar_slice_warning(aTHX_ o);
2579 kid = OpSIBLING(cLISTOPo->op_first);
2580 if (/* I bet there's always a pushmark... */
2581 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2582 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2587 key_op = (SVOP*)(kid->op_type == OP_CONST
2589 : OpSIBLING(kLISTOP->op_first));
2591 rop = (UNOP*)((LISTOP*)o)->op_last;
2594 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2596 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2600 S_scalar_slice_warning(aTHX_ o);
2604 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2605 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2612 if (o->op_flags & OPf_KIDS) {
2616 /* check that op_last points to the last sibling, and that
2617 * the last op_sibling/op_sibparent field points back to the
2618 * parent, and that the only ops with KIDS are those which are
2619 * entitled to them */
2620 U32 type = o->op_type;
2624 if (type == OP_NULL) {
2626 /* ck_glob creates a null UNOP with ex-type GLOB
2627 * (which is a list op. So pretend it wasn't a listop */
2628 if (type == OP_GLOB)
2631 family = PL_opargs[type] & OA_CLASS_MASK;
2633 has_last = ( family == OA_BINOP
2634 || family == OA_LISTOP
2635 || family == OA_PMOP
2636 || family == OA_LOOP
2638 assert( has_last /* has op_first and op_last, or ...
2639 ... has (or may have) op_first: */
2640 || family == OA_UNOP
2641 || family == OA_UNOP_AUX
2642 || family == OA_LOGOP
2643 || family == OA_BASEOP_OR_UNOP
2644 || family == OA_FILESTATOP
2645 || family == OA_LOOPEXOP
2646 || family == OA_METHOP
2647 || type == OP_CUSTOM
2648 || type == OP_NULL /* new_logop does this */
2651 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2652 # ifdef PERL_OP_PARENT
2653 if (!OpHAS_SIBLING(kid)) {
2655 assert(kid == cLISTOPo->op_last);
2656 assert(kid->op_sibparent == o);
2659 if (has_last && !OpHAS_SIBLING(kid))
2660 assert(kid == cLISTOPo->op_last);
2665 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2671 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2673 Propagate lvalue ("modifiable") context to an op and its children.
2674 C<type> represents the context type, roughly based on the type of op that
2675 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2676 because it has no op type of its own (it is signalled by a flag on
2679 This function detects things that can't be modified, such as C<$x+1>, and
2680 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2681 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2683 It also flags things that need to behave specially in an lvalue context,
2684 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2690 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2693 PadnameLVALUE_on(pn);
2694 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2696 /* RT #127786: cv can be NULL due to an eval within the DB package
2697 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2698 * unless they contain an eval, but calling eval within DB
2699 * pretends the eval was done in the caller's scope.
2703 assert(CvPADLIST(cv));
2705 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2706 assert(PadnameLEN(pn));
2707 PadnameLVALUE_on(pn);
2712 S_vivifies(const OPCODE type)
2715 case OP_RV2AV: case OP_ASLICE:
2716 case OP_RV2HV: case OP_KVASLICE:
2717 case OP_RV2SV: case OP_HSLICE:
2718 case OP_AELEMFAST: case OP_KVHSLICE:
2727 S_lvref(pTHX_ OP *o, I32 type)
2731 switch (o->op_type) {
2733 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2734 kid = OpSIBLING(kid))
2735 S_lvref(aTHX_ kid, type);
2740 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2741 o->op_flags |= OPf_STACKED;
2742 if (o->op_flags & OPf_PARENS) {
2743 if (o->op_private & OPpLVAL_INTRO) {
2744 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2745 "localized parenthesized array in list assignment"));
2749 OpTYPE_set(o, OP_LVAVREF);
2750 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2751 o->op_flags |= OPf_MOD|OPf_REF;
2754 o->op_private |= OPpLVREF_AV;
2757 kid = cUNOPo->op_first;
2758 if (kid->op_type == OP_NULL)
2759 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2761 o->op_private = OPpLVREF_CV;
2762 if (kid->op_type == OP_GV)
2763 o->op_flags |= OPf_STACKED;
2764 else if (kid->op_type == OP_PADCV) {
2765 o->op_targ = kid->op_targ;
2767 op_free(cUNOPo->op_first);
2768 cUNOPo->op_first = NULL;
2769 o->op_flags &=~ OPf_KIDS;
2774 if (o->op_flags & OPf_PARENS) {
2776 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2777 "parenthesized hash in list assignment"));
2780 o->op_private |= OPpLVREF_HV;
2784 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2785 o->op_flags |= OPf_STACKED;
2788 if (o->op_flags & OPf_PARENS) goto parenhash;
2789 o->op_private |= OPpLVREF_HV;
2792 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2795 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2796 if (o->op_flags & OPf_PARENS) goto slurpy;
2797 o->op_private |= OPpLVREF_AV;
2801 o->op_private |= OPpLVREF_ELEM;
2802 o->op_flags |= OPf_STACKED;
2806 OpTYPE_set(o, OP_LVREFSLICE);
2807 o->op_private &= OPpLVAL_INTRO;
2810 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2812 else if (!(o->op_flags & OPf_KIDS))
2814 if (o->op_targ != OP_LIST) {
2815 S_lvref(aTHX_ cBINOPo->op_first, type);
2820 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2821 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2822 S_lvref(aTHX_ kid, type);
2826 if (o->op_flags & OPf_PARENS)
2831 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2832 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2833 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2839 OpTYPE_set(o, OP_LVREF);
2841 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2842 if (type == OP_ENTERLOOP)
2843 o->op_private |= OPpLVREF_ITER;
2846 PERL_STATIC_INLINE bool
2847 S_potential_mod_type(I32 type)
2849 /* Types that only potentially result in modification. */
2850 return type == OP_GREPSTART || type == OP_ENTERSUB
2851 || type == OP_REFGEN || type == OP_LEAVESUBLV;
2855 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2859 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2862 if (!o || (PL_parser && PL_parser->error_count))
2865 if ((o->op_private & OPpTARGET_MY)
2866 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2871 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2873 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2875 switch (o->op_type) {
2880 if ((o->op_flags & OPf_PARENS))
2884 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2885 !(o->op_flags & OPf_STACKED)) {
2886 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2887 assert(cUNOPo->op_first->op_type == OP_NULL);
2888 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2891 else { /* lvalue subroutine call */
2892 o->op_private |= OPpLVAL_INTRO;
2893 PL_modcount = RETURN_UNLIMITED_NUMBER;
2894 if (S_potential_mod_type(type)) {
2895 o->op_private |= OPpENTERSUB_INARGS;
2898 else { /* Compile-time error message: */
2899 OP *kid = cUNOPo->op_first;
2904 if (kid->op_type != OP_PUSHMARK) {
2905 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2907 "panic: unexpected lvalue entersub "
2908 "args: type/targ %ld:%" UVuf,
2909 (long)kid->op_type, (UV)kid->op_targ);
2910 kid = kLISTOP->op_first;
2912 while (OpHAS_SIBLING(kid))
2913 kid = OpSIBLING(kid);
2914 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2915 break; /* Postpone until runtime */
2918 kid = kUNOP->op_first;
2919 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2920 kid = kUNOP->op_first;
2921 if (kid->op_type == OP_NULL)
2923 "Unexpected constant lvalue entersub "
2924 "entry via type/targ %ld:%" UVuf,
2925 (long)kid->op_type, (UV)kid->op_targ);
2926 if (kid->op_type != OP_GV) {
2933 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2934 ? MUTABLE_CV(SvRV(gv))
2940 if (flags & OP_LVALUE_NO_CROAK)
2943 namesv = cv_name(cv, NULL, 0);
2944 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2945 "subroutine call of &%" SVf " in %s",
2946 SVfARG(namesv), PL_op_desc[type]),
2954 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2955 /* grep, foreach, subcalls, refgen */
2956 if (S_potential_mod_type(type))
2958 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2959 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2962 type ? PL_op_desc[type] : "local"));
2975 case OP_RIGHT_SHIFT:
2984 if (!(o->op_flags & OPf_STACKED))
2990 if (o->op_flags & OPf_STACKED) {
2994 if (!(o->op_private & OPpREPEAT_DOLIST))
2997 const I32 mods = PL_modcount;
2998 modkids(cBINOPo->op_first, type);
2999 if (type != OP_AASSIGN)
3001 kid = cBINOPo->op_last;
3002 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3003 const IV iv = SvIV(kSVOP_sv);
3004 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3006 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3009 PL_modcount = RETURN_UNLIMITED_NUMBER;
3015 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3016 op_lvalue(kid, type);
3021 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3022 PL_modcount = RETURN_UNLIMITED_NUMBER;
3023 return o; /* Treat \(@foo) like ordinary list. */
3027 if (scalar_mod_type(o, type))
3029 ref(cUNOPo->op_first, o->op_type);
3036 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3037 if (type == OP_LEAVESUBLV && (
3038 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3039 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3041 o->op_private |= OPpMAYBE_LVSUB;
3045 PL_modcount = RETURN_UNLIMITED_NUMBER;
3050 if (type == OP_LEAVESUBLV)
3051 o->op_private |= OPpMAYBE_LVSUB;
3054 if (type == OP_LEAVESUBLV
3055 && (o->op_private & 3) + OP_EACH == OP_KEYS)
3056 o->op_private |= OPpMAYBE_LVSUB;
3059 PL_hints |= HINT_BLOCK_SCOPE;
3060 if (type == OP_LEAVESUBLV)
3061 o->op_private |= OPpMAYBE_LVSUB;
3065 ref(cUNOPo->op_first, o->op_type);
3069 PL_hints |= HINT_BLOCK_SCOPE;
3079 case OP_AELEMFAST_LEX:
3086 PL_modcount = RETURN_UNLIMITED_NUMBER;
3087 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3088 return o; /* Treat \(@foo) like ordinary list. */
3089 if (scalar_mod_type(o, type))
3091 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3092 && type == OP_LEAVESUBLV)
3093 o->op_private |= OPpMAYBE_LVSUB;
3097 if (!type) /* local() */
3098 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3099 PNfARG(PAD_COMPNAME(o->op_targ)));
3100 if (!(o->op_private & OPpLVAL_INTRO)
3101 || ( type != OP_SASSIGN && type != OP_AASSIGN
3102 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3103 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3111 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3115 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3121 if (type == OP_LEAVESUBLV)
3122 o->op_private |= OPpMAYBE_LVSUB;
3123 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3124 /* substr and vec */
3125 /* If this op is in merely potential (non-fatal) modifiable
3126 context, then apply OP_ENTERSUB context to
3127 the kid op (to avoid croaking). Other-
3128 wise pass this op’s own type so the correct op is mentioned
3129 in error messages. */
3130 op_lvalue(OpSIBLING(cBINOPo->op_first),
3131 S_potential_mod_type(type)
3139 ref(cBINOPo->op_first, o->op_type);
3140 if (type == OP_ENTERSUB &&
3141 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3142 o->op_private |= OPpLVAL_DEFER;
3143 if (type == OP_LEAVESUBLV)
3144 o->op_private |= OPpMAYBE_LVSUB;
3151 o->op_private |= OPpLVALUE;
3157 if (o->op_flags & OPf_KIDS)
3158 op_lvalue(cLISTOPo->op_last, type);
3163 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3165 else if (!(o->op_flags & OPf_KIDS))
3168 if (o->op_targ != OP_LIST) {
3169 OP *sib = OpSIBLING(cLISTOPo->op_first);
3170 /* OP_TRANS and OP_TRANSR with argument have a weird optree
3177 * compared with things like OP_MATCH which have the argument
3183 * so handle specially to correctly get "Can't modify" croaks etc
3186 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3188 /* this should trigger a "Can't modify transliteration" err */
3189 op_lvalue(sib, type);
3191 op_lvalue(cBINOPo->op_first, type);
3197 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3198 /* elements might be in void context because the list is
3199 in scalar context or because they are attribute sub calls */
3200 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3201 op_lvalue(kid, type);
3209 if (type == OP_LEAVESUBLV
3210 || !S_vivifies(cLOGOPo->op_first->op_type))
3211 op_lvalue(cLOGOPo->op_first, type);
3212 if (type == OP_LEAVESUBLV
3213 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3214 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3218 if (type == OP_NULL) { /* local */
3220 if (!FEATURE_MYREF_IS_ENABLED)
3221 Perl_croak(aTHX_ "The experimental declared_refs "
3222 "feature is not enabled");
3223 Perl_ck_warner_d(aTHX_
3224 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3225 "Declaring references is experimental");
3226 op_lvalue(cUNOPo->op_first, OP_NULL);
3229 if (type != OP_AASSIGN && type != OP_SASSIGN
3230 && type != OP_ENTERLOOP)
3232 /* Don’t bother applying lvalue context to the ex-list. */
3233 kid = cUNOPx(cUNOPo->op_first)->op_first;
3234 assert (!OpHAS_SIBLING(kid));
3237 if (type == OP_NULL) /* local */
3239 if (type != OP_AASSIGN) goto nomod;
3240 kid = cUNOPo->op_first;
3243 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3244 S_lvref(aTHX_ kid, type);
3245 if (!PL_parser || PL_parser->error_count == ec) {
3246 if (!FEATURE_REFALIASING_IS_ENABLED)
3248 "Experimental aliasing via reference not enabled");
3249 Perl_ck_warner_d(aTHX_
3250 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3251 "Aliasing via reference is experimental");
3254 if (o->op_type == OP_REFGEN)
3255 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3260 if ((o->op_private & OPpSPLIT_ASSIGN)) {
3261 /* This is actually @array = split. */
3262 PL_modcount = RETURN_UNLIMITED_NUMBER;
3268 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3272 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3273 their argument is a filehandle; thus \stat(".") should not set
3275 if (type == OP_REFGEN &&
3276 PL_check[o->op_type] == Perl_ck_ftst)
3279 if (type != OP_LEAVESUBLV)
3280 o->op_flags |= OPf_MOD;
3282 if (type == OP_AASSIGN || type == OP_SASSIGN)
3283 o->op_flags |= OPf_SPECIAL
3284 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3285 else if (!type) { /* local() */
3288 o->op_private |= OPpLVAL_INTRO;
3289 o->op_flags &= ~OPf_SPECIAL;
3290 PL_hints |= HINT_BLOCK_SCOPE;
3295 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3296 "Useless localization of %s", OP_DESC(o));
3299 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3300 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3301 o->op_flags |= OPf_REF;
3306 S_scalar_mod_type(const OP *o, I32 type)
3311 if (o && o->op_type == OP_RV2GV)
3335 case OP_RIGHT_SHIFT:
3364 S_is_handle_constructor(const OP *o, I32 numargs)
3366 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3368 switch (o->op_type) {
3376 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3389 S_refkids(pTHX_ OP *o, I32 type)
3391 if (o && o->op_flags & OPf_KIDS) {
3393 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3400 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3405 PERL_ARGS_ASSERT_DOREF;
3407 if (PL_parser && PL_parser->error_count)
3410 switch (o->op_type) {
3412 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3413 !(o->op_flags & OPf_STACKED)) {
3414 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3415 assert(cUNOPo->op_first->op_type == OP_NULL);
3416 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3417 o->op_flags |= OPf_SPECIAL;
3419 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3420 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3421 : type == OP_RV2HV ? OPpDEREF_HV
3423 o->op_flags |= OPf_MOD;
3429 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3430 doref(kid, type, set_op_ref);
3433 if (type == OP_DEFINED)
3434 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3435 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3438 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3439 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3440 : type == OP_RV2HV ? OPpDEREF_HV
3442 o->op_flags |= OPf_MOD;
3449 o->op_flags |= OPf_REF;
3452 if (type == OP_DEFINED)
3453 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3454 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3460 o->op_flags |= OPf_REF;
3465 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3467 doref(cBINOPo->op_first, type, set_op_ref);
3471 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3472 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3473 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3474 : type == OP_RV2HV ? OPpDEREF_HV
3476 o->op_flags |= OPf_MOD;
3486 if (!(o->op_flags & OPf_KIDS))
3488 doref(cLISTOPo->op_last, type, set_op_ref);
3498 S_dup_attrlist(pTHX_ OP *o)
3502 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3504 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3505 * where the first kid is OP_PUSHMARK and the remaining ones
3506 * are OP_CONST. We need to push the OP_CONST values.
3508 if (o->op_type == OP_CONST)
3509 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3511 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3513 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3514 if (o->op_type == OP_CONST)
3515 rop = op_append_elem(OP_LIST, rop,
3516 newSVOP(OP_CONST, o->op_flags,
3517 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3524 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3526 PERL_ARGS_ASSERT_APPLY_ATTRS;
3528 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3530 /* fake up C<use attributes $pkg,$rv,@attrs> */
3532 #define ATTRSMODULE "attributes"
3533 #define ATTRSMODULE_PM "attributes.pm"
3536 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3537 newSVpvs(ATTRSMODULE),
3539 op_prepend_elem(OP_LIST,
3540 newSVOP(OP_CONST, 0, stashsv),
3541 op_prepend_elem(OP_LIST,
3542 newSVOP(OP_CONST, 0,
3544 dup_attrlist(attrs))));
3549 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3551 OP *pack, *imop, *arg;
3552 SV *meth, *stashsv, **svp;
3554 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3559 assert(target->op_type == OP_PADSV ||
3560 target->op_type == OP_PADHV ||
3561 target->op_type == OP_PADAV);
3563 /* Ensure that attributes.pm is loaded. */
3564 /* Don't force the C<use> if we don't need it. */
3565 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3566 if (svp && *svp != &PL_sv_undef)
3567 NOOP; /* already in %INC */
3569 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3570 newSVpvs(ATTRSMODULE), NULL);
3572 /* Need package name for method call. */
3573 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3575 /* Build up the real arg-list. */
3576 stashsv = newSVhek(HvNAME_HEK(stash));
3578 arg = newOP(OP_PADSV, 0);
3579 arg->op_targ = target->op_targ;
3580 arg = op_prepend_elem(OP_LIST,
3581 newSVOP(OP_CONST, 0, stashsv),
3582 op_prepend_elem(OP_LIST,
3583 newUNOP(OP_REFGEN, 0,
3585 dup_attrlist(attrs)));
3587 /* Fake up a method call to import */
3588 meth = newSVpvs_share("import");
3589 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3590 op_append_elem(OP_LIST,
3591 op_prepend_elem(OP_LIST, pack, arg),
3592 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3594 /* Combine the ops. */
3595 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3599 =notfor apidoc apply_attrs_string
3601 Attempts to apply a list of attributes specified by the C<attrstr> and
3602 C<len> arguments to the subroutine identified by the C<cv> argument which
3603 is expected to be associated with the package identified by the C<stashpv>
3604 argument (see L<attributes>). It gets this wrong, though, in that it
3605 does not correctly identify the boundaries of the individual attribute
3606 specifications within C<attrstr>. This is not really intended for the
3607 public API, but has to be listed here for systems such as AIX which
3608 need an explicit export list for symbols. (It's called from XS code
3609 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3610 to respect attribute syntax properly would be welcome.
3616 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3617 const char *attrstr, STRLEN len)
3621 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3624 len = strlen(attrstr);
3628 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3630 const char * const sstr = attrstr;
3631 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3632 attrs = op_append_elem(OP_LIST, attrs,
3633 newSVOP(OP_CONST, 0,
3634 newSVpvn(sstr, attrstr-sstr)));
3638 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3639 newSVpvs(ATTRSMODULE),
3640 NULL, op_prepend_elem(OP_LIST,
3641 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3642 op_prepend_elem(OP_LIST,
3643 newSVOP(OP_CONST, 0,
3644 newRV(MUTABLE_SV(cv))),
3649 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3651 OP *new_proto = NULL;
3656 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3662 if (o->op_type == OP_CONST) {
3663 pv = SvPV(cSVOPo_sv, pvlen);
3664 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3665 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3666 SV ** const tmpo = cSVOPx_svp(o);
3667 SvREFCNT_dec(cSVOPo_sv);
3672 } else if (o->op_type == OP_LIST) {
3674 assert(o->op_flags & OPf_KIDS);
3675 lasto = cLISTOPo->op_first;
3676 assert(lasto->op_type == OP_PUSHMARK);
3677 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3678 if (o->op_type == OP_CONST) {
3679 pv = SvPV(cSVOPo_sv, pvlen);
3680 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3681 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3682 SV ** const tmpo = cSVOPx_svp(o);
3683 SvREFCNT_dec(cSVOPo_sv);
3685 if (new_proto && ckWARN(WARN_MISC)) {
3687 const char * newp = SvPV(cSVOPo_sv, new_len);
3688 Perl_warner(aTHX_ packWARN(WARN_MISC),
3689 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3690 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3696 /* excise new_proto from the list */
3697 op_sibling_splice(*attrs, lasto, 1, NULL);
3704 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3705 would get pulled in with no real need */
3706 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3715 svname = sv_newmortal();
3716 gv_efullname3(svname, name, NULL);
3718 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3719 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3721 svname = (SV *)name;
3722 if (ckWARN(WARN_ILLEGALPROTO))
3723 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3724 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3725 STRLEN old_len, new_len;
3726 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3727 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3729 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3730 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3732 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3733 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3743 S_cant_declare(pTHX_ OP *o)
3745 if (o->op_type == OP_NULL
3746 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3747 o = cUNOPo->op_first;
3748 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3749 o->op_type == OP_NULL
3750 && o->op_flags & OPf_SPECIAL
3753 PL_parser->in_my == KEY_our ? "our" :
3754 PL_parser->in_my == KEY_state ? "state" :
3759 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3762 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3764 PERL_ARGS_ASSERT_MY_KID;
3766 if (!o || (PL_parser && PL_parser->error_count))
3771 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3773 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3774 my_kid(kid, attrs, imopsp);
3776 } else if (type == OP_UNDEF || type == OP_STUB) {
3778 } else if (type == OP_RV2SV || /* "our" declaration */
3781 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3782 S_cant_declare(aTHX_ o);
3784 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3786 PL_parser->in_my = FALSE;
3787 PL_parser->in_my_stash = NULL;
3788 apply_attrs(GvSTASH(gv),
3789 (type == OP_RV2SV ? GvSV(gv) :
3790 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3791 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3794 o->op_private |= OPpOUR_INTRO;
3797 else if (type == OP_REFGEN || type == OP_SREFGEN) {
3798 if (!FEATURE_MYREF_IS_ENABLED)
3799 Perl_croak(aTHX_ "The experimental declared_refs "
3800 "feature is not enabled");
3801 Perl_ck_warner_d(aTHX_
3802 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3803 "Declaring references is experimental");
3804 /* Kid is a nulled OP_LIST, handled above. */
3805 my_kid(cUNOPo->op_first, attrs, imopsp);
3808 else if (type != OP_PADSV &&
3811 type != OP_PUSHMARK)
3813 S_cant_declare(aTHX_ o);
3816 else if (attrs && type != OP_PUSHMARK) {
3820 PL_parser->in_my = FALSE;
3821 PL_parser->in_my_stash = NULL;
3823 /* check for C<my Dog $spot> when deciding package */
3824 stash = PAD_COMPNAME_TYPE(o->op_targ);
3826 stash = PL_curstash;
3827 apply_attrs_my(stash, o, attrs, imopsp);
3829 o->op_flags |= OPf_MOD;
3830 o->op_private |= OPpLVAL_INTRO;
3832 o->op_private |= OPpPAD_STATE;
3837 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3840 int maybe_scalar = 0;
3842 PERL_ARGS_ASSERT_MY_ATTRS;
3844 /* [perl #17376]: this appears to be premature, and results in code such as
3845 C< our(%x); > executing in list mode rather than void mode */
3847 if (o->op_flags & OPf_PARENS)
3857 o = my_kid(o, attrs, &rops);
3859 if (maybe_scalar && o->op_type == OP_PADSV) {
3860 o = scalar(op_append_list(OP_LIST, rops, o));
3861 o->op_private |= OPpLVAL_INTRO;
3864 /* The listop in rops might have a pushmark at the beginning,
3865 which will mess up list assignment. */
3866 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3867 if (rops->op_type == OP_LIST &&
3868 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3870 OP * const pushmark = lrops->op_first;
3871 /* excise pushmark */
3872 op_sibling_splice(rops, NULL, 1, NULL);
3875 o = op_append_list(OP_LIST, o, rops);
3878 PL_parser->in_my = FALSE;
3879 PL_parser->in_my_stash = NULL;
3884 Perl_sawparens(pTHX_ OP *o)
3886 PERL_UNUSED_CONTEXT;
3888 o->op_flags |= OPf_PARENS;
3893 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3897 const OPCODE ltype = left->op_type;
3898 const OPCODE rtype = right->op_type;
3900 PERL_ARGS_ASSERT_BIND_MATCH;
3902 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3903 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3905 const char * const desc
3907 rtype == OP_SUBST || rtype == OP_TRANS
3908 || rtype == OP_TRANSR
3910 ? (int)rtype : OP_MATCH];
3911 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3913 S_op_varname(aTHX_ left);
3915 Perl_warner(aTHX_ packWARN(WARN_MISC),
3916 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
3917 desc, SVfARG(name), SVfARG(name));
3919 const char * const sample = (isary
3920 ? "@array" : "%hash");
3921 Perl_warner(aTHX_ packWARN(WARN_MISC),
3922 "Applying %s to %s will act on scalar(%s)",
3923 desc, sample, sample);
3927 if (rtype == OP_CONST &&
3928 cSVOPx(right)->op_private & OPpCONST_BARE &&
3929 cSVOPx(right)->op_private & OPpCONST_STRICT)
3931 no_bareword_allowed(right);
3934 /* !~ doesn't make sense with /r, so error on it for now */
3935 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3937 /* diag_listed_as: Using !~ with %s doesn't make sense */
3938 yyerror("Using !~ with s///r doesn't make sense");
3939 if (rtype == OP_TRANSR && type == OP_NOT)
3940 /* diag_listed_as: Using !~ with %s doesn't make sense */
3941 yyerror("Using !~ with tr///r doesn't make sense");
3943 ismatchop = (rtype == OP_MATCH ||
3944 rtype == OP_SUBST ||
3945 rtype == OP_TRANS || rtype == OP_TRANSR)
3946 && !(right->op_flags & OPf_SPECIAL);
3947 if (ismatchop && right->op_private & OPpTARGET_MY) {
3949 right->op_private &= ~OPpTARGET_MY;
3951 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3952 if (left->op_type == OP_PADSV
3953 && !(left->op_private & OPpLVAL_INTRO))
3955 right->op_targ = left->op_targ;
3960 right->op_flags |= OPf_STACKED;
3961 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3962 ! (rtype == OP_TRANS &&
3963 right->op_private & OPpTRANS_IDENTICAL) &&
3964 ! (rtype == OP_SUBST &&
3965 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3966 left = op_lvalue(left, rtype);
3967 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3968 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3970 o = op_prepend_elem(rtype, scalar(left), right);
3973 return newUNOP(OP_NOT, 0, scalar(o));
3977 return bind_match(type, left,
3978 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3982 Perl_invert(pTHX_ OP *o)
3986 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3990 =for apidoc Amx|OP *|op_scope|OP *o
3992 Wraps up an op tree with some additional ops so that at runtime a dynamic
3993 scope will be created. The original ops run in the new dynamic scope,
3994 and then, provided that they exit normally, the scope will be unwound.
3995 The additional ops used to create and unwind the dynamic scope will
3996 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3997 instead if the ops are simple enough to not need the full dynamic scope
4004 Perl_op_scope(pTHX_ OP *o)
4008 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4009 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
4010 OpTYPE_set(o, OP_LEAVE);
4012 else if (o->op_type == OP_LINESEQ) {
4014 OpTYPE_set(o, OP_SCOPE);
4015 kid = ((LISTOP*)o)->op_first;
4016 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4019 /* The following deals with things like 'do {1 for 1}' */
4020 kid = OpSIBLING(kid);
4022 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4027 o = newLISTOP(OP_SCOPE, 0, o, NULL);
4033 Perl_op_unscope(pTHX_ OP *o)
4035 if (o && o->op_type == OP_LINESEQ) {
4036 OP *kid = cLISTOPo->op_first;
4037 for(; kid; kid = OpSIBLING(kid))
4038 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4045 =for apidoc Am|int|block_start|int full
4047 Handles compile-time scope entry.
4048 Arranges for hints to be restored on block
4049 exit and also handles pad sequence numbers to make lexical variables scope
4050 right. Returns a savestack index for use with C<block_end>.
4056 Perl_block_start(pTHX_ int full)
4058 const int retval = PL_savestack_ix;
4060 PL_compiling.cop_seq = PL_cop_seqmax;
4062 pad_block_start(full);
4064 PL_hints &= ~HINT_BLOCK_SCOPE;
4065 SAVECOMPILEWARNINGS();
4066 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4067 SAVEI32(PL_compiling.cop_seq);
4068 PL_compiling.cop_seq = 0;
4070 CALL_BLOCK_HOOKS(bhk_start, full);
4076 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4078 Handles compile-time scope exit. C<floor>
4079 is the savestack index returned by
4080 C<block_start>, and C<seq> is the body of the block. Returns the block,
4087 Perl_block_end(pTHX_ I32 floor, OP *seq)
4089 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4090 OP* retval = scalarseq(seq);
4093 /* XXX Is the null PL_parser check necessary here? */
4094 assert(PL_parser); /* Let’s find out under debugging builds. */
4095 if (PL_parser && PL_parser->parsed_sub) {
4096 o = newSTATEOP(0, NULL, NULL);
4098 retval = op_append_elem(OP_LINESEQ, retval, o);
4101 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4105 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4109 /* pad_leavemy has created a sequence of introcv ops for all my
4110 subs declared in the block. We have to replicate that list with
4111 clonecv ops, to deal with this situation:
4116 sub s1 { state sub foo { \&s2 } }
4119 Originally, I was going to have introcv clone the CV and turn
4120 off the stale flag. Since &s1 is declared before &s2, the
4121 introcv op for &s1 is executed (on sub entry) before the one for
4122 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
4123 cloned, since it is a state sub) closes over &s2 and expects
4124 to see it in its outer CV’s pad. If the introcv op clones &s1,
4125 then &s2 is still marked stale. Since &s1 is not active, and
4126 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4127 ble will not stay shared’ warning. Because it is the same stub
4128 that will be used when the introcv op for &s2 is executed, clos-
4129 ing over it is safe. Hence, we have to turn off the stale flag
4130 on all lexical subs in the block before we clone any of them.
4131 Hence, having introcv clone the sub cannot work. So we create a
4132 list of ops like this:
4156 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4157 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4158 for (;; kid = OpSIBLING(kid)) {
4159 OP *newkid = newOP(OP_CLONECV, 0);
4160 newkid->op_targ = kid->op_targ;
4161 o = op_append_elem(OP_LINESEQ, o, newkid);
4162 if (kid == last) break;
4164 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4167 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4173 =head1 Compile-time scope hooks
4175 =for apidoc Aox||blockhook_register
4177 Register a set of hooks to be called when the Perl lexical scope changes
4178 at compile time. See L<perlguts/"Compile-time scope hooks">.
4184 Perl_blockhook_register(pTHX_ BHK *hk)
4186 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4188 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4192 Perl_newPROG(pTHX_ OP *o)
4194 PERL_ARGS_ASSERT_NEWPROG;
4201 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4202 ((PL_in_eval & EVAL_KEEPERR)
4203 ? OPf_SPECIAL : 0), o);
4206 assert(CxTYPE(cx) == CXt_EVAL);
4208 if ((cx->blk_gimme & G_WANT) == G_VOID)
4209 scalarvoid(PL_eval_root);
4210 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4213 scalar(PL_eval_root);
4215 PL_eval_start = op_linklist(PL_eval_root);
4216 PL_eval_root->op_private |= OPpREFCOUNTED;
4217 OpREFCNT_set(PL_eval_root, 1);
4218 PL_eval_root->op_next = 0;
4219 i = PL_savestack_ix;
4222 CALL_PEEP(PL_eval_start);
4223 finalize_optree(PL_eval_root);
4224 S_prune_chain_head(&PL_eval_start);
4226 PL_savestack_ix = i;
4229 if (o->op_type == OP_STUB) {
4230 /* This block is entered if nothing is compiled for the main
4231 program. This will be the case for an genuinely empty main
4232 program, or one which only has BEGIN blocks etc, so already
4235 Historically (5.000) the guard above was !o. However, commit
4236 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4237 c71fccf11fde0068, changed perly.y so that newPROG() is now
4238 called with the output of block_end(), which returns a new
4239 OP_STUB for the case of an empty optree. ByteLoader (and
4240 maybe other things) also take this path, because they set up
4241 PL_main_start and PL_main_root directly, without generating an
4244 If the parsing the main program aborts (due to parse errors,
4245 or due to BEGIN or similar calling exit), then newPROG()
4246 isn't even called, and hence this code path and its cleanups
4247 are skipped. This shouldn't make a make a difference:
4248 * a non-zero return from perl_parse is a failure, and
4249 perl_destruct() should be called immediately.
4250 * however, if exit(0) is called during the parse, then
4251 perl_parse() returns 0, and perl_run() is called. As
4252 PL_main_start will be NULL, perl_run() will return
4253 promptly, and the exit code will remain 0.
4256 PL_comppad_name = 0;
4258 S_op_destroy(aTHX_ o);
4261 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4262 PL_curcop = &PL_compiling;
4263 PL_main_start = LINKLIST(PL_main_root);
4264 PL_main_root->op_private |= OPpREFCOUNTED;
4265 OpREFCNT_set(PL_main_root, 1);
4266 PL_main_root->op_next = 0;
4267 CALL_PEEP(PL_main_start);
4268 finalize_optree(PL_main_root);
4269 S_prune_chain_head(&PL_main_start);
4270 cv_forget_slab(PL_compcv);
4273 /* Register with debugger */
4275 CV * const cv = get_cvs("DB::postponed", 0);
4279 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4281 call_sv(MUTABLE_SV(cv), G_DISCARD);
4288 Perl_localize(pTHX_ OP *o, I32 lex)
4290 PERL_ARGS_ASSERT_LOCALIZE;
4292 if (o->op_flags & OPf_PARENS)
4293 /* [perl #17376]: this appears to be premature, and results in code such as
4294 C< our(%x); > executing in list mode rather than void mode */
4301 if ( PL_parser->bufptr > PL_parser->oldbufptr
4302 && PL_parser->bufptr[-1] == ','
4303 && ckWARN(WARN_PARENTHESIS))
4305 char *s = PL_parser->bufptr;
4308 /* some heuristics to detect a potential error */
4309 while (*s && (strchr(", \t\n", *s)))
4313 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4315 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4318 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4320 while (*s && (strchr(", \t\n", *s)))
4326 if (sigil && (*s == ';' || *s == '=')) {
4327 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4328 "Parentheses missing around \"%s\" list",
4330 ? (PL_parser->in_my == KEY_our
4332 : PL_parser->in_my == KEY_state
4342 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4343 PL_parser->in_my = FALSE;
4344 PL_parser->in_my_stash = NULL;
4349 Perl_jmaybe(pTHX_ OP *o)
4351 PERL_ARGS_ASSERT_JMAYBE;
4353 if (o->op_type == OP_LIST) {
4355 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4356 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4361 PERL_STATIC_INLINE OP *
4362 S_op_std_init(pTHX_ OP *o)
4364 I32 type = o->op_type;
4366 PERL_ARGS_ASSERT_OP_STD_INIT;
4368 if (PL_opargs[type] & OA_RETSCALAR)
4370 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4371 o->op_targ = pad_alloc(type, SVs_PADTMP);
4376 PERL_STATIC_INLINE OP *
4377 S_op_integerize(pTHX_ OP *o)
4379 I32 type = o->op_type;
4381 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4383 /* integerize op. */
4384 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4387 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4390 if (type == OP_NEGATE)
4391 /* XXX might want a ck_negate() for this */
4392 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4398 S_fold_constants(pTHX_ OP *const o)
4403 VOL I32 type = o->op_type;
4408 SV * const oldwarnhook = PL_warnhook;
4409 SV * const olddiehook = PL_diehook;
4411 U8 oldwarn = PL_dowarn;
4415 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4417 if (!(PL_opargs[type] & OA_FOLDCONST))
4426 #ifdef USE_LOCALE_CTYPE
4427 if (IN_LC_COMPILETIME(LC_CTYPE))
4436 #ifdef USE_LOCALE_COLLATE
4437 if (IN_LC_COMPILETIME(LC_COLLATE))
4442 /* XXX what about the numeric ops? */
4443 #ifdef USE_LOCALE_NUMERIC
4444 if (IN_LC_COMPILETIME(LC_NUMERIC))
4449 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4450 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4453 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4454 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4456 const char *s = SvPVX_const(sv);
4457 while (s < SvEND(sv)) {
4458 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4465 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4468 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4469 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4473 if (PL_parser && PL_parser->error_count)
4474 goto nope; /* Don't try to run w/ errors */
4476 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4477 switch (curop->op_type) {
4479 if ( (curop->op_private & OPpCONST_BARE)
4480 && (curop->op_private & OPpCONST_STRICT)) {
4481 no_bareword_allowed(curop);
4489 /* Foldable; move to next op in list */
4493 /* No other op types are considered foldable */
4498 curop = LINKLIST(o);
4499 old_next = o->op_next;
4503 old_cxix = cxstack_ix;
4504 create_eval_scope(NULL, G_FAKINGEVAL);
4506 /* Verify that we don't need to save it: */
4507 assert(PL_curcop == &PL_compiling);
4508 StructCopy(&PL_compiling, ¬_compiling, COP);
4509 PL_curcop = ¬_compiling;
4510 /* The above ensures that we run with all the correct hints of the
4511 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4512 assert(IN_PERL_RUNTIME);
4513 PL_warnhook = PERL_WARNHOOK_FATAL;
4517 /* Effective $^W=1. */
4518 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4519 PL_dowarn |= G_WARN_ON;
4524 sv = *(PL_stack_sp--);
4525 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4526 pad_swipe(o->op_targ, FALSE);
4528 else if (SvTEMP(sv)) { /* grab mortal temp? */
4529 SvREFCNT_inc_simple_void(sv);
4532 else { assert(SvIMMORTAL(sv)); }
4535 /* Something tried to die. Abandon constant folding. */
4536 /* Pretend the error never happened. */
4538 o->op_next = old_next;
4542 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4543 PL_warnhook = oldwarnhook;
4544 PL_diehook = olddiehook;
4545 /* XXX note that this croak may fail as we've already blown away
4546 * the stack - eg any nested evals */
4547 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4550 PL_dowarn = oldwarn;
4551 PL_warnhook = oldwarnhook;
4552 PL_diehook = olddiehook;
4553 PL_curcop = &PL_compiling;
4555 /* if we croaked, depending on how we croaked the eval scope
4556 * may or may not have already been popped */
4557 if (cxstack_ix > old_cxix) {
4558 assert(cxstack_ix == old_cxix + 1);
4559 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4560 delete_eval_scope();
4565 /* OP_STRINGIFY and constant folding are used to implement qq.
4566 Here the constant folding is an implementation detail that we
4567 want to hide. If the stringify op is itself already marked
4568 folded, however, then it is actually a folded join. */
4569 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4574 else if (!SvIMMORTAL(sv)) {
4578 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4579 if (!is_stringify) newop->op_folded = 1;
4587 S_gen_constant_list(pTHX_ OP *o)
4591 const SSize_t oldtmps_floor = PL_tmps_floor;
4596 if (PL_parser && PL_parser->error_count)
4597 return o; /* Don't attempt to run with errors */
4599 curop = LINKLIST(o);
4602 S_prune_chain_head(&curop);
4604 Perl_pp_pushmark(aTHX);
4607 assert (!(curop->op_flags & OPf_SPECIAL));
4608 assert(curop->op_type == OP_RANGE);
4609 Perl_pp_anonlist(aTHX);
4610 PL_tmps_floor = oldtmps_floor;
4612 OpTYPE_set(o, OP_RV2AV);
4613 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4614 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4615 o->op_opt = 0; /* needs to be revisited in rpeep() */
4616 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4618 /* replace subtree with an OP_CONST */
4619 curop = ((UNOP*)o)->op_first;
4620 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4623 if (AvFILLp(av) != -1)
4624 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4627 SvREADONLY_on(*svp);
4634 =head1 Optree Manipulation Functions
4637 /* List constructors */
4640 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4642 Append an item to the list of ops contained directly within a list-type
4643 op, returning the lengthened list. C<first> is the list-type op,
4644 and C<last> is the op to append to the list. C<optype> specifies the
4645 intended opcode for the list. If C<first> is not already a list of the
4646 right type, it will be upgraded into one. If either C<first> or C<last>
4647 is null, the other is returned unchanged.
4653 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4661 if (first->op_type != (unsigned)type
4662 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4664 return newLISTOP(type, 0, first, last);
4667 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4668 first->op_flags |= OPf_KIDS;
4673 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4675 Concatenate the lists of ops contained directly within two list-type ops,
4676 returning the combined list. C<first> and C<last> are the list-type ops
4677 to concatenate. C<optype> specifies the intended opcode for the list.
4678 If either C<first> or C<last> is not already a list of the right type,
4679 it will be upgraded into one. If either C<first> or C<last> is null,
4680 the other is returned unchanged.
4686 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4694 if (first->op_type != (unsigned)type)
4695 return op_prepend_elem(type, first, last);
4697 if (last->op_type != (unsigned)type)
4698 return op_append_elem(type, first, last);
4700 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4701 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4702 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4703 first->op_flags |= (last->op_flags & OPf_KIDS);
4705 S_op_destroy(aTHX_ last);
4711 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4713 Prepend an item to the list of ops contained directly within a list-type
4714 op, returning the lengthened list. C<first> is the op to prepend to the
4715 list, and C<last> is the list-type op. C<optype> specifies the intended
4716 opcode for the list. If C<last> is not already a list of the right type,
4717 it will be upgraded into one. If either C<first> or C<last> is null,
4718 the other is returned unchanged.
4724 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4732 if (last->op_type == (unsigned)type) {
4733 if (type == OP_LIST) { /* already a PUSHMARK there */
4734 /* insert 'first' after pushmark */
4735 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4736 if (!(first->op_flags & OPf_PARENS))
4737 last->op_flags &= ~OPf_PARENS;
4740 op_sibling_splice(last, NULL, 0, first);
4741 last->op_flags |= OPf_KIDS;
4745 return newLISTOP(type, 0, first, last);
4749 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4751 Converts C<o> into a list op if it is not one already, and then converts it
4752 into the specified C<type>, calling its check function, allocating a target if
4753 it needs one, and folding constants.
4755 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4756 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4757 C<op_convert_list> to make it the right type.
4763 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4766 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4767 if (!o || o->op_type != OP_LIST)
4768 o = force_list(o, 0);
4771 o->op_flags &= ~OPf_WANT;
4772 o->op_private &= ~OPpLVAL_INTRO;
4775 if (!(PL_opargs[type] & OA_MARK))
4776 op_null(cLISTOPo->op_first);
4778 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4779 if (kid2 && kid2->op_type == OP_COREARGS) {
4780 op_null(cLISTOPo->op_first);
4781 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4785 if (type != OP_SPLIT)
4786 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4787 * ck_split() create a real PMOP and leave the op's type as listop
4788 * for now. Otherwise op_free() etc will crash.
4790 OpTYPE_set(o, type);
4792 o->op_flags |= flags;
4793 if (flags & OPf_FOLDED)
4796 o = CHECKOP(type, o);
4797 if (o->op_type != (unsigned)type)
4800 return fold_constants(op_integerize(op_std_init(o)));
4807 =head1 Optree construction
4809 =for apidoc Am|OP *|newNULLLIST
4811 Constructs, checks, and returns a new C<stub> op, which represents an
4812 empty list expression.
4818 Perl_newNULLLIST(pTHX)
4820 return newOP(OP_STUB, 0);
4823 /* promote o and any siblings to be a list if its not already; i.e.
4831 * pushmark - o - A - B
4833 * If nullit it true, the list op is nulled.
4837 S_force_list(pTHX_ OP *o, bool nullit)
4839 if (!o || o->op_type != OP_LIST) {
4842 /* manually detach any siblings then add them back later */
4843 rest = OpSIBLING(o);
4844 OpLASTSIB_set(o, NULL);
4846 o = newLISTOP(OP_LIST, 0, o, NULL);
4848 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4856 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4858 Constructs, checks, and returns an op of any list type. C<type> is
4859 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4860 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4861 supply up to two ops to be direct children of the list op; they are
4862 consumed by this function and become part of the constructed op tree.
4864 For most list operators, the check function expects all the kid ops to be
4865 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4866 appropriate. What you want to do in that case is create an op of type
4867 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4868 See L</op_convert_list> for more information.
4875 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4880 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4881 || type == OP_CUSTOM);
4883 NewOp(1101, listop, 1, LISTOP);
4885 OpTYPE_set(listop, type);
4888 listop->op_flags = (U8)flags;
4892 else if (!first && last)
4895 OpMORESIB_set(first, last);
4896 listop->op_first = first;
4897 listop->op_last = last;
4898 if (type == OP_LIST) {
4899 OP* const pushop = newOP(OP_PUSHMARK, 0);
4900 OpMORESIB_set(pushop, first);
4901 listop->op_first = pushop;
4902 listop->op_flags |= OPf_KIDS;
4904 listop->op_last = pushop;
4906 if (listop->op_last)
4907 OpLASTSIB_set(listop->op_last, (OP*)listop);
4909 return CHECKOP(type, listop);
4913 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4915 Constructs, checks, and returns an op of any base type (any type that
4916 has no extra fields). C<type> is the opcode. C<flags> gives the
4917 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4924 Perl_newOP(pTHX_ I32 type, I32 flags)
4929 if (type == -OP_ENTEREVAL) {
4930 type = OP_ENTEREVAL;
4931 flags |= OPpEVAL_BYTES<<8;
4934 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4935 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4936 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4937 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4939 NewOp(1101, o, 1, OP);
4940 OpTYPE_set(o, type);
4941 o->op_flags = (U8)flags;
4944 o->op_private = (U8)(0 | (flags >> 8));
4945 if (PL_opargs[type] & OA_RETSCALAR)
4947 if (PL_opargs[type] & OA_TARGET)
4948 o->op_targ = pad_alloc(type, SVs_PADTMP);
4949 return CHECKOP(type, o);
4953 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4955 Constructs, checks, and returns an op of any unary type. C<type> is
4956 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4957 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4958 bits, the eight bits of C<op_private>, except that the bit with value 1
4959 is automatically set. C<first> supplies an optional op to be the direct
4960 child of the unary op; it is consumed by this function and become part
4961 of the constructed op tree.
4967 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4972 if (type == -OP_ENTEREVAL) {
4973 type = OP_ENTEREVAL;
4974 flags |= OPpEVAL_BYTES<<8;
4977 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4978 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4979 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4980 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4981 || type == OP_SASSIGN
4982 || type == OP_ENTERTRY
4983 || type == OP_CUSTOM
4984 || type == OP_NULL );
4987 first = newOP(OP_STUB, 0);
4988 if (PL_opargs[type] & OA_MARK)
4989 first = force_list(first, 1);
4991 NewOp(1101, unop, 1, UNOP);
4992 OpTYPE_set(unop, type);
4993 unop->op_first = first;
4994 unop->op_flags = (U8)(flags | OPf_KIDS);
4995 unop->op_private = (U8)(1 | (flags >> 8));
4997 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4998 OpLASTSIB_set(first, (OP*)unop);
5000 unop = (UNOP*) CHECKOP(type, unop);
5004 return fold_constants(op_integerize(op_std_init((OP *) unop)));
5008 =for apidoc newUNOP_AUX
5010 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5011 initialised to C<aux>
5017 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5022 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5023 || type == OP_CUSTOM);
5025 NewOp(1101, unop, 1, UNOP_AUX);
5026 unop->op_type = (OPCODE)type;
5027 unop->op_ppaddr = PL_ppaddr[type];
5028 unop->op_first = first;
5029 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5030 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5033 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5034 OpLASTSIB_set(first, (OP*)unop);
5036 unop = (UNOP_AUX*) CHECKOP(type, unop);
5038 return op_std_init((OP *) unop);
5042 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5044 Constructs, checks, and returns an op of method type with a method name
5045 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
5046 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5047 and, shifted up eight bits, the eight bits of C<op_private>, except that
5048 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
5049 op which evaluates method name; it is consumed by this function and
5050 become part of the constructed op tree.
5051 Supported optypes: C<OP_METHOD>.
5057 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5061 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5062 || type == OP_CUSTOM);
5064 NewOp(1101, methop, 1, METHOP);
5066 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5067 methop->op_flags = (U8)(flags | OPf_KIDS);
5068 methop->op_u.op_first = dynamic_meth;
5069 methop->op_private = (U8)(1 | (flags >> 8));
5071 if (!OpHAS_SIBLING(dynamic_meth))
5072 OpLASTSIB_set(dynamic_meth, (OP*)methop);
5076 methop->op_flags = (U8)(flags & ~OPf_KIDS);
5077 methop->op_u.op_meth_sv = const_meth;
5078 methop->op_private = (U8)(0 | (flags >> 8));
5079 methop->op_next = (OP*)methop;
5083 methop->op_rclass_targ = 0;
5085 methop->op_rclass_sv = NULL;
5088 OpTYPE_set(methop, type);
5089 return CHECKOP(type, methop);
5093 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5094 PERL_ARGS_ASSERT_NEWMETHOP;
5095 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5099 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5101 Constructs, checks, and returns an op of method type with a constant
5102 method name. C<type> is the opcode. C<flags> gives the eight bits of
5103 C<op_flags>, and, shifted up eight bits, the eight bits of
5104 C<op_private>. C<const_meth> supplies a constant method name;
5105 it must be a shared COW string.
5106 Supported optypes: C<OP_METHOD_NAMED>.
5112 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5113 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5114 return newMETHOP_internal(type, flags, NULL, const_meth);
5118 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5120 Constructs, checks, and returns an op of any binary type. C<type>
5121 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
5122 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5123 the eight bits of C<op_private>, except that the bit with value 1 or
5124 2 is automatically set as required. C<first> and C<last> supply up to
5125 two ops to be the direct children of the binary op; they are consumed
5126 by this function and become part of the constructed op tree.
5132 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5137 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5138 || type == OP_NULL || type == OP_CUSTOM);
5140 NewOp(1101, binop, 1, BINOP);
5143 first = newOP(OP_NULL, 0);
5145 OpTYPE_set(binop, type);
5146 binop->op_first = first;
5147 binop->op_flags = (U8)(flags | OPf_KIDS);
5150 binop->op_private = (U8)(1 | (flags >> 8));
5153 binop->op_private = (U8)(2 | (flags >> 8));
5154 OpMORESIB_set(first, last);
5157 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5158 OpLASTSIB_set(last, (OP*)binop);
5160 binop->op_last = OpSIBLING(binop->op_first);
5162 OpLASTSIB_set(binop->op_last, (OP*)binop);
5164 binop = (BINOP*)CHECKOP(type, binop);
5165 if (binop->op_next || binop->op_type != (OPCODE)type)
5168 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5171 static int uvcompare(const void *a, const void *b)
5172 __attribute__nonnull__(1)
5173 __attribute__nonnull__(2)
5174 __attribute__pure__;
5175 static int uvcompare(const void *a, const void *b)
5177 if (*((const UV *)a) < (*(const UV *)b))
5179 if (*((const UV *)a) > (*(const UV *)b))
5181 if (*((const UV *)a+1) < (*(const UV *)b+1))
5183 if (*((const UV *)a+1) > (*(const UV *)b+1))
5189 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5191 SV * const tstr = ((SVOP*)expr)->op_sv;
5193 ((SVOP*)repl)->op_sv;
5196 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5197 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5203 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5204 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5205 I32 del = o->op_private & OPpTRANS_DELETE;
5208 PERL_ARGS_ASSERT_PMTRANS;
5210 PL_hints |= HINT_BLOCK_SCOPE;
5213 o->op_private |= OPpTRANS_FROM_UTF;
5216 o->op_private |= OPpTRANS_TO_UTF;
5218 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5219 SV* const listsv = newSVpvs("# comment\n");
5221 const U8* tend = t + tlen;
5222 const U8* rend = r + rlen;
5238 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5239 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5242 const U32 flags = UTF8_ALLOW_DEFAULT;
5246 t = tsave = bytes_to_utf8(t, &len);
5249 if (!to_utf && rlen) {
5251 r = rsave = bytes_to_utf8(r, &len);
5255 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5256 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5260 U8 tmpbuf[UTF8_MAXBYTES+1];
5263 Newx(cp, 2*tlen, UV);
5265 transv = newSVpvs("");
5267 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5269 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5271 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5275 cp[2*i+1] = cp[2*i];
5279 qsort(cp, i, 2*sizeof(UV), uvcompare);
5280 for (j = 0; j < i; j++) {
5282 diff = val - nextmin;
5284 t = uvchr_to_utf8(tmpbuf,nextmin);
5285 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5287 U8 range_mark = ILLEGAL_UTF8_BYTE;
5288 t = uvchr_to_utf8(tmpbuf, val - 1);
5289 sv_catpvn(transv, (char *)&range_mark, 1);
5290 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5297 t = uvchr_to_utf8(tmpbuf,nextmin);
5298 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5300 U8 range_mark = ILLEGAL_UTF8_BYTE;
5301 sv_catpvn(transv, (char *)&range_mark, 1);
5303 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5304 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5305 t = (const U8*)SvPVX_const(transv);
5306 tlen = SvCUR(transv);
5310 else if (!rlen && !del) {
5311 r = t; rlen = tlen; rend = tend;
5314 if ((!rlen && !del) || t == r ||
5315 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5317 o->op_private |= OPpTRANS_IDENTICAL;
5321 while (t < tend || tfirst <= tlast) {
5322 /* see if we need more "t" chars */
5323 if (tfirst > tlast) {
5324 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5326 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5328 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5335 /* now see if we need more "r" chars */
5336 if (rfirst > rlast) {
5338 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5340 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5342 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5351 rfirst = rlast = 0xffffffff;
5355 /* now see which range will peter out first, if either. */
5356 tdiff = tlast - tfirst;
5357 rdiff = rlast - rfirst;
5358 tcount += tdiff + 1;
5359 rcount += rdiff + 1;
5366 if (rfirst == 0xffffffff) {
5367 diff = tdiff; /* oops, pretend rdiff is infinite */
5369 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5370 (long)tfirst, (long)tlast);
5372 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5376 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5377 (long)tfirst, (long)(tfirst + diff),
5380 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5381 (long)tfirst, (long)rfirst);
5383 if (rfirst + diff > max)
5384 max = rfirst + diff;
5386 grows = (tfirst < rfirst &&
5387 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5399 else if (max > 0xff)
5404 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5406 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5407 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5408 PAD_SETSV(cPADOPo->op_padix, swash);
5410 SvREADONLY_on(swash);
5412 cSVOPo->op_sv = swash;
5414 SvREFCNT_dec(listsv);
5415 SvREFCNT_dec(transv);
5417 if (!del && havefinal && rlen)
5418 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5419 newSVuv((UV)final), 0);
5428 else if (rlast == 0xffffffff)
5434 tbl = (short*)PerlMemShared_calloc(
5435 (o->op_private & OPpTRANS_COMPLEMENT) &&
5436 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5438 cPVOPo->op_pv = (char*)tbl;
5440 for (i = 0; i < (I32)tlen; i++)
5442 for (i = 0, j = 0; i < 256; i++) {
5444 if (j >= (I32)rlen) {
5453 if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
5463 o->op_private |= OPpTRANS_IDENTICAL;
5465 else if (j >= (I32)rlen)
5470 PerlMemShared_realloc(tbl,
5471 (0x101+rlen-j) * sizeof(short));
5472 cPVOPo->op_pv = (char*)tbl;
5474 tbl[0x100] = (short)(rlen - j);
5475 for (i=0; i < (I32)rlen - j; i++)
5476 tbl[0x101+i] = r[j+i];
5480 if (!rlen && !del) {
5483 o->op_private |= OPpTRANS_IDENTICAL;
5485 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5486 o->op_private |= OPpTRANS_IDENTICAL;
5488 for (i = 0; i < 256; i++)
5490 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5491 if (j >= (I32)rlen) {
5493 if (tbl[t[i]] == -1)
5499 if (tbl[t[i]] == -1) {
5500 if ( UVCHR_IS_INVARIANT(t[i])
5501 && ! UVCHR_IS_INVARIANT(r[j]))
5509 if(del && rlen == tlen) {
5510 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5511 } else if(rlen > tlen && !complement) {
5512 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5516 o->op_private |= OPpTRANS_GROWS;
5524 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5526 Constructs, checks, and returns an op of any pattern matching type.
5527 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5528 and, shifted up eight bits, the eight bits of C<op_private>.
5534 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5539 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5540 || type == OP_CUSTOM);
5542 NewOp(1101, pmop, 1, PMOP);
5543 OpTYPE_set(pmop, type);
5544 pmop->op_flags = (U8)flags;
5545 pmop->op_private = (U8)(0 | (flags >> 8));
5546 if (PL_opargs[type] & OA_RETSCALAR)
5549 if (PL_hints & HINT_RE_TAINT)
5550 pmop->op_pmflags |= PMf_RETAINT;
5551 #ifdef USE_LOCALE_CTYPE
5552 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5553 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5558 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5560 if (PL_hints & HINT_RE_FLAGS) {
5561 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5562 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5564 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5565 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5566 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5568 if (reflags && SvOK(reflags)) {
5569 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5575 assert(SvPOK(PL_regex_pad[0]));
5576 if (SvCUR(PL_regex_pad[0])) {
5577 /* Pop off the "packed" IV from the end. */
5578 SV *const repointer_list = PL_regex_pad[0];
5579 const char *p = SvEND(repointer_list) - sizeof(IV);
5580 const IV offset = *((IV*)p);
5582 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5584 SvEND_set(repointer_list, p);
5586 pmop->op_pmoffset = offset;
5587 /* This slot should be free, so assert this: */
5588 assert(PL_regex_pad[offset] == &PL_sv_undef);
5590 SV * const repointer = &PL_sv_undef;
5591 av_push(PL_regex_padav, repointer);
5592 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5593 PL_regex_pad = AvARRAY(PL_regex_padav);
5597 return CHECKOP(type, pmop);
5605 /* Any pad names in scope are potentially lvalues. */
5606 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5607 PADNAME *pn = PAD_COMPNAME_SV(i);
5608 if (!pn || !PadnameLEN(pn))
5610 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5611 S_mark_padname_lvalue(aTHX_ pn);
5615 /* Given some sort of match op o, and an expression expr containing a
5616 * pattern, either compile expr into a regex and attach it to o (if it's
5617 * constant), or convert expr into a runtime regcomp op sequence (if it's
5620 * Flags currently has 2 bits of meaning:
5621 * 1: isreg indicates that the pattern is part of a regex construct, eg
5622 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5623 * split "pattern", which aren't. In the former case, expr will be a list
5624 * if the pattern contains more than one term (eg /a$b/).
5625 * 2: The pattern is for a split.
5627 * When the pattern has been compiled within a new anon CV (for
5628 * qr/(?{...})/ ), then floor indicates the savestack level just before
5629 * the new sub was created
5633 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
5637 I32 repl_has_vars = 0;
5638 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5639 bool is_compiletime;
5641 bool isreg = cBOOL(flags & 1);
5642 bool is_split = cBOOL(flags & 2);
5644 PERL_ARGS_ASSERT_PMRUNTIME;
5647 return pmtrans(o, expr, repl);
5650 /* find whether we have any runtime or code elements;
5651 * at the same time, temporarily set the op_next of each DO block;
5652 * then when we LINKLIST, this will cause the DO blocks to be excluded
5653 * from the op_next chain (and from having LINKLIST recursively
5654 * applied to them). We fix up the DOs specially later */
5658 if (expr->op_type == OP_LIST) {
5660 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5661 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5663 assert(!o->op_next);
5664 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5665 assert(PL_parser && PL_parser->error_count);
5666 /* This can happen with qr/ (?{(^{})/. Just fake up
5667 the op we were expecting to see, to avoid crashing
5669 op_sibling_splice(expr, o, 0,
5670 newSVOP(OP_CONST, 0, &PL_sv_no));
5672 o->op_next = OpSIBLING(o);
5674 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5678 else if (expr->op_type != OP_CONST)
5683 /* fix up DO blocks; treat each one as a separate little sub;
5684 * also, mark any arrays as LIST/REF */
5686 if (expr->op_type == OP_LIST) {
5688 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5690 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5691 assert( !(o->op_flags & OPf_WANT));
5692 /* push the array rather than its contents. The regex
5693 * engine will retrieve and join the elements later */
5694 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5698 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5700 o->op_next = NULL; /* undo temporary hack from above */
5703 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5704 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5706 assert(leaveop->op_first->op_type == OP_ENTER);
5707 assert(OpHAS_SIBLING(leaveop->op_first));
5708 o->op_next = OpSIBLING(leaveop->op_first);
5710 assert(leaveop->op_flags & OPf_KIDS);
5711 assert(leaveop->op_last->op_next == (OP*)leaveop);
5712 leaveop->op_next = NULL; /* stop on last op */
5713 op_null((OP*)leaveop);
5717 OP *scope = cLISTOPo->op_first;
5718 assert(scope->op_type == OP_SCOPE);
5719 assert(scope->op_flags & OPf_KIDS);
5720 scope->op_next = NULL; /* stop on last op */
5723 /* have to peep the DOs individually as we've removed it from
5724 * the op_next chain */
5726 S_prune_chain_head(&(o->op_next));
5728 /* runtime finalizes as part of finalizing whole tree */
5732 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5733 assert( !(expr->op_flags & OPf_WANT));
5734 /* push the array rather than its contents. The regex
5735 * engine will retrieve and join the elements later */
5736 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5739 PL_hints |= HINT_BLOCK_SCOPE;
5741 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5743 if (is_compiletime) {
5744 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5745 regexp_engine const *eng = current_re_engine();
5748 /* make engine handle split ' ' specially */
5749 pm->op_pmflags |= PMf_SPLIT;
5750 rx_flags |= RXf_SPLIT;
5753 if (!has_code || !eng->op_comp) {
5754 /* compile-time simple constant pattern */
5756 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5757 /* whoops! we guessed that a qr// had a code block, but we
5758 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5759 * that isn't required now. Note that we have to be pretty
5760 * confident that nothing used that CV's pad while the
5761 * regex was parsed, except maybe op targets for \Q etc.
5762 * If there were any op targets, though, they should have
5763 * been stolen by constant folding.
5767 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5768 while (++i <= AvFILLp(PL_comppad)) {
5769 # ifdef USE_PAD_RESET
5770 /* under USE_PAD_RESET, pad swipe replaces a swiped
5771 * folded constant with a fresh padtmp */
5772 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
5774 assert(!PL_curpad[i]);
5778 /* But we know that one op is using this CV's slab. */
5779 cv_forget_slab(PL_compcv);
5781 pm->op_pmflags &= ~PMf_HAS_CV;
5786 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5787 rx_flags, pm->op_pmflags)
5788 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5789 rx_flags, pm->op_pmflags)
5794 /* compile-time pattern that includes literal code blocks */
5795 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5798 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5801 if (pm->op_pmflags & PMf_HAS_CV) {
5803 /* this QR op (and the anon sub we embed it in) is never
5804 * actually executed. It's just a placeholder where we can
5805 * squirrel away expr in op_code_list without the peephole
5806 * optimiser etc processing it for a second time */
5807 OP *qr = newPMOP(OP_QR, 0);
5808 ((PMOP*)qr)->op_code_list = expr;
5810 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5811 SvREFCNT_inc_simple_void(PL_compcv);
5812 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5813 ReANY(re)->qr_anoncv = cv;
5815 /* attach the anon CV to the pad so that
5816 * pad_fixup_inner_anons() can find it */
5817 (void)pad_add_anon(cv, o->op_type);
5818 SvREFCNT_inc_simple_void(cv);
5821 pm->op_code_list = expr;
5826 /* runtime pattern: build chain of regcomp etc ops */
5828 PADOFFSET cv_targ = 0;
5830 reglist = isreg && expr->op_type == OP_LIST;
5835 pm->op_code_list = expr;
5836 /* don't free op_code_list; its ops are embedded elsewhere too */
5837 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5841 /* make engine handle split ' ' specially */
5842 pm->op_pmflags |= PMf_SPLIT;
5844 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5845 * to allow its op_next to be pointed past the regcomp and
5846 * preceding stacking ops;
5847 * OP_REGCRESET is there to reset taint before executing the
5849 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5850 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5852 if (pm->op_pmflags & PMf_HAS_CV) {
5853 /* we have a runtime qr with literal code. This means
5854 * that the qr// has been wrapped in a new CV, which
5855 * means that runtime consts, vars etc will have been compiled
5856 * against a new pad. So... we need to execute those ops
5857 * within the environment of the new CV. So wrap them in a call
5858 * to a new anon sub. i.e. for
5862 * we build an anon sub that looks like
5864 * sub { "a", $b, '(?{...})' }
5866 * and call it, passing the returned list to regcomp.
5867 * Or to put it another way, the list of ops that get executed
5871 * ------ -------------------
5872 * pushmark (for regcomp)
5873 * pushmark (for entersub)
5877 * regcreset regcreset
5879 * const("a") const("a")
5881 * const("(?{...})") const("(?{...})")
5886 SvREFCNT_inc_simple_void(PL_compcv);
5887 CvLVALUE_on(PL_compcv);
5888 /* these lines are just an unrolled newANONATTRSUB */
5889 expr = newSVOP(OP_ANONCODE, 0,
5890 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5891 cv_targ = expr->op_targ;
5892 expr = newUNOP(OP_REFGEN, 0, expr);
5894 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5897 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
5898 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5899 | (reglist ? OPf_STACKED : 0);
5900 rcop->op_targ = cv_targ;
5902 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5903 if (PL_hints & HINT_RE_EVAL)
5904 S_set_haseval(aTHX);
5906 /* establish postfix order */
5907 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5909 rcop->op_next = expr;
5910 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5913 rcop->op_next = LINKLIST(expr);
5914 expr->op_next = (OP*)rcop;
5917 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5923 /* If we are looking at s//.../e with a single statement, get past
5924 the implicit do{}. */
5925 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5926 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5927 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5930 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5931 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5932 && !OpHAS_SIBLING(sib))
5935 if (curop->op_type == OP_CONST)
5937 else if (( (curop->op_type == OP_RV2SV ||
5938 curop->op_type == OP_RV2AV ||
5939 curop->op_type == OP_RV2HV ||
5940 curop->op_type == OP_RV2GV)
5941 && cUNOPx(curop)->op_first
5942 && cUNOPx(curop)->op_first->op_type == OP_GV )
5943 || curop->op_type == OP_PADSV
5944 || curop->op_type == OP_PADAV
5945 || curop->op_type == OP_PADHV
5946 || curop->op_type == OP_PADANY) {
5954 || !RX_PRELEN(PM_GETRE(pm))
5955 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5957 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5958 op_prepend_elem(o->op_type, scalar(repl), o);
5961 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
5962 rcop->op_private = 1;
5964 /* establish postfix order */
5965 rcop->op_next = LINKLIST(repl);
5966 repl->op_next = (OP*)rcop;
5968 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5969 assert(!(pm->op_pmflags & PMf_ONCE));
5970 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5979 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5981 Constructs, checks, and returns an op of any type that involves an
5982 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5983 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5984 takes ownership of one reference to it.
5990 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5995 PERL_ARGS_ASSERT_NEWSVOP;
5997 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5998 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5999 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6000 || type == OP_CUSTOM);
6002 NewOp(1101, svop, 1, SVOP);
6003 OpTYPE_set(svop, type);
6005 svop->op_next = (OP*)svop;
6006 svop->op_flags = (U8)flags;
6007 svop->op_private = (U8)(0 | (flags >> 8));
6008 if (PL_opargs[type] & OA_RETSCALAR)
6010 if (PL_opargs[type] & OA_TARGET)
6011 svop->op_targ = pad_alloc(type, SVs_PADTMP);
6012 return CHECKOP(type, svop);
6016 =for apidoc Am|OP *|newDEFSVOP|
6018 Constructs and returns an op to access C<$_>.
6024 Perl_newDEFSVOP(pTHX)
6026 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
6032 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
6034 Constructs, checks, and returns an op of any type that involves a
6035 reference to a pad element. C<type> is the opcode. C<flags> gives the
6036 eight bits of C<op_flags>. A pad slot is automatically allocated, and
6037 is populated with C<sv>; this function takes ownership of one reference
6040 This function only exists if Perl has been compiled to use ithreads.
6046 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
6051 PERL_ARGS_ASSERT_NEWPADOP;
6053 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6054 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6055 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6056 || type == OP_CUSTOM);
6058 NewOp(1101, padop, 1, PADOP);
6059 OpTYPE_set(padop, type);
6061 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
6062 SvREFCNT_dec(PAD_SVl(padop->op_padix));
6063 PAD_SETSV(padop->op_padix, sv);
6065 padop->op_next = (OP*)padop;
6066 padop->op_flags = (U8)flags;
6067 if (PL_opargs[type] & OA_RETSCALAR)
6069 if (PL_opargs[type] & OA_TARGET)
6070 padop->op_targ = pad_alloc(type, SVs_PADTMP);
6071 return CHECKOP(type, padop);
6074 #endif /* USE_ITHREADS */
6077 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
6079 Constructs, checks, and returns an op of any type that involves an
6080 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
6081 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
6082 reference; calling this function does not transfer ownership of any
6089 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
6091 PERL_ARGS_ASSERT_NEWGVOP;
6094 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6096 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6101 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
6103 Constructs, checks, and returns an op of any type that involves an
6104 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
6105 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
6106 must have been allocated using C<PerlMemShared_malloc>; the memory will
6107 be freed when the op is destroyed.
6113 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
6116 const bool utf8 = cBOOL(flags & SVf_UTF8);
6121 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6122 || type == OP_RUNCV || type == OP_CUSTOM
6123 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6125 NewOp(1101, pvop, 1, PVOP);
6126 OpTYPE_set(pvop, type);
6128 pvop->op_next = (OP*)pvop;
6129 pvop->op_flags = (U8)flags;
6130 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6131 if (PL_opargs[type] & OA_RETSCALAR)
6133 if (PL_opargs[type] & OA_TARGET)
6134 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6135 return CHECKOP(type, pvop);
6139 Perl_package(pTHX_ OP *o)
6141 SV *const sv = cSVOPo->op_sv;
6143 PERL_ARGS_ASSERT_PACKAGE;
6145 SAVEGENERICSV(PL_curstash);
6146 save_item(PL_curstname);
6148 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6150 sv_setsv(PL_curstname, sv);
6152 PL_hints |= HINT_BLOCK_SCOPE;
6153 PL_parser->copline = NOLINE;
6159 Perl_package_version( pTHX_ OP *v )
6161 U32 savehints = PL_hints;
6162 PERL_ARGS_ASSERT_PACKAGE_VERSION;
6163 PL_hints &= ~HINT_STRICT_VARS;
6164 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6165 PL_hints = savehints;
6170 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6175 SV *use_version = NULL;
6177 PERL_ARGS_ASSERT_UTILIZE;
6179 if (idop->op_type != OP_CONST)
6180 Perl_croak(aTHX_ "Module name must be constant");
6185 SV * const vesv = ((SVOP*)version)->op_sv;
6187 if (!arg && !SvNIOKp(vesv)) {
6194 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6195 Perl_croak(aTHX_ "Version number must be a constant number");
6197 /* Make copy of idop so we don't free it twice */
6198 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6200 /* Fake up a method call to VERSION */
6201 meth = newSVpvs_share("VERSION");
6202 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6203 op_append_elem(OP_LIST,
6204 op_prepend_elem(OP_LIST, pack, version),
6205 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6209 /* Fake up an import/unimport */
6210 if (arg && arg->op_type == OP_STUB) {
6211 imop = arg; /* no import on explicit () */
6213 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6214 imop = NULL; /* use 5.0; */
6216 use_version = ((SVOP*)idop)->op_sv;
6218 idop->op_private |= OPpCONST_NOVER;
6223 /* Make copy of idop so we don't free it twice */
6224 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6226 /* Fake up a method call to import/unimport */
6228 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6229 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6230 op_append_elem(OP_LIST,
6231 op_prepend_elem(OP_LIST, pack, arg),
6232 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6236 /* Fake up the BEGIN {}, which does its thing immediately. */
6238 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6241 op_append_elem(OP_LINESEQ,
6242 op_append_elem(OP_LINESEQ,
6243 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6244 newSTATEOP(0, NULL, veop)),
6245 newSTATEOP(0, NULL, imop) ));
6249 * feature bundle that corresponds to the required version. */
6250 use_version = sv_2mortal(new_version(use_version));
6251 S_enable_feature_bundle(aTHX_ use_version);
6253 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6254 if (vcmp(use_version,
6255 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6256 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6257 PL_hints |= HINT_STRICT_REFS;
6258 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6259 PL_hints |= HINT_STRICT_SUBS;
6260 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6261 PL_hints |= HINT_STRICT_VARS;
6263 /* otherwise they are off */
6265 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6266 PL_hints &= ~HINT_STRICT_REFS;
6267 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6268 PL_hints &= ~HINT_STRICT_SUBS;
6269 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6270 PL_hints &= ~HINT_STRICT_VARS;
6274 /* The "did you use incorrect case?" warning used to be here.
6275 * The problem is that on case-insensitive filesystems one
6276 * might get false positives for "use" (and "require"):
6277 * "use Strict" or "require CARP" will work. This causes
6278 * portability problems for the script: in case-strict
6279 * filesystems the script will stop working.
6281 * The "incorrect case" warning checked whether "use Foo"
6282 * imported "Foo" to your namespace, but that is wrong, too:
6283 * there is no requirement nor promise in the language that
6284 * a Foo.pm should or would contain anything in package "Foo".
6286 * There is very little Configure-wise that can be done, either:
6287 * the case-sensitivity of the build filesystem of Perl does not
6288 * help in guessing the case-sensitivity of the runtime environment.
6291 PL_hints |= HINT_BLOCK_SCOPE;
6292 PL_parser->copline = NOLINE;
6293 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6297 =head1 Embedding Functions
6299 =for apidoc load_module
6301 Loads the module whose name is pointed to by the string part of C<name>.
6302 Note that the actual module name, not its filename, should be given.
6303 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
6304 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
6305 trailing arguments can be used to specify arguments to the module's C<import()>
6306 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
6307 on the flags. The flags argument is a bitwise-ORed collection of any of
6308 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6309 (or 0 for no flags).
6311 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
6312 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
6313 the trailing optional arguments may be omitted entirely. Otherwise, if
6314 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
6315 exactly one C<OP*>, containing the op tree that produces the relevant import
6316 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
6317 will be used as import arguments; and the list must be terminated with C<(SV*)
6318 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
6319 set, the trailing C<NULL> pointer is needed even if no import arguments are
6320 desired. The reference count for each specified C<SV*> argument is
6321 decremented. In addition, the C<name> argument is modified.
6323 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
6329 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6333 PERL_ARGS_ASSERT_LOAD_MODULE;
6335 va_start(args, ver);
6336 vload_module(flags, name, ver, &args);
6340 #ifdef PERL_IMPLICIT_CONTEXT
6342 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6346 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6347 va_start(args, ver);
6348 vload_module(flags, name, ver, &args);
6354 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6357 OP * const modname = newSVOP(OP_CONST, 0, name);
6359 PERL_ARGS_ASSERT_VLOAD_MODULE;
6361 modname->op_private |= OPpCONST_BARE;
6363 veop = newSVOP(OP_CONST, 0, ver);
6367 if (flags & PERL_LOADMOD_NOIMPORT) {
6368 imop = sawparens(newNULLLIST());
6370 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6371 imop = va_arg(*args, OP*);
6376 sv = va_arg(*args, SV*);
6378 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6379 sv = va_arg(*args, SV*);
6383 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6384 * that it has a PL_parser to play with while doing that, and also
6385 * that it doesn't mess with any existing parser, by creating a tmp
6386 * new parser with lex_start(). This won't actually be used for much,
6387 * since pp_require() will create another parser for the real work.
6388 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6391 SAVEVPTR(PL_curcop);
6392 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6393 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6394 veop, modname, imop);
6398 PERL_STATIC_INLINE OP *
6399 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6401 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6402 newLISTOP(OP_LIST, 0, arg,
6403 newUNOP(OP_RV2CV, 0,
6404 newGVOP(OP_GV, 0, gv))));
6408 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6413 PERL_ARGS_ASSERT_DOFILE;
6415 if (!force_builtin && (gv = gv_override("do", 2))) {
6416 doop = S_new_entersubop(aTHX_ gv, term);
6419 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6425 =head1 Optree construction
6427 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6429 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6430 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6431 be set automatically, and, shifted up eight bits, the eight bits of
6432 C<op_private>, except that the bit with value 1 or 2 is automatically
6433 set as required. C<listval> and C<subscript> supply the parameters of
6434 the slice; they are consumed by this function and become part of the
6435 constructed op tree.
6441 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6443 return newBINOP(OP_LSLICE, flags,
6444 list(force_list(subscript, 1)),
6445 list(force_list(listval, 1)) );
6448 #define ASSIGN_LIST 1
6449 #define ASSIGN_REF 2
6452 S_assignment_type(pTHX_ const OP *o)
6461 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6462 o = cUNOPo->op_first;
6464 flags = o->op_flags;
6466 if (type == OP_COND_EXPR) {
6467 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6468 const I32 t = assignment_type(sib);
6469 const I32 f = assignment_type(OpSIBLING(sib));
6471 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6473 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6474 yyerror("Assignment to both a list and a scalar");
6478 if (type == OP_SREFGEN)
6480 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6481 type = kid->op_type;
6482 flags |= kid->op_flags;
6483 if (!(flags & OPf_PARENS)
6484 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6485 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6491 if (type == OP_LIST &&
6492 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6493 o->op_private & OPpLVAL_INTRO)
6496 if (type == OP_LIST || flags & OPf_PARENS ||
6497 type == OP_RV2AV || type == OP_RV2HV ||
6498 type == OP_ASLICE || type == OP_HSLICE ||
6499 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6502 if (type == OP_PADAV || type == OP_PADHV)
6505 if (type == OP_RV2SV)
6513 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6515 Constructs, checks, and returns an assignment op. C<left> and C<right>
6516 supply the parameters of the assignment; they are consumed by this
6517 function and become part of the constructed op tree.
6519 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6520 a suitable conditional optree is constructed. If C<optype> is the opcode
6521 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6522 performs the binary operation and assigns the result to the left argument.
6523 Either way, if C<optype> is non-zero then C<flags> has no effect.
6525 If C<optype> is zero, then a plain scalar or list assignment is
6526 constructed. Which type of assignment it is is automatically determined.
6527 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6528 will be set automatically, and, shifted up eight bits, the eight bits
6529 of C<op_private>, except that the bit with value 1 or 2 is automatically
6536 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6542 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6543 right = scalar(right);
6544 return newLOGOP(optype, 0,
6545 op_lvalue(scalar(left), optype),
6546 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
6549 return newBINOP(optype, OPf_STACKED,
6550 op_lvalue(scalar(left), optype), scalar(right));
6554 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6555 static const char no_list_state[] = "Initialization of state variables"
6556 " in list context currently forbidden";
6559 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6560 left->op_private &= ~ OPpSLICEWARNING;
6563 left = op_lvalue(left, OP_AASSIGN);
6564 curop = list(force_list(left, 1));
6565 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6566 o->op_private = (U8)(0 | (flags >> 8));
6568 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6570 OP* lop = ((LISTOP*)left)->op_first;
6572 if ((lop->op_type == OP_PADSV ||
6573 lop->op_type == OP_PADAV ||
6574 lop->op_type == OP_PADHV ||
6575 lop->op_type == OP_PADANY)
6576 && (lop->op_private & OPpPAD_STATE)
6578 yyerror(no_list_state);
6579 lop = OpSIBLING(lop);
6582 else if ( (left->op_private & OPpLVAL_INTRO)
6583 && (left->op_private & OPpPAD_STATE)
6584 && ( left->op_type == OP_PADSV
6585 || left->op_type == OP_PADAV
6586 || left->op_type == OP_PADHV
6587 || left->op_type == OP_PADANY)
6589 /* All single variable list context state assignments, hence
6599 yyerror(no_list_state);
6602 /* optimise @a = split(...) into:
6603 * @{expr}: split(..., @{expr}) (where @a is not flattened)
6604 * @a, my @a, local @a: split(...) (where @a is attached to
6605 * the split op itself)
6609 && right->op_type == OP_SPLIT
6610 /* don't do twice, e.g. @b = (@a = split) */
6611 && !(right->op_private & OPpSPLIT_ASSIGN))
6615 if ( ( left->op_type == OP_RV2AV
6616 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
6617 || left->op_type == OP_PADAV)
6619 /* @pkg or @lex or local @pkg' or 'my @lex' */
6623 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
6624 = cPADOPx(gvop)->op_padix;
6625 cPADOPx(gvop)->op_padix = 0; /* steal it */
6627 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
6628 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
6629 cSVOPx(gvop)->op_sv = NULL; /* steal it */
6631 right->op_private |=
6632 left->op_private & OPpOUR_INTRO;
6635 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
6636 left->op_targ = 0; /* steal it */
6637 right->op_private |= OPpSPLIT_LEX;
6639 right->op_private |= left->op_private & OPpLVAL_INTRO;
6642 tmpop = cUNOPo->op_first; /* to list (nulled) */
6643 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6644 assert(OpSIBLING(tmpop) == right);
6645 assert(!OpHAS_SIBLING(right));
6646 /* detach the split subtreee from the o tree,
6647 * then free the residual o tree */
6648 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
6649 op_free(o); /* blow off assign */
6650 right->op_private |= OPpSPLIT_ASSIGN;
6651 right->op_flags &= ~OPf_WANT;
6652 /* "I don't know and I don't care." */
6655 else if (left->op_type == OP_RV2AV) {
6658 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
6659 assert(OpSIBLING(pushop) == left);
6660 /* Detach the array ... */
6661 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
6662 /* ... and attach it to the split. */
6663 op_sibling_splice(right, cLISTOPx(right)->op_last,
6665 right->op_flags |= OPf_STACKED;
6666 /* Detach split and expunge aassign as above. */
6669 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6670 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6672 /* convert split(...,0) to split(..., PL_modcount+1) */
6674 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6675 SV * const sv = *svp;
6676 if (SvIOK(sv) && SvIVX(sv) == 0)
6678 if (right->op_private & OPpSPLIT_IMPLIM) {
6679 /* our own SV, created in ck_split */
6681 sv_setiv(sv, PL_modcount+1);
6684 /* SV may belong to someone else */
6686 *svp = newSViv(PL_modcount+1);
6693 if (assign_type == ASSIGN_REF)
6694 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6696 right = newOP(OP_UNDEF, 0);
6697 if (right->op_type == OP_READLINE) {
6698 right->op_flags |= OPf_STACKED;
6699 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6703 o = newBINOP(OP_SASSIGN, flags,
6704 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6710 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6712 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6713 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6714 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6715 If C<label> is non-null, it supplies the name of a label to attach to
6716 the state op; this function takes ownership of the memory pointed at by
6717 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6720 If C<o> is null, the state op is returned. Otherwise the state op is
6721 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6722 is consumed by this function and becomes part of the returned op tree.
6728 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6731 const U32 seq = intro_my();
6732 const U32 utf8 = flags & SVf_UTF8;
6735 PL_parser->parsed_sub = 0;
6739 NewOp(1101, cop, 1, COP);
6740 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6741 OpTYPE_set(cop, OP_DBSTATE);
6744 OpTYPE_set(cop, OP_NEXTSTATE);
6746 cop->op_flags = (U8)flags;
6747 CopHINTS_set(cop, PL_hints);
6749 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6751 cop->op_next = (OP*)cop;
6754 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6755 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6757 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6759 PL_hints |= HINT_BLOCK_SCOPE;
6760 /* It seems that we need to defer freeing this pointer, as other parts
6761 of the grammar end up wanting to copy it after this op has been
6766 if (PL_parser->preambling != NOLINE) {
6767 CopLINE_set(cop, PL_parser->preambling);
6768 PL_parser->copline = NOLINE;
6770 else if (PL_parser->copline == NOLINE)
6771 CopLINE_set(cop, CopLINE(PL_curcop));
6773 CopLINE_set(cop, PL_parser->copline);
6774 PL_parser->copline = NOLINE;
6777 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6779 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6781 CopSTASH_set(cop, PL_curstash);
6783 if (cop->op_type == OP_DBSTATE) {
6784 /* this line can have a breakpoint - store the cop in IV */
6785 AV *av = CopFILEAVx(PL_curcop);
6787 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6788 if (svp && *svp != &PL_sv_undef ) {
6789 (void)SvIOK_on(*svp);
6790 SvIV_set(*svp, PTR2IV(cop));
6795 if (flags & OPf_SPECIAL)
6797 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6801 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6803 Constructs, checks, and returns a logical (flow control) op. C<type>
6804 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6805 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6806 the eight bits of C<op_private>, except that the bit with value 1 is
6807 automatically set. C<first> supplies the expression controlling the
6808 flow, and C<other> supplies the side (alternate) chain of ops; they are
6809 consumed by this function and become part of the constructed op tree.
6815 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6817 PERL_ARGS_ASSERT_NEWLOGOP;
6819 return new_logop(type, flags, &first, &other);
6823 S_search_const(pTHX_ OP *o)
6825 PERL_ARGS_ASSERT_SEARCH_CONST;
6827 switch (o->op_type) {
6831 if (o->op_flags & OPf_KIDS)
6832 return search_const(cUNOPo->op_first);
6839 if (!(o->op_flags & OPf_KIDS))
6841 kid = cLISTOPo->op_first;
6843 switch (kid->op_type) {
6847 kid = OpSIBLING(kid);
6850 if (kid != cLISTOPo->op_last)
6856 kid = cLISTOPo->op_last;
6858 return search_const(kid);
6866 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6874 int prepend_not = 0;
6876 PERL_ARGS_ASSERT_NEW_LOGOP;
6881 /* [perl #59802]: Warn about things like "return $a or $b", which
6882 is parsed as "(return $a) or $b" rather than "return ($a or
6883 $b)". NB: This also applies to xor, which is why we do it
6886 switch (first->op_type) {
6890 /* XXX: Perhaps we should emit a stronger warning for these.
6891 Even with the high-precedence operator they don't seem to do
6894 But until we do, fall through here.
6900 /* XXX: Currently we allow people to "shoot themselves in the
6901 foot" by explicitly writing "(return $a) or $b".
6903 Warn unless we are looking at the result from folding or if
6904 the programmer explicitly grouped the operators like this.
6905 The former can occur with e.g.
6907 use constant FEATURE => ( $] >= ... );
6908 sub { not FEATURE and return or do_stuff(); }
6910 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6911 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6912 "Possible precedence issue with control flow operator");
6913 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6919 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6920 return newBINOP(type, flags, scalar(first), scalar(other));
6922 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6923 || type == OP_CUSTOM);
6925 scalarboolean(first);
6927 /* search for a constant op that could let us fold the test */
6928 if ((cstop = search_const(first))) {
6929 if (cstop->op_private & OPpCONST_STRICT)
6930 no_bareword_allowed(cstop);
6931 else if ((cstop->op_private & OPpCONST_BARE))
6932 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6933 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6934 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6935 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6936 /* Elide the (constant) lhs, since it can't affect the outcome */
6938 if (other->op_type == OP_CONST)
6939 other->op_private |= OPpCONST_SHORTCIRCUIT;
6941 if (other->op_type == OP_LEAVE)
6942 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6943 else if (other->op_type == OP_MATCH
6944 || other->op_type == OP_SUBST
6945 || other->op_type == OP_TRANSR
6946 || other->op_type == OP_TRANS)
6947 /* Mark the op as being unbindable with =~ */
6948 other->op_flags |= OPf_SPECIAL;
6950 other->op_folded = 1;
6954 /* Elide the rhs, since the outcome is entirely determined by
6955 * the (constant) lhs */
6957 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6958 const OP *o2 = other;
6959 if ( ! (o2->op_type == OP_LIST
6960 && (( o2 = cUNOPx(o2)->op_first))
6961 && o2->op_type == OP_PUSHMARK
6962 && (( o2 = OpSIBLING(o2))) )
6965 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6966 || o2->op_type == OP_PADHV)
6967 && o2->op_private & OPpLVAL_INTRO
6968 && !(o2->op_private & OPpPAD_STATE))
6970 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6971 "Deprecated use of my() in false conditional");
6975 if (cstop->op_type == OP_CONST)
6976 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6981 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6982 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6984 const OP * const k1 = ((UNOP*)first)->op_first;
6985 const OP * const k2 = OpSIBLING(k1);
6987 switch (first->op_type)
6990 if (k2 && k2->op_type == OP_READLINE
6991 && (k2->op_flags & OPf_STACKED)
6992 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6994 warnop = k2->op_type;
6999 if (k1->op_type == OP_READDIR
7000 || k1->op_type == OP_GLOB
7001 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7002 || k1->op_type == OP_EACH
7003 || k1->op_type == OP_AEACH)
7005 warnop = ((k1->op_type == OP_NULL)
7006 ? (OPCODE)k1->op_targ : k1->op_type);
7011 const line_t oldline = CopLINE(PL_curcop);
7012 /* This ensures that warnings are reported at the first line
7013 of the construction, not the last. */
7014 CopLINE_set(PL_curcop, PL_parser->copline);
7015 Perl_warner(aTHX_ packWARN(WARN_MISC),
7016 "Value of %s%s can be \"0\"; test with defined()",
7018 ((warnop == OP_READLINE || warnop == OP_GLOB)
7019 ? " construct" : "() operator"));
7020 CopLINE_set(PL_curcop, oldline);
7024 /* optimize AND and OR ops that have NOTs as children */
7025 if (first->op_type == OP_NOT
7026 && (first->op_flags & OPf_KIDS)
7027 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
7028 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
7030 if (type == OP_AND || type == OP_OR) {
7036 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
7038 prepend_not = 1; /* prepend a NOT op later */
7043 logop = alloc_LOGOP(type, first, LINKLIST(other));
7044 logop->op_flags |= (U8)flags;
7045 logop->op_private = (U8)(1 | (flags >> 8));
7047 /* establish postfix order */
7048 logop->op_next = LINKLIST(first);
7049 first->op_next = (OP*)logop;
7050 assert(!OpHAS_SIBLING(first));
7051 op_sibling_splice((OP*)logop, first, 0, other);
7053 CHECKOP(type,logop);
7055 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7056 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7064 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7066 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7067 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7068 will be set automatically, and, shifted up eight bits, the eight bits of
7069 C<op_private>, except that the bit with value 1 is automatically set.
7070 C<first> supplies the expression selecting between the two branches,
7071 and C<trueop> and C<falseop> supply the branches; they are consumed by
7072 this function and become part of the constructed op tree.
7078 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7086 PERL_ARGS_ASSERT_NEWCONDOP;
7089 return newLOGOP(OP_AND, 0, first, trueop);
7091 return newLOGOP(OP_OR, 0, first, falseop);
7093 scalarboolean(first);
7094 if ((cstop = search_const(first))) {
7095 /* Left or right arm of the conditional? */
7096 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7097 OP *live = left ? trueop : falseop;
7098 OP *const dead = left ? falseop : trueop;
7099 if (cstop->op_private & OPpCONST_BARE &&
7100 cstop->op_private & OPpCONST_STRICT) {
7101 no_bareword_allowed(cstop);
7105 if (live->op_type == OP_LEAVE)
7106 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7107 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7108 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7109 /* Mark the op as being unbindable with =~ */
7110 live->op_flags |= OPf_SPECIAL;
7111 live->op_folded = 1;
7114 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
7115 logop->op_flags |= (U8)flags;
7116 logop->op_private = (U8)(1 | (flags >> 8));
7117 logop->op_next = LINKLIST(falseop);
7119 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7122 /* establish postfix order */
7123 start = LINKLIST(first);
7124 first->op_next = (OP*)logop;
7126 /* make first, trueop, falseop siblings */
7127 op_sibling_splice((OP*)logop, first, 0, trueop);
7128 op_sibling_splice((OP*)logop, trueop, 0, falseop);
7130 o = newUNOP(OP_NULL, 0, (OP*)logop);
7132 trueop->op_next = falseop->op_next = o;
7139 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7141 Constructs and returns a C<range> op, with subordinate C<flip> and
7142 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
7143 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7144 for both the C<flip> and C<range> ops, except that the bit with value
7145 1 is automatically set. C<left> and C<right> supply the expressions
7146 controlling the endpoints of the range; they are consumed by this function
7147 and become part of the constructed op tree.
7153 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7161 PERL_ARGS_ASSERT_NEWRANGE;
7163 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
7164 range->op_flags = OPf_KIDS;
7165 leftstart = LINKLIST(left);
7166 range->op_private = (U8)(1 | (flags >> 8));
7168 /* make left and right siblings */
7169 op_sibling_splice((OP*)range, left, 0, right);
7171 range->op_next = (OP*)range;
7172 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7173 flop = newUNOP(OP_FLOP, 0, flip);
7174 o = newUNOP(OP_NULL, 0, flop);
7176 range->op_next = leftstart;
7178 left->op_next = flip;
7179 right->op_next = flop;
7182 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7183 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7185 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7186 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7187 SvPADTMP_on(PAD_SV(flip->op_targ));
7189 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7190 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7192 /* check barewords before they might be optimized aways */
7193 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7194 no_bareword_allowed(left);
7195 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7196 no_bareword_allowed(right);
7199 if (!flip->op_private || !flop->op_private)
7200 LINKLIST(o); /* blow off optimizer unless constant */
7206 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7208 Constructs, checks, and returns an op tree expressing a loop. This is
7209 only a loop in the control flow through the op tree; it does not have
7210 the heavyweight loop structure that allows exiting the loop by C<last>
7211 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7212 top-level op, except that some bits will be set automatically as required.
7213 C<expr> supplies the expression controlling loop iteration, and C<block>
7214 supplies the body of the loop; they are consumed by this function and
7215 become part of the constructed op tree. C<debuggable> is currently
7216 unused and should always be 1.
7222 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7226 const bool once = block && block->op_flags & OPf_SPECIAL &&
7227 block->op_type == OP_NULL;
7229 PERL_UNUSED_ARG(debuggable);
7233 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7234 || ( expr->op_type == OP_NOT
7235 && cUNOPx(expr)->op_first->op_type == OP_CONST
7236 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7239 /* Return the block now, so that S_new_logop does not try to
7241 return block; /* do {} while 0 does once */
7242 if (expr->op_type == OP_READLINE
7243 || expr->op_type == OP_READDIR
7244 || expr->op_type == OP_GLOB
7245 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7246 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7247 expr = newUNOP(OP_DEFINED, 0,
7248 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7249 } else if (expr->op_flags & OPf_KIDS) {
7250 const OP * const k1 = ((UNOP*)expr)->op_first;
7251 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7252 switch (expr->op_type) {
7254 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7255 && (k2->op_flags & OPf_STACKED)
7256 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7257 expr = newUNOP(OP_DEFINED, 0, expr);
7261 if (k1 && (k1->op_type == OP_READDIR
7262 || k1->op_type == OP_GLOB
7263 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7264 || k1->op_type == OP_EACH
7265 || k1->op_type == OP_AEACH))
7266 expr = newUNOP(OP_DEFINED, 0, expr);
7272 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7273 * op, in listop. This is wrong. [perl #27024] */
7275 block = newOP(OP_NULL, 0);
7276 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7277 o = new_logop(OP_AND, 0, &expr, &listop);
7284 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7286 if (once && o != listop)
7288 assert(cUNOPo->op_first->op_type == OP_AND
7289 || cUNOPo->op_first->op_type == OP_OR);
7290 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7294 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7296 o->op_flags |= flags;
7298 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7303 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7305 Constructs, checks, and returns an op tree expressing a C<while> loop.
7306 This is a heavyweight loop, with structure that allows exiting the loop
7307 by C<last> and suchlike.
7309 C<loop> is an optional preconstructed C<enterloop> op to use in the
7310 loop; if it is null then a suitable op will be constructed automatically.
7311 C<expr> supplies the loop's controlling expression. C<block> supplies the
7312 main body of the loop, and C<cont> optionally supplies a C<continue> block
7313 that operates as a second half of the body. All of these optree inputs
7314 are consumed by this function and become part of the constructed op tree.
7316 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7317 op and, shifted up eight bits, the eight bits of C<op_private> for
7318 the C<leaveloop> op, except that (in both cases) some bits will be set
7319 automatically. C<debuggable> is currently unused and should always be 1.
7320 C<has_my> can be supplied as true to force the
7321 loop body to be enclosed in its own scope.
7327 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7328 OP *expr, OP *block, OP *cont, I32 has_my)
7337 PERL_UNUSED_ARG(debuggable);
7340 if (expr->op_type == OP_READLINE
7341 || expr->op_type == OP_READDIR
7342 || expr->op_type == OP_GLOB
7343 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7344 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7345 expr = newUNOP(OP_DEFINED, 0,
7346 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7347 } else if (expr->op_flags & OPf_KIDS) {
7348 const OP * const k1 = ((UNOP*)expr)->op_first;
7349 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7350 switch (expr->op_type) {
7352 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7353 && (k2->op_flags & OPf_STACKED)
7354 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7355 expr = newUNOP(OP_DEFINED, 0, expr);
7359 if (k1 && (k1->op_type == OP_READDIR
7360 || k1->op_type == OP_GLOB
7361 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7362 || k1->op_type == OP_EACH
7363 || k1->op_type == OP_AEACH))
7364 expr = newUNOP(OP_DEFINED, 0, expr);
7371 block = newOP(OP_NULL, 0);
7372 else if (cont || has_my) {
7373 block = op_scope(block);
7377 next = LINKLIST(cont);
7380 OP * const unstack = newOP(OP_UNSTACK, 0);
7383 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7387 listop = op_append_list(OP_LINESEQ, block, cont);
7389 redo = LINKLIST(listop);
7393 o = new_logop(OP_AND, 0, &expr, &listop);
7394 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7396 return expr; /* listop already freed by new_logop */
7399 ((LISTOP*)listop)->op_last->op_next =
7400 (o == listop ? redo : LINKLIST(o));
7406 NewOp(1101,loop,1,LOOP);
7407 OpTYPE_set(loop, OP_ENTERLOOP);
7408 loop->op_private = 0;
7409 loop->op_next = (OP*)loop;
7412 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7414 loop->op_redoop = redo;
7415 loop->op_lastop = o;
7416 o->op_private |= loopflags;
7419 loop->op_nextop = next;
7421 loop->op_nextop = o;
7423 o->op_flags |= flags;
7424 o->op_private |= (flags >> 8);
7429 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7431 Constructs, checks, and returns an op tree expressing a C<foreach>
7432 loop (iteration through a list of values). This is a heavyweight loop,
7433 with structure that allows exiting the loop by C<last> and suchlike.
7435 C<sv> optionally supplies the variable that will be aliased to each
7436 item in turn; if null, it defaults to C<$_>.
7437 C<expr> supplies the list of values to iterate over. C<block> supplies
7438 the main body of the loop, and C<cont> optionally supplies a C<continue>
7439 block that operates as a second half of the body. All of these optree
7440 inputs are consumed by this function and become part of the constructed
7443 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7444 op and, shifted up eight bits, the eight bits of C<op_private> for
7445 the C<leaveloop> op, except that (in both cases) some bits will be set
7452 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7457 PADOFFSET padoff = 0;
7461 PERL_ARGS_ASSERT_NEWFOROP;
7464 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7465 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7466 OpTYPE_set(sv, OP_RV2GV);
7468 /* The op_type check is needed to prevent a possible segfault
7469 * if the loop variable is undeclared and 'strict vars' is in
7470 * effect. This is illegal but is nonetheless parsed, so we
7471 * may reach this point with an OP_CONST where we're expecting
7474 if (cUNOPx(sv)->op_first->op_type == OP_GV
7475 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7476 iterpflags |= OPpITER_DEF;
7478 else if (sv->op_type == OP_PADSV) { /* private variable */
7479 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7480 padoff = sv->op_targ;
7484 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7486 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7489 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7491 PADNAME * const pn = PAD_COMPNAME(padoff);
7492 const char * const name = PadnamePV(pn);
7494 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7495 iterpflags |= OPpITER_DEF;
7499 sv = newGVOP(OP_GV, 0, PL_defgv);
7500 iterpflags |= OPpITER_DEF;
7503 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7504 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7505 iterflags |= OPf_STACKED;
7507 else if (expr->op_type == OP_NULL &&
7508 (expr->op_flags & OPf_KIDS) &&
7509 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7511 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7512 * set the STACKED flag to indicate that these values are to be
7513 * treated as min/max values by 'pp_enteriter'.
7515 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7516 LOGOP* const range = (LOGOP*) flip->op_first;
7517 OP* const left = range->op_first;
7518 OP* const right = OpSIBLING(left);
7521 range->op_flags &= ~OPf_KIDS;
7522 /* detach range's children */
7523 op_sibling_splice((OP*)range, NULL, -1, NULL);
7525 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7526 listop->op_first->op_next = range->op_next;
7527 left->op_next = range->op_other;
7528 right->op_next = (OP*)listop;
7529 listop->op_next = listop->op_first;
7532 expr = (OP*)(listop);
7534 iterflags |= OPf_STACKED;
7537 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7540 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7541 op_append_elem(OP_LIST, list(expr),
7543 assert(!loop->op_next);
7544 /* for my $x () sets OPpLVAL_INTRO;
7545 * for our $x () sets OPpOUR_INTRO */
7546 loop->op_private = (U8)iterpflags;
7547 if (loop->op_slabbed
7548 && DIFF(loop, OpSLOT(loop)->opslot_next)
7549 < SIZE_TO_PSIZE(sizeof(LOOP)))
7552 NewOp(1234,tmp,1,LOOP);
7553 Copy(loop,tmp,1,LISTOP);
7554 #ifdef PERL_OP_PARENT
7555 assert(loop->op_last->op_sibparent == (OP*)loop);
7556 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7558 S_op_destroy(aTHX_ (OP*)loop);
7561 else if (!loop->op_slabbed)
7563 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7564 #ifdef PERL_OP_PARENT
7565 OpLASTSIB_set(loop->op_last, (OP*)loop);
7568 loop->op_targ = padoff;
7569 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7574 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7576 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7577 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7578 determining the target of the op; it is consumed by this function and
7579 becomes part of the constructed op tree.
7585 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7589 PERL_ARGS_ASSERT_NEWLOOPEX;
7591 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7592 || type == OP_CUSTOM);
7594 if (type != OP_GOTO) {
7595 /* "last()" means "last" */
7596 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7597 o = newOP(type, OPf_SPECIAL);
7601 /* Check whether it's going to be a goto &function */
7602 if (label->op_type == OP_ENTERSUB
7603 && !(label->op_flags & OPf_STACKED))
7604 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7607 /* Check for a constant argument */
7608 if (label->op_type == OP_CONST) {
7609 SV * const sv = ((SVOP *)label)->op_sv;
7611 const char *s = SvPV_const(sv,l);
7612 if (l == strlen(s)) {
7614 SvUTF8(((SVOP*)label)->op_sv),
7616 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7620 /* If we have already created an op, we do not need the label. */
7623 else o = newUNOP(type, OPf_STACKED, label);
7625 PL_hints |= HINT_BLOCK_SCOPE;
7629 /* if the condition is a literal array or hash
7630 (or @{ ... } etc), make a reference to it.
7633 S_ref_array_or_hash(pTHX_ OP *cond)
7636 && (cond->op_type == OP_RV2AV
7637 || cond->op_type == OP_PADAV
7638 || cond->op_type == OP_RV2HV
7639 || cond->op_type == OP_PADHV))
7641 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7644 && (cond->op_type == OP_ASLICE
7645 || cond->op_type == OP_KVASLICE
7646 || cond->op_type == OP_HSLICE
7647 || cond->op_type == OP_KVHSLICE)) {
7649 /* anonlist now needs a list from this op, was previously used in
7651 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7652 cond->op_flags |= OPf_WANT_LIST;
7654 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7661 /* These construct the optree fragments representing given()
7664 entergiven and enterwhen are LOGOPs; the op_other pointer
7665 points up to the associated leave op. We need this so we
7666 can put it in the context and make break/continue work.
7667 (Also, of course, pp_enterwhen will jump straight to
7668 op_other if the match fails.)
7672 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7673 I32 enter_opcode, I32 leave_opcode,
7674 PADOFFSET entertarg)
7680 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7681 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7683 enterop = alloc_LOGOP(enter_opcode, block, NULL);
7684 enterop->op_targ = 0;
7685 enterop->op_private = 0;
7687 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7690 /* prepend cond if we have one */
7691 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7693 o->op_next = LINKLIST(cond);
7694 cond->op_next = (OP *) enterop;
7697 /* This is a default {} block */
7698 enterop->op_flags |= OPf_SPECIAL;
7699 o ->op_flags |= OPf_SPECIAL;
7701 o->op_next = (OP *) enterop;
7704 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7705 entergiven and enterwhen both
7708 enterop->op_next = LINKLIST(block);
7709 block->op_next = enterop->op_other = o;
7714 /* Does this look like a boolean operation? For these purposes
7715 a boolean operation is:
7716 - a subroutine call [*]
7717 - a logical connective
7718 - a comparison operator
7719 - a filetest operator, with the exception of -s -M -A -C
7720 - defined(), exists() or eof()
7721 - /$re/ or $foo =~ /$re/
7723 [*] possibly surprising
7726 S_looks_like_bool(pTHX_ const OP *o)
7728 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7730 switch(o->op_type) {
7733 return looks_like_bool(cLOGOPo->op_first);
7737 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7740 looks_like_bool(cLOGOPo->op_first)
7741 && looks_like_bool(sibl));
7747 o->op_flags & OPf_KIDS
7748 && looks_like_bool(cUNOPo->op_first));
7752 case OP_NOT: case OP_XOR:
7754 case OP_EQ: case OP_NE: case OP_LT:
7755 case OP_GT: case OP_LE: case OP_GE:
7757 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7758 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7760 case OP_SEQ: case OP_SNE: case OP_SLT:
7761 case OP_SGT: case OP_SLE: case OP_SGE:
7765 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7766 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7767 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7768 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7769 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7770 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7771 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7772 case OP_FTTEXT: case OP_FTBINARY:
7774 case OP_DEFINED: case OP_EXISTS:
7775 case OP_MATCH: case OP_EOF:
7782 /* Detect comparisons that have been optimized away */
7783 if (cSVOPo->op_sv == &PL_sv_yes
7784 || cSVOPo->op_sv == &PL_sv_no)
7797 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7799 Constructs, checks, and returns an op tree expressing a C<given> block.
7800 C<cond> supplies the expression that will be locally assigned to a lexical
7801 variable, and C<block> supplies the body of the C<given> construct; they
7802 are consumed by this function and become part of the constructed op tree.
7803 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7809 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7811 PERL_ARGS_ASSERT_NEWGIVENOP;
7812 PERL_UNUSED_ARG(defsv_off);
7815 return newGIVWHENOP(
7816 ref_array_or_hash(cond),
7818 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7823 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7825 Constructs, checks, and returns an op tree expressing a C<when> block.
7826 C<cond> supplies the test expression, and C<block> supplies the block
7827 that will be executed if the test evaluates to true; they are consumed
7828 by this function and become part of the constructed op tree. C<cond>
7829 will be interpreted DWIMically, often as a comparison against C<$_>,
7830 and may be null to generate a C<default> block.
7836 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7838 const bool cond_llb = (!cond || looks_like_bool(cond));
7841 PERL_ARGS_ASSERT_NEWWHENOP;
7846 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7848 scalar(ref_array_or_hash(cond)));
7851 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7854 /* must not conflict with SVf_UTF8 */
7855 #define CV_CKPROTO_CURSTASH 0x1
7858 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7859 const STRLEN len, const U32 flags)
7861 SV *name = NULL, *msg;
7862 const char * cvp = SvROK(cv)
7863 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7864 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7867 STRLEN clen = CvPROTOLEN(cv), plen = len;
7869 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7871 if (p == NULL && cvp == NULL)
7874 if (!ckWARN_d(WARN_PROTOTYPE))
7878 p = S_strip_spaces(aTHX_ p, &plen);
7879 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7880 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7881 if (plen == clen && memEQ(cvp, p, plen))
7884 if (flags & SVf_UTF8) {
7885 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7889 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7895 msg = sv_newmortal();
7900 gv_efullname3(name = sv_newmortal(), gv, NULL);
7901 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7902 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7903 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7904 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7905 sv_catpvs(name, "::");
7907 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7908 assert (CvNAMED(SvRV_const(gv)));
7909 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7911 else sv_catsv(name, (SV *)gv);
7913 else name = (SV *)gv;
7915 sv_setpvs(msg, "Prototype mismatch:");
7917 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
7919 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
7920 UTF8fARG(SvUTF8(cv),clen,cvp)
7923 sv_catpvs(msg, ": none");
7924 sv_catpvs(msg, " vs ");
7926 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
7928 sv_catpvs(msg, "none");
7929 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
7932 static void const_sv_xsub(pTHX_ CV* cv);
7933 static void const_av_xsub(pTHX_ CV* cv);
7937 =head1 Optree Manipulation Functions
7939 =for apidoc cv_const_sv
7941 If C<cv> is a constant sub eligible for inlining, returns the constant
7942 value returned by the sub. Otherwise, returns C<NULL>.
7944 Constant subs can be created with C<newCONSTSUB> or as described in
7945 L<perlsub/"Constant Functions">.
7950 Perl_cv_const_sv(const CV *const cv)
7955 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7957 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7958 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7963 Perl_cv_const_sv_or_av(const CV * const cv)
7967 if (SvROK(cv)) return SvRV((SV *)cv);
7968 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7969 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7972 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7973 * Can be called in 2 ways:
7976 * look for a single OP_CONST with attached value: return the value
7978 * allow_lex && !CvCONST(cv);
7980 * examine the clone prototype, and if contains only a single
7981 * OP_CONST, return the value; or if it contains a single PADSV ref-
7982 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7983 * a candidate for "constizing" at clone time, and return NULL.
7987 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7995 for (; o; o = o->op_next) {
7996 const OPCODE type = o->op_type;
7998 if (type == OP_NEXTSTATE || type == OP_LINESEQ
8000 || type == OP_PUSHMARK)
8002 if (type == OP_DBSTATE)
8004 if (type == OP_LEAVESUB)
8008 if (type == OP_CONST && cSVOPo->op_sv)
8010 else if (type == OP_UNDEF && !o->op_private) {
8014 else if (allow_lex && type == OP_PADSV) {
8015 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
8017 sv = &PL_sv_undef; /* an arbitrary non-null value */
8035 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
8036 PADNAME * const name, SV ** const const_svp)
8042 if (CvFLAGS(PL_compcv)) {
8043 /* might have had built-in attrs applied */
8044 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8045 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8046 && ckWARN(WARN_MISC))
8048 /* protect against fatal warnings leaking compcv */
8049 SAVEFREESV(PL_compcv);
8050 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8051 SvREFCNT_inc_simple_void_NN(PL_compcv);
8054 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8055 & ~(CVf_LVALUE * pureperl));
8060 /* redundant check for speed: */
8061 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8062 const line_t oldline = CopLINE(PL_curcop);
8065 : sv_2mortal(newSVpvn_utf8(
8066 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8068 if (PL_parser && PL_parser->copline != NOLINE)
8069 /* This ensures that warnings are reported at the first
8070 line of a redefinition, not the last. */
8071 CopLINE_set(PL_curcop, PL_parser->copline);
8072 /* protect against fatal warnings leaking compcv */
8073 SAVEFREESV(PL_compcv);
8074 report_redefined_cv(namesv, cv, const_svp);
8075 SvREFCNT_inc_simple_void_NN(PL_compcv);
8076 CopLINE_set(PL_curcop, oldline);
8083 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8088 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8091 CV *compcv = PL_compcv;
8094 PADOFFSET pax = o->op_targ;
8095 CV *outcv = CvOUTSIDE(PL_compcv);
8098 bool reusable = FALSE;
8100 #ifdef PERL_DEBUG_READONLY_OPS
8101 OPSLAB *slab = NULL;
8104 PERL_ARGS_ASSERT_NEWMYSUB;
8106 /* Find the pad slot for storing the new sub.
8107 We cannot use PL_comppad, as it is the pad owned by the new sub. We
8108 need to look in CvOUTSIDE and find the pad belonging to the enclos-
8109 ing sub. And then we need to dig deeper if this is a lexical from
8111 my sub foo; sub { sub foo { } }
8114 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8115 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8116 pax = PARENT_PAD_INDEX(name);
8117 outcv = CvOUTSIDE(outcv);
8122 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8123 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8124 spot = (CV **)svspot;
8126 if (!(PL_parser && PL_parser->error_count))
8127 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8130 assert(proto->op_type == OP_CONST);
8131 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8132 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8142 if (PL_parser && PL_parser->error_count) {
8144 SvREFCNT_dec(PL_compcv);
8149 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8151 svspot = (SV **)(spot = &clonee);
8153 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8156 assert (SvTYPE(*spot) == SVt_PVCV);
8158 hek = CvNAME_HEK(*spot);
8162 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8163 CvNAME_HEK_set(*spot, hek =
8166 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8170 CvLEXICAL_on(*spot);
8172 cv = PadnamePROTOCV(name);
8173 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8177 /* This makes sub {}; work as expected. */
8178 if (block->op_type == OP_STUB) {
8179 const line_t l = PL_parser->copline;
8181 block = newSTATEOP(0, NULL, 0);
8182 PL_parser->copline = l;
8184 block = CvLVALUE(compcv)
8185 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8186 ? newUNOP(OP_LEAVESUBLV, 0,
8187 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8188 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8189 start = LINKLIST(block);
8191 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8192 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8200 const bool exists = CvROOT(cv) || CvXSUB(cv);
8202 /* if the subroutine doesn't exist and wasn't pre-declared
8203 * with a prototype, assume it will be AUTOLOADed,
8204 * skipping the prototype check
8206 if (exists || SvPOK(cv))
8207 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8209 /* already defined? */
8211 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
8217 /* just a "sub foo;" when &foo is already defined */
8222 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8229 SvREFCNT_inc_simple_void_NN(const_sv);
8230 SvFLAGS(const_sv) |= SVs_PADTMP;
8232 assert(!CvROOT(cv) && !CvCONST(cv));
8236 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8237 CvFILE_set_from_cop(cv, PL_curcop);
8238 CvSTASH_set(cv, PL_curstash);
8241 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
8242 CvXSUBANY(cv).any_ptr = const_sv;
8243 CvXSUB(cv) = const_sv_xsub;
8247 CvFLAGS(cv) |= CvMETHOD(compcv);
8249 SvREFCNT_dec(compcv);
8254 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8255 determine whether this sub definition is in the same scope as its
8256 declaration. If this sub definition is inside an inner named pack-
8257 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8258 the package sub. So check PadnameOUTER(name) too.
8260 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8261 assert(!CvWEAKOUTSIDE(compcv));
8262 SvREFCNT_dec(CvOUTSIDE(compcv));
8263 CvWEAKOUTSIDE_on(compcv);
8265 /* XXX else do we have a circular reference? */
8267 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8268 /* transfer PL_compcv to cv */
8270 cv_flags_t preserved_flags =
8271 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8272 PADLIST *const temp_padl = CvPADLIST(cv);
8273 CV *const temp_cv = CvOUTSIDE(cv);
8274 const cv_flags_t other_flags =
8275 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8276 OP * const cvstart = CvSTART(cv);
8280 CvFLAGS(compcv) | preserved_flags;
8281 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8282 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8283 CvPADLIST_set(cv, CvPADLIST(compcv));
8284 CvOUTSIDE(compcv) = temp_cv;
8285 CvPADLIST_set(compcv, temp_padl);
8286 CvSTART(cv) = CvSTART(compcv);
8287 CvSTART(compcv) = cvstart;
8288 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8289 CvFLAGS(compcv) |= other_flags;
8291 if (CvFILE(cv) && CvDYNFILE(cv)) {
8292 Safefree(CvFILE(cv));
8295 /* inner references to compcv must be fixed up ... */
8296 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8297 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8298 ++PL_sub_generation;
8301 /* Might have had built-in attributes applied -- propagate them. */
8302 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8304 /* ... before we throw it away */
8305 SvREFCNT_dec(compcv);
8306 PL_compcv = compcv = cv;
8315 if (!CvNAME_HEK(cv)) {
8316 if (hek) (void)share_hek_hek(hek);
8320 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8321 hek = share_hek(PadnamePV(name)+1,
8322 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8325 CvNAME_HEK_set(cv, hek);
8331 CvFILE_set_from_cop(cv, PL_curcop);
8332 CvSTASH_set(cv, PL_curstash);
8335 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8337 SvUTF8_on(MUTABLE_SV(cv));
8341 /* If we assign an optree to a PVCV, then we've defined a
8342 * subroutine that the debugger could be able to set a breakpoint
8343 * in, so signal to pp_entereval that it should not throw away any
8344 * saved lines at scope exit. */
8346 PL_breakable_sub_gen++;
8348 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8349 OpREFCNT_set(CvROOT(cv), 1);
8350 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8351 itself has a refcount. */
8353 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8354 #ifdef PERL_DEBUG_READONLY_OPS
8355 slab = (OPSLAB *)CvSTART(cv);
8357 CvSTART(cv) = start;
8359 finalize_optree(CvROOT(cv));
8360 S_prune_chain_head(&CvSTART(cv));
8362 /* now that optimizer has done its work, adjust pad values */
8364 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8369 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8370 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8374 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8375 SV * const tmpstr = sv_newmortal();
8376 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8377 GV_ADDMULTI, SVt_PVHV);
8379 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8382 (long)CopLINE(PL_curcop));
8383 if (HvNAME_HEK(PL_curstash)) {
8384 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8385 sv_catpvs(tmpstr, "::");
8388 sv_setpvs(tmpstr, "__ANON__::");
8390 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8391 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8392 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8393 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8394 hv = GvHVn(db_postponed);
8395 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8396 CV * const pcv = GvCV(db_postponed);
8402 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8410 assert(CvDEPTH(outcv));
8412 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8414 cv_clone_into(clonee, *spot);
8415 else *spot = cv_clone(clonee);
8416 SvREFCNT_dec_NN(clonee);
8420 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8421 PADOFFSET depth = CvDEPTH(outcv);
8424 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8426 *svspot = SvREFCNT_inc_simple_NN(cv);
8427 SvREFCNT_dec(oldcv);
8433 PL_parser->copline = NOLINE;
8435 #ifdef PERL_DEBUG_READONLY_OPS
8446 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8447 OP *block, bool o_is_gv)
8451 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8453 CV *cv = NULL; /* the previous CV with this name, if any */
8455 const bool ec = PL_parser && PL_parser->error_count;
8456 /* If the subroutine has no body, no attributes, and no builtin attributes
8457 then it's just a sub declaration, and we may be able to get away with
8458 storing with a placeholder scalar in the symbol table, rather than a
8459 full CV. If anything is present then it will take a full CV to
8461 const I32 gv_fetch_flags
8462 = ec ? GV_NOADD_NOINIT :
8463 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8464 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8466 const char * const name =
8467 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8469 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8470 bool evanescent = FALSE;
8472 #ifdef PERL_DEBUG_READONLY_OPS
8473 OPSLAB *slab = NULL;
8481 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8482 hek and CvSTASH pointer together can imply the GV. If the name
8483 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8484 CvSTASH, so forego the optimisation if we find any.
8485 Also, we may be called from load_module at run time, so
8486 PL_curstash (which sets CvSTASH) may not point to the stash the
8487 sub is stored in. */
8489 ec ? GV_NOADD_NOINIT
8490 : PL_curstash != CopSTASH(PL_curcop)
8491 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8493 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8494 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8496 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8497 SV * const sv = sv_newmortal();
8498 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
8499 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8500 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8501 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8503 } else if (PL_curstash) {
8504 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8507 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8513 move_proto_attr(&proto, &attrs, gv);
8516 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8521 assert(proto->op_type == OP_CONST);
8522 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8523 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8539 SvREFCNT_dec(PL_compcv);
8544 if (name && block) {
8545 const char *s = strrchr(name, ':');
8547 if (strEQ(s, "BEGIN")) {
8548 if (PL_in_eval & EVAL_KEEPERR)
8549 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8551 SV * const errsv = ERRSV;
8552 /* force display of errors found but not reported */
8553 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8554 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
8561 if (!block && SvTYPE(gv) != SVt_PVGV) {
8562 /* If we are not defining a new sub and the existing one is not a
8564 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8565 /* We are applying attributes to an existing sub, so we need it
8566 upgraded if it is a constant. */
8567 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8568 gv_init_pvn(gv, PL_curstash, name, namlen,
8569 SVf_UTF8 * name_is_utf8);
8571 else { /* Maybe prototype now, and had at maximum
8572 a prototype or const/sub ref before. */
8573 if (SvTYPE(gv) > SVt_NULL) {
8574 cv_ckproto_len_flags((const CV *)gv,
8575 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8581 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8583 SvUTF8_on(MUTABLE_SV(gv));
8586 sv_setiv(MUTABLE_SV(gv), -1);
8589 SvREFCNT_dec(PL_compcv);
8590 cv = PL_compcv = NULL;
8595 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8599 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8605 /* This makes sub {}; work as expected. */
8606 if (block->op_type == OP_STUB) {
8607 const line_t l = PL_parser->copline;
8609 block = newSTATEOP(0, NULL, 0);
8610 PL_parser->copline = l;
8612 block = CvLVALUE(PL_compcv)
8613 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8614 && (!isGV(gv) || !GvASSUMECV(gv)))
8615 ? newUNOP(OP_LEAVESUBLV, 0,
8616 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8617 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8618 start = LINKLIST(block);
8620 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8622 S_op_const_sv(aTHX_ start, PL_compcv,
8623 cBOOL(CvCLONE(PL_compcv)));
8630 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8631 cv_ckproto_len_flags((const CV *)gv,
8632 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8633 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8635 /* All the other code for sub redefinition warnings expects the
8636 clobbered sub to be a CV. Instead of making all those code
8637 paths more complex, just inline the RV version here. */
8638 const line_t oldline = CopLINE(PL_curcop);
8639 assert(IN_PERL_COMPILETIME);
8640 if (PL_parser && PL_parser->copline != NOLINE)
8641 /* This ensures that warnings are reported at the first
8642 line of a redefinition, not the last. */
8643 CopLINE_set(PL_curcop, PL_parser->copline);
8644 /* protect against fatal warnings leaking compcv */
8645 SAVEFREESV(PL_compcv);
8647 if (ckWARN(WARN_REDEFINE)
8648 || ( ckWARN_d(WARN_REDEFINE)
8649 && ( !const_sv || SvRV(gv) == const_sv
8650 || sv_cmp(SvRV(gv), const_sv) ))) {
8652 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8653 "Constant subroutine %" SVf " redefined",
8654 SVfARG(cSVOPo->op_sv));
8657 SvREFCNT_inc_simple_void_NN(PL_compcv);
8658 CopLINE_set(PL_curcop, oldline);
8659 SvREFCNT_dec(SvRV(gv));
8664 const bool exists = CvROOT(cv) || CvXSUB(cv);
8666 /* if the subroutine doesn't exist and wasn't pre-declared
8667 * with a prototype, assume it will be AUTOLOADed,
8668 * skipping the prototype check
8670 if (exists || SvPOK(cv))
8671 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8672 /* already defined (or promised)? */
8673 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8674 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
8680 /* just a "sub foo;" when &foo is already defined */
8681 SAVEFREESV(PL_compcv);
8688 SvREFCNT_inc_simple_void_NN(const_sv);
8689 SvFLAGS(const_sv) |= SVs_PADTMP;
8691 assert(!CvROOT(cv) && !CvCONST(cv));
8693 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
8694 CvXSUBANY(cv).any_ptr = const_sv;
8695 CvXSUB(cv) = const_sv_xsub;
8699 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8702 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8703 if (name && isGV(gv))
8705 cv = newCONSTSUB_flags(
8706 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8709 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8713 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8714 prepare_SV_for_RV((SV *)gv);
8718 SvRV_set(gv, const_sv);
8722 SvREFCNT_dec(PL_compcv);
8727 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
8728 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
8731 if (cv) { /* must reuse cv if autoloaded */
8732 /* transfer PL_compcv to cv */
8734 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8735 PADLIST *const temp_av = CvPADLIST(cv);
8736 CV *const temp_cv = CvOUTSIDE(cv);
8737 const cv_flags_t other_flags =
8738 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8739 OP * const cvstart = CvSTART(cv);
8743 assert(!CvCVGV_RC(cv));
8744 assert(CvGV(cv) == gv);
8749 PERL_HASH(hash, name, namlen);
8759 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8761 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8762 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8763 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8764 CvOUTSIDE(PL_compcv) = temp_cv;
8765 CvPADLIST_set(PL_compcv, temp_av);
8766 CvSTART(cv) = CvSTART(PL_compcv);
8767 CvSTART(PL_compcv) = cvstart;
8768 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8769 CvFLAGS(PL_compcv) |= other_flags;
8771 if (CvFILE(cv) && CvDYNFILE(cv)) {
8772 Safefree(CvFILE(cv));
8774 CvFILE_set_from_cop(cv, PL_curcop);
8775 CvSTASH_set(cv, PL_curstash);
8777 /* inner references to PL_compcv must be fixed up ... */
8778 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8779 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8780 ++PL_sub_generation;
8783 /* Might have had built-in attributes applied -- propagate them. */
8784 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8786 /* ... before we throw it away */
8787 SvREFCNT_dec(PL_compcv);
8792 if (name && isGV(gv)) {
8795 if (HvENAME_HEK(GvSTASH(gv)))
8796 /* sub Foo::bar { (shift)+1 } */
8797 gv_method_changed(gv);
8801 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8802 prepare_SV_for_RV((SV *)gv);
8806 SvRV_set(gv, (SV *)cv);
8816 PERL_HASH(hash, name, namlen);
8817 CvNAME_HEK_set(cv, share_hek(name,
8823 CvFILE_set_from_cop(cv, PL_curcop);
8824 CvSTASH_set(cv, PL_curstash);
8828 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8830 SvUTF8_on(MUTABLE_SV(cv));
8834 /* If we assign an optree to a PVCV, then we've defined a
8835 * subroutine that the debugger could be able to set a breakpoint
8836 * in, so signal to pp_entereval that it should not throw away any
8837 * saved lines at scope exit. */
8839 PL_breakable_sub_gen++;
8841 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8842 OpREFCNT_set(CvROOT(cv), 1);
8843 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8844 itself has a refcount. */
8846 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8847 #ifdef PERL_DEBUG_READONLY_OPS
8848 slab = (OPSLAB *)CvSTART(cv);
8850 CvSTART(cv) = start;
8852 finalize_optree(CvROOT(cv));
8853 S_prune_chain_head(&CvSTART(cv));
8855 /* now that optimizer has done its work, adjust pad values */
8857 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8862 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8863 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8868 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8870 SvREFCNT_inc_simple_void_NN(cv);
8873 if (block && has_name) {
8874 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8875 SV * const tmpstr = cv_name(cv,NULL,0);
8876 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8877 GV_ADDMULTI, SVt_PVHV);
8879 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8882 (long)CopLINE(PL_curcop));
8883 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8884 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8885 hv = GvHVn(db_postponed);
8886 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8887 CV * const pcv = GvCV(db_postponed);
8893 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8899 if (PL_parser && PL_parser->error_count)
8900 clear_special_blocks(name, gv, cv);
8903 process_special_blocks(floor, name, gv, cv);
8909 PL_parser->copline = NOLINE;
8913 #ifdef PERL_DEBUG_READONLY_OPS
8917 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8918 pad_add_weakref(cv);
8924 S_clear_special_blocks(pTHX_ const char *const fullname,
8925 GV *const gv, CV *const cv) {
8929 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8931 colon = strrchr(fullname,':');
8932 name = colon ? colon + 1 : fullname;
8934 if ((*name == 'B' && strEQ(name, "BEGIN"))
8935 || (*name == 'E' && strEQ(name, "END"))
8936 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8937 || (*name == 'C' && strEQ(name, "CHECK"))
8938 || (*name == 'I' && strEQ(name, "INIT"))) {
8944 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8948 /* Returns true if the sub has been freed. */
8950 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8954 const char *const colon = strrchr(fullname,':');
8955 const char *const name = colon ? colon + 1 : fullname;
8957 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8960 if (strEQ(name, "BEGIN")) {
8961 const I32 oldscope = PL_scopestack_ix;
8964 if (floor) LEAVE_SCOPE(floor);
8966 PUSHSTACKi(PERLSI_REQUIRE);
8967 SAVECOPFILE(&PL_compiling);
8968 SAVECOPLINE(&PL_compiling);
8969 SAVEVPTR(PL_curcop);
8971 DEBUG_x( dump_sub(gv) );
8972 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8973 GvCV_set(gv,0); /* cv has been hijacked */
8974 call_list(oldscope, PL_beginav);
8978 return !PL_savebegin;
8984 if strEQ(name, "END") {
8985 DEBUG_x( dump_sub(gv) );
8986 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8989 } else if (*name == 'U') {
8990 if (strEQ(name, "UNITCHECK")) {
8991 /* It's never too late to run a unitcheck block */
8992 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8996 } else if (*name == 'C') {
8997 if (strEQ(name, "CHECK")) {
8999 /* diag_listed_as: Too late to run %s block */
9000 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
9001 "Too late to run CHECK block");
9002 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
9006 } else if (*name == 'I') {
9007 if (strEQ(name, "INIT")) {
9009 /* diag_listed_as: Too late to run %s block */
9010 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
9011 "Too late to run INIT block");
9012 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
9018 DEBUG_x( dump_sub(gv) );
9020 GvCV_set(gv,0); /* cv has been hijacked */
9026 =for apidoc newCONSTSUB
9028 See L</newCONSTSUB_flags>.
9034 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
9036 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
9040 =for apidoc newCONSTSUB_flags
9042 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
9043 eligible for inlining at compile-time.
9045 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
9047 The newly created subroutine takes ownership of a reference to the passed in
9050 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
9051 which won't be called if used as a destructor, but will suppress the overhead
9052 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
9059 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
9063 const char *const file = CopFILE(PL_curcop);
9067 if (IN_PERL_RUNTIME) {
9068 /* at runtime, it's not safe to manipulate PL_curcop: it may be
9069 * an op shared between threads. Use a non-shared COP for our
9071 SAVEVPTR(PL_curcop);
9072 SAVECOMPILEWARNINGS();
9073 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9074 PL_curcop = &PL_compiling;
9076 SAVECOPLINE(PL_curcop);
9077 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9080 PL_hints &= ~HINT_BLOCK_SCOPE;
9083 SAVEGENERICSV(PL_curstash);
9084 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9087 /* Protect sv against leakage caused by fatal warnings. */
9088 if (sv) SAVEFREESV(sv);
9090 /* file becomes the CvFILE. For an XS, it's usually static storage,
9091 and so doesn't get free()d. (It's expected to be from the C pre-
9092 processor __FILE__ directive). But we need a dynamically allocated one,
9093 and we need it to get freed. */
9094 cv = newXS_len_flags(name, len,
9095 sv && SvTYPE(sv) == SVt_PVAV
9098 file ? file : "", "",
9099 &sv, XS_DYNAMIC_FILENAME | flags);
9100 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9109 =for apidoc U||newXS
9111 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
9112 static storage, as it is used directly as CvFILE(), without a copy being made.
9118 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9120 PERL_ARGS_ASSERT_NEWXS;
9121 return newXS_len_flags(
9122 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9127 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9128 const char *const filename, const char *const proto,
9131 PERL_ARGS_ASSERT_NEWXS_FLAGS;
9132 return newXS_len_flags(
9133 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9138 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9140 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9141 return newXS_len_flags(
9142 name, strlen(name), subaddr, NULL, NULL, NULL, 0
9147 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9148 XSUBADDR_t subaddr, const char *const filename,
9149 const char *const proto, SV **const_svp,
9153 bool interleave = FALSE;
9155 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9158 GV * const gv = gv_fetchpvn(
9159 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9160 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9161 sizeof("__ANON__::__ANON__") - 1,
9162 GV_ADDMULTI | flags, SVt_PVCV);
9164 if ((cv = (name ? GvCV(gv) : NULL))) {
9166 /* just a cached method */
9170 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9171 /* already defined (or promised) */
9172 /* Redundant check that allows us to avoid creating an SV
9173 most of the time: */
9174 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9175 report_redefined_cv(newSVpvn_flags(
9176 name,len,(flags&SVf_UTF8)|SVs_TEMP
9187 if (cv) /* must reuse cv if autoloaded */
9190 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9194 if (HvENAME_HEK(GvSTASH(gv)))
9195 gv_method_changed(gv); /* newXS */
9201 /* XSUBs can't be perl lang/perl5db.pl debugged
9202 if (PERLDB_LINE_OR_SAVESRC)
9203 (void)gv_fetchfile(filename); */
9204 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9205 if (flags & XS_DYNAMIC_FILENAME) {
9207 CvFILE(cv) = savepv(filename);
9209 /* NOTE: not copied, as it is expected to be an external constant string */
9210 CvFILE(cv) = (char *)filename;
9213 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9214 CvFILE(cv) = (char*)PL_xsubfilename;
9217 CvXSUB(cv) = subaddr;
9218 #ifndef PERL_IMPLICIT_CONTEXT
9219 CvHSCXT(cv) = &PL_stack_sp;
9225 process_special_blocks(0, name, gv, cv);
9228 } /* <- not a conditional branch */
9231 sv_setpv(MUTABLE_SV(cv), proto);
9232 if (interleave) LEAVE;
9237 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9239 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9241 PERL_ARGS_ASSERT_NEWSTUB;
9245 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9246 gv_method_changed(gv);
9248 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9253 CvFILE_set_from_cop(cv, PL_curcop);
9254 CvSTASH_set(cv, PL_curstash);
9260 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9266 if (PL_parser && PL_parser->error_count) {
9272 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9273 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9276 if ((cv = GvFORM(gv))) {
9277 if (ckWARN(WARN_REDEFINE)) {
9278 const line_t oldline = CopLINE(PL_curcop);
9279 if (PL_parser && PL_parser->copline != NOLINE)
9280 CopLINE_set(PL_curcop, PL_parser->copline);
9282 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9283 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
9285 /* diag_listed_as: Format %s redefined */
9286 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9287 "Format STDOUT redefined");
9289 CopLINE_set(PL_curcop, oldline);
9294 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9296 CvFILE_set_from_cop(cv, PL_curcop);
9299 pad_tidy(padtidy_FORMAT);
9300 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9301 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9302 OpREFCNT_set(CvROOT(cv), 1);
9303 CvSTART(cv) = LINKLIST(CvROOT(cv));
9304 CvROOT(cv)->op_next = 0;
9305 CALL_PEEP(CvSTART(cv));
9306 finalize_optree(CvROOT(cv));
9307 S_prune_chain_head(&CvSTART(cv));
9313 PL_parser->copline = NOLINE;
9315 PL_compiling.cop_seq = 0;
9319 Perl_newANONLIST(pTHX_ OP *o)
9321 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9325 Perl_newANONHASH(pTHX_ OP *o)
9327 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9331 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9333 return newANONATTRSUB(floor, proto, NULL, block);
9337 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9339 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9341 newSVOP(OP_ANONCODE, 0,
9343 if (CvANONCONST(cv))
9344 anoncode = newUNOP(OP_ANONCONST, 0,
9345 op_convert_list(OP_ENTERSUB,
9346 OPf_STACKED|OPf_WANT_SCALAR,
9348 return newUNOP(OP_REFGEN, 0, anoncode);
9352 Perl_oopsAV(pTHX_ OP *o)
9356 PERL_ARGS_ASSERT_OOPSAV;
9358 switch (o->op_type) {
9361 OpTYPE_set(o, OP_PADAV);
9362 return ref(o, OP_RV2AV);
9366 OpTYPE_set(o, OP_RV2AV);
9371 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9378 Perl_oopsHV(pTHX_ OP *o)
9382 PERL_ARGS_ASSERT_OOPSHV;
9384 switch (o->op_type) {
9387 OpTYPE_set(o, OP_PADHV);
9388 return ref(o, OP_RV2HV);
9392 OpTYPE_set(o, OP_RV2HV);
9397 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9404 Perl_newAVREF(pTHX_ OP *o)
9408 PERL_ARGS_ASSERT_NEWAVREF;
9410 if (o->op_type == OP_PADANY) {
9411 OpTYPE_set(o, OP_PADAV);
9414 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9415 Perl_croak(aTHX_ "Can't use an array as a reference");
9417 return newUNOP(OP_RV2AV, 0, scalar(o));
9421 Perl_newGVREF(pTHX_ I32 type, OP *o)
9423 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9424 return newUNOP(OP_NULL, 0, o);
9425 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9429 Perl_newHVREF(pTHX_ OP *o)
9433 PERL_ARGS_ASSERT_NEWHVREF;
9435 if (o->op_type == OP_PADANY) {
9436 OpTYPE_set(o, OP_PADHV);
9439 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9440 Perl_croak(aTHX_ "Can't use a hash as a reference");
9442 return newUNOP(OP_RV2HV, 0, scalar(o));
9446 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9448 if (o->op_type == OP_PADANY) {
9450 OpTYPE_set(o, OP_PADCV);
9452 return newUNOP(OP_RV2CV, flags, scalar(o));
9456 Perl_newSVREF(pTHX_ OP *o)
9460 PERL_ARGS_ASSERT_NEWSVREF;
9462 if (o->op_type == OP_PADANY) {
9463 OpTYPE_set(o, OP_PADSV);
9467 return newUNOP(OP_RV2SV, 0, scalar(o));
9470 /* Check routines. See the comments at the top of this file for details
9471 * on when these are called */
9474 Perl_ck_anoncode(pTHX_ OP *o)
9476 PERL_ARGS_ASSERT_CK_ANONCODE;
9478 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9479 cSVOPo->op_sv = NULL;
9484 S_io_hints(pTHX_ OP *o)
9486 #if O_BINARY != 0 || O_TEXT != 0
9488 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9490 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9493 const char *d = SvPV_const(*svp, len);
9494 const I32 mode = mode_from_discipline(d, len);
9495 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9497 if (mode & O_BINARY)
9498 o->op_private |= OPpOPEN_IN_RAW;
9502 o->op_private |= OPpOPEN_IN_CRLF;
9506 svp = hv_fetchs(table, "open_OUT", FALSE);
9509 const char *d = SvPV_const(*svp, len);
9510 const I32 mode = mode_from_discipline(d, len);
9511 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9513 if (mode & O_BINARY)
9514 o->op_private |= OPpOPEN_OUT_RAW;
9518 o->op_private |= OPpOPEN_OUT_CRLF;
9523 PERL_UNUSED_CONTEXT;
9529 Perl_ck_backtick(pTHX_ OP *o)
9534 PERL_ARGS_ASSERT_CK_BACKTICK;
9535 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9536 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9537 && (gv = gv_override("readpipe",8)))
9539 /* detach rest of siblings from o and its first child */
9540 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9541 newop = S_new_entersubop(aTHX_ gv, sibl);
9543 else if (!(o->op_flags & OPf_KIDS))
9544 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9549 S_io_hints(aTHX_ o);
9554 Perl_ck_bitop(pTHX_ OP *o)
9556 PERL_ARGS_ASSERT_CK_BITOP;
9558 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9560 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9561 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9562 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9563 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9564 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9565 "The bitwise feature is experimental");
9566 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9567 && OP_IS_INFIX_BIT(o->op_type))
9569 const OP * const left = cBINOPo->op_first;
9570 const OP * const right = OpSIBLING(left);
9571 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9572 (left->op_flags & OPf_PARENS) == 0) ||
9573 (OP_IS_NUMCOMPARE(right->op_type) &&
9574 (right->op_flags & OPf_PARENS) == 0))
9575 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9576 "Possible precedence problem on bitwise %s operator",
9577 o->op_type == OP_BIT_OR
9578 ||o->op_type == OP_NBIT_OR ? "|"
9579 : o->op_type == OP_BIT_AND
9580 ||o->op_type == OP_NBIT_AND ? "&"
9581 : o->op_type == OP_BIT_XOR
9582 ||o->op_type == OP_NBIT_XOR ? "^"
9583 : o->op_type == OP_SBIT_OR ? "|."
9584 : o->op_type == OP_SBIT_AND ? "&." : "^."
9590 PERL_STATIC_INLINE bool
9591 is_dollar_bracket(pTHX_ const OP * const o)
9594 PERL_UNUSED_CONTEXT;
9595 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9596 && (kid = cUNOPx(o)->op_first)
9597 && kid->op_type == OP_GV
9598 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9602 Perl_ck_cmp(pTHX_ OP *o)
9604 PERL_ARGS_ASSERT_CK_CMP;
9605 if (ckWARN(WARN_SYNTAX)) {
9606 const OP *kid = cUNOPo->op_first;
9609 ( is_dollar_bracket(aTHX_ kid)
9610 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9612 || ( kid->op_type == OP_CONST
9613 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9617 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9618 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9624 Perl_ck_concat(pTHX_ OP *o)
9626 const OP * const kid = cUNOPo->op_first;
9628 PERL_ARGS_ASSERT_CK_CONCAT;
9629 PERL_UNUSED_CONTEXT;
9631 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9632 !(kUNOP->op_first->op_flags & OPf_MOD))
9633 o->op_flags |= OPf_STACKED;
9638 Perl_ck_spair(pTHX_ OP *o)
9642 PERL_ARGS_ASSERT_CK_SPAIR;
9644 if (o->op_flags & OPf_KIDS) {
9648 const OPCODE type = o->op_type;
9649 o = modkids(ck_fun(o), type);
9650 kid = cUNOPo->op_first;
9651 kidkid = kUNOP->op_first;
9652 newop = OpSIBLING(kidkid);
9654 const OPCODE type = newop->op_type;
9655 if (OpHAS_SIBLING(newop))
9657 if (o->op_type == OP_REFGEN
9658 && ( type == OP_RV2CV
9659 || ( !(newop->op_flags & OPf_PARENS)
9660 && ( type == OP_RV2AV || type == OP_PADAV
9661 || type == OP_RV2HV || type == OP_PADHV))))
9662 NOOP; /* OK (allow srefgen for \@a and \%h) */
9663 else if (OP_GIMME(newop,0) != G_SCALAR)
9666 /* excise first sibling */
9667 op_sibling_splice(kid, NULL, 1, NULL);
9670 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9671 * and OP_CHOMP into OP_SCHOMP */
9672 o->op_ppaddr = PL_ppaddr[++o->op_type];
9677 Perl_ck_delete(pTHX_ OP *o)
9679 PERL_ARGS_ASSERT_CK_DELETE;
9683 if (o->op_flags & OPf_KIDS) {
9684 OP * const kid = cUNOPo->op_first;
9685 switch (kid->op_type) {
9687 o->op_flags |= OPf_SPECIAL;
9690 o->op_private |= OPpSLICE;
9693 o->op_flags |= OPf_SPECIAL;
9698 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9699 " use array slice");
9701 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9704 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9705 "element or slice");
9707 if (kid->op_private & OPpLVAL_INTRO)
9708 o->op_private |= OPpLVAL_INTRO;
9715 Perl_ck_eof(pTHX_ OP *o)
9717 PERL_ARGS_ASSERT_CK_EOF;
9719 if (o->op_flags & OPf_KIDS) {
9721 if (cLISTOPo->op_first->op_type == OP_STUB) {
9723 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9728 kid = cLISTOPo->op_first;
9729 if (kid->op_type == OP_RV2GV)
9730 kid->op_private |= OPpALLOW_FAKE;
9736 Perl_ck_eval(pTHX_ OP *o)
9740 PERL_ARGS_ASSERT_CK_EVAL;
9742 PL_hints |= HINT_BLOCK_SCOPE;
9743 if (o->op_flags & OPf_KIDS) {
9744 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9747 if (o->op_type == OP_ENTERTRY) {
9750 /* cut whole sibling chain free from o */
9751 op_sibling_splice(o, NULL, -1, NULL);
9754 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
9756 /* establish postfix order */
9757 enter->op_next = (OP*)enter;
9759 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9760 OpTYPE_set(o, OP_LEAVETRY);
9761 enter->op_other = o;
9766 S_set_haseval(aTHX);
9770 const U8 priv = o->op_private;
9772 /* the newUNOP will recursively call ck_eval(), which will handle
9773 * all the stuff at the end of this function, like adding
9776 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9778 o->op_targ = (PADOFFSET)PL_hints;
9779 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9780 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9781 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9782 /* Store a copy of %^H that pp_entereval can pick up. */
9783 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9784 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9785 /* append hhop to only child */
9786 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9788 o->op_private |= OPpEVAL_HAS_HH;
9790 if (!(o->op_private & OPpEVAL_BYTES)
9791 && FEATURE_UNIEVAL_IS_ENABLED)
9792 o->op_private |= OPpEVAL_UNICODE;
9797 Perl_ck_exec(pTHX_ OP *o)
9799 PERL_ARGS_ASSERT_CK_EXEC;
9801 if (o->op_flags & OPf_STACKED) {
9804 kid = OpSIBLING(cUNOPo->op_first);
9805 if (kid->op_type == OP_RV2GV)
9814 Perl_ck_exists(pTHX_ OP *o)
9816 PERL_ARGS_ASSERT_CK_EXISTS;
9819 if (o->op_flags & OPf_KIDS) {
9820 OP * const kid = cUNOPo->op_first;
9821 if (kid->op_type == OP_ENTERSUB) {
9822 (void) ref(kid, o->op_type);
9823 if (kid->op_type != OP_RV2CV
9824 && !(PL_parser && PL_parser->error_count))
9826 "exists argument is not a subroutine name");
9827 o->op_private |= OPpEXISTS_SUB;
9829 else if (kid->op_type == OP_AELEM)
9830 o->op_flags |= OPf_SPECIAL;
9831 else if (kid->op_type != OP_HELEM)
9832 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9833 "element or a subroutine");
9840 Perl_ck_rvconst(pTHX_ OP *o)
9843 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9845 PERL_ARGS_ASSERT_CK_RVCONST;
9847 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9849 if (kid->op_type == OP_CONST) {
9852 SV * const kidsv = kid->op_sv;
9854 /* Is it a constant from cv_const_sv()? */
9855 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9858 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9859 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9860 const char *badthing;
9861 switch (o->op_type) {
9863 badthing = "a SCALAR";
9866 badthing = "an ARRAY";
9869 badthing = "a HASH";
9877 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
9878 SVfARG(kidsv), badthing);
9881 * This is a little tricky. We only want to add the symbol if we
9882 * didn't add it in the lexer. Otherwise we get duplicate strict
9883 * warnings. But if we didn't add it in the lexer, we must at
9884 * least pretend like we wanted to add it even if it existed before,
9885 * or we get possible typo warnings. OPpCONST_ENTERED says
9886 * whether the lexer already added THIS instance of this symbol.
9888 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9889 gv = gv_fetchsv(kidsv,
9890 o->op_type == OP_RV2CV
9891 && o->op_private & OPpMAY_RETURN_CONSTANT
9893 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9896 : o->op_type == OP_RV2SV
9898 : o->op_type == OP_RV2AV
9900 : o->op_type == OP_RV2HV
9907 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9908 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9909 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9911 OpTYPE_set(kid, OP_GV);
9912 SvREFCNT_dec(kid->op_sv);
9914 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9915 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9916 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9917 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9918 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9920 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9922 kid->op_private = 0;
9923 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9931 Perl_ck_ftst(pTHX_ OP *o)
9934 const I32 type = o->op_type;
9936 PERL_ARGS_ASSERT_CK_FTST;
9938 if (o->op_flags & OPf_REF) {
9941 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9942 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9943 const OPCODE kidtype = kid->op_type;
9945 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9946 && !kid->op_folded) {
9947 OP * const newop = newGVOP(type, OPf_REF,
9948 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9953 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9954 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9956 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9957 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9958 array_passed_to_stat, name);
9961 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9962 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9966 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9967 o->op_private |= OPpFT_ACCESS;
9968 if (type != OP_STAT && type != OP_LSTAT
9969 && PL_check[kidtype] == Perl_ck_ftst
9970 && kidtype != OP_STAT && kidtype != OP_LSTAT
9972 o->op_private |= OPpFT_STACKED;
9973 kid->op_private |= OPpFT_STACKING;
9974 if (kidtype == OP_FTTTY && (
9975 !(kid->op_private & OPpFT_STACKED)
9976 || kid->op_private & OPpFT_AFTER_t
9978 o->op_private |= OPpFT_AFTER_t;
9983 if (type == OP_FTTTY)
9984 o = newGVOP(type, OPf_REF, PL_stdingv);
9986 o = newUNOP(type, 0, newDEFSVOP());
9992 Perl_ck_fun(pTHX_ OP *o)
9994 const int type = o->op_type;
9995 I32 oa = PL_opargs[type] >> OASHIFT;
9997 PERL_ARGS_ASSERT_CK_FUN;
9999 if (o->op_flags & OPf_STACKED) {
10000 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
10001 oa &= ~OA_OPTIONAL;
10003 return no_fh_allowed(o);
10006 if (o->op_flags & OPf_KIDS) {
10007 OP *prev_kid = NULL;
10008 OP *kid = cLISTOPo->op_first;
10010 bool seen_optional = FALSE;
10012 if (kid->op_type == OP_PUSHMARK ||
10013 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
10016 kid = OpSIBLING(kid);
10018 if (kid && kid->op_type == OP_COREARGS) {
10019 bool optional = FALSE;
10022 if (oa & OA_OPTIONAL) optional = TRUE;
10025 if (optional) o->op_private |= numargs;
10030 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
10031 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
10032 kid = newDEFSVOP();
10033 /* append kid to chain */
10034 op_sibling_splice(o, prev_kid, 0, kid);
10036 seen_optional = TRUE;
10043 /* list seen where single (scalar) arg expected? */
10044 if (numargs == 1 && !(oa >> 4)
10045 && kid->op_type == OP_LIST && type != OP_SCALAR)
10047 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10049 if (type != OP_DELETE) scalar(kid);
10060 if ((type == OP_PUSH || type == OP_UNSHIFT)
10061 && !OpHAS_SIBLING(kid))
10062 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10063 "Useless use of %s with no values",
10066 if (kid->op_type == OP_CONST
10067 && ( !SvROK(cSVOPx_sv(kid))
10068 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
10070 bad_type_pv(numargs, "array", o, kid);
10071 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
10072 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
10073 PL_op_desc[type]), 0);
10076 op_lvalue(kid, type);
10080 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
10081 bad_type_pv(numargs, "hash", o, kid);
10082 op_lvalue(kid, type);
10086 /* replace kid with newop in chain */
10088 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10089 newop->op_next = newop;
10094 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10095 if (kid->op_type == OP_CONST &&
10096 (kid->op_private & OPpCONST_BARE))
10098 OP * const newop = newGVOP(OP_GV, 0,
10099 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10100 /* replace kid with newop in chain */
10101 op_sibling_splice(o, prev_kid, 1, newop);
10105 else if (kid->op_type == OP_READLINE) {
10106 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10107 bad_type_pv(numargs, "HANDLE", o, kid);
10110 I32 flags = OPf_SPECIAL;
10112 PADOFFSET targ = 0;
10114 /* is this op a FH constructor? */
10115 if (is_handle_constructor(o,numargs)) {
10116 const char *name = NULL;
10119 bool want_dollar = TRUE;
10122 /* Set a flag to tell rv2gv to vivify
10123 * need to "prove" flag does not mean something
10124 * else already - NI-S 1999/05/07
10127 if (kid->op_type == OP_PADSV) {
10129 = PAD_COMPNAME_SV(kid->op_targ);
10130 name = PadnamePV (pn);
10131 len = PadnameLEN(pn);
10132 name_utf8 = PadnameUTF8(pn);
10134 else if (kid->op_type == OP_RV2SV
10135 && kUNOP->op_first->op_type == OP_GV)
10137 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10139 len = GvNAMELEN(gv);
10140 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10142 else if (kid->op_type == OP_AELEM
10143 || kid->op_type == OP_HELEM)
10146 OP *op = ((BINOP*)kid)->op_first;
10150 const char * const a =
10151 kid->op_type == OP_AELEM ?
10153 if (((op->op_type == OP_RV2AV) ||
10154 (op->op_type == OP_RV2HV)) &&
10155 (firstop = ((UNOP*)op)->op_first) &&
10156 (firstop->op_type == OP_GV)) {
10157 /* packagevar $a[] or $h{} */
10158 GV * const gv = cGVOPx_gv(firstop);
10161 Perl_newSVpvf(aTHX_
10166 else if (op->op_type == OP_PADAV
10167 || op->op_type == OP_PADHV) {
10168 /* lexicalvar $a[] or $h{} */
10169 const char * const padname =
10170 PAD_COMPNAME_PV(op->op_targ);
10173 Perl_newSVpvf(aTHX_
10179 name = SvPV_const(tmpstr, len);
10180 name_utf8 = SvUTF8(tmpstr);
10181 sv_2mortal(tmpstr);
10185 name = "__ANONIO__";
10187 want_dollar = FALSE;
10189 op_lvalue(kid, type);
10193 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10194 namesv = PAD_SVl(targ);
10195 if (want_dollar && *name != '$')
10196 sv_setpvs(namesv, "$");
10199 sv_catpvn(namesv, name, len);
10200 if ( name_utf8 ) SvUTF8_on(namesv);
10204 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10206 kid->op_targ = targ;
10207 kid->op_private |= priv;
10213 if ((type == OP_UNDEF || type == OP_POS)
10214 && numargs == 1 && !(oa >> 4)
10215 && kid->op_type == OP_LIST)
10216 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10217 op_lvalue(scalar(kid), type);
10222 kid = OpSIBLING(kid);
10224 /* FIXME - should the numargs or-ing move after the too many
10225 * arguments check? */
10226 o->op_private |= numargs;
10228 return too_many_arguments_pv(o,OP_DESC(o), 0);
10231 else if (PL_opargs[type] & OA_DEFGV) {
10232 /* Ordering of these two is important to keep f_map.t passing. */
10234 return newUNOP(type, 0, newDEFSVOP());
10238 while (oa & OA_OPTIONAL)
10240 if (oa && oa != OA_LIST)
10241 return too_few_arguments_pv(o,OP_DESC(o), 0);
10247 Perl_ck_glob(pTHX_ OP *o)
10251 PERL_ARGS_ASSERT_CK_GLOB;
10254 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10255 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10257 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10261 * \ null - const(wildcard)
10266 * \ mark - glob - rv2cv
10267 * | \ gv(CORE::GLOBAL::glob)
10269 * \ null - const(wildcard)
10271 o->op_flags |= OPf_SPECIAL;
10272 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10273 o = S_new_entersubop(aTHX_ gv, o);
10274 o = newUNOP(OP_NULL, 0, o);
10275 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10278 else o->op_flags &= ~OPf_SPECIAL;
10279 #if !defined(PERL_EXTERNAL_GLOB)
10280 if (!PL_globhook) {
10282 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10283 newSVpvs("File::Glob"), NULL, NULL, NULL);
10286 #endif /* !PERL_EXTERNAL_GLOB */
10287 gv = (GV *)newSV(0);
10288 gv_init(gv, 0, "", 0, 0);
10290 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10291 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10297 Perl_ck_grep(pTHX_ OP *o)
10301 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10303 PERL_ARGS_ASSERT_CK_GREP;
10305 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10307 if (o->op_flags & OPf_STACKED) {
10308 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10309 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10310 return no_fh_allowed(o);
10311 o->op_flags &= ~OPf_STACKED;
10313 kid = OpSIBLING(cLISTOPo->op_first);
10314 if (type == OP_MAPWHILE)
10319 if (PL_parser && PL_parser->error_count)
10321 kid = OpSIBLING(cLISTOPo->op_first);
10322 if (kid->op_type != OP_NULL)
10323 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10324 kid = kUNOP->op_first;
10326 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
10327 kid->op_next = (OP*)gwop;
10328 o->op_private = gwop->op_private = 0;
10329 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10331 kid = OpSIBLING(cLISTOPo->op_first);
10332 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10333 op_lvalue(kid, OP_GREPSTART);
10339 Perl_ck_index(pTHX_ OP *o)
10341 PERL_ARGS_ASSERT_CK_INDEX;
10343 if (o->op_flags & OPf_KIDS) {
10344 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10346 kid = OpSIBLING(kid); /* get past "big" */
10347 if (kid && kid->op_type == OP_CONST) {
10348 const bool save_taint = TAINT_get;
10349 SV *sv = kSVOP->op_sv;
10350 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10352 sv_copypv(sv, kSVOP->op_sv);
10353 SvREFCNT_dec_NN(kSVOP->op_sv);
10356 if (SvOK(sv)) fbm_compile(sv, 0);
10357 TAINT_set(save_taint);
10358 #ifdef NO_TAINT_SUPPORT
10359 PERL_UNUSED_VAR(save_taint);
10367 Perl_ck_lfun(pTHX_ OP *o)
10369 const OPCODE type = o->op_type;
10371 PERL_ARGS_ASSERT_CK_LFUN;
10373 return modkids(ck_fun(o), type);
10377 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10379 PERL_ARGS_ASSERT_CK_DEFINED;
10381 if ((o->op_flags & OPf_KIDS)) {
10382 switch (cUNOPo->op_first->op_type) {
10385 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10386 " (Maybe you should just omit the defined()?)");
10387 NOT_REACHED; /* NOTREACHED */
10391 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10392 " (Maybe you should just omit the defined()?)");
10393 NOT_REACHED; /* NOTREACHED */
10404 Perl_ck_readline(pTHX_ OP *o)
10406 PERL_ARGS_ASSERT_CK_READLINE;
10408 if (o->op_flags & OPf_KIDS) {
10409 OP *kid = cLISTOPo->op_first;
10410 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10414 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10422 Perl_ck_rfun(pTHX_ OP *o)
10424 const OPCODE type = o->op_type;
10426 PERL_ARGS_ASSERT_CK_RFUN;
10428 return refkids(ck_fun(o), type);
10432 Perl_ck_listiob(pTHX_ OP *o)
10436 PERL_ARGS_ASSERT_CK_LISTIOB;
10438 kid = cLISTOPo->op_first;
10440 o = force_list(o, 1);
10441 kid = cLISTOPo->op_first;
10443 if (kid->op_type == OP_PUSHMARK)
10444 kid = OpSIBLING(kid);
10445 if (kid && o->op_flags & OPf_STACKED)
10446 kid = OpSIBLING(kid);
10447 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10448 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10449 && !kid->op_folded) {
10450 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10452 /* replace old const op with new OP_RV2GV parent */
10453 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10454 OP_RV2GV, OPf_REF);
10455 kid = OpSIBLING(kid);
10460 op_append_elem(o->op_type, o, newDEFSVOP());
10462 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10463 return listkids(o);
10467 Perl_ck_smartmatch(pTHX_ OP *o)
10470 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10471 if (0 == (o->op_flags & OPf_SPECIAL)) {
10472 OP *first = cBINOPo->op_first;
10473 OP *second = OpSIBLING(first);
10475 /* Implicitly take a reference to an array or hash */
10477 /* remove the original two siblings, then add back the
10478 * (possibly different) first and second sibs.
10480 op_sibling_splice(o, NULL, 1, NULL);
10481 op_sibling_splice(o, NULL, 1, NULL);
10482 first = ref_array_or_hash(first);
10483 second = ref_array_or_hash(second);
10484 op_sibling_splice(o, NULL, 0, second);
10485 op_sibling_splice(o, NULL, 0, first);
10487 /* Implicitly take a reference to a regular expression */
10488 if (first->op_type == OP_MATCH) {
10489 OpTYPE_set(first, OP_QR);
10491 if (second->op_type == OP_MATCH) {
10492 OpTYPE_set(second, OP_QR);
10501 S_maybe_targlex(pTHX_ OP *o)
10503 OP * const kid = cLISTOPo->op_first;
10504 /* has a disposable target? */
10505 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10506 && !(kid->op_flags & OPf_STACKED)
10507 /* Cannot steal the second time! */
10508 && !(kid->op_private & OPpTARGET_MY)
10511 OP * const kkid = OpSIBLING(kid);
10513 /* Can just relocate the target. */
10514 if (kkid && kkid->op_type == OP_PADSV
10515 && (!(kkid->op_private & OPpLVAL_INTRO)
10516 || kkid->op_private & OPpPAD_STATE))
10518 kid->op_targ = kkid->op_targ;
10520 /* Now we do not need PADSV and SASSIGN.
10521 * Detach kid and free the rest. */
10522 op_sibling_splice(o, NULL, 1, NULL);
10524 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10532 Perl_ck_sassign(pTHX_ OP *o)
10535 OP * const kid = cBINOPo->op_first;
10537 PERL_ARGS_ASSERT_CK_SASSIGN;
10539 if (OpHAS_SIBLING(kid)) {
10540 OP *kkid = OpSIBLING(kid);
10541 /* For state variable assignment with attributes, kkid is a list op
10542 whose op_last is a padsv. */
10543 if ((kkid->op_type == OP_PADSV ||
10544 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10545 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10548 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10549 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10550 const PADOFFSET target = kkid->op_targ;
10551 OP *const other = newOP(OP_PADSV,
10553 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10554 OP *const first = newOP(OP_NULL, 0);
10556 newCONDOP(0, first, o, other);
10557 /* XXX targlex disabled for now; see ticket #124160
10558 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10560 OP *const condop = first->op_next;
10562 OpTYPE_set(condop, OP_ONCE);
10563 other->op_targ = target;
10564 nullop->op_flags |= OPf_WANT_SCALAR;
10566 /* Store the initializedness of state vars in a separate
10569 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10570 /* hijacking PADSTALE for uninitialized state variables */
10571 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10576 return S_maybe_targlex(aTHX_ o);
10580 Perl_ck_match(pTHX_ OP *o)
10582 PERL_UNUSED_CONTEXT;
10583 PERL_ARGS_ASSERT_CK_MATCH;
10589 Perl_ck_method(pTHX_ OP *o)
10591 SV *sv, *methsv, *rclass;
10592 const char* method;
10595 STRLEN len, nsplit = 0, i;
10597 OP * const kid = cUNOPo->op_first;
10599 PERL_ARGS_ASSERT_CK_METHOD;
10600 if (kid->op_type != OP_CONST) return o;
10604 /* replace ' with :: */
10605 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10607 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10610 method = SvPVX_const(sv);
10612 utf8 = SvUTF8(sv) ? -1 : 1;
10614 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10619 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10621 if (!nsplit) { /* $proto->method() */
10623 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10626 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10628 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10631 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10632 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10633 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10634 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10636 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10637 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10639 #ifdef USE_ITHREADS
10640 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10642 cMETHOPx(new_op)->op_rclass_sv = rclass;
10649 Perl_ck_null(pTHX_ OP *o)
10651 PERL_ARGS_ASSERT_CK_NULL;
10652 PERL_UNUSED_CONTEXT;
10657 Perl_ck_open(pTHX_ OP *o)
10659 PERL_ARGS_ASSERT_CK_OPEN;
10661 S_io_hints(aTHX_ o);
10663 /* In case of three-arg dup open remove strictness
10664 * from the last arg if it is a bareword. */
10665 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10666 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10670 if ((last->op_type == OP_CONST) && /* The bareword. */
10671 (last->op_private & OPpCONST_BARE) &&
10672 (last->op_private & OPpCONST_STRICT) &&
10673 (oa = OpSIBLING(first)) && /* The fh. */
10674 (oa = OpSIBLING(oa)) && /* The mode. */
10675 (oa->op_type == OP_CONST) &&
10676 SvPOK(((SVOP*)oa)->op_sv) &&
10677 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10678 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10679 (last == OpSIBLING(oa))) /* The bareword. */
10680 last->op_private &= ~OPpCONST_STRICT;
10686 Perl_ck_prototype(pTHX_ OP *o)
10688 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10689 if (!(o->op_flags & OPf_KIDS)) {
10691 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10697 Perl_ck_refassign(pTHX_ OP *o)
10699 OP * const right = cLISTOPo->op_first;
10700 OP * const left = OpSIBLING(right);
10701 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10704 PERL_ARGS_ASSERT_CK_REFASSIGN;
10706 assert (left->op_type == OP_SREFGEN);
10709 /* we use OPpPAD_STATE in refassign to mean either of those things,
10710 * and the code assumes the two flags occupy the same bit position
10711 * in the various ops below */
10712 assert(OPpPAD_STATE == OPpOUR_INTRO);
10714 switch (varop->op_type) {
10716 o->op_private |= OPpLVREF_AV;
10719 o->op_private |= OPpLVREF_HV;
10723 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10724 o->op_targ = varop->op_targ;
10725 varop->op_targ = 0;
10726 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10730 o->op_private |= OPpLVREF_AV;
10732 NOT_REACHED; /* NOTREACHED */
10734 o->op_private |= OPpLVREF_HV;
10738 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10739 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10741 /* Point varop to its GV kid, detached. */
10742 varop = op_sibling_splice(varop, NULL, -1, NULL);
10746 OP * const kidparent =
10747 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10748 OP * const kid = cUNOPx(kidparent)->op_first;
10749 o->op_private |= OPpLVREF_CV;
10750 if (kid->op_type == OP_GV) {
10752 goto detach_and_stack;
10754 if (kid->op_type != OP_PADCV) goto bad;
10755 o->op_targ = kid->op_targ;
10761 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10762 o->op_private |= OPpLVREF_ELEM;
10765 /* Detach varop. */
10766 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10770 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10771 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10776 if (!FEATURE_REFALIASING_IS_ENABLED)
10778 "Experimental aliasing via reference not enabled");
10779 Perl_ck_warner_d(aTHX_
10780 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10781 "Aliasing via reference is experimental");
10783 o->op_flags |= OPf_STACKED;
10784 op_sibling_splice(o, right, 1, varop);
10787 o->op_flags &=~ OPf_STACKED;
10788 op_sibling_splice(o, right, 1, NULL);
10795 Perl_ck_repeat(pTHX_ OP *o)
10797 PERL_ARGS_ASSERT_CK_REPEAT;
10799 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10801 o->op_private |= OPpREPEAT_DOLIST;
10802 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10803 kids = force_list(kids, 1); /* promote it to a list */
10804 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10812 Perl_ck_require(pTHX_ OP *o)
10816 PERL_ARGS_ASSERT_CK_REQUIRE;
10818 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10819 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10824 if (kid->op_type == OP_CONST) {
10825 SV * const sv = kid->op_sv;
10826 U32 const was_readonly = SvREADONLY(sv);
10827 if (kid->op_private & OPpCONST_BARE) {
10831 if (was_readonly) {
10832 SvREADONLY_off(sv);
10834 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10839 /* treat ::foo::bar as foo::bar */
10840 if (len >= 2 && s[0] == ':' && s[1] == ':')
10841 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10843 DIE(aTHX_ "Bareword in require maps to empty filename");
10845 for (; s < end; s++) {
10846 if (*s == ':' && s[1] == ':') {
10848 Move(s+2, s+1, end - s - 1, char);
10852 SvEND_set(sv, end);
10853 sv_catpvs(sv, ".pm");
10854 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10855 hek = share_hek(SvPVX(sv),
10856 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10858 sv_sethek(sv, hek);
10860 SvFLAGS(sv) |= was_readonly;
10862 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10865 if (SvREFCNT(sv) > 1) {
10866 kid->op_sv = newSVpvn_share(
10867 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10868 SvREFCNT_dec_NN(sv);
10872 if (was_readonly) SvREADONLY_off(sv);
10873 PERL_HASH(hash, s, len);
10875 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10877 sv_sethek(sv, hek);
10879 SvFLAGS(sv) |= was_readonly;
10885 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10886 /* handle override, if any */
10887 && (gv = gv_override("require", 7))) {
10889 if (o->op_flags & OPf_KIDS) {
10890 kid = cUNOPo->op_first;
10891 op_sibling_splice(o, NULL, -1, NULL);
10894 kid = newDEFSVOP();
10897 newop = S_new_entersubop(aTHX_ gv, kid);
10905 Perl_ck_return(pTHX_ OP *o)
10909 PERL_ARGS_ASSERT_CK_RETURN;
10911 kid = OpSIBLING(cLISTOPo->op_first);
10912 if (CvLVALUE(PL_compcv)) {
10913 for (; kid; kid = OpSIBLING(kid))
10914 op_lvalue(kid, OP_LEAVESUBLV);
10921 Perl_ck_select(pTHX_ OP *o)
10926 PERL_ARGS_ASSERT_CK_SELECT;
10928 if (o->op_flags & OPf_KIDS) {
10929 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10930 if (kid && OpHAS_SIBLING(kid)) {
10931 OpTYPE_set(o, OP_SSELECT);
10933 return fold_constants(op_integerize(op_std_init(o)));
10937 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10938 if (kid && kid->op_type == OP_RV2GV)
10939 kid->op_private &= ~HINT_STRICT_REFS;
10944 Perl_ck_shift(pTHX_ OP *o)
10946 const I32 type = o->op_type;
10948 PERL_ARGS_ASSERT_CK_SHIFT;
10950 if (!(o->op_flags & OPf_KIDS)) {
10953 if (!CvUNIQUE(PL_compcv)) {
10954 o->op_flags |= OPf_SPECIAL;
10958 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10960 return newUNOP(type, 0, scalar(argop));
10962 return scalar(ck_fun(o));
10966 Perl_ck_sort(pTHX_ OP *o)
10970 HV * const hinthv =
10971 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10974 PERL_ARGS_ASSERT_CK_SORT;
10977 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10979 const I32 sorthints = (I32)SvIV(*svp);
10980 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10981 o->op_private |= OPpSORT_QSORT;
10982 if ((sorthints & HINT_SORT_STABLE) != 0)
10983 o->op_private |= OPpSORT_STABLE;
10987 if (o->op_flags & OPf_STACKED)
10989 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10991 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10992 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10994 /* if the first arg is a code block, process it and mark sort as
10996 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10998 if (kid->op_type == OP_LEAVE)
10999 op_null(kid); /* wipe out leave */
11000 /* Prevent execution from escaping out of the sort block. */
11003 /* provide scalar context for comparison function/block */
11004 kid = scalar(firstkid);
11005 kid->op_next = kid;
11006 o->op_flags |= OPf_SPECIAL;
11008 else if (kid->op_type == OP_CONST
11009 && kid->op_private & OPpCONST_BARE) {
11013 const char * const name = SvPV(kSVOP_sv, len);
11015 assert (len < 256);
11016 Copy(name, tmpbuf+1, len, char);
11017 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
11018 if (off != NOT_IN_PAD) {
11019 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
11021 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
11022 sv_catpvs(fq, "::");
11023 sv_catsv(fq, kSVOP_sv);
11024 SvREFCNT_dec_NN(kSVOP_sv);
11028 OP * const padop = newOP(OP_PADCV, 0);
11029 padop->op_targ = off;
11030 /* replace the const op with the pad op */
11031 op_sibling_splice(firstkid, NULL, 1, padop);
11037 firstkid = OpSIBLING(firstkid);
11040 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
11041 /* provide list context for arguments */
11044 op_lvalue(kid, OP_GREPSTART);
11050 /* for sort { X } ..., where X is one of
11051 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
11052 * elide the second child of the sort (the one containing X),
11053 * and set these flags as appropriate
11057 * Also, check and warn on lexical $a, $b.
11061 S_simplify_sort(pTHX_ OP *o)
11063 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
11067 const char *gvname;
11070 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
11072 kid = kUNOP->op_first; /* get past null */
11073 if (!(have_scopeop = kid->op_type == OP_SCOPE)
11074 && kid->op_type != OP_LEAVE)
11076 kid = kLISTOP->op_last; /* get past scope */
11077 switch(kid->op_type) {
11081 if (!have_scopeop) goto padkids;
11086 k = kid; /* remember this node*/
11087 if (kBINOP->op_first->op_type != OP_RV2SV
11088 || kBINOP->op_last ->op_type != OP_RV2SV)
11091 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11092 then used in a comparison. This catches most, but not
11093 all cases. For instance, it catches
11094 sort { my($a); $a <=> $b }
11096 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11097 (although why you'd do that is anyone's guess).
11101 if (!ckWARN(WARN_SYNTAX)) return;
11102 kid = kBINOP->op_first;
11104 if (kid->op_type == OP_PADSV) {
11105 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11106 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11107 && ( PadnamePV(name)[1] == 'a'
11108 || PadnamePV(name)[1] == 'b' ))
11109 /* diag_listed_as: "my %s" used in sort comparison */
11110 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11111 "\"%s %s\" used in sort comparison",
11112 PadnameIsSTATE(name)
11117 } while ((kid = OpSIBLING(kid)));
11120 kid = kBINOP->op_first; /* get past cmp */
11121 if (kUNOP->op_first->op_type != OP_GV)
11123 kid = kUNOP->op_first; /* get past rv2sv */
11125 if (GvSTASH(gv) != PL_curstash)
11127 gvname = GvNAME(gv);
11128 if (*gvname == 'a' && gvname[1] == '\0')
11130 else if (*gvname == 'b' && gvname[1] == '\0')
11135 kid = k; /* back to cmp */
11136 /* already checked above that it is rv2sv */
11137 kid = kBINOP->op_last; /* down to 2nd arg */
11138 if (kUNOP->op_first->op_type != OP_GV)
11140 kid = kUNOP->op_first; /* get past rv2sv */
11142 if (GvSTASH(gv) != PL_curstash)
11144 gvname = GvNAME(gv);
11146 ? !(*gvname == 'a' && gvname[1] == '\0')
11147 : !(*gvname == 'b' && gvname[1] == '\0'))
11149 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11151 o->op_private |= OPpSORT_DESCEND;
11152 if (k->op_type == OP_NCMP)
11153 o->op_private |= OPpSORT_NUMERIC;
11154 if (k->op_type == OP_I_NCMP)
11155 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11156 kid = OpSIBLING(cLISTOPo->op_first);
11157 /* cut out and delete old block (second sibling) */
11158 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11163 Perl_ck_split(pTHX_ OP *o)
11169 PERL_ARGS_ASSERT_CK_SPLIT;
11171 assert(o->op_type == OP_LIST);
11173 if (o->op_flags & OPf_STACKED)
11174 return no_fh_allowed(o);
11176 kid = cLISTOPo->op_first;
11177 /* delete leading NULL node, then add a CONST if no other nodes */
11178 assert(kid->op_type == OP_NULL);
11179 op_sibling_splice(o, NULL, 1,
11180 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11182 kid = cLISTOPo->op_first;
11184 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11185 /* remove match expression, and replace with new optree with
11186 * a match op at its head */
11187 op_sibling_splice(o, NULL, 1, NULL);
11188 /* pmruntime will handle split " " behavior with flag==2 */
11189 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
11190 op_sibling_splice(o, NULL, 0, kid);
11193 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
11195 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11196 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11197 "Use of /g modifier is meaningless in split");
11200 /* eliminate the split op, and move the match op (plus any children)
11201 * into its place, then convert the match op into a split op. i.e.
11203 * SPLIT MATCH SPLIT(ex-MATCH)
11205 * MATCH - A - B - C => R - A - B - C => R - A - B - C
11211 * (R, if it exists, will be a regcomp op)
11214 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
11215 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
11216 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
11217 OpTYPE_set(kid, OP_SPLIT);
11218 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
11219 kid->op_private = o->op_private;
11222 kid = sibs; /* kid is now the string arg of the split */
11225 kid = newDEFSVOP();
11226 op_append_elem(OP_SPLIT, o, kid);
11230 kid = OpSIBLING(kid);
11232 kid = newSVOP(OP_CONST, 0, newSViv(0));
11233 op_append_elem(OP_SPLIT, o, kid);
11234 o->op_private |= OPpSPLIT_IMPLIM;
11238 if (OpHAS_SIBLING(kid))
11239 return too_many_arguments_pv(o,OP_DESC(o), 0);
11245 Perl_ck_stringify(pTHX_ OP *o)
11247 OP * const kid = OpSIBLING(cUNOPo->op_first);
11248 PERL_ARGS_ASSERT_CK_STRINGIFY;
11249 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11250 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11251 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11252 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11254 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11262 Perl_ck_join(pTHX_ OP *o)
11264 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11266 PERL_ARGS_ASSERT_CK_JOIN;
11268 if (kid && kid->op_type == OP_MATCH) {
11269 if (ckWARN(WARN_SYNTAX)) {
11270 const REGEXP *re = PM_GETRE(kPMOP);
11272 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11273 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11274 : newSVpvs_flags( "STRING", SVs_TEMP );
11275 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11276 "/%" SVf "/ should probably be written as \"%" SVf "\"",
11277 SVfARG(msg), SVfARG(msg));
11281 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11282 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11283 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11284 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11286 const OP * const bairn = OpSIBLING(kid); /* the list */
11287 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11288 && OP_GIMME(bairn,0) == G_SCALAR)
11290 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11291 op_sibling_splice(o, kid, 1, NULL));
11301 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11303 Examines an op, which is expected to identify a subroutine at runtime,
11304 and attempts to determine at compile time which subroutine it identifies.
11305 This is normally used during Perl compilation to determine whether
11306 a prototype can be applied to a function call. C<cvop> is the op
11307 being considered, normally an C<rv2cv> op. A pointer to the identified
11308 subroutine is returned, if it could be determined statically, and a null
11309 pointer is returned if it was not possible to determine statically.
11311 Currently, the subroutine can be identified statically if the RV that the
11312 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11313 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11314 suitable if the constant value must be an RV pointing to a CV. Details of
11315 this process may change in future versions of Perl. If the C<rv2cv> op
11316 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11317 the subroutine statically: this flag is used to suppress compile-time
11318 magic on a subroutine call, forcing it to use default runtime behaviour.
11320 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11321 of a GV reference is modified. If a GV was examined and its CV slot was
11322 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11323 If the op is not optimised away, and the CV slot is later populated with
11324 a subroutine having a prototype, that flag eventually triggers the warning
11325 "called too early to check prototype".
11327 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11328 of returning a pointer to the subroutine it returns a pointer to the
11329 GV giving the most appropriate name for the subroutine in this context.
11330 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11331 (C<CvANON>) subroutine that is referenced through a GV it will be the
11332 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11333 A null pointer is returned as usual if there is no statically-determinable
11339 /* shared by toke.c:yylex */
11341 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11343 PADNAME *name = PAD_COMPNAME(off);
11344 CV *compcv = PL_compcv;
11345 while (PadnameOUTER(name)) {
11346 assert(PARENT_PAD_INDEX(name));
11347 compcv = CvOUTSIDE(compcv);
11348 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11349 [off = PARENT_PAD_INDEX(name)];
11351 assert(!PadnameIsOUR(name));
11352 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11353 return PadnamePROTOCV(name);
11355 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11359 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11364 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11365 if (flags & ~RV2CVOPCV_FLAG_MASK)
11366 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11367 if (cvop->op_type != OP_RV2CV)
11369 if (cvop->op_private & OPpENTERSUB_AMPER)
11371 if (!(cvop->op_flags & OPf_KIDS))
11373 rvop = cUNOPx(cvop)->op_first;
11374 switch (rvop->op_type) {
11376 gv = cGVOPx_gv(rvop);
11378 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11379 cv = MUTABLE_CV(SvRV(gv));
11383 if (flags & RV2CVOPCV_RETURN_STUB)
11389 if (flags & RV2CVOPCV_MARK_EARLY)
11390 rvop->op_private |= OPpEARLY_CV;
11395 SV *rv = cSVOPx_sv(rvop);
11398 cv = (CV*)SvRV(rv);
11402 cv = find_lexical_cv(rvop->op_targ);
11407 } NOT_REACHED; /* NOTREACHED */
11409 if (SvTYPE((SV*)cv) != SVt_PVCV)
11411 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11412 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11413 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11422 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11424 Performs the default fixup of the arguments part of an C<entersub>
11425 op tree. This consists of applying list context to each of the
11426 argument ops. This is the standard treatment used on a call marked
11427 with C<&>, or a method call, or a call through a subroutine reference,
11428 or any other call where the callee can't be identified at compile time,
11429 or a call where the callee has no prototype.
11435 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11439 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11441 aop = cUNOPx(entersubop)->op_first;
11442 if (!OpHAS_SIBLING(aop))
11443 aop = cUNOPx(aop)->op_first;
11444 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11445 /* skip the extra attributes->import() call implicitly added in
11446 * something like foo(my $x : bar)
11448 if ( aop->op_type == OP_ENTERSUB
11449 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11453 op_lvalue(aop, OP_ENTERSUB);
11459 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11461 Performs the fixup of the arguments part of an C<entersub> op tree
11462 based on a subroutine prototype. This makes various modifications to
11463 the argument ops, from applying context up to inserting C<refgen> ops,
11464 and checking the number and syntactic types of arguments, as directed by
11465 the prototype. This is the standard treatment used on a subroutine call,
11466 not marked with C<&>, where the callee can be identified at compile time
11467 and has a prototype.
11469 C<protosv> supplies the subroutine prototype to be applied to the call.
11470 It may be a normal defined scalar, of which the string value will be used.
11471 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11472 that has been cast to C<SV*>) which has a prototype. The prototype
11473 supplied, in whichever form, does not need to match the actual callee
11474 referenced by the op tree.
11476 If the argument ops disagree with the prototype, for example by having
11477 an unacceptable number of arguments, a valid op tree is returned anyway.
11478 The error is reflected in the parser state, normally resulting in a single
11479 exception at the top level of parsing which covers all the compilation
11480 errors that occurred. In the error message, the callee is referred to
11481 by the name defined by the C<namegv> parameter.
11487 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11490 const char *proto, *proto_end;
11491 OP *aop, *prev, *cvop, *parent;
11494 I32 contextclass = 0;
11495 const char *e = NULL;
11496 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11497 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11498 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11499 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11500 if (SvTYPE(protosv) == SVt_PVCV)
11501 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11502 else proto = SvPV(protosv, proto_len);
11503 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11504 proto_end = proto + proto_len;
11505 parent = entersubop;
11506 aop = cUNOPx(entersubop)->op_first;
11507 if (!OpHAS_SIBLING(aop)) {
11509 aop = cUNOPx(aop)->op_first;
11512 aop = OpSIBLING(aop);
11513 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11514 while (aop != cvop) {
11517 if (proto >= proto_end)
11519 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11520 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
11521 SVfARG(namesv)), SvUTF8(namesv));
11531 /* _ must be at the end */
11532 if (proto[1] && !strchr(";@%", proto[1]))
11548 if ( o3->op_type != OP_UNDEF
11549 && (o3->op_type != OP_SREFGEN
11550 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11552 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11554 bad_type_gv(arg, namegv, o3,
11555 arg == 1 ? "block or sub {}" : "sub {}");
11558 /* '*' allows any scalar type, including bareword */
11561 if (o3->op_type == OP_RV2GV)
11562 goto wrapref; /* autoconvert GLOB -> GLOBref */
11563 else if (o3->op_type == OP_CONST)
11564 o3->op_private &= ~OPpCONST_STRICT;
11570 if (o3->op_type == OP_RV2AV ||
11571 o3->op_type == OP_PADAV ||
11572 o3->op_type == OP_RV2HV ||
11573 o3->op_type == OP_PADHV
11579 case '[': case ']':
11586 switch (*proto++) {
11588 if (contextclass++ == 0) {
11589 e = strchr(proto, ']');
11590 if (!e || e == proto)
11598 if (contextclass) {
11599 const char *p = proto;
11600 const char *const end = proto;
11602 while (*--p != '[')
11603 /* \[$] accepts any scalar lvalue */
11605 && Perl_op_lvalue_flags(aTHX_
11607 OP_READ, /* not entersub */
11610 bad_type_gv(arg, namegv, o3,
11611 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11616 if (o3->op_type == OP_RV2GV)
11619 bad_type_gv(arg, namegv, o3, "symbol");
11622 if (o3->op_type == OP_ENTERSUB
11623 && !(o3->op_flags & OPf_STACKED))
11626 bad_type_gv(arg, namegv, o3, "subroutine");
11629 if (o3->op_type == OP_RV2SV ||
11630 o3->op_type == OP_PADSV ||
11631 o3->op_type == OP_HELEM ||
11632 o3->op_type == OP_AELEM)
11634 if (!contextclass) {
11635 /* \$ accepts any scalar lvalue */
11636 if (Perl_op_lvalue_flags(aTHX_
11638 OP_READ, /* not entersub */
11641 bad_type_gv(arg, namegv, o3, "scalar");
11645 if (o3->op_type == OP_RV2AV ||
11646 o3->op_type == OP_PADAV)
11648 o3->op_flags &=~ OPf_PARENS;
11652 bad_type_gv(arg, namegv, o3, "array");
11655 if (o3->op_type == OP_RV2HV ||
11656 o3->op_type == OP_PADHV)
11658 o3->op_flags &=~ OPf_PARENS;
11662 bad_type_gv(arg, namegv, o3, "hash");
11665 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11667 if (contextclass && e) {
11672 default: goto oops;
11682 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
11683 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11688 op_lvalue(aop, OP_ENTERSUB);
11690 aop = OpSIBLING(aop);
11692 if (aop == cvop && *proto == '_') {
11693 /* generate an access to $_ */
11694 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11696 if (!optional && proto_end > proto &&
11697 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11699 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11700 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
11701 SVfARG(namesv)), SvUTF8(namesv));
11707 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11709 Performs the fixup of the arguments part of an C<entersub> op tree either
11710 based on a subroutine prototype or using default list-context processing.
11711 This is the standard treatment used on a subroutine call, not marked
11712 with C<&>, where the callee can be identified at compile time.
11714 C<protosv> supplies the subroutine prototype to be applied to the call,
11715 or indicates that there is no prototype. It may be a normal scalar,
11716 in which case if it is defined then the string value will be used
11717 as a prototype, and if it is undefined then there is no prototype.
11718 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11719 that has been cast to C<SV*>), of which the prototype will be used if it
11720 has one. The prototype (or lack thereof) supplied, in whichever form,
11721 does not need to match the actual callee referenced by the op tree.
11723 If the argument ops disagree with the prototype, for example by having
11724 an unacceptable number of arguments, a valid op tree is returned anyway.
11725 The error is reflected in the parser state, normally resulting in a single
11726 exception at the top level of parsing which covers all the compilation
11727 errors that occurred. In the error message, the callee is referred to
11728 by the name defined by the C<namegv> parameter.
11734 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11735 GV *namegv, SV *protosv)
11737 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11738 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11739 return ck_entersub_args_proto(entersubop, namegv, protosv);
11741 return ck_entersub_args_list(entersubop);
11745 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11747 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11748 OP *aop = cUNOPx(entersubop)->op_first;
11750 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11754 if (!OpHAS_SIBLING(aop))
11755 aop = cUNOPx(aop)->op_first;
11756 aop = OpSIBLING(aop);
11757 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11759 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11761 op_free(entersubop);
11762 switch(GvNAME(namegv)[2]) {
11763 case 'F': return newSVOP(OP_CONST, 0,
11764 newSVpv(CopFILE(PL_curcop),0));
11765 case 'L': return newSVOP(
11767 Perl_newSVpvf(aTHX_
11768 "%" IVdf, (IV)CopLINE(PL_curcop)
11771 case 'P': return newSVOP(OP_CONST, 0,
11773 ? newSVhek(HvNAME_HEK(PL_curstash))
11778 NOT_REACHED; /* NOTREACHED */
11781 OP *prev, *cvop, *first, *parent;
11784 parent = entersubop;
11785 if (!OpHAS_SIBLING(aop)) {
11787 aop = cUNOPx(aop)->op_first;
11790 first = prev = aop;
11791 aop = OpSIBLING(aop);
11792 /* find last sibling */
11794 OpHAS_SIBLING(cvop);
11795 prev = cvop, cvop = OpSIBLING(cvop))
11797 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11798 /* Usually, OPf_SPECIAL on an op with no args means that it had
11799 * parens, but these have their own meaning for that flag: */
11800 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11801 && opnum != OP_DELETE && opnum != OP_EXISTS)
11802 flags |= OPf_SPECIAL;
11803 /* excise cvop from end of sibling chain */
11804 op_sibling_splice(parent, prev, 1, NULL);
11806 if (aop == cvop) aop = NULL;
11808 /* detach remaining siblings from the first sibling, then
11809 * dispose of original optree */
11812 op_sibling_splice(parent, first, -1, NULL);
11813 op_free(entersubop);
11815 if (opnum == OP_ENTEREVAL
11816 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11817 flags |= OPpEVAL_BYTES <<8;
11819 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11821 case OA_BASEOP_OR_UNOP:
11822 case OA_FILESTATOP:
11823 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11826 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11829 return opnum == OP_RUNCV
11830 ? newPVOP(OP_RUNCV,0,NULL)
11833 return op_convert_list(opnum,0,aop);
11836 NOT_REACHED; /* NOTREACHED */
11841 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11843 Retrieves the function that will be used to fix up a call to C<cv>.
11844 Specifically, the function is applied to an C<entersub> op tree for a
11845 subroutine call, not marked with C<&>, where the callee can be identified
11846 at compile time as C<cv>.
11848 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11849 argument for it is returned in C<*ckobj_p>. The function is intended
11850 to be called in this manner:
11852 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11854 In this call, C<entersubop> is a pointer to the C<entersub> op,
11855 which may be replaced by the check function, and C<namegv> is a GV
11856 supplying the name that should be used by the check function to refer
11857 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11858 It is permitted to apply the check function in non-standard situations,
11859 such as to a call to a different subroutine or to a method call.
11861 By default, the function is
11862 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11863 and the SV parameter is C<cv> itself. This implements standard
11864 prototype processing. It can be changed, for a particular subroutine,
11865 by L</cv_set_call_checker>.
11871 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11875 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11877 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11878 *ckobj_p = callmg->mg_obj;
11879 if (flagsp) *flagsp = callmg->mg_flags;
11881 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11882 *ckobj_p = (SV*)cv;
11883 if (flagsp) *flagsp = 0;
11888 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11890 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11891 PERL_UNUSED_CONTEXT;
11892 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11896 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11898 Sets the function that will be used to fix up a call to C<cv>.
11899 Specifically, the function is applied to an C<entersub> op tree for a
11900 subroutine call, not marked with C<&>, where the callee can be identified
11901 at compile time as C<cv>.
11903 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11904 for it is supplied in C<ckobj>. The function should be defined like this:
11906 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11908 It is intended to be called in this manner:
11910 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11912 In this call, C<entersubop> is a pointer to the C<entersub> op,
11913 which may be replaced by the check function, and C<namegv> supplies
11914 the name that should be used by the check function to refer
11915 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11916 It is permitted to apply the check function in non-standard situations,
11917 such as to a call to a different subroutine or to a method call.
11919 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11920 CV or other SV instead. Whatever is passed can be used as the first
11921 argument to L</cv_name>. You can force perl to pass a GV by including
11922 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11924 The current setting for a particular CV can be retrieved by
11925 L</cv_get_call_checker>.
11927 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11929 The original form of L</cv_set_call_checker_flags>, which passes it the
11930 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11936 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11938 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11939 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11943 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11944 SV *ckobj, U32 flags)
11946 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11947 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11948 if (SvMAGICAL((SV*)cv))
11949 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11952 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11953 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11955 if (callmg->mg_flags & MGf_REFCOUNTED) {
11956 SvREFCNT_dec(callmg->mg_obj);
11957 callmg->mg_flags &= ~MGf_REFCOUNTED;
11959 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11960 callmg->mg_obj = ckobj;
11961 if (ckobj != (SV*)cv) {
11962 SvREFCNT_inc_simple_void_NN(ckobj);
11963 callmg->mg_flags |= MGf_REFCOUNTED;
11965 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11966 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11971 S_entersub_alloc_targ(pTHX_ OP * const o)
11973 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11974 o->op_private |= OPpENTERSUB_HASTARG;
11978 Perl_ck_subr(pTHX_ OP *o)
11983 SV **const_class = NULL;
11985 PERL_ARGS_ASSERT_CK_SUBR;
11987 aop = cUNOPx(o)->op_first;
11988 if (!OpHAS_SIBLING(aop))
11989 aop = cUNOPx(aop)->op_first;
11990 aop = OpSIBLING(aop);
11991 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11992 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11993 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11995 o->op_private &= ~1;
11996 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11997 if (PERLDB_SUB && PL_curstash != PL_debstash)
11998 o->op_private |= OPpENTERSUB_DB;
11999 switch (cvop->op_type) {
12001 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
12005 case OP_METHOD_NAMED:
12006 case OP_METHOD_SUPER:
12007 case OP_METHOD_REDIR:
12008 case OP_METHOD_REDIR_SUPER:
12009 o->op_flags |= OPf_REF;
12010 if (aop->op_type == OP_CONST) {
12011 aop->op_private &= ~OPpCONST_STRICT;
12012 const_class = &cSVOPx(aop)->op_sv;
12014 else if (aop->op_type == OP_LIST) {
12015 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
12016 if (sib && sib->op_type == OP_CONST) {
12017 sib->op_private &= ~OPpCONST_STRICT;
12018 const_class = &cSVOPx(sib)->op_sv;
12021 /* make class name a shared cow string to speedup method calls */
12022 /* constant string might be replaced with object, f.e. bigint */
12023 if (const_class && SvPOK(*const_class)) {
12025 const char* str = SvPV(*const_class, len);
12027 SV* const shared = newSVpvn_share(
12028 str, SvUTF8(*const_class)
12029 ? -(SSize_t)len : (SSize_t)len,
12032 if (SvREADONLY(*const_class))
12033 SvREADONLY_on(shared);
12034 SvREFCNT_dec(*const_class);
12035 *const_class = shared;
12042 S_entersub_alloc_targ(aTHX_ o);
12043 return ck_entersub_args_list(o);
12045 Perl_call_checker ckfun;
12048 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
12049 if (CvISXSUB(cv) || !CvROOT(cv))
12050 S_entersub_alloc_targ(aTHX_ o);
12052 /* The original call checker API guarantees that a GV will be
12053 be provided with the right name. So, if the old API was
12054 used (or the REQUIRE_GV flag was passed), we have to reify
12055 the CV’s GV, unless this is an anonymous sub. This is not
12056 ideal for lexical subs, as its stringification will include
12057 the package. But it is the best we can do. */
12058 if (flags & MGf_REQUIRE_GV) {
12059 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
12062 else namegv = MUTABLE_GV(cv);
12063 /* After a syntax error in a lexical sub, the cv that
12064 rv2cv_op_cv returns may be a nameless stub. */
12065 if (!namegv) return ck_entersub_args_list(o);
12068 return ckfun(aTHX_ o, namegv, ckobj);
12073 Perl_ck_svconst(pTHX_ OP *o)
12075 SV * const sv = cSVOPo->op_sv;
12076 PERL_ARGS_ASSERT_CK_SVCONST;
12077 PERL_UNUSED_CONTEXT;
12078 #ifdef PERL_COPY_ON_WRITE
12079 /* Since the read-only flag may be used to protect a string buffer, we
12080 cannot do copy-on-write with existing read-only scalars that are not
12081 already copy-on-write scalars. To allow $_ = "hello" to do COW with
12082 that constant, mark the constant as COWable here, if it is not
12083 already read-only. */
12084 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
12087 # ifdef PERL_DEBUG_READONLY_COW
12097 Perl_ck_trunc(pTHX_ OP *o)
12099 PERL_ARGS_ASSERT_CK_TRUNC;
12101 if (o->op_flags & OPf_KIDS) {
12102 SVOP *kid = (SVOP*)cUNOPo->op_first;
12104 if (kid->op_type == OP_NULL)
12105 kid = (SVOP*)OpSIBLING(kid);
12106 if (kid && kid->op_type == OP_CONST &&
12107 (kid->op_private & OPpCONST_BARE) &&
12110 o->op_flags |= OPf_SPECIAL;
12111 kid->op_private &= ~OPpCONST_STRICT;
12118 Perl_ck_substr(pTHX_ OP *o)
12120 PERL_ARGS_ASSERT_CK_SUBSTR;
12123 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
12124 OP *kid = cLISTOPo->op_first;
12126 if (kid->op_type == OP_NULL)
12127 kid = OpSIBLING(kid);
12129 kid->op_flags |= OPf_MOD;
12136 Perl_ck_tell(pTHX_ OP *o)
12138 PERL_ARGS_ASSERT_CK_TELL;
12140 if (o->op_flags & OPf_KIDS) {
12141 OP *kid = cLISTOPo->op_first;
12142 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12143 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12149 Perl_ck_each(pTHX_ OP *o)
12152 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12153 const unsigned orig_type = o->op_type;
12155 PERL_ARGS_ASSERT_CK_EACH;
12158 switch (kid->op_type) {
12164 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12165 : orig_type == OP_KEYS ? OP_AKEYS
12169 if (kid->op_private == OPpCONST_BARE
12170 || !SvROK(cSVOPx_sv(kid))
12171 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12172 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
12177 qerror(Perl_mess(aTHX_
12178 "Experimental %s on scalar is now forbidden",
12179 PL_op_desc[orig_type]));
12181 bad_type_pv(1, "hash or array", o, kid);
12189 Perl_ck_length(pTHX_ OP *o)
12191 PERL_ARGS_ASSERT_CK_LENGTH;
12195 if (ckWARN(WARN_SYNTAX)) {
12196 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12200 const bool hash = kid->op_type == OP_PADHV
12201 || kid->op_type == OP_RV2HV;
12202 switch (kid->op_type) {
12207 name = S_op_varname(aTHX_ kid);
12213 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12214 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
12216 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12219 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12220 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12221 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12223 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12224 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12225 "length() used on @array (did you mean \"scalar(@array)\"?)");
12235 ---------------------------------------------------------
12237 Common vars in list assignment
12239 There now follows some enums and static functions for detecting
12240 common variables in list assignments. Here is a little essay I wrote
12241 for myself when trying to get my head around this. DAPM.
12245 First some random observations:
12247 * If a lexical var is an alias of something else, e.g.
12248 for my $x ($lex, $pkg, $a[0]) {...}
12249 then the act of aliasing will increase the reference count of the SV
12251 * If a package var is an alias of something else, it may still have a
12252 reference count of 1, depending on how the alias was created, e.g.
12253 in *a = *b, $a may have a refcount of 1 since the GP is shared
12254 with a single GvSV pointer to the SV. So If it's an alias of another
12255 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12256 a lexical var or an array element, then it will have RC > 1.
12258 * There are many ways to create a package alias; ultimately, XS code
12259 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12260 run-time tracing mechanisms are unlikely to be able to catch all cases.
12262 * When the LHS is all my declarations, the same vars can't appear directly
12263 on the RHS, but they can indirectly via closures, aliasing and lvalue
12264 subs. But those techniques all involve an increase in the lexical
12265 scalar's ref count.
12267 * When the LHS is all lexical vars (but not necessarily my declarations),
12268 it is possible for the same lexicals to appear directly on the RHS, and
12269 without an increased ref count, since the stack isn't refcounted.
12270 This case can be detected at compile time by scanning for common lex
12271 vars with PL_generation.
12273 * lvalue subs defeat common var detection, but they do at least
12274 return vars with a temporary ref count increment. Also, you can't
12275 tell at compile time whether a sub call is lvalue.
12280 A: There are a few circumstances where there definitely can't be any
12283 LHS empty: () = (...);
12284 RHS empty: (....) = ();
12285 RHS contains only constants or other 'can't possibly be shared'
12286 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12287 i.e. they only contain ops not marked as dangerous, whose children
12288 are also not dangerous;
12290 LHS contains a single scalar element: e.g. ($x) = (....); because
12291 after $x has been modified, it won't be used again on the RHS;
12292 RHS contains a single element with no aggregate on LHS: e.g.
12293 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12294 won't be used again.
12296 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12299 my ($a, $b, @c) = ...;
12301 Due to closure and goto tricks, these vars may already have content.
12302 For the same reason, an element on the RHS may be a lexical or package
12303 alias of one of the vars on the left, or share common elements, for
12306 my ($x,$y) = f(); # $x and $y on both sides
12307 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12312 my @a = @$ra; # elements of @a on both sides
12313 sub f { @a = 1..4; \@a }
12316 First, just consider scalar vars on LHS:
12318 RHS is safe only if (A), or in addition,
12319 * contains only lexical *scalar* vars, where neither side's
12320 lexicals have been flagged as aliases
12322 If RHS is not safe, then it's always legal to check LHS vars for
12323 RC==1, since the only RHS aliases will always be associated
12326 Note that in particular, RHS is not safe if:
12328 * it contains package scalar vars; e.g.:
12331 my ($x, $y) = (2, $x_alias);
12332 sub f { $x = 1; *x_alias = \$x; }
12334 * It contains other general elements, such as flattened or
12335 * spliced or single array or hash elements, e.g.
12338 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12342 use feature 'refaliasing';
12343 \($a[0], $a[1]) = \($y,$x);
12346 It doesn't matter if the array/hash is lexical or package.
12348 * it contains a function call that happens to be an lvalue
12349 sub which returns one or more of the above, e.g.
12360 (so a sub call on the RHS should be treated the same
12361 as having a package var on the RHS).
12363 * any other "dangerous" thing, such an op or built-in that
12364 returns one of the above, e.g. pp_preinc
12367 If RHS is not safe, what we can do however is at compile time flag
12368 that the LHS are all my declarations, and at run time check whether
12369 all the LHS have RC == 1, and if so skip the full scan.
12371 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12373 Here the issue is whether there can be elements of @a on the RHS
12374 which will get prematurely freed when @a is cleared prior to
12375 assignment. This is only a problem if the aliasing mechanism
12376 is one which doesn't increase the refcount - only if RC == 1
12377 will the RHS element be prematurely freed.
12379 Because the array/hash is being INTROed, it or its elements
12380 can't directly appear on the RHS:
12382 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12384 but can indirectly, e.g.:
12388 sub f { @a = 1..3; \@a }
12390 So if the RHS isn't safe as defined by (A), we must always
12391 mortalise and bump the ref count of any remaining RHS elements
12392 when assigning to a non-empty LHS aggregate.
12394 Lexical scalars on the RHS aren't safe if they've been involved in
12397 use feature 'refaliasing';
12400 \(my $lex) = \$pkg;
12401 my @a = ($lex,3); # equivalent to ($a[0],3)
12408 Similarly with lexical arrays and hashes on the RHS:
12422 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12423 my $a; ($a, my $b) = (....);
12425 The difference between (B) and (C) is that it is now physically
12426 possible for the LHS vars to appear on the RHS too, where they
12427 are not reference counted; but in this case, the compile-time
12428 PL_generation sweep will detect such common vars.
12430 So the rules for (C) differ from (B) in that if common vars are
12431 detected, the runtime "test RC==1" optimisation can no longer be used,
12432 and a full mark and sweep is required
12434 D: As (C), but in addition the LHS may contain package vars.
12436 Since package vars can be aliased without a corresponding refcount
12437 increase, all bets are off. It's only safe if (A). E.g.
12439 my ($x, $y) = (1,2);
12441 for $x_alias ($x) {
12442 ($x_alias, $y) = (3, $x); # whoops
12445 Ditto for LHS aggregate package vars.
12447 E: Any other dangerous ops on LHS, e.g.
12448 (f(), $a[0], @$r) = (...);
12450 this is similar to (E) in that all bets are off. In addition, it's
12451 impossible to determine at compile time whether the LHS
12452 contains a scalar or an aggregate, e.g.
12454 sub f : lvalue { @a }
12457 * ---------------------------------------------------------
12461 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12462 * that at least one of the things flagged was seen.
12466 AAS_MY_SCALAR = 0x001, /* my $scalar */
12467 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12468 AAS_LEX_SCALAR = 0x004, /* $lexical */
12469 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12470 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12471 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12472 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12473 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12474 that's flagged OA_DANGEROUS */
12475 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12476 not in any of the categories above */
12477 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12482 /* helper function for S_aassign_scan().
12483 * check a PAD-related op for commonality and/or set its generation number.
12484 * Returns a boolean indicating whether its shared */
12487 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12489 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12490 /* lexical used in aliasing */
12494 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12496 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12503 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12504 It scans the left or right hand subtree of the aassign op, and returns a
12505 set of flags indicating what sorts of things it found there.
12506 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12507 set PL_generation on lexical vars; if the latter, we see if
12508 PL_generation matches.
12509 'top' indicates whether we're recursing or at the top level.
12510 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12511 This fn will increment it by the number seen. It's not intended to
12512 be an accurate count (especially as many ops can push a variable
12513 number of SVs onto the stack); rather it's used as to test whether there
12514 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12518 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12521 bool kid_top = FALSE;
12523 /* first, look for a solitary @_ on the RHS */
12526 && (o->op_flags & OPf_KIDS)
12527 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12529 OP *kid = cUNOPo->op_first;
12530 if ( ( kid->op_type == OP_PUSHMARK
12531 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12532 && ((kid = OpSIBLING(kid)))
12533 && !OpHAS_SIBLING(kid)
12534 && kid->op_type == OP_RV2AV
12535 && !(kid->op_flags & OPf_REF)
12536 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12537 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12538 && ((kid = cUNOPx(kid)->op_first))
12539 && kid->op_type == OP_GV
12540 && cGVOPx_gv(kid) == PL_defgv
12542 flags |= AAS_DEFAV;
12545 switch (o->op_type) {
12548 return AAS_PKG_SCALAR;
12553 /* if !top, could be e.g. @a[0,1] */
12554 if (top && (o->op_flags & OPf_REF))
12555 return (o->op_private & OPpLVAL_INTRO)
12556 ? AAS_MY_AGG : AAS_LEX_AGG;
12557 return AAS_DANGEROUS;
12561 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12562 ? AAS_LEX_SCALAR_COMM : 0;
12564 return (o->op_private & OPpLVAL_INTRO)
12565 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12571 if (cUNOPx(o)->op_first->op_type != OP_GV)
12572 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12574 /* if !top, could be e.g. @a[0,1] */
12575 if (top && (o->op_flags & OPf_REF))
12576 return AAS_PKG_AGG;
12577 return AAS_DANGEROUS;
12581 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12583 return AAS_DANGEROUS; /* ${expr} */
12585 return AAS_PKG_SCALAR; /* $pkg */
12588 if (o->op_private & OPpSPLIT_ASSIGN) {
12589 /* the assign in @a = split() has been optimised away
12590 * and the @a attached directly to the split op
12591 * Treat the array as appearing on the RHS, i.e.
12592 * ... = (@a = split)
12597 if (o->op_flags & OPf_STACKED)
12598 /* @{expr} = split() - the array expression is tacked
12599 * on as an extra child to split - process kid */
12600 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
12603 /* ... else array is directly attached to split op */
12605 if (PL_op->op_private & OPpSPLIT_LEX)
12606 return (o->op_private & OPpLVAL_INTRO)
12607 ? AAS_MY_AGG : AAS_LEX_AGG;
12609 return AAS_PKG_AGG;
12612 /* other args of split can't be returned */
12613 return AAS_SAFE_SCALAR;
12616 /* undef counts as a scalar on the RHS:
12617 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12618 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12622 flags = AAS_SAFE_SCALAR;
12627 /* these are all no-ops; they don't push a potentially common SV
12628 * onto the stack, so they are neither AAS_DANGEROUS nor
12629 * AAS_SAFE_SCALAR */
12632 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12637 /* these do nothing but may have children; but their children
12638 * should also be treated as top-level */
12643 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12645 flags = AAS_DANGEROUS;
12649 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12650 && (o->op_private & OPpTARGET_MY))
12653 return S_aassign_padcheck(aTHX_ o, rhs)
12654 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12657 /* if its an unrecognised, non-dangerous op, assume that it
12658 * it the cause of at least one safe scalar */
12660 flags = AAS_SAFE_SCALAR;
12664 /* XXX this assumes that all other ops are "transparent" - i.e. that
12665 * they can return some of their children. While this true for e.g.
12666 * sort and grep, it's not true for e.g. map. We really need a
12667 * 'transparent' flag added to regen/opcodes
12669 if (o->op_flags & OPf_KIDS) {
12671 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12672 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12678 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12679 and modify the optree to make them work inplace */
12682 S_inplace_aassign(pTHX_ OP *o) {
12684 OP *modop, *modop_pushmark;
12686 OP *oleft, *oleft_pushmark;
12688 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12690 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12692 assert(cUNOPo->op_first->op_type == OP_NULL);
12693 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12694 assert(modop_pushmark->op_type == OP_PUSHMARK);
12695 modop = OpSIBLING(modop_pushmark);
12697 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12700 /* no other operation except sort/reverse */
12701 if (OpHAS_SIBLING(modop))
12704 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12705 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12707 if (modop->op_flags & OPf_STACKED) {
12708 /* skip sort subroutine/block */
12709 assert(oright->op_type == OP_NULL);
12710 oright = OpSIBLING(oright);
12713 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12714 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12715 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12716 oleft = OpSIBLING(oleft_pushmark);
12718 /* Check the lhs is an array */
12720 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12721 || OpHAS_SIBLING(oleft)
12722 || (oleft->op_private & OPpLVAL_INTRO)
12726 /* Only one thing on the rhs */
12727 if (OpHAS_SIBLING(oright))
12730 /* check the array is the same on both sides */
12731 if (oleft->op_type == OP_RV2AV) {
12732 if (oright->op_type != OP_RV2AV
12733 || !cUNOPx(oright)->op_first
12734 || cUNOPx(oright)->op_first->op_type != OP_GV
12735 || cUNOPx(oleft )->op_first->op_type != OP_GV
12736 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12737 cGVOPx_gv(cUNOPx(oright)->op_first)
12741 else if (oright->op_type != OP_PADAV
12742 || oright->op_targ != oleft->op_targ
12746 /* This actually is an inplace assignment */
12748 modop->op_private |= OPpSORT_INPLACE;
12750 /* transfer MODishness etc from LHS arg to RHS arg */
12751 oright->op_flags = oleft->op_flags;
12753 /* remove the aassign op and the lhs */
12755 op_null(oleft_pushmark);
12756 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12757 op_null(cUNOPx(oleft)->op_first);
12763 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12764 * that potentially represent a series of one or more aggregate derefs
12765 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12766 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12767 * additional ops left in too).
12769 * The caller will have already verified that the first few ops in the
12770 * chain following 'start' indicate a multideref candidate, and will have
12771 * set 'orig_o' to the point further on in the chain where the first index
12772 * expression (if any) begins. 'orig_action' specifies what type of
12773 * beginning has already been determined by the ops between start..orig_o
12774 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12776 * 'hints' contains any hints flags that need adding (currently just
12777 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12781 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12785 UNOP_AUX_item *arg_buf = NULL;
12786 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12787 int index_skip = -1; /* don't output index arg on this action */
12789 /* similar to regex compiling, do two passes; the first pass
12790 * determines whether the op chain is convertible and calculates the
12791 * buffer size; the second pass populates the buffer and makes any
12792 * changes necessary to ops (such as moving consts to the pad on
12793 * threaded builds).
12795 * NB: for things like Coverity, note that both passes take the same
12796 * path through the logic tree (except for 'if (pass)' bits), since
12797 * both passes are following the same op_next chain; and in
12798 * particular, if it would return early on the second pass, it would
12799 * already have returned early on the first pass.
12801 for (pass = 0; pass < 2; pass++) {
12803 UV action = orig_action;
12804 OP *first_elem_op = NULL; /* first seen aelem/helem */
12805 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12806 int action_count = 0; /* number of actions seen so far */
12807 int action_ix = 0; /* action_count % (actions per IV) */
12808 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12809 bool is_last = FALSE; /* no more derefs to follow */
12810 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12811 UNOP_AUX_item *arg = arg_buf;
12812 UNOP_AUX_item *action_ptr = arg_buf;
12815 action_ptr->uv = 0;
12819 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12820 case MDEREF_HV_gvhv_helem:
12821 next_is_hash = TRUE;
12823 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12824 case MDEREF_AV_gvav_aelem:
12826 #ifdef USE_ITHREADS
12827 arg->pad_offset = cPADOPx(start)->op_padix;
12828 /* stop it being swiped when nulled */
12829 cPADOPx(start)->op_padix = 0;
12831 arg->sv = cSVOPx(start)->op_sv;
12832 cSVOPx(start)->op_sv = NULL;
12838 case MDEREF_HV_padhv_helem:
12839 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12840 next_is_hash = TRUE;
12842 case MDEREF_AV_padav_aelem:
12843 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12845 arg->pad_offset = start->op_targ;
12846 /* we skip setting op_targ = 0 for now, since the intact
12847 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12848 reset_start_targ = TRUE;
12853 case MDEREF_HV_pop_rv2hv_helem:
12854 next_is_hash = TRUE;
12856 case MDEREF_AV_pop_rv2av_aelem:
12860 NOT_REACHED; /* NOTREACHED */
12865 /* look for another (rv2av/hv; get index;
12866 * aelem/helem/exists/delele) sequence */
12871 UV index_type = MDEREF_INDEX_none;
12873 if (action_count) {
12874 /* if this is not the first lookup, consume the rv2av/hv */
12876 /* for N levels of aggregate lookup, we normally expect
12877 * that the first N-1 [ah]elem ops will be flagged as
12878 * /DEREF (so they autovivifiy if necessary), and the last
12879 * lookup op not to be.
12880 * For other things (like @{$h{k1}{k2}}) extra scope or
12881 * leave ops can appear, so abandon the effort in that
12883 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12886 /* rv2av or rv2hv sKR/1 */
12888 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12889 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12890 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12893 /* at this point, we wouldn't expect any of these
12894 * possible private flags:
12895 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12896 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12898 ASSUME(!(o->op_private &
12899 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12901 hints = (o->op_private & OPpHINT_STRICT_REFS);
12903 /* make sure the type of the previous /DEREF matches the
12904 * type of the next lookup */
12905 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12908 action = next_is_hash
12909 ? MDEREF_HV_vivify_rv2hv_helem
12910 : MDEREF_AV_vivify_rv2av_aelem;
12914 /* if this is the second pass, and we're at the depth where
12915 * previously we encountered a non-simple index expression,
12916 * stop processing the index at this point */
12917 if (action_count != index_skip) {
12919 /* look for one or more simple ops that return an array
12920 * index or hash key */
12922 switch (o->op_type) {
12924 /* it may be a lexical var index */
12925 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12926 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12927 ASSUME(!(o->op_private &
12928 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12930 if ( OP_GIMME(o,0) == G_SCALAR
12931 && !(o->op_flags & (OPf_REF|OPf_MOD))
12932 && o->op_private == 0)
12935 arg->pad_offset = o->op_targ;
12937 index_type = MDEREF_INDEX_padsv;
12943 if (next_is_hash) {
12944 /* it's a constant hash index */
12945 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12946 /* "use constant foo => FOO; $h{+foo}" for
12947 * some weird FOO, can leave you with constants
12948 * that aren't simple strings. It's not worth
12949 * the extra hassle for those edge cases */
12954 OP * helem_op = o->op_next;
12956 ASSUME( helem_op->op_type == OP_HELEM
12957 || helem_op->op_type == OP_NULL);
12958 if (helem_op->op_type == OP_HELEM) {
12959 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12960 if ( helem_op->op_private & OPpLVAL_INTRO
12961 || rop->op_type != OP_RV2HV
12965 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12967 #ifdef USE_ITHREADS
12968 /* Relocate sv to the pad for thread safety */
12969 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12970 arg->pad_offset = o->op_targ;
12973 arg->sv = cSVOPx_sv(o);
12978 /* it's a constant array index */
12980 SV *ix_sv = cSVOPo->op_sv;
12985 if ( action_count == 0
12988 && ( action == MDEREF_AV_padav_aelem
12989 || action == MDEREF_AV_gvav_aelem)
12991 maybe_aelemfast = TRUE;
12995 SvREFCNT_dec_NN(cSVOPo->op_sv);
12999 /* we've taken ownership of the SV */
13000 cSVOPo->op_sv = NULL;
13002 index_type = MDEREF_INDEX_const;
13007 /* it may be a package var index */
13009 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
13010 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
13011 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
13012 || o->op_private != 0
13017 if (kid->op_type != OP_RV2SV)
13020 ASSUME(!(kid->op_flags &
13021 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
13022 |OPf_SPECIAL|OPf_PARENS)));
13023 ASSUME(!(kid->op_private &
13025 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
13026 |OPpDEREF|OPpLVAL_INTRO)));
13027 if( (kid->op_flags &~ OPf_PARENS)
13028 != (OPf_WANT_SCALAR|OPf_KIDS)
13029 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
13034 #ifdef USE_ITHREADS
13035 arg->pad_offset = cPADOPx(o)->op_padix;
13036 /* stop it being swiped when nulled */
13037 cPADOPx(o)->op_padix = 0;
13039 arg->sv = cSVOPx(o)->op_sv;
13040 cSVOPo->op_sv = NULL;
13044 index_type = MDEREF_INDEX_gvsv;
13049 } /* action_count != index_skip */
13051 action |= index_type;
13054 /* at this point we have either:
13055 * * detected what looks like a simple index expression,
13056 * and expect the next op to be an [ah]elem, or
13057 * an nulled [ah]elem followed by a delete or exists;
13058 * * found a more complex expression, so something other
13059 * than the above follows.
13062 /* possibly an optimised away [ah]elem (where op_next is
13063 * exists or delete) */
13064 if (o->op_type == OP_NULL)
13067 /* at this point we're looking for an OP_AELEM, OP_HELEM,
13068 * OP_EXISTS or OP_DELETE */
13070 /* if something like arybase (a.k.a $[ ) is in scope,
13071 * abandon optimisation attempt */
13072 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13073 && PL_check[o->op_type] != Perl_ck_null)
13075 /* similarly for customised exists and delete */
13076 if ( (o->op_type == OP_EXISTS)
13077 && PL_check[o->op_type] != Perl_ck_exists)
13079 if ( (o->op_type == OP_DELETE)
13080 && PL_check[o->op_type] != Perl_ck_delete)
13083 if ( o->op_type != OP_AELEM
13084 || (o->op_private &
13085 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
13087 maybe_aelemfast = FALSE;
13089 /* look for aelem/helem/exists/delete. If it's not the last elem
13090 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
13091 * flags; if it's the last, then it mustn't have
13092 * OPpDEREF_AV/HV, but may have lots of other flags, like
13093 * OPpLVAL_INTRO etc
13096 if ( index_type == MDEREF_INDEX_none
13097 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
13098 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
13102 /* we have aelem/helem/exists/delete with valid simple index */
13104 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13105 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
13106 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
13109 ASSUME(!(o->op_flags &
13110 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
13111 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
13113 ok = (o->op_flags &~ OPf_PARENS)
13114 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
13115 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
13117 else if (o->op_type == OP_EXISTS) {
13118 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13119 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13120 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
13121 ok = !(o->op_private & ~OPpARG1_MASK);
13123 else if (o->op_type == OP_DELETE) {
13124 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13125 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13126 ASSUME(!(o->op_private &
13127 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
13128 /* don't handle slices or 'local delete'; the latter
13129 * is fairly rare, and has a complex runtime */
13130 ok = !(o->op_private & ~OPpARG1_MASK);
13131 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
13132 /* skip handling run-tome error */
13133 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
13136 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
13137 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
13138 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
13139 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
13140 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
13141 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
13146 if (!first_elem_op)
13150 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
13155 action |= MDEREF_FLAG_last;
13159 /* at this point we have something that started
13160 * promisingly enough (with rv2av or whatever), but failed
13161 * to find a simple index followed by an
13162 * aelem/helem/exists/delete. If this is the first action,
13163 * give up; but if we've already seen at least one
13164 * aelem/helem, then keep them and add a new action with
13165 * MDEREF_INDEX_none, which causes it to do the vivify
13166 * from the end of the previous lookup, and do the deref,
13167 * but stop at that point. So $a[0][expr] will do one
13168 * av_fetch, vivify and deref, then continue executing at
13173 index_skip = action_count;
13174 action |= MDEREF_FLAG_last;
13175 if (index_type != MDEREF_INDEX_none)
13180 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
13183 /* if there's no space for the next action, create a new slot
13184 * for it *before* we start adding args for that action */
13185 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
13192 } /* while !is_last */
13200 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
13201 if (index_skip == -1) {
13202 mderef->op_flags = o->op_flags
13203 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
13204 if (o->op_type == OP_EXISTS)
13205 mderef->op_private = OPpMULTIDEREF_EXISTS;
13206 else if (o->op_type == OP_DELETE)
13207 mderef->op_private = OPpMULTIDEREF_DELETE;
13209 mderef->op_private = o->op_private
13210 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
13212 /* accumulate strictness from every level (although I don't think
13213 * they can actually vary) */
13214 mderef->op_private |= hints;
13216 /* integrate the new multideref op into the optree and the
13219 * In general an op like aelem or helem has two child
13220 * sub-trees: the aggregate expression (a_expr) and the
13221 * index expression (i_expr):
13227 * The a_expr returns an AV or HV, while the i-expr returns an
13228 * index. In general a multideref replaces most or all of a
13229 * multi-level tree, e.g.
13245 * With multideref, all the i_exprs will be simple vars or
13246 * constants, except that i_expr1 may be arbitrary in the case
13247 * of MDEREF_INDEX_none.
13249 * The bottom-most a_expr will be either:
13250 * 1) a simple var (so padXv or gv+rv2Xv);
13251 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
13252 * so a simple var with an extra rv2Xv;
13253 * 3) or an arbitrary expression.
13255 * 'start', the first op in the execution chain, will point to
13256 * 1),2): the padXv or gv op;
13257 * 3): the rv2Xv which forms the last op in the a_expr
13258 * execution chain, and the top-most op in the a_expr
13261 * For all cases, the 'start' node is no longer required,
13262 * but we can't free it since one or more external nodes
13263 * may point to it. E.g. consider
13264 * $h{foo} = $a ? $b : $c
13265 * Here, both the op_next and op_other branches of the
13266 * cond_expr point to the gv[*h] of the hash expression, so
13267 * we can't free the 'start' op.
13269 * For expr->[...], we need to save the subtree containing the
13270 * expression; for the other cases, we just need to save the
13272 * So in all cases, we null the start op and keep it around by
13273 * making it the child of the multideref op; for the expr->
13274 * case, the expr will be a subtree of the start node.
13276 * So in the simple 1,2 case the optree above changes to
13282 * ex-gv (or ex-padxv)
13284 * with the op_next chain being
13286 * -> ex-gv -> multideref -> op-following-ex-exists ->
13288 * In the 3 case, we have
13301 * -> rest-of-a_expr subtree ->
13302 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13305 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13306 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13307 * multideref attached as the child, e.g.
13313 * ex-rv2av - i_expr1
13321 /* if we free this op, don't free the pad entry */
13322 if (reset_start_targ)
13323 start->op_targ = 0;
13326 /* Cut the bit we need to save out of the tree and attach to
13327 * the multideref op, then free the rest of the tree */
13329 /* find parent of node to be detached (for use by splice) */
13331 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13332 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13334 /* there is an arbitrary expression preceding us, e.g.
13335 * expr->[..]? so we need to save the 'expr' subtree */
13336 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13337 p = cUNOPx(p)->op_first;
13338 ASSUME( start->op_type == OP_RV2AV
13339 || start->op_type == OP_RV2HV);
13342 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13343 * above for exists/delete. */
13344 while ( (p->op_flags & OPf_KIDS)
13345 && cUNOPx(p)->op_first != start
13347 p = cUNOPx(p)->op_first;
13349 ASSUME(cUNOPx(p)->op_first == start);
13351 /* detach from main tree, and re-attach under the multideref */
13352 op_sibling_splice(mderef, NULL, 0,
13353 op_sibling_splice(p, NULL, 1, NULL));
13356 start->op_next = mderef;
13358 mderef->op_next = index_skip == -1 ? o->op_next : o;
13360 /* excise and free the original tree, and replace with
13361 * the multideref op */
13362 p = op_sibling_splice(top_op, NULL, -1, mderef);
13371 Size_t size = arg - arg_buf;
13373 if (maybe_aelemfast && action_count == 1)
13376 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13377 sizeof(UNOP_AUX_item) * (size + 1));
13378 /* for dumping etc: store the length in a hidden first slot;
13379 * we set the op_aux pointer to the second slot */
13380 arg_buf->uv = size;
13383 } /* for (pass = ...) */
13388 /* mechanism for deferring recursion in rpeep() */
13390 #define MAX_DEFERRED 4
13394 if (defer_ix == (MAX_DEFERRED-1)) { \
13395 OP **defer = defer_queue[defer_base]; \
13396 CALL_RPEEP(*defer); \
13397 S_prune_chain_head(defer); \
13398 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13401 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13404 #define IS_AND_OP(o) (o->op_type == OP_AND)
13405 #define IS_OR_OP(o) (o->op_type == OP_OR)
13408 /* A peephole optimizer. We visit the ops in the order they're to execute.
13409 * See the comments at the top of this file for more details about when
13410 * peep() is called */
13413 Perl_rpeep(pTHX_ OP *o)
13417 OP* oldoldop = NULL;
13418 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13419 int defer_base = 0;
13424 if (!o || o->op_opt)
13427 assert(o->op_type != OP_FREED);
13431 SAVEVPTR(PL_curcop);
13432 for (;; o = o->op_next) {
13433 if (o && o->op_opt)
13436 while (defer_ix >= 0) {
13438 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13439 CALL_RPEEP(*defer);
13440 S_prune_chain_head(defer);
13447 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13448 assert(!oldoldop || oldoldop->op_next == oldop);
13449 assert(!oldop || oldop->op_next == o);
13451 /* By default, this op has now been optimised. A couple of cases below
13452 clear this again. */
13456 /* look for a series of 1 or more aggregate derefs, e.g.
13457 * $a[1]{foo}[$i]{$k}
13458 * and replace with a single OP_MULTIDEREF op.
13459 * Each index must be either a const, or a simple variable,
13461 * First, look for likely combinations of starting ops,
13462 * corresponding to (global and lexical variants of)
13464 * $r->[...] $r->{...}
13465 * (preceding expression)->[...]
13466 * (preceding expression)->{...}
13467 * and if so, call maybe_multideref() to do a full inspection
13468 * of the op chain and if appropriate, replace with an
13476 switch (o2->op_type) {
13478 /* $pkg[..] : gv[*pkg]
13479 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13481 /* Fail if there are new op flag combinations that we're
13482 * not aware of, rather than:
13483 * * silently failing to optimise, or
13484 * * silently optimising the flag away.
13485 * If this ASSUME starts failing, examine what new flag
13486 * has been added to the op, and decide whether the
13487 * optimisation should still occur with that flag, then
13488 * update the code accordingly. This applies to all the
13489 * other ASSUMEs in the block of code too.
13491 ASSUME(!(o2->op_flags &
13492 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13493 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13497 if (o2->op_type == OP_RV2AV) {
13498 action = MDEREF_AV_gvav_aelem;
13502 if (o2->op_type == OP_RV2HV) {
13503 action = MDEREF_HV_gvhv_helem;
13507 if (o2->op_type != OP_RV2SV)
13510 /* at this point we've seen gv,rv2sv, so the only valid
13511 * construct left is $pkg->[] or $pkg->{} */
13513 ASSUME(!(o2->op_flags & OPf_STACKED));
13514 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13515 != (OPf_WANT_SCALAR|OPf_MOD))
13518 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13519 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13520 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13522 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13523 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13527 if (o2->op_type == OP_RV2AV) {
13528 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13531 if (o2->op_type == OP_RV2HV) {
13532 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13538 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13540 ASSUME(!(o2->op_flags &
13541 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13542 if ((o2->op_flags &
13543 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13544 != (OPf_WANT_SCALAR|OPf_MOD))
13547 ASSUME(!(o2->op_private &
13548 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13549 /* skip if state or intro, or not a deref */
13550 if ( o2->op_private != OPpDEREF_AV
13551 && o2->op_private != OPpDEREF_HV)
13555 if (o2->op_type == OP_RV2AV) {
13556 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13559 if (o2->op_type == OP_RV2HV) {
13560 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13567 /* $lex[..]: padav[@lex:1,2] sR *
13568 * or $lex{..}: padhv[%lex:1,2] sR */
13569 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13570 OPf_REF|OPf_SPECIAL)));
13571 if ((o2->op_flags &
13572 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13573 != (OPf_WANT_SCALAR|OPf_REF))
13575 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13577 /* OPf_PARENS isn't currently used in this case;
13578 * if that changes, let us know! */
13579 ASSUME(!(o2->op_flags & OPf_PARENS));
13581 /* at this point, we wouldn't expect any of the remaining
13582 * possible private flags:
13583 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13584 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13586 * OPpSLICEWARNING shouldn't affect runtime
13588 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13590 action = o2->op_type == OP_PADAV
13591 ? MDEREF_AV_padav_aelem
13592 : MDEREF_HV_padhv_helem;
13594 S_maybe_multideref(aTHX_ o, o2, action, 0);
13600 action = o2->op_type == OP_RV2AV
13601 ? MDEREF_AV_pop_rv2av_aelem
13602 : MDEREF_HV_pop_rv2hv_helem;
13605 /* (expr)->[...]: rv2av sKR/1;
13606 * (expr)->{...}: rv2hv sKR/1; */
13608 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13610 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13611 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13612 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13615 /* at this point, we wouldn't expect any of these
13616 * possible private flags:
13617 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13618 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13620 ASSUME(!(o2->op_private &
13621 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13623 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13627 S_maybe_multideref(aTHX_ o, o2, action, hints);
13636 switch (o->op_type) {
13638 PL_curcop = ((COP*)o); /* for warnings */
13641 PL_curcop = ((COP*)o); /* for warnings */
13643 /* Optimise a "return ..." at the end of a sub to just be "...".
13644 * This saves 2 ops. Before:
13645 * 1 <;> nextstate(main 1 -e:1) v ->2
13646 * 4 <@> return K ->5
13647 * 2 <0> pushmark s ->3
13648 * - <1> ex-rv2sv sK/1 ->4
13649 * 3 <#> gvsv[*cat] s ->4
13652 * - <@> return K ->-
13653 * - <0> pushmark s ->2
13654 * - <1> ex-rv2sv sK/1 ->-
13655 * 2 <$> gvsv(*cat) s ->3
13658 OP *next = o->op_next;
13659 OP *sibling = OpSIBLING(o);
13660 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13661 && OP_TYPE_IS(sibling, OP_RETURN)
13662 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13663 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13664 ||OP_TYPE_IS(sibling->op_next->op_next,
13666 && cUNOPx(sibling)->op_first == next
13667 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13670 /* Look through the PUSHMARK's siblings for one that
13671 * points to the RETURN */
13672 OP *top = OpSIBLING(next);
13673 while (top && top->op_next) {
13674 if (top->op_next == sibling) {
13675 top->op_next = sibling->op_next;
13676 o->op_next = next->op_next;
13679 top = OpSIBLING(top);
13684 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13686 * This latter form is then suitable for conversion into padrange
13687 * later on. Convert:
13689 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13693 * nextstate1 -> listop -> nextstate3
13695 * pushmark -> padop1 -> padop2
13697 if (o->op_next && (
13698 o->op_next->op_type == OP_PADSV
13699 || o->op_next->op_type == OP_PADAV
13700 || o->op_next->op_type == OP_PADHV
13702 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13703 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13704 && o->op_next->op_next->op_next && (
13705 o->op_next->op_next->op_next->op_type == OP_PADSV
13706 || o->op_next->op_next->op_next->op_type == OP_PADAV
13707 || o->op_next->op_next->op_next->op_type == OP_PADHV
13709 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13710 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13711 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13712 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13714 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13717 ns2 = pad1->op_next;
13718 pad2 = ns2->op_next;
13719 ns3 = pad2->op_next;
13721 /* we assume here that the op_next chain is the same as
13722 * the op_sibling chain */
13723 assert(OpSIBLING(o) == pad1);
13724 assert(OpSIBLING(pad1) == ns2);
13725 assert(OpSIBLING(ns2) == pad2);
13726 assert(OpSIBLING(pad2) == ns3);
13728 /* excise and delete ns2 */
13729 op_sibling_splice(NULL, pad1, 1, NULL);
13732 /* excise pad1 and pad2 */
13733 op_sibling_splice(NULL, o, 2, NULL);
13735 /* create new listop, with children consisting of:
13736 * a new pushmark, pad1, pad2. */
13737 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13738 newop->op_flags |= OPf_PARENS;
13739 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13741 /* insert newop between o and ns3 */
13742 op_sibling_splice(NULL, o, 0, newop);
13744 /*fixup op_next chain */
13745 newpm = cUNOPx(newop)->op_first; /* pushmark */
13746 o ->op_next = newpm;
13747 newpm->op_next = pad1;
13748 pad1 ->op_next = pad2;
13749 pad2 ->op_next = newop; /* listop */
13750 newop->op_next = ns3;
13752 /* Ensure pushmark has this flag if padops do */
13753 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13754 newpm->op_flags |= OPf_MOD;
13760 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13761 to carry two labels. For now, take the easier option, and skip
13762 this optimisation if the first NEXTSTATE has a label. */
13763 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13764 OP *nextop = o->op_next;
13765 while (nextop && nextop->op_type == OP_NULL)
13766 nextop = nextop->op_next;
13768 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13771 oldop->op_next = nextop;
13773 /* Skip (old)oldop assignment since the current oldop's
13774 op_next already points to the next op. */
13781 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13782 if (o->op_next->op_private & OPpTARGET_MY) {
13783 if (o->op_flags & OPf_STACKED) /* chained concats */
13784 break; /* ignore_optimization */
13786 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13787 o->op_targ = o->op_next->op_targ;
13788 o->op_next->op_targ = 0;
13789 o->op_private |= OPpTARGET_MY;
13792 op_null(o->op_next);
13796 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13797 break; /* Scalar stub must produce undef. List stub is noop */
13801 if (o->op_targ == OP_NEXTSTATE
13802 || o->op_targ == OP_DBSTATE)
13804 PL_curcop = ((COP*)o);
13806 /* XXX: We avoid setting op_seq here to prevent later calls
13807 to rpeep() from mistakenly concluding that optimisation
13808 has already occurred. This doesn't fix the real problem,
13809 though (See 20010220.007 (#5874)). AMS 20010719 */
13810 /* op_seq functionality is now replaced by op_opt */
13818 oldop->op_next = o->op_next;
13832 convert repeat into a stub with no kids.
13834 if (o->op_next->op_type == OP_CONST
13835 || ( o->op_next->op_type == OP_PADSV
13836 && !(o->op_next->op_private & OPpLVAL_INTRO))
13837 || ( o->op_next->op_type == OP_GV
13838 && o->op_next->op_next->op_type == OP_RV2SV
13839 && !(o->op_next->op_next->op_private
13840 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13842 const OP *kid = o->op_next->op_next;
13843 if (o->op_next->op_type == OP_GV)
13844 kid = kid->op_next;
13845 /* kid is now the ex-list. */
13846 if (kid->op_type == OP_NULL
13847 && (kid = kid->op_next)->op_type == OP_CONST
13848 /* kid is now the repeat count. */
13849 && kid->op_next->op_type == OP_REPEAT
13850 && kid->op_next->op_private & OPpREPEAT_DOLIST
13851 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13852 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
13855 o = kid->op_next; /* repeat */
13856 oldop->op_next = o;
13857 op_free(cBINOPo->op_first);
13858 op_free(cBINOPo->op_last );
13859 o->op_flags &=~ OPf_KIDS;
13860 /* stub is a baseop; repeat is a binop */
13861 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13862 OpTYPE_set(o, OP_STUB);
13868 /* Convert a series of PAD ops for my vars plus support into a
13869 * single padrange op. Basically
13871 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13873 * becomes, depending on circumstances, one of
13875 * padrange ----------------------------------> (list) -> rest
13876 * padrange --------------------------------------------> rest
13878 * where all the pad indexes are sequential and of the same type
13880 * We convert the pushmark into a padrange op, then skip
13881 * any other pad ops, and possibly some trailing ops.
13882 * Note that we don't null() the skipped ops, to make it
13883 * easier for Deparse to undo this optimisation (and none of
13884 * the skipped ops are holding any resourses). It also makes
13885 * it easier for find_uninit_var(), as it can just ignore
13886 * padrange, and examine the original pad ops.
13890 OP *followop = NULL; /* the op that will follow the padrange op */
13893 PADOFFSET base = 0; /* init only to stop compiler whining */
13894 bool gvoid = 0; /* init only to stop compiler whining */
13895 bool defav = 0; /* seen (...) = @_ */
13896 bool reuse = 0; /* reuse an existing padrange op */
13898 /* look for a pushmark -> gv[_] -> rv2av */
13903 if ( p->op_type == OP_GV
13904 && cGVOPx_gv(p) == PL_defgv
13905 && (rv2av = p->op_next)
13906 && rv2av->op_type == OP_RV2AV
13907 && !(rv2av->op_flags & OPf_REF)
13908 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13909 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13911 q = rv2av->op_next;
13912 if (q->op_type == OP_NULL)
13914 if (q->op_type == OP_PUSHMARK) {
13924 /* scan for PAD ops */
13926 for (p = p->op_next; p; p = p->op_next) {
13927 if (p->op_type == OP_NULL)
13930 if (( p->op_type != OP_PADSV
13931 && p->op_type != OP_PADAV
13932 && p->op_type != OP_PADHV
13934 /* any private flag other than INTRO? e.g. STATE */
13935 || (p->op_private & ~OPpLVAL_INTRO)
13939 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13941 if ( p->op_type == OP_PADAV
13943 && p->op_next->op_type == OP_CONST
13944 && p->op_next->op_next
13945 && p->op_next->op_next->op_type == OP_AELEM
13949 /* for 1st padop, note what type it is and the range
13950 * start; for the others, check that it's the same type
13951 * and that the targs are contiguous */
13953 intro = (p->op_private & OPpLVAL_INTRO);
13955 gvoid = OP_GIMME(p,0) == G_VOID;
13958 if ((p->op_private & OPpLVAL_INTRO) != intro)
13960 /* Note that you'd normally expect targs to be
13961 * contiguous in my($a,$b,$c), but that's not the case
13962 * when external modules start doing things, e.g.
13963 * Function::Parameters */
13964 if (p->op_targ != base + count)
13966 assert(p->op_targ == base + count);
13967 /* Either all the padops or none of the padops should
13968 be in void context. Since we only do the optimisa-
13969 tion for av/hv when the aggregate itself is pushed
13970 on to the stack (one item), there is no need to dis-
13971 tinguish list from scalar context. */
13972 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13976 /* for AV, HV, only when we're not flattening */
13977 if ( p->op_type != OP_PADSV
13979 && !(p->op_flags & OPf_REF)
13983 if (count >= OPpPADRANGE_COUNTMASK)
13986 /* there's a biggest base we can fit into a
13987 * SAVEt_CLEARPADRANGE in pp_padrange.
13988 * (The sizeof() stuff will be constant-folded, and is
13989 * intended to avoid getting "comparison is always false"
13990 * compiler warnings. See the comments above
13991 * MEM_WRAP_CHECK for more explanation on why we do this
13992 * in a weird way to avoid compiler warnings.)
13995 && (8*sizeof(base) >
13996 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13998 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
14000 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
14004 /* Success! We've got another valid pad op to optimise away */
14006 followop = p->op_next;
14009 if (count < 1 || (count == 1 && !defav))
14012 /* pp_padrange in specifically compile-time void context
14013 * skips pushing a mark and lexicals; in all other contexts
14014 * (including unknown till runtime) it pushes a mark and the
14015 * lexicals. We must be very careful then, that the ops we
14016 * optimise away would have exactly the same effect as the
14018 * In particular in void context, we can only optimise to
14019 * a padrange if we see the complete sequence
14020 * pushmark, pad*v, ...., list
14021 * which has the net effect of leaving the markstack as it
14022 * was. Not pushing onto the stack (whereas padsv does touch
14023 * the stack) makes no difference in void context.
14027 if (followop->op_type == OP_LIST
14028 && OP_GIMME(followop,0) == G_VOID
14031 followop = followop->op_next; /* skip OP_LIST */
14033 /* consolidate two successive my(...);'s */
14036 && oldoldop->op_type == OP_PADRANGE
14037 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
14038 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
14039 && !(oldoldop->op_flags & OPf_SPECIAL)
14042 assert(oldoldop->op_next == oldop);
14043 assert( oldop->op_type == OP_NEXTSTATE
14044 || oldop->op_type == OP_DBSTATE);
14045 assert(oldop->op_next == o);
14048 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
14050 /* Do not assume pad offsets for $c and $d are con-
14055 if ( oldoldop->op_targ + old_count == base
14056 && old_count < OPpPADRANGE_COUNTMASK - count) {
14057 base = oldoldop->op_targ;
14058 count += old_count;
14063 /* if there's any immediately following singleton
14064 * my var's; then swallow them and the associated
14066 * my ($a,$b); my $c; my $d;
14068 * my ($a,$b,$c,$d);
14071 while ( ((p = followop->op_next))
14072 && ( p->op_type == OP_PADSV
14073 || p->op_type == OP_PADAV
14074 || p->op_type == OP_PADHV)
14075 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
14076 && (p->op_private & OPpLVAL_INTRO) == intro
14077 && !(p->op_private & ~OPpLVAL_INTRO)
14079 && ( p->op_next->op_type == OP_NEXTSTATE
14080 || p->op_next->op_type == OP_DBSTATE)
14081 && count < OPpPADRANGE_COUNTMASK
14082 && base + count == p->op_targ
14085 followop = p->op_next;
14093 assert(oldoldop->op_type == OP_PADRANGE);
14094 oldoldop->op_next = followop;
14095 oldoldop->op_private = (intro | count);
14101 /* Convert the pushmark into a padrange.
14102 * To make Deparse easier, we guarantee that a padrange was
14103 * *always* formerly a pushmark */
14104 assert(o->op_type == OP_PUSHMARK);
14105 o->op_next = followop;
14106 OpTYPE_set(o, OP_PADRANGE);
14108 /* bit 7: INTRO; bit 6..0: count */
14109 o->op_private = (intro | count);
14110 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
14111 | gvoid * OPf_WANT_VOID
14112 | (defav ? OPf_SPECIAL : 0));
14120 /* Skip over state($x) in void context. */
14121 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
14122 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
14124 oldop->op_next = o->op_next;
14125 goto redo_nextstate;
14127 if (o->op_type != OP_PADAV)
14131 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
14132 OP* const pop = (o->op_type == OP_PADAV) ?
14133 o->op_next : o->op_next->op_next;
14135 if (pop && pop->op_type == OP_CONST &&
14136 ((PL_op = pop->op_next)) &&
14137 pop->op_next->op_type == OP_AELEM &&
14138 !(pop->op_next->op_private &
14139 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
14140 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
14143 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
14144 no_bareword_allowed(pop);
14145 if (o->op_type == OP_GV)
14146 op_null(o->op_next);
14147 op_null(pop->op_next);
14149 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
14150 o->op_next = pop->op_next->op_next;
14151 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
14152 o->op_private = (U8)i;
14153 if (o->op_type == OP_GV) {
14156 o->op_type = OP_AELEMFAST;
14159 o->op_type = OP_AELEMFAST_LEX;
14161 if (o->op_type != OP_GV)
14165 /* Remove $foo from the op_next chain in void context. */
14167 && ( o->op_next->op_type == OP_RV2SV
14168 || o->op_next->op_type == OP_RV2AV
14169 || o->op_next->op_type == OP_RV2HV )
14170 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14171 && !(o->op_next->op_private & OPpLVAL_INTRO))
14173 oldop->op_next = o->op_next->op_next;
14174 /* Reprocess the previous op if it is a nextstate, to
14175 allow double-nextstate optimisation. */
14177 if (oldop->op_type == OP_NEXTSTATE) {
14184 o = oldop->op_next;
14187 else if (o->op_next->op_type == OP_RV2SV) {
14188 if (!(o->op_next->op_private & OPpDEREF)) {
14189 op_null(o->op_next);
14190 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
14192 o->op_next = o->op_next->op_next;
14193 OpTYPE_set(o, OP_GVSV);
14196 else if (o->op_next->op_type == OP_READLINE
14197 && o->op_next->op_next->op_type == OP_CONCAT
14198 && (o->op_next->op_next->op_flags & OPf_STACKED))
14200 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
14201 OpTYPE_set(o, OP_RCATLINE);
14202 o->op_flags |= OPf_STACKED;
14203 op_null(o->op_next->op_next);
14204 op_null(o->op_next);
14209 #define HV_OR_SCALARHV(op) \
14210 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
14212 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
14213 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
14214 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
14215 ? cUNOPx(op)->op_first \
14219 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
14220 fop->op_private |= OPpTRUEBOOL;
14226 fop = cLOGOP->op_first;
14227 sop = OpSIBLING(fop);
14228 while (cLOGOP->op_other->op_type == OP_NULL)
14229 cLOGOP->op_other = cLOGOP->op_other->op_next;
14230 while (o->op_next && ( o->op_type == o->op_next->op_type
14231 || o->op_next->op_type == OP_NULL))
14232 o->op_next = o->op_next->op_next;
14234 /* If we're an OR and our next is an AND in void context, we'll
14235 follow its op_other on short circuit, same for reverse.
14236 We can't do this with OP_DOR since if it's true, its return
14237 value is the underlying value which must be evaluated
14241 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14242 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14244 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14246 o->op_next = ((LOGOP*)o->op_next)->op_other;
14248 DEFER(cLOGOP->op_other);
14251 fop = HV_OR_SCALARHV(fop);
14252 if (sop) sop = HV_OR_SCALARHV(sop);
14257 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14258 while (nop && nop->op_next) {
14259 switch (nop->op_next->op_type) {
14264 lop = nop = nop->op_next;
14267 nop = nop->op_next;
14276 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14277 || o->op_type == OP_AND )
14278 fop->op_private |= OPpTRUEBOOL;
14279 else if (!(lop->op_flags & OPf_WANT))
14280 fop->op_private |= OPpMAYBE_TRUEBOOL;
14282 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14284 sop->op_private |= OPpTRUEBOOL;
14291 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14292 fop->op_private |= OPpTRUEBOOL;
14293 #undef HV_OR_SCALARHV
14294 /* GERONIMO! */ /* FALLTHROUGH */
14303 case OP_ARGDEFELEM:
14304 while (cLOGOP->op_other->op_type == OP_NULL)
14305 cLOGOP->op_other = cLOGOP->op_other->op_next;
14306 DEFER(cLOGOP->op_other);
14311 while (cLOOP->op_redoop->op_type == OP_NULL)
14312 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14313 while (cLOOP->op_nextop->op_type == OP_NULL)
14314 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14315 while (cLOOP->op_lastop->op_type == OP_NULL)
14316 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14317 /* a while(1) loop doesn't have an op_next that escapes the
14318 * loop, so we have to explicitly follow the op_lastop to
14319 * process the rest of the code */
14320 DEFER(cLOOP->op_lastop);
14324 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14325 DEFER(cLOGOPo->op_other);
14329 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14330 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14331 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14332 cPMOP->op_pmstashstartu.op_pmreplstart
14333 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14334 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14340 if (o->op_flags & OPf_SPECIAL) {
14341 /* first arg is a code block */
14342 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14343 OP * kid = cUNOPx(nullop)->op_first;
14345 assert(nullop->op_type == OP_NULL);
14346 assert(kid->op_type == OP_SCOPE
14347 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14348 /* since OP_SORT doesn't have a handy op_other-style
14349 * field that can point directly to the start of the code
14350 * block, store it in the otherwise-unused op_next field
14351 * of the top-level OP_NULL. This will be quicker at
14352 * run-time, and it will also allow us to remove leading
14353 * OP_NULLs by just messing with op_nexts without
14354 * altering the basic op_first/op_sibling layout. */
14355 kid = kLISTOP->op_first;
14357 (kid->op_type == OP_NULL
14358 && ( kid->op_targ == OP_NEXTSTATE
14359 || kid->op_targ == OP_DBSTATE ))
14360 || kid->op_type == OP_STUB
14361 || kid->op_type == OP_ENTER);
14362 nullop->op_next = kLISTOP->op_next;
14363 DEFER(nullop->op_next);
14366 /* check that RHS of sort is a single plain array */
14367 oright = cUNOPo->op_first;
14368 if (!oright || oright->op_type != OP_PUSHMARK)
14371 if (o->op_private & OPpSORT_INPLACE)
14374 /* reverse sort ... can be optimised. */
14375 if (!OpHAS_SIBLING(cUNOPo)) {
14376 /* Nothing follows us on the list. */
14377 OP * const reverse = o->op_next;
14379 if (reverse->op_type == OP_REVERSE &&
14380 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14381 OP * const pushmark = cUNOPx(reverse)->op_first;
14382 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14383 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14384 /* reverse -> pushmark -> sort */
14385 o->op_private |= OPpSORT_REVERSE;
14387 pushmark->op_next = oright->op_next;
14397 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14399 LISTOP *enter, *exlist;
14401 if (o->op_private & OPpSORT_INPLACE)
14404 enter = (LISTOP *) o->op_next;
14407 if (enter->op_type == OP_NULL) {
14408 enter = (LISTOP *) enter->op_next;
14412 /* for $a (...) will have OP_GV then OP_RV2GV here.
14413 for (...) just has an OP_GV. */
14414 if (enter->op_type == OP_GV) {
14415 gvop = (OP *) enter;
14416 enter = (LISTOP *) enter->op_next;
14419 if (enter->op_type == OP_RV2GV) {
14420 enter = (LISTOP *) enter->op_next;
14426 if (enter->op_type != OP_ENTERITER)
14429 iter = enter->op_next;
14430 if (!iter || iter->op_type != OP_ITER)
14433 expushmark = enter->op_first;
14434 if (!expushmark || expushmark->op_type != OP_NULL
14435 || expushmark->op_targ != OP_PUSHMARK)
14438 exlist = (LISTOP *) OpSIBLING(expushmark);
14439 if (!exlist || exlist->op_type != OP_NULL
14440 || exlist->op_targ != OP_LIST)
14443 if (exlist->op_last != o) {
14444 /* Mmm. Was expecting to point back to this op. */
14447 theirmark = exlist->op_first;
14448 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14451 if (OpSIBLING(theirmark) != o) {
14452 /* There's something between the mark and the reverse, eg
14453 for (1, reverse (...))
14458 ourmark = ((LISTOP *)o)->op_first;
14459 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14462 ourlast = ((LISTOP *)o)->op_last;
14463 if (!ourlast || ourlast->op_next != o)
14466 rv2av = OpSIBLING(ourmark);
14467 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14468 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14469 /* We're just reversing a single array. */
14470 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14471 enter->op_flags |= OPf_STACKED;
14474 /* We don't have control over who points to theirmark, so sacrifice
14476 theirmark->op_next = ourmark->op_next;
14477 theirmark->op_flags = ourmark->op_flags;
14478 ourlast->op_next = gvop ? gvop : (OP *) enter;
14481 enter->op_private |= OPpITER_REVERSED;
14482 iter->op_private |= OPpITER_REVERSED;
14486 o = oldop->op_next;
14488 NOT_REACHED; /* NOTREACHED */
14494 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14495 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14500 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14501 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14504 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14506 sv = newRV((SV *)PL_compcv);
14510 OpTYPE_set(o, OP_CONST);
14511 o->op_flags |= OPf_SPECIAL;
14512 cSVOPo->op_sv = sv;
14517 if (OP_GIMME(o,0) == G_VOID
14518 || ( o->op_next->op_type == OP_LINESEQ
14519 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14520 || ( o->op_next->op_next->op_type == OP_RETURN
14521 && !CvLVALUE(PL_compcv)))))
14523 OP *right = cBINOP->op_first;
14542 OP *left = OpSIBLING(right);
14543 if (left->op_type == OP_SUBSTR
14544 && (left->op_private & 7) < 4) {
14546 /* cut out right */
14547 op_sibling_splice(o, NULL, 1, NULL);
14548 /* and insert it as second child of OP_SUBSTR */
14549 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14551 left->op_private |= OPpSUBSTR_REPL_FIRST;
14553 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14560 int l, r, lr, lscalars, rscalars;
14562 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14563 Note that we do this now rather than in newASSIGNOP(),
14564 since only by now are aliased lexicals flagged as such
14566 See the essay "Common vars in list assignment" above for
14567 the full details of the rationale behind all the conditions
14570 PL_generation sorcery:
14571 To detect whether there are common vars, the global var
14572 PL_generation is incremented for each assign op we scan.
14573 Then we run through all the lexical variables on the LHS,
14574 of the assignment, setting a spare slot in each of them to
14575 PL_generation. Then we scan the RHS, and if any lexicals
14576 already have that value, we know we've got commonality.
14577 Also, if the generation number is already set to
14578 PERL_INT_MAX, then the variable is involved in aliasing, so
14579 we also have potential commonality in that case.
14585 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14588 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14592 /* After looking for things which are *always* safe, this main
14593 * if/else chain selects primarily based on the type of the
14594 * LHS, gradually working its way down from the more dangerous
14595 * to the more restrictive and thus safer cases */
14597 if ( !l /* () = ....; */
14598 || !r /* .... = (); */
14599 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14600 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14601 || (lscalars < 2) /* ($x, undef) = ... */
14603 NOOP; /* always safe */
14605 else if (l & AAS_DANGEROUS) {
14606 /* always dangerous */
14607 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14608 o->op_private |= OPpASSIGN_COMMON_AGG;
14610 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14611 /* package vars are always dangerous - too many
14612 * aliasing possibilities */
14613 if (l & AAS_PKG_SCALAR)
14614 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14615 if (l & AAS_PKG_AGG)
14616 o->op_private |= OPpASSIGN_COMMON_AGG;
14618 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14619 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14621 /* LHS contains only lexicals and safe ops */
14623 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14624 o->op_private |= OPpASSIGN_COMMON_AGG;
14626 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14627 if (lr & AAS_LEX_SCALAR_COMM)
14628 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14629 else if ( !(l & AAS_LEX_SCALAR)
14630 && (r & AAS_DEFAV))
14634 * as scalar-safe for performance reasons.
14635 * (it will still have been marked _AGG if necessary */
14638 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14639 /* if there are only lexicals on the LHS and no
14640 * common ones on the RHS, then we assume that the
14641 * only way those lexicals could also get
14642 * on the RHS is via some sort of dereffing or
14645 * ($lex, $x) = (1, $$r)
14646 * and in this case we assume the var must have
14647 * a bumped ref count. So if its ref count is 1,
14648 * it must only be on the LHS.
14650 o->op_private |= OPpASSIGN_COMMON_RC1;
14655 * may have to handle aggregate on LHS, but we can't
14656 * have common scalars. */
14659 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14665 Perl_cpeep_t cpeep =
14666 XopENTRYCUSTOM(o, xop_peep);
14668 cpeep(aTHX_ o, oldop);
14673 /* did we just null the current op? If so, re-process it to handle
14674 * eliding "empty" ops from the chain */
14675 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14688 Perl_peep(pTHX_ OP *o)
14694 =head1 Custom Operators
14696 =for apidoc Ao||custom_op_xop
14697 Return the XOP structure for a given custom op. This macro should be
14698 considered internal to C<OP_NAME> and the other access macros: use them instead.
14699 This macro does call a function. Prior
14700 to 5.19.6, this was implemented as a
14707 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14713 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14715 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14716 assert(o->op_type == OP_CUSTOM);
14718 /* This is wrong. It assumes a function pointer can be cast to IV,
14719 * which isn't guaranteed, but this is what the old custom OP code
14720 * did. In principle it should be safer to Copy the bytes of the
14721 * pointer into a PV: since the new interface is hidden behind
14722 * functions, this can be changed later if necessary. */
14723 /* Change custom_op_xop if this ever happens */
14724 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14727 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14729 /* assume noone will have just registered a desc */
14730 if (!he && PL_custom_op_names &&
14731 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14736 /* XXX does all this need to be shared mem? */
14737 Newxz(xop, 1, XOP);
14738 pv = SvPV(HeVAL(he), l);
14739 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14740 if (PL_custom_op_descs &&
14741 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14743 pv = SvPV(HeVAL(he), l);
14744 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14746 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14750 xop = (XOP *)&xop_null;
14752 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14756 if(field == XOPe_xop_ptr) {
14759 const U32 flags = XopFLAGS(xop);
14760 if(flags & field) {
14762 case XOPe_xop_name:
14763 any.xop_name = xop->xop_name;
14765 case XOPe_xop_desc:
14766 any.xop_desc = xop->xop_desc;
14768 case XOPe_xop_class:
14769 any.xop_class = xop->xop_class;
14771 case XOPe_xop_peep:
14772 any.xop_peep = xop->xop_peep;
14775 NOT_REACHED; /* NOTREACHED */
14780 case XOPe_xop_name:
14781 any.xop_name = XOPd_xop_name;
14783 case XOPe_xop_desc:
14784 any.xop_desc = XOPd_xop_desc;
14786 case XOPe_xop_class:
14787 any.xop_class = XOPd_xop_class;
14789 case XOPe_xop_peep:
14790 any.xop_peep = XOPd_xop_peep;
14793 NOT_REACHED; /* NOTREACHED */
14798 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14799 * op.c: In function 'Perl_custom_op_get_field':
14800 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14801 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14802 * expands to assert(0), which expands to ((0) ? (void)0 :
14803 * __assert(...)), and gcc doesn't know that __assert can never return. */
14809 =for apidoc Ao||custom_op_register
14810 Register a custom op. See L<perlguts/"Custom Operators">.
14816 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14820 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14822 /* see the comment in custom_op_xop */
14823 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14825 if (!PL_custom_ops)
14826 PL_custom_ops = newHV();
14828 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14829 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14834 =for apidoc core_prototype
14836 This function assigns the prototype of the named core function to C<sv>, or
14837 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14838 C<NULL> if the core function has no prototype. C<code> is a code as returned
14839 by C<keyword()>. It must not be equal to 0.
14845 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14848 int i = 0, n = 0, seen_question = 0, defgv = 0;
14850 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14851 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14852 bool nullret = FALSE;
14854 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14858 if (!sv) sv = sv_newmortal();
14860 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14862 switch (code < 0 ? -code : code) {
14863 case KEY_and : case KEY_chop: case KEY_chomp:
14864 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14865 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14866 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14867 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14868 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14869 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14870 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14871 case KEY_x : case KEY_xor :
14872 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14873 case KEY_glob: retsetpvs("_;", OP_GLOB);
14874 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14875 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14876 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14877 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14878 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14880 case KEY_evalbytes:
14881 name = "entereval"; break;
14889 while (i < MAXO) { /* The slow way. */
14890 if (strEQ(name, PL_op_name[i])
14891 || strEQ(name, PL_op_desc[i]))
14893 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14900 defgv = PL_opargs[i] & OA_DEFGV;
14901 oa = PL_opargs[i] >> OASHIFT;
14903 if (oa & OA_OPTIONAL && !seen_question && (
14904 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14909 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14910 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14911 /* But globs are already references (kinda) */
14912 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14916 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14917 && !scalar_mod_type(NULL, i)) {
14922 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14926 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14927 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14928 str[n-1] = '_'; defgv = 0;
14932 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14934 sv_setpvn(sv, str, n - 1);
14935 if (opnum) *opnum = i;
14940 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14943 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14946 PERL_ARGS_ASSERT_CORESUB_OP;
14950 return op_append_elem(OP_LINESEQ,
14953 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14960 o = newUNOP(OP_AVHVSWITCH,0,argop);
14961 o->op_private = opnum-OP_EACH;
14963 case OP_SELECT: /* which represents OP_SSELECT as well */
14968 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14969 newSVOP(OP_CONST, 0, newSVuv(1))
14971 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14973 coresub_op(coreargssv, 0, OP_SELECT)
14977 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14979 return op_append_elem(
14982 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14983 ? OPpOFFBYONE << 8 : 0)
14985 case OA_BASEOP_OR_UNOP:
14986 if (opnum == OP_ENTEREVAL) {
14987 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14988 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14990 else o = newUNOP(opnum,0,argop);
14991 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14994 if (is_handle_constructor(o, 1))
14995 argop->op_private |= OPpCOREARGS_DEREF1;
14996 if (scalar_mod_type(NULL, opnum))
14997 argop->op_private |= OPpCOREARGS_SCALARMOD;
15001 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
15002 if (is_handle_constructor(o, 2))
15003 argop->op_private |= OPpCOREARGS_DEREF2;
15004 if (opnum == OP_SUBSTR) {
15005 o->op_private |= OPpMAYBE_LVSUB;
15014 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
15015 SV * const *new_const_svp)
15017 const char *hvname;
15018 bool is_const = !!CvCONST(old_cv);
15019 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
15021 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
15023 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
15025 /* They are 2 constant subroutines generated from
15026 the same constant. This probably means that
15027 they are really the "same" proxy subroutine
15028 instantiated in 2 places. Most likely this is
15029 when a constant is exported twice. Don't warn.
15032 (ckWARN(WARN_REDEFINE)
15034 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15035 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15036 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15037 strEQ(hvname, "autouse"))
15041 && ckWARN_d(WARN_REDEFINE)
15042 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
15045 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15047 ? "Constant subroutine %" SVf " redefined"
15048 : "Subroutine %" SVf " redefined",
15053 =head1 Hook manipulation
15055 These functions provide convenient and thread-safe means of manipulating
15062 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
15064 Puts a C function into the chain of check functions for a specified op
15065 type. This is the preferred way to manipulate the L</PL_check> array.
15066 C<opcode> specifies which type of op is to be affected. C<new_checker>
15067 is a pointer to the C function that is to be added to that opcode's
15068 check chain, and C<old_checker_p> points to the storage location where a
15069 pointer to the next function in the chain will be stored. The value of
15070 C<new_pointer> is written into the L</PL_check> array, while the value
15071 previously stored there is written to C<*old_checker_p>.
15073 The function should be defined like this:
15075 static OP *new_checker(pTHX_ OP *op) { ... }
15077 It is intended to be called in this manner:
15079 new_checker(aTHX_ op)
15081 C<old_checker_p> should be defined like this:
15083 static Perl_check_t old_checker_p;
15085 L</PL_check> is global to an entire process, and a module wishing to
15086 hook op checking may find itself invoked more than once per process,
15087 typically in different threads. To handle that situation, this function
15088 is idempotent. The location C<*old_checker_p> must initially (once
15089 per process) contain a null pointer. A C variable of static duration
15090 (declared at file scope, typically also marked C<static> to give
15091 it internal linkage) will be implicitly initialised appropriately,
15092 if it does not have an explicit initialiser. This function will only
15093 actually modify the check chain if it finds C<*old_checker_p> to be null.
15094 This function is also thread safe on the small scale. It uses appropriate
15095 locking to avoid race conditions in accessing L</PL_check>.
15097 When this function is called, the function referenced by C<new_checker>
15098 must be ready to be called, except for C<*old_checker_p> being unfilled.
15099 In a threading situation, C<new_checker> may be called immediately,
15100 even before this function has returned. C<*old_checker_p> will always
15101 be appropriately set before C<new_checker> is called. If C<new_checker>
15102 decides not to do anything special with an op that it is given (which
15103 is the usual case for most uses of op check hooking), it must chain the
15104 check function referenced by C<*old_checker_p>.
15106 If you want to influence compilation of calls to a specific subroutine,
15107 then use L</cv_set_call_checker> rather than hooking checking of all
15114 Perl_wrap_op_checker(pTHX_ Optype opcode,
15115 Perl_check_t new_checker, Perl_check_t *old_checker_p)
15119 PERL_UNUSED_CONTEXT;
15120 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15121 if (*old_checker_p) return;
15122 OP_CHECK_MUTEX_LOCK;
15123 if (!*old_checker_p) {
15124 *old_checker_p = PL_check[opcode];
15125 PL_check[opcode] = new_checker;
15127 OP_CHECK_MUTEX_UNLOCK;
15132 /* Efficient sub that returns a constant scalar value. */
15134 const_sv_xsub(pTHX_ CV* cv)
15137 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15138 PERL_UNUSED_ARG(items);
15148 const_av_xsub(pTHX_ CV* cv)
15151 AV * const av = MUTABLE_AV(XSANY.any_ptr);
15159 if (SvRMAGICAL(av))
15160 Perl_croak(aTHX_ "Magical list constants are not supported");
15161 if (GIMME_V != G_ARRAY) {
15163 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15166 EXTEND(SP, AvFILLp(av)+1);
15167 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15168 XSRETURN(AvFILLp(av)+1);
15173 * ex: set ts=8 sts=4 sw=4 et: