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)
491 size_t savestack_count = 0;
493 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_type == OP_TRANS || o->op_type == OP_TRANSR)
998 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1001 if (cPADOPo->op_padix > 0) {
1002 pad_swipe(cPADOPo->op_padix, TRUE);
1003 cPADOPo->op_padix = 0;
1006 SvREFCNT_dec(cSVOPo->op_sv);
1007 cSVOPo->op_sv = NULL;
1011 PerlMemShared_free(cPVOPo->op_pv);
1012 cPVOPo->op_pv = NULL;
1016 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1020 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1021 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1023 if (o->op_private & OPpSPLIT_LEX)
1024 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1027 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1029 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1036 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1037 op_free(cPMOPo->op_code_list);
1038 cPMOPo->op_code_list = NULL;
1039 forget_pmop(cPMOPo);
1040 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1041 /* we use the same protection as the "SAFE" version of the PM_ macros
1042 * here since sv_clean_all might release some PMOPs
1043 * after PL_regex_padav has been cleared
1044 * and the clearing of PL_regex_padav needs to
1045 * happen before sv_clean_all
1048 if(PL_regex_pad) { /* We could be in destruction */
1049 const IV offset = (cPMOPo)->op_pmoffset;
1050 ReREFCNT_dec(PM_GETRE(cPMOPo));
1051 PL_regex_pad[offset] = &PL_sv_undef;
1052 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1056 ReREFCNT_dec(PM_GETRE(cPMOPo));
1057 PM_SETRE(cPMOPo, NULL);
1063 PerlMemShared_free(cUNOP_AUXo->op_aux);
1068 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1069 UV actions = items->uv;
1071 bool is_hash = FALSE;
1074 switch (actions & MDEREF_ACTION_MASK) {
1077 actions = (++items)->uv;
1080 case MDEREF_HV_padhv_helem:
1082 case MDEREF_AV_padav_aelem:
1083 pad_free((++items)->pad_offset);
1086 case MDEREF_HV_gvhv_helem:
1088 case MDEREF_AV_gvav_aelem:
1090 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1092 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1096 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1098 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1100 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1102 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1104 goto do_vivify_rv2xv_elem;
1106 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1108 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1109 pad_free((++items)->pad_offset);
1110 goto do_vivify_rv2xv_elem;
1112 case MDEREF_HV_pop_rv2hv_helem:
1113 case MDEREF_HV_vivify_rv2hv_helem:
1115 do_vivify_rv2xv_elem:
1116 case MDEREF_AV_pop_rv2av_aelem:
1117 case MDEREF_AV_vivify_rv2av_aelem:
1119 switch (actions & MDEREF_INDEX_MASK) {
1120 case MDEREF_INDEX_none:
1123 case MDEREF_INDEX_const:
1127 pad_swipe((++items)->pad_offset, 1);
1129 SvREFCNT_dec((++items)->sv);
1135 case MDEREF_INDEX_padsv:
1136 pad_free((++items)->pad_offset);
1138 case MDEREF_INDEX_gvsv:
1140 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1142 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1147 if (actions & MDEREF_FLAG_last)
1160 actions >>= MDEREF_SHIFT;
1163 /* start of malloc is at op_aux[-1], where the length is
1165 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1170 if (o->op_targ > 0) {
1171 pad_free(o->op_targ);
1177 S_cop_free(pTHX_ COP* cop)
1179 PERL_ARGS_ASSERT_COP_FREE;
1182 if (! specialWARN(cop->cop_warnings))
1183 PerlMemShared_free(cop->cop_warnings);
1184 cophh_free(CopHINTHASH_get(cop));
1185 if (PL_curcop == cop)
1190 S_forget_pmop(pTHX_ PMOP *const o
1193 HV * const pmstash = PmopSTASH(o);
1195 PERL_ARGS_ASSERT_FORGET_PMOP;
1197 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1198 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1200 PMOP **const array = (PMOP**) mg->mg_ptr;
1201 U32 count = mg->mg_len / sizeof(PMOP**);
1205 if (array[i] == o) {
1206 /* Found it. Move the entry at the end to overwrite it. */
1207 array[i] = array[--count];
1208 mg->mg_len = count * sizeof(PMOP**);
1209 /* Could realloc smaller at this point always, but probably
1210 not worth it. Probably worth free()ing if we're the
1213 Safefree(mg->mg_ptr);
1226 S_find_and_forget_pmops(pTHX_ OP *o)
1228 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1230 if (o->op_flags & OPf_KIDS) {
1231 OP *kid = cUNOPo->op_first;
1233 switch (kid->op_type) {
1238 forget_pmop((PMOP*)kid);
1240 find_and_forget_pmops(kid);
1241 kid = OpSIBLING(kid);
1247 =for apidoc Am|void|op_null|OP *o
1249 Neutralizes an op when it is no longer needed, but is still linked to from
1256 Perl_op_null(pTHX_ OP *o)
1260 PERL_ARGS_ASSERT_OP_NULL;
1262 if (o->op_type == OP_NULL)
1265 o->op_targ = o->op_type;
1266 OpTYPE_set(o, OP_NULL);
1270 Perl_op_refcnt_lock(pTHX)
1271 PERL_TSA_ACQUIRE(PL_op_mutex)
1276 PERL_UNUSED_CONTEXT;
1281 Perl_op_refcnt_unlock(pTHX)
1282 PERL_TSA_RELEASE(PL_op_mutex)
1287 PERL_UNUSED_CONTEXT;
1293 =for apidoc op_sibling_splice
1295 A general function for editing the structure of an existing chain of
1296 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1297 you to delete zero or more sequential nodes, replacing them with zero or
1298 more different nodes. Performs the necessary op_first/op_last
1299 housekeeping on the parent node and op_sibling manipulation on the
1300 children. The last deleted node will be marked as as the last node by
1301 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1303 Note that op_next is not manipulated, and nodes are not freed; that is the
1304 responsibility of the caller. It also won't create a new list op for an
1305 empty list etc; use higher-level functions like op_append_elem() for that.
1307 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1308 the splicing doesn't affect the first or last op in the chain.
1310 C<start> is the node preceding the first node to be spliced. Node(s)
1311 following it will be deleted, and ops will be inserted after it. If it is
1312 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1315 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1316 If -1 or greater than or equal to the number of remaining kids, all
1317 remaining kids are deleted.
1319 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1320 If C<NULL>, no nodes are inserted.
1322 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1327 action before after returns
1328 ------ ----- ----- -------
1331 splice(P, A, 2, X-Y-Z) | | B-C
1335 splice(P, NULL, 1, X-Y) | | A
1339 splice(P, NULL, 3, NULL) | | A-B-C
1343 splice(P, B, 0, X-Y) | | NULL
1347 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1348 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1354 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1358 OP *last_del = NULL;
1359 OP *last_ins = NULL;
1362 first = OpSIBLING(start);
1366 first = cLISTOPx(parent)->op_first;
1368 assert(del_count >= -1);
1370 if (del_count && first) {
1372 while (--del_count && OpHAS_SIBLING(last_del))
1373 last_del = OpSIBLING(last_del);
1374 rest = OpSIBLING(last_del);
1375 OpLASTSIB_set(last_del, NULL);
1382 while (OpHAS_SIBLING(last_ins))
1383 last_ins = OpSIBLING(last_ins);
1384 OpMAYBESIB_set(last_ins, rest, NULL);
1390 OpMAYBESIB_set(start, insert, NULL);
1395 cLISTOPx(parent)->op_first = insert;
1397 parent->op_flags |= OPf_KIDS;
1399 parent->op_flags &= ~OPf_KIDS;
1403 /* update op_last etc */
1410 /* ought to use OP_CLASS(parent) here, but that can't handle
1411 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1413 type = parent->op_type;
1414 if (type == OP_CUSTOM) {
1416 type = XopENTRYCUSTOM(parent, xop_class);
1419 if (type == OP_NULL)
1420 type = parent->op_targ;
1421 type = PL_opargs[type] & OA_CLASS_MASK;
1424 lastop = last_ins ? last_ins : start ? start : NULL;
1425 if ( type == OA_BINOP
1426 || type == OA_LISTOP
1430 cLISTOPx(parent)->op_last = lastop;
1433 OpLASTSIB_set(lastop, parent);
1435 return last_del ? first : NULL;
1438 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1442 #ifdef PERL_OP_PARENT
1445 =for apidoc op_parent
1447 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1448 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1454 Perl_op_parent(OP *o)
1456 PERL_ARGS_ASSERT_OP_PARENT;
1457 while (OpHAS_SIBLING(o))
1459 return o->op_sibparent;
1465 /* replace the sibling following start with a new UNOP, which becomes
1466 * the parent of the original sibling; e.g.
1468 * op_sibling_newUNOP(P, A, unop-args...)
1476 * where U is the new UNOP.
1478 * parent and start args are the same as for op_sibling_splice();
1479 * type and flags args are as newUNOP().
1481 * Returns the new UNOP.
1485 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1489 kid = op_sibling_splice(parent, start, 1, NULL);
1490 newop = newUNOP(type, flags, kid);
1491 op_sibling_splice(parent, start, 0, newop);
1496 /* lowest-level newLOGOP-style function - just allocates and populates
1497 * the struct. Higher-level stuff should be done by S_new_logop() /
1498 * newLOGOP(). This function exists mainly to avoid op_first assignment
1499 * being spread throughout this file.
1503 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1508 NewOp(1101, logop, 1, LOGOP);
1509 OpTYPE_set(logop, type);
1510 logop->op_first = first;
1511 logop->op_other = other;
1512 logop->op_flags = OPf_KIDS;
1513 while (kid && OpHAS_SIBLING(kid))
1514 kid = OpSIBLING(kid);
1516 OpLASTSIB_set(kid, (OP*)logop);
1521 /* Contextualizers */
1524 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1526 Applies a syntactic context to an op tree representing an expression.
1527 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1528 or C<G_VOID> to specify the context to apply. The modified op tree
1535 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1537 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1539 case G_SCALAR: return scalar(o);
1540 case G_ARRAY: return list(o);
1541 case G_VOID: return scalarvoid(o);
1543 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1550 =for apidoc Am|OP*|op_linklist|OP *o
1551 This function is the implementation of the L</LINKLIST> macro. It should
1552 not be called directly.
1558 Perl_op_linklist(pTHX_ OP *o)
1562 PERL_ARGS_ASSERT_OP_LINKLIST;
1567 /* establish postfix order */
1568 first = cUNOPo->op_first;
1571 o->op_next = LINKLIST(first);
1574 OP *sibl = OpSIBLING(kid);
1576 kid->op_next = LINKLIST(sibl);
1591 S_scalarkids(pTHX_ OP *o)
1593 if (o && o->op_flags & OPf_KIDS) {
1595 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1602 S_scalarboolean(pTHX_ OP *o)
1604 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1606 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1607 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1608 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1609 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1610 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1611 if (ckWARN(WARN_SYNTAX)) {
1612 const line_t oldline = CopLINE(PL_curcop);
1614 if (PL_parser && PL_parser->copline != NOLINE) {
1615 /* This ensures that warnings are reported at the first line
1616 of the conditional, not the last. */
1617 CopLINE_set(PL_curcop, PL_parser->copline);
1619 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1620 CopLINE_set(PL_curcop, oldline);
1627 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1630 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1631 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1633 const char funny = o->op_type == OP_PADAV
1634 || o->op_type == OP_RV2AV ? '@' : '%';
1635 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1637 if (cUNOPo->op_first->op_type != OP_GV
1638 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1640 return varname(gv, funny, 0, NULL, 0, subscript_type);
1643 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1648 S_op_varname(pTHX_ const OP *o)
1650 return S_op_varname_subscript(aTHX_ o, 1);
1654 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1655 { /* or not so pretty :-) */
1656 if (o->op_type == OP_CONST) {
1658 if (SvPOK(*retsv)) {
1660 *retsv = sv_newmortal();
1661 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1662 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1664 else if (!SvOK(*retsv))
1667 else *retpv = "...";
1671 S_scalar_slice_warning(pTHX_ const OP *o)
1674 const bool h = o->op_type == OP_HSLICE
1675 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1681 SV *keysv = NULL; /* just to silence compiler warnings */
1682 const char *key = NULL;
1684 if (!(o->op_private & OPpSLICEWARNING))
1686 if (PL_parser && PL_parser->error_count)
1687 /* This warning can be nonsensical when there is a syntax error. */
1690 kid = cLISTOPo->op_first;
1691 kid = OpSIBLING(kid); /* get past pushmark */
1692 /* weed out false positives: any ops that can return lists */
1693 switch (kid->op_type) {
1719 /* Don't warn if we have a nulled list either. */
1720 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1723 assert(OpSIBLING(kid));
1724 name = S_op_varname(aTHX_ OpSIBLING(kid));
1725 if (!name) /* XS module fiddling with the op tree */
1727 S_op_pretty(aTHX_ kid, &keysv, &key);
1728 assert(SvPOK(name));
1729 sv_chop(name,SvPVX(name)+1);
1731 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1732 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1733 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1735 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1736 lbrack, key, rbrack);
1738 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1739 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1740 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1742 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1743 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1747 Perl_scalar(pTHX_ OP *o)
1751 /* assumes no premature commitment */
1752 if (!o || (PL_parser && PL_parser->error_count)
1753 || (o->op_flags & OPf_WANT)
1754 || o->op_type == OP_RETURN)
1759 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1761 switch (o->op_type) {
1763 scalar(cBINOPo->op_first);
1764 if (o->op_private & OPpREPEAT_DOLIST) {
1765 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1766 assert(kid->op_type == OP_PUSHMARK);
1767 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1768 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1769 o->op_private &=~ OPpREPEAT_DOLIST;
1776 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1786 if (o->op_flags & OPf_KIDS) {
1787 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1793 kid = cLISTOPo->op_first;
1795 kid = OpSIBLING(kid);
1798 OP *sib = OpSIBLING(kid);
1799 if (sib && kid->op_type != OP_LEAVEWHEN
1800 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1801 || ( sib->op_targ != OP_NEXTSTATE
1802 && sib->op_targ != OP_DBSTATE )))
1808 PL_curcop = &PL_compiling;
1813 kid = cLISTOPo->op_first;
1816 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1821 /* Warn about scalar context */
1822 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1823 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1826 const char *key = NULL;
1828 /* This warning can be nonsensical when there is a syntax error. */
1829 if (PL_parser && PL_parser->error_count)
1832 if (!ckWARN(WARN_SYNTAX)) break;
1834 kid = cLISTOPo->op_first;
1835 kid = OpSIBLING(kid); /* get past pushmark */
1836 assert(OpSIBLING(kid));
1837 name = S_op_varname(aTHX_ OpSIBLING(kid));
1838 if (!name) /* XS module fiddling with the op tree */
1840 S_op_pretty(aTHX_ kid, &keysv, &key);
1841 assert(SvPOK(name));
1842 sv_chop(name,SvPVX(name)+1);
1844 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1845 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1846 "%%%" SVf "%c%s%c in scalar context better written "
1847 "as $%" SVf "%c%s%c",
1848 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1849 lbrack, key, rbrack);
1851 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1852 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1853 "%%%" SVf "%c%" SVf "%c in scalar context better "
1854 "written as $%" SVf "%c%" SVf "%c",
1855 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1856 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1863 Perl_scalarvoid(pTHX_ OP *arg)
1868 SSize_t defer_stack_alloc = 0;
1869 SSize_t defer_ix = -1;
1870 OP **defer_stack = NULL;
1873 PERL_ARGS_ASSERT_SCALARVOID;
1877 SV *useless_sv = NULL;
1878 const char* useless = NULL;
1880 if (o->op_type == OP_NEXTSTATE
1881 || o->op_type == OP_DBSTATE
1882 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1883 || o->op_targ == OP_DBSTATE)))
1884 PL_curcop = (COP*)o; /* for warning below */
1886 /* assumes no premature commitment */
1887 want = o->op_flags & OPf_WANT;
1888 if ((want && want != OPf_WANT_SCALAR)
1889 || (PL_parser && PL_parser->error_count)
1890 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1895 if ((o->op_private & OPpTARGET_MY)
1896 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1898 /* newASSIGNOP has already applied scalar context, which we
1899 leave, as if this op is inside SASSIGN. */
1903 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1905 switch (o->op_type) {
1907 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1911 if (o->op_flags & OPf_STACKED)
1913 if (o->op_type == OP_REPEAT)
1914 scalar(cBINOPo->op_first);
1917 if (o->op_private == 4)
1952 case OP_GETSOCKNAME:
1953 case OP_GETPEERNAME:
1958 case OP_GETPRIORITY:
1983 useless = OP_DESC(o);
1993 case OP_AELEMFAST_LEX:
1997 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1998 /* Otherwise it's "Useless use of grep iterator" */
1999 useless = OP_DESC(o);
2003 if (!(o->op_private & OPpSPLIT_ASSIGN))
2004 useless = OP_DESC(o);
2008 kid = cUNOPo->op_first;
2009 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2010 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2013 useless = "negative pattern binding (!~)";
2017 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2018 useless = "non-destructive substitution (s///r)";
2022 useless = "non-destructive transliteration (tr///r)";
2029 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2030 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2031 useless = "a variable";
2036 if (cSVOPo->op_private & OPpCONST_STRICT)
2037 no_bareword_allowed(o);
2039 if (ckWARN(WARN_VOID)) {
2041 /* don't warn on optimised away booleans, eg
2042 * use constant Foo, 5; Foo || print; */
2043 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2045 /* the constants 0 and 1 are permitted as they are
2046 conventionally used as dummies in constructs like
2047 1 while some_condition_with_side_effects; */
2048 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2050 else if (SvPOK(sv)) {
2051 SV * const dsv = newSVpvs("");
2053 = Perl_newSVpvf(aTHX_
2055 pv_pretty(dsv, SvPVX_const(sv),
2056 SvCUR(sv), 32, NULL, NULL,
2058 | PERL_PV_ESCAPE_NOCLEAR
2059 | PERL_PV_ESCAPE_UNI_DETECT));
2060 SvREFCNT_dec_NN(dsv);
2062 else if (SvOK(sv)) {
2063 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2066 useless = "a constant (undef)";
2069 op_null(o); /* don't execute or even remember it */
2073 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2077 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2081 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2085 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2090 UNOP *refgen, *rv2cv;
2093 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2096 rv2gv = ((BINOP *)o)->op_last;
2097 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2100 refgen = (UNOP *)((BINOP *)o)->op_first;
2102 if (!refgen || (refgen->op_type != OP_REFGEN
2103 && refgen->op_type != OP_SREFGEN))
2106 exlist = (LISTOP *)refgen->op_first;
2107 if (!exlist || exlist->op_type != OP_NULL
2108 || exlist->op_targ != OP_LIST)
2111 if (exlist->op_first->op_type != OP_PUSHMARK
2112 && exlist->op_first != exlist->op_last)
2115 rv2cv = (UNOP*)exlist->op_last;
2117 if (rv2cv->op_type != OP_RV2CV)
2120 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2121 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2122 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2124 o->op_private |= OPpASSIGN_CV_TO_GV;
2125 rv2gv->op_private |= OPpDONT_INIT_GV;
2126 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2138 kid = cLOGOPo->op_first;
2139 if (kid->op_type == OP_NOT
2140 && (kid->op_flags & OPf_KIDS)) {
2141 if (o->op_type == OP_AND) {
2142 OpTYPE_set(o, OP_OR);
2144 OpTYPE_set(o, OP_AND);
2154 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2155 if (!(kid->op_flags & OPf_KIDS))
2162 if (o->op_flags & OPf_STACKED)
2169 if (!(o->op_flags & OPf_KIDS))
2180 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2181 if (!(kid->op_flags & OPf_KIDS))
2187 /* If the first kid after pushmark is something that the padrange
2188 optimisation would reject, then null the list and the pushmark.
2190 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2191 && ( !(kid = OpSIBLING(kid))
2192 || ( kid->op_type != OP_PADSV
2193 && kid->op_type != OP_PADAV
2194 && kid->op_type != OP_PADHV)
2195 || kid->op_private & ~OPpLVAL_INTRO
2196 || !(kid = OpSIBLING(kid))
2197 || ( kid->op_type != OP_PADSV
2198 && kid->op_type != OP_PADAV
2199 && kid->op_type != OP_PADHV)
2200 || kid->op_private & ~OPpLVAL_INTRO)
2202 op_null(cUNOPo->op_first); /* NULL the pushmark */
2203 op_null(o); /* NULL the list */
2215 /* mortalise it, in case warnings are fatal. */
2216 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2217 "Useless use of %" SVf " in void context",
2218 SVfARG(sv_2mortal(useless_sv)));
2221 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2222 "Useless use of %s in void context",
2225 } while ( (o = POP_DEFERRED_OP()) );
2227 Safefree(defer_stack);
2233 S_listkids(pTHX_ OP *o)
2235 if (o && o->op_flags & OPf_KIDS) {
2237 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2244 Perl_list(pTHX_ OP *o)
2248 /* assumes no premature commitment */
2249 if (!o || (o->op_flags & OPf_WANT)
2250 || (PL_parser && PL_parser->error_count)
2251 || o->op_type == OP_RETURN)
2256 if ((o->op_private & OPpTARGET_MY)
2257 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2259 return o; /* As if inside SASSIGN */
2262 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2264 switch (o->op_type) {
2266 list(cBINOPo->op_first);
2269 if (o->op_private & OPpREPEAT_DOLIST
2270 && !(o->op_flags & OPf_STACKED))
2272 list(cBINOPo->op_first);
2273 kid = cBINOPo->op_last;
2274 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2275 && SvIVX(kSVOP_sv) == 1)
2277 op_null(o); /* repeat */
2278 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2280 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2287 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2295 if (!(o->op_flags & OPf_KIDS))
2297 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2298 list(cBINOPo->op_first);
2299 return gen_constant_list(o);
2305 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2306 op_null(cUNOPo->op_first); /* NULL the pushmark */
2307 op_null(o); /* NULL the list */
2312 kid = cLISTOPo->op_first;
2314 kid = OpSIBLING(kid);
2317 OP *sib = OpSIBLING(kid);
2318 if (sib && kid->op_type != OP_LEAVEWHEN)
2324 PL_curcop = &PL_compiling;
2328 kid = cLISTOPo->op_first;
2335 S_scalarseq(pTHX_ OP *o)
2338 const OPCODE type = o->op_type;
2340 if (type == OP_LINESEQ || type == OP_SCOPE ||
2341 type == OP_LEAVE || type == OP_LEAVETRY)
2344 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2345 if ((sib = OpSIBLING(kid))
2346 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2347 || ( sib->op_targ != OP_NEXTSTATE
2348 && sib->op_targ != OP_DBSTATE )))
2353 PL_curcop = &PL_compiling;
2355 o->op_flags &= ~OPf_PARENS;
2356 if (PL_hints & HINT_BLOCK_SCOPE)
2357 o->op_flags |= OPf_PARENS;
2360 o = newOP(OP_STUB, 0);
2365 S_modkids(pTHX_ OP *o, I32 type)
2367 if (o && o->op_flags & OPf_KIDS) {
2369 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2370 op_lvalue(kid, type);
2376 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2377 * const fields. Also, convert CONST keys to HEK-in-SVs.
2378 * rop is the op that retrieves the hash;
2379 * key_op is the first key
2383 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2389 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2391 if (rop->op_first->op_type == OP_PADSV)
2392 /* @$hash{qw(keys here)} */
2393 rop = (UNOP*)rop->op_first;
2395 /* @{$hash}{qw(keys here)} */
2396 if (rop->op_first->op_type == OP_SCOPE
2397 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2399 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2406 lexname = NULL; /* just to silence compiler warnings */
2407 fields = NULL; /* just to silence compiler warnings */
2411 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2412 SvPAD_TYPED(lexname))
2413 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2414 && isGV(*fields) && GvHV(*fields);
2416 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2418 if (key_op->op_type != OP_CONST)
2420 svp = cSVOPx_svp(key_op);
2422 /* make sure it's not a bareword under strict subs */
2423 if (key_op->op_private & OPpCONST_BARE &&
2424 key_op->op_private & OPpCONST_STRICT)
2426 no_bareword_allowed((OP*)key_op);
2429 /* Make the CONST have a shared SV */
2430 if ( !SvIsCOW_shared_hash(sv = *svp)
2431 && SvTYPE(sv) < SVt_PVMG
2436 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2437 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2438 SvREFCNT_dec_NN(sv);
2443 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2445 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2446 "in variable %" PNf " of type %" HEKf,
2447 SVfARG(*svp), PNfARG(lexname),
2448 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2454 /* do all the final processing on an optree (e.g. running the peephole
2455 * optimiser on it), then attach it to cv (if cv is non-null)
2459 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2463 /* XXX for some reason, evals, require and main optrees are
2464 * never attached to their CV; instead they just hang off
2465 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2466 * and get manually freed when appropriate */
2468 startp = &CvSTART(cv);
2470 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2473 optree->op_private |= OPpREFCOUNTED;
2474 OpREFCNT_set(optree, 1);
2476 finalize_optree(optree);
2477 S_prune_chain_head(startp);
2480 /* now that optimizer has done its work, adjust pad values */
2481 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2482 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2488 =for apidoc finalize_optree
2490 This function finalizes the optree. Should be called directly after
2491 the complete optree is built. It does some additional
2492 checking which can't be done in the normal C<ck_>xxx functions and makes
2493 the tree thread-safe.
2498 Perl_finalize_optree(pTHX_ OP* o)
2500 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2503 SAVEVPTR(PL_curcop);
2511 /* Relocate sv to the pad for thread safety.
2512 * Despite being a "constant", the SV is written to,
2513 * for reference counts, sv_upgrade() etc. */
2514 PERL_STATIC_INLINE void
2515 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2518 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2520 ix = pad_alloc(OP_CONST, SVf_READONLY);
2521 SvREFCNT_dec(PAD_SVl(ix));
2522 PAD_SETSV(ix, *svp);
2523 /* XXX I don't know how this isn't readonly already. */
2524 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2532 S_finalize_op(pTHX_ OP* o)
2534 PERL_ARGS_ASSERT_FINALIZE_OP;
2536 assert(o->op_type != OP_FREED);
2538 switch (o->op_type) {
2541 PL_curcop = ((COP*)o); /* for warnings */
2544 if (OpHAS_SIBLING(o)) {
2545 OP *sib = OpSIBLING(o);
2546 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2547 && ckWARN(WARN_EXEC)
2548 && OpHAS_SIBLING(sib))
2550 const OPCODE type = OpSIBLING(sib)->op_type;
2551 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2552 const line_t oldline = CopLINE(PL_curcop);
2553 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2554 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2555 "Statement unlikely to be reached");
2556 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2557 "\t(Maybe you meant system() when you said exec()?)\n");
2558 CopLINE_set(PL_curcop, oldline);
2565 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2566 GV * const gv = cGVOPo_gv;
2567 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2568 /* XXX could check prototype here instead of just carping */
2569 SV * const sv = sv_newmortal();
2570 gv_efullname3(sv, gv, NULL);
2571 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2572 "%" SVf "() called too early to check prototype",
2579 if (cSVOPo->op_private & OPpCONST_STRICT)
2580 no_bareword_allowed(o);
2584 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2589 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2590 case OP_METHOD_NAMED:
2591 case OP_METHOD_SUPER:
2592 case OP_METHOD_REDIR:
2593 case OP_METHOD_REDIR_SUPER:
2594 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2603 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2606 rop = (UNOP*)((BINOP*)o)->op_first;
2611 S_scalar_slice_warning(aTHX_ o);
2615 kid = OpSIBLING(cLISTOPo->op_first);
2616 if (/* I bet there's always a pushmark... */
2617 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2618 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2623 key_op = (SVOP*)(kid->op_type == OP_CONST
2625 : OpSIBLING(kLISTOP->op_first));
2627 rop = (UNOP*)((LISTOP*)o)->op_last;
2630 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2632 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2636 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
2640 S_scalar_slice_warning(aTHX_ o);
2644 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2645 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2652 if (o->op_flags & OPf_KIDS) {
2656 /* check that op_last points to the last sibling, and that
2657 * the last op_sibling/op_sibparent field points back to the
2658 * parent, and that the only ops with KIDS are those which are
2659 * entitled to them */
2660 U32 type = o->op_type;
2664 if (type == OP_NULL) {
2666 /* ck_glob creates a null UNOP with ex-type GLOB
2667 * (which is a list op. So pretend it wasn't a listop */
2668 if (type == OP_GLOB)
2671 family = PL_opargs[type] & OA_CLASS_MASK;
2673 has_last = ( family == OA_BINOP
2674 || family == OA_LISTOP
2675 || family == OA_PMOP
2676 || family == OA_LOOP
2678 assert( has_last /* has op_first and op_last, or ...
2679 ... has (or may have) op_first: */
2680 || family == OA_UNOP
2681 || family == OA_UNOP_AUX
2682 || family == OA_LOGOP
2683 || family == OA_BASEOP_OR_UNOP
2684 || family == OA_FILESTATOP
2685 || family == OA_LOOPEXOP
2686 || family == OA_METHOP
2687 || type == OP_CUSTOM
2688 || type == OP_NULL /* new_logop does this */
2691 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2692 # ifdef PERL_OP_PARENT
2693 if (!OpHAS_SIBLING(kid)) {
2695 assert(kid == cLISTOPo->op_last);
2696 assert(kid->op_sibparent == o);
2699 if (has_last && !OpHAS_SIBLING(kid))
2700 assert(kid == cLISTOPo->op_last);
2705 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2711 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2713 Propagate lvalue ("modifiable") context to an op and its children.
2714 C<type> represents the context type, roughly based on the type of op that
2715 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2716 because it has no op type of its own (it is signalled by a flag on
2719 This function detects things that can't be modified, such as C<$x+1>, and
2720 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2721 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2723 It also flags things that need to behave specially in an lvalue context,
2724 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2730 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2733 PadnameLVALUE_on(pn);
2734 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2736 /* RT #127786: cv can be NULL due to an eval within the DB package
2737 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2738 * unless they contain an eval, but calling eval within DB
2739 * pretends the eval was done in the caller's scope.
2743 assert(CvPADLIST(cv));
2745 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2746 assert(PadnameLEN(pn));
2747 PadnameLVALUE_on(pn);
2752 S_vivifies(const OPCODE type)
2755 case OP_RV2AV: case OP_ASLICE:
2756 case OP_RV2HV: case OP_KVASLICE:
2757 case OP_RV2SV: case OP_HSLICE:
2758 case OP_AELEMFAST: case OP_KVHSLICE:
2767 S_lvref(pTHX_ OP *o, I32 type)
2771 switch (o->op_type) {
2773 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2774 kid = OpSIBLING(kid))
2775 S_lvref(aTHX_ kid, type);
2780 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2781 o->op_flags |= OPf_STACKED;
2782 if (o->op_flags & OPf_PARENS) {
2783 if (o->op_private & OPpLVAL_INTRO) {
2784 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2785 "localized parenthesized array in list assignment"));
2789 OpTYPE_set(o, OP_LVAVREF);
2790 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2791 o->op_flags |= OPf_MOD|OPf_REF;
2794 o->op_private |= OPpLVREF_AV;
2797 kid = cUNOPo->op_first;
2798 if (kid->op_type == OP_NULL)
2799 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2801 o->op_private = OPpLVREF_CV;
2802 if (kid->op_type == OP_GV)
2803 o->op_flags |= OPf_STACKED;
2804 else if (kid->op_type == OP_PADCV) {
2805 o->op_targ = kid->op_targ;
2807 op_free(cUNOPo->op_first);
2808 cUNOPo->op_first = NULL;
2809 o->op_flags &=~ OPf_KIDS;
2814 if (o->op_flags & OPf_PARENS) {
2816 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2817 "parenthesized hash in list assignment"));
2820 o->op_private |= OPpLVREF_HV;
2824 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2825 o->op_flags |= OPf_STACKED;
2828 if (o->op_flags & OPf_PARENS) goto parenhash;
2829 o->op_private |= OPpLVREF_HV;
2832 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2835 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2836 if (o->op_flags & OPf_PARENS) goto slurpy;
2837 o->op_private |= OPpLVREF_AV;
2841 o->op_private |= OPpLVREF_ELEM;
2842 o->op_flags |= OPf_STACKED;
2846 OpTYPE_set(o, OP_LVREFSLICE);
2847 o->op_private &= OPpLVAL_INTRO;
2850 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2852 else if (!(o->op_flags & OPf_KIDS))
2854 if (o->op_targ != OP_LIST) {
2855 S_lvref(aTHX_ cBINOPo->op_first, type);
2860 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2861 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2862 S_lvref(aTHX_ kid, type);
2866 if (o->op_flags & OPf_PARENS)
2871 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2872 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2873 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2879 OpTYPE_set(o, OP_LVREF);
2881 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2882 if (type == OP_ENTERLOOP)
2883 o->op_private |= OPpLVREF_ITER;
2886 PERL_STATIC_INLINE bool
2887 S_potential_mod_type(I32 type)
2889 /* Types that only potentially result in modification. */
2890 return type == OP_GREPSTART || type == OP_ENTERSUB
2891 || type == OP_REFGEN || type == OP_LEAVESUBLV;
2895 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2899 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2902 if (!o || (PL_parser && PL_parser->error_count))
2905 if ((o->op_private & OPpTARGET_MY)
2906 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2911 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2913 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2915 switch (o->op_type) {
2920 if ((o->op_flags & OPf_PARENS))
2924 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2925 !(o->op_flags & OPf_STACKED)) {
2926 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2927 assert(cUNOPo->op_first->op_type == OP_NULL);
2928 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2931 else { /* lvalue subroutine call */
2932 o->op_private |= OPpLVAL_INTRO;
2933 PL_modcount = RETURN_UNLIMITED_NUMBER;
2934 if (S_potential_mod_type(type)) {
2935 o->op_private |= OPpENTERSUB_INARGS;
2938 else { /* Compile-time error message: */
2939 OP *kid = cUNOPo->op_first;
2944 if (kid->op_type != OP_PUSHMARK) {
2945 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2947 "panic: unexpected lvalue entersub "
2948 "args: type/targ %ld:%" UVuf,
2949 (long)kid->op_type, (UV)kid->op_targ);
2950 kid = kLISTOP->op_first;
2952 while (OpHAS_SIBLING(kid))
2953 kid = OpSIBLING(kid);
2954 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2955 break; /* Postpone until runtime */
2958 kid = kUNOP->op_first;
2959 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2960 kid = kUNOP->op_first;
2961 if (kid->op_type == OP_NULL)
2963 "Unexpected constant lvalue entersub "
2964 "entry via type/targ %ld:%" UVuf,
2965 (long)kid->op_type, (UV)kid->op_targ);
2966 if (kid->op_type != OP_GV) {
2973 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2974 ? MUTABLE_CV(SvRV(gv))
2980 if (flags & OP_LVALUE_NO_CROAK)
2983 namesv = cv_name(cv, NULL, 0);
2984 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2985 "subroutine call of &%" SVf " in %s",
2986 SVfARG(namesv), PL_op_desc[type]),
2994 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2995 /* grep, foreach, subcalls, refgen */
2996 if (S_potential_mod_type(type))
2998 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2999 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3002 type ? PL_op_desc[type] : "local"));
3015 case OP_RIGHT_SHIFT:
3024 if (!(o->op_flags & OPf_STACKED))
3030 if (o->op_flags & OPf_STACKED) {
3034 if (!(o->op_private & OPpREPEAT_DOLIST))
3037 const I32 mods = PL_modcount;
3038 modkids(cBINOPo->op_first, type);
3039 if (type != OP_AASSIGN)
3041 kid = cBINOPo->op_last;
3042 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3043 const IV iv = SvIV(kSVOP_sv);
3044 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3046 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3049 PL_modcount = RETURN_UNLIMITED_NUMBER;
3055 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3056 op_lvalue(kid, type);
3061 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3062 PL_modcount = RETURN_UNLIMITED_NUMBER;
3063 return o; /* Treat \(@foo) like ordinary list. */
3067 if (scalar_mod_type(o, type))
3069 ref(cUNOPo->op_first, o->op_type);
3076 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3077 if (type == OP_LEAVESUBLV && (
3078 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3079 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3081 o->op_private |= OPpMAYBE_LVSUB;
3085 PL_modcount = RETURN_UNLIMITED_NUMBER;
3090 if (type == OP_LEAVESUBLV)
3091 o->op_private |= OPpMAYBE_LVSUB;
3094 if (type == OP_LEAVESUBLV
3095 && (o->op_private & 3) + OP_EACH == OP_KEYS)
3096 o->op_private |= OPpMAYBE_LVSUB;
3099 PL_hints |= HINT_BLOCK_SCOPE;
3100 if (type == OP_LEAVESUBLV)
3101 o->op_private |= OPpMAYBE_LVSUB;
3105 ref(cUNOPo->op_first, o->op_type);
3109 PL_hints |= HINT_BLOCK_SCOPE;
3119 case OP_AELEMFAST_LEX:
3126 PL_modcount = RETURN_UNLIMITED_NUMBER;
3127 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3128 return o; /* Treat \(@foo) like ordinary list. */
3129 if (scalar_mod_type(o, type))
3131 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3132 && type == OP_LEAVESUBLV)
3133 o->op_private |= OPpMAYBE_LVSUB;
3137 if (!type) /* local() */
3138 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3139 PNfARG(PAD_COMPNAME(o->op_targ)));
3140 if (!(o->op_private & OPpLVAL_INTRO)
3141 || ( type != OP_SASSIGN && type != OP_AASSIGN
3142 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3143 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3151 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3155 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3161 if (type == OP_LEAVESUBLV)
3162 o->op_private |= OPpMAYBE_LVSUB;
3163 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3164 /* substr and vec */
3165 /* If this op is in merely potential (non-fatal) modifiable
3166 context, then apply OP_ENTERSUB context to
3167 the kid op (to avoid croaking). Other-
3168 wise pass this op’s own type so the correct op is mentioned
3169 in error messages. */
3170 op_lvalue(OpSIBLING(cBINOPo->op_first),
3171 S_potential_mod_type(type)
3179 ref(cBINOPo->op_first, o->op_type);
3180 if (type == OP_ENTERSUB &&
3181 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3182 o->op_private |= OPpLVAL_DEFER;
3183 if (type == OP_LEAVESUBLV)
3184 o->op_private |= OPpMAYBE_LVSUB;
3191 o->op_private |= OPpLVALUE;
3197 if (o->op_flags & OPf_KIDS)
3198 op_lvalue(cLISTOPo->op_last, type);
3203 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3205 else if (!(o->op_flags & OPf_KIDS))
3208 if (o->op_targ != OP_LIST) {
3209 OP *sib = OpSIBLING(cLISTOPo->op_first);
3210 /* OP_TRANS and OP_TRANSR with argument have a weird optree
3217 * compared with things like OP_MATCH which have the argument
3223 * so handle specially to correctly get "Can't modify" croaks etc
3226 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3228 /* this should trigger a "Can't modify transliteration" err */
3229 op_lvalue(sib, type);
3231 op_lvalue(cBINOPo->op_first, type);
3237 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3238 /* elements might be in void context because the list is
3239 in scalar context or because they are attribute sub calls */
3240 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3241 op_lvalue(kid, type);
3249 if (type == OP_LEAVESUBLV
3250 || !S_vivifies(cLOGOPo->op_first->op_type))
3251 op_lvalue(cLOGOPo->op_first, type);
3252 if (type == OP_LEAVESUBLV
3253 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3254 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3258 if (type == OP_NULL) { /* local */
3260 if (!FEATURE_MYREF_IS_ENABLED)
3261 Perl_croak(aTHX_ "The experimental declared_refs "
3262 "feature is not enabled");
3263 Perl_ck_warner_d(aTHX_
3264 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3265 "Declaring references is experimental");
3266 op_lvalue(cUNOPo->op_first, OP_NULL);
3269 if (type != OP_AASSIGN && type != OP_SASSIGN
3270 && type != OP_ENTERLOOP)
3272 /* Don’t bother applying lvalue context to the ex-list. */
3273 kid = cUNOPx(cUNOPo->op_first)->op_first;
3274 assert (!OpHAS_SIBLING(kid));
3277 if (type == OP_NULL) /* local */
3279 if (type != OP_AASSIGN) goto nomod;
3280 kid = cUNOPo->op_first;
3283 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3284 S_lvref(aTHX_ kid, type);
3285 if (!PL_parser || PL_parser->error_count == ec) {
3286 if (!FEATURE_REFALIASING_IS_ENABLED)
3288 "Experimental aliasing via reference not enabled");
3289 Perl_ck_warner_d(aTHX_
3290 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3291 "Aliasing via reference is experimental");
3294 if (o->op_type == OP_REFGEN)
3295 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3300 if ((o->op_private & OPpSPLIT_ASSIGN)) {
3301 /* This is actually @array = split. */
3302 PL_modcount = RETURN_UNLIMITED_NUMBER;
3308 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3312 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3313 their argument is a filehandle; thus \stat(".") should not set
3315 if (type == OP_REFGEN &&
3316 PL_check[o->op_type] == Perl_ck_ftst)
3319 if (type != OP_LEAVESUBLV)
3320 o->op_flags |= OPf_MOD;
3322 if (type == OP_AASSIGN || type == OP_SASSIGN)
3323 o->op_flags |= OPf_SPECIAL
3324 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
3325 else if (!type) { /* local() */
3328 o->op_private |= OPpLVAL_INTRO;
3329 o->op_flags &= ~OPf_SPECIAL;
3330 PL_hints |= HINT_BLOCK_SCOPE;
3335 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3336 "Useless localization of %s", OP_DESC(o));
3339 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3340 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3341 o->op_flags |= OPf_REF;
3346 S_scalar_mod_type(const OP *o, I32 type)
3351 if (o && o->op_type == OP_RV2GV)
3375 case OP_RIGHT_SHIFT:
3404 S_is_handle_constructor(const OP *o, I32 numargs)
3406 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3408 switch (o->op_type) {
3416 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3429 S_refkids(pTHX_ OP *o, I32 type)
3431 if (o && o->op_flags & OPf_KIDS) {
3433 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3440 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3445 PERL_ARGS_ASSERT_DOREF;
3447 if (PL_parser && PL_parser->error_count)
3450 switch (o->op_type) {
3452 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3453 !(o->op_flags & OPf_STACKED)) {
3454 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3455 assert(cUNOPo->op_first->op_type == OP_NULL);
3456 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3457 o->op_flags |= OPf_SPECIAL;
3459 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3460 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3461 : type == OP_RV2HV ? OPpDEREF_HV
3463 o->op_flags |= OPf_MOD;
3469 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3470 doref(kid, type, set_op_ref);
3473 if (type == OP_DEFINED)
3474 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3475 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3478 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3479 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3480 : type == OP_RV2HV ? OPpDEREF_HV
3482 o->op_flags |= OPf_MOD;
3489 o->op_flags |= OPf_REF;
3492 if (type == OP_DEFINED)
3493 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3494 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3500 o->op_flags |= OPf_REF;
3505 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3507 doref(cBINOPo->op_first, type, set_op_ref);
3511 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3512 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3513 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3514 : type == OP_RV2HV ? OPpDEREF_HV
3516 o->op_flags |= OPf_MOD;
3526 if (!(o->op_flags & OPf_KIDS))
3528 doref(cLISTOPo->op_last, type, set_op_ref);
3538 S_dup_attrlist(pTHX_ OP *o)
3542 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3544 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3545 * where the first kid is OP_PUSHMARK and the remaining ones
3546 * are OP_CONST. We need to push the OP_CONST values.
3548 if (o->op_type == OP_CONST)
3549 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3551 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3553 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3554 if (o->op_type == OP_CONST)
3555 rop = op_append_elem(OP_LIST, rop,
3556 newSVOP(OP_CONST, o->op_flags,
3557 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3564 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3566 PERL_ARGS_ASSERT_APPLY_ATTRS;
3568 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3570 /* fake up C<use attributes $pkg,$rv,@attrs> */
3572 #define ATTRSMODULE "attributes"
3573 #define ATTRSMODULE_PM "attributes.pm"
3576 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3577 newSVpvs(ATTRSMODULE),
3579 op_prepend_elem(OP_LIST,
3580 newSVOP(OP_CONST, 0, stashsv),
3581 op_prepend_elem(OP_LIST,
3582 newSVOP(OP_CONST, 0,
3584 dup_attrlist(attrs))));
3589 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3591 OP *pack, *imop, *arg;
3592 SV *meth, *stashsv, **svp;
3594 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3599 assert(target->op_type == OP_PADSV ||
3600 target->op_type == OP_PADHV ||
3601 target->op_type == OP_PADAV);
3603 /* Ensure that attributes.pm is loaded. */
3604 /* Don't force the C<use> if we don't need it. */
3605 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3606 if (svp && *svp != &PL_sv_undef)
3607 NOOP; /* already in %INC */
3609 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3610 newSVpvs(ATTRSMODULE), NULL);
3612 /* Need package name for method call. */
3613 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3615 /* Build up the real arg-list. */
3616 stashsv = newSVhek(HvNAME_HEK(stash));
3618 arg = newOP(OP_PADSV, 0);
3619 arg->op_targ = target->op_targ;
3620 arg = op_prepend_elem(OP_LIST,
3621 newSVOP(OP_CONST, 0, stashsv),
3622 op_prepend_elem(OP_LIST,
3623 newUNOP(OP_REFGEN, 0,
3625 dup_attrlist(attrs)));
3627 /* Fake up a method call to import */
3628 meth = newSVpvs_share("import");
3629 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3630 op_append_elem(OP_LIST,
3631 op_prepend_elem(OP_LIST, pack, arg),
3632 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3634 /* Combine the ops. */
3635 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3639 =notfor apidoc apply_attrs_string
3641 Attempts to apply a list of attributes specified by the C<attrstr> and
3642 C<len> arguments to the subroutine identified by the C<cv> argument which
3643 is expected to be associated with the package identified by the C<stashpv>
3644 argument (see L<attributes>). It gets this wrong, though, in that it
3645 does not correctly identify the boundaries of the individual attribute
3646 specifications within C<attrstr>. This is not really intended for the
3647 public API, but has to be listed here for systems such as AIX which
3648 need an explicit export list for symbols. (It's called from XS code
3649 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3650 to respect attribute syntax properly would be welcome.
3656 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3657 const char *attrstr, STRLEN len)
3661 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3664 len = strlen(attrstr);
3668 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3670 const char * const sstr = attrstr;
3671 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3672 attrs = op_append_elem(OP_LIST, attrs,
3673 newSVOP(OP_CONST, 0,
3674 newSVpvn(sstr, attrstr-sstr)));
3678 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3679 newSVpvs(ATTRSMODULE),
3680 NULL, op_prepend_elem(OP_LIST,
3681 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3682 op_prepend_elem(OP_LIST,
3683 newSVOP(OP_CONST, 0,
3684 newRV(MUTABLE_SV(cv))),
3689 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3691 OP *new_proto = NULL;
3696 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3702 if (o->op_type == OP_CONST) {
3703 pv = SvPV(cSVOPo_sv, pvlen);
3704 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3705 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3706 SV ** const tmpo = cSVOPx_svp(o);
3707 SvREFCNT_dec(cSVOPo_sv);
3712 } else if (o->op_type == OP_LIST) {
3714 assert(o->op_flags & OPf_KIDS);
3715 lasto = cLISTOPo->op_first;
3716 assert(lasto->op_type == OP_PUSHMARK);
3717 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3718 if (o->op_type == OP_CONST) {
3719 pv = SvPV(cSVOPo_sv, pvlen);
3720 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3721 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3722 SV ** const tmpo = cSVOPx_svp(o);
3723 SvREFCNT_dec(cSVOPo_sv);
3725 if (new_proto && ckWARN(WARN_MISC)) {
3727 const char * newp = SvPV(cSVOPo_sv, new_len);
3728 Perl_warner(aTHX_ packWARN(WARN_MISC),
3729 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3730 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3736 /* excise new_proto from the list */
3737 op_sibling_splice(*attrs, lasto, 1, NULL);
3744 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3745 would get pulled in with no real need */
3746 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3755 svname = sv_newmortal();
3756 gv_efullname3(svname, name, NULL);
3758 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3759 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3761 svname = (SV *)name;
3762 if (ckWARN(WARN_ILLEGALPROTO))
3763 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3764 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3765 STRLEN old_len, new_len;
3766 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3767 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3769 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3770 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
3772 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3773 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3783 S_cant_declare(pTHX_ OP *o)
3785 if (o->op_type == OP_NULL
3786 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3787 o = cUNOPo->op_first;
3788 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3789 o->op_type == OP_NULL
3790 && o->op_flags & OPf_SPECIAL
3793 PL_parser->in_my == KEY_our ? "our" :
3794 PL_parser->in_my == KEY_state ? "state" :
3799 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3802 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3804 PERL_ARGS_ASSERT_MY_KID;
3806 if (!o || (PL_parser && PL_parser->error_count))
3811 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3813 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3814 my_kid(kid, attrs, imopsp);
3816 } else if (type == OP_UNDEF || type == OP_STUB) {
3818 } else if (type == OP_RV2SV || /* "our" declaration */
3821 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3822 S_cant_declare(aTHX_ o);
3824 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3826 PL_parser->in_my = FALSE;
3827 PL_parser->in_my_stash = NULL;
3828 apply_attrs(GvSTASH(gv),
3829 (type == OP_RV2SV ? GvSV(gv) :
3830 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3831 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3834 o->op_private |= OPpOUR_INTRO;
3837 else if (type == OP_REFGEN || type == OP_SREFGEN) {
3838 if (!FEATURE_MYREF_IS_ENABLED)
3839 Perl_croak(aTHX_ "The experimental declared_refs "
3840 "feature is not enabled");
3841 Perl_ck_warner_d(aTHX_
3842 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3843 "Declaring references is experimental");
3844 /* Kid is a nulled OP_LIST, handled above. */
3845 my_kid(cUNOPo->op_first, attrs, imopsp);
3848 else if (type != OP_PADSV &&
3851 type != OP_PUSHMARK)
3853 S_cant_declare(aTHX_ o);
3856 else if (attrs && type != OP_PUSHMARK) {
3860 PL_parser->in_my = FALSE;
3861 PL_parser->in_my_stash = NULL;
3863 /* check for C<my Dog $spot> when deciding package */
3864 stash = PAD_COMPNAME_TYPE(o->op_targ);
3866 stash = PL_curstash;
3867 apply_attrs_my(stash, o, attrs, imopsp);
3869 o->op_flags |= OPf_MOD;
3870 o->op_private |= OPpLVAL_INTRO;
3872 o->op_private |= OPpPAD_STATE;
3877 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3880 int maybe_scalar = 0;
3882 PERL_ARGS_ASSERT_MY_ATTRS;
3884 /* [perl #17376]: this appears to be premature, and results in code such as
3885 C< our(%x); > executing in list mode rather than void mode */
3887 if (o->op_flags & OPf_PARENS)
3897 o = my_kid(o, attrs, &rops);
3899 if (maybe_scalar && o->op_type == OP_PADSV) {
3900 o = scalar(op_append_list(OP_LIST, rops, o));
3901 o->op_private |= OPpLVAL_INTRO;
3904 /* The listop in rops might have a pushmark at the beginning,
3905 which will mess up list assignment. */
3906 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3907 if (rops->op_type == OP_LIST &&
3908 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3910 OP * const pushmark = lrops->op_first;
3911 /* excise pushmark */
3912 op_sibling_splice(rops, NULL, 1, NULL);
3915 o = op_append_list(OP_LIST, o, rops);
3918 PL_parser->in_my = FALSE;
3919 PL_parser->in_my_stash = NULL;
3924 Perl_sawparens(pTHX_ OP *o)
3926 PERL_UNUSED_CONTEXT;
3928 o->op_flags |= OPf_PARENS;
3933 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3937 const OPCODE ltype = left->op_type;
3938 const OPCODE rtype = right->op_type;
3940 PERL_ARGS_ASSERT_BIND_MATCH;
3942 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3943 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3945 const char * const desc
3947 rtype == OP_SUBST || rtype == OP_TRANS
3948 || rtype == OP_TRANSR
3950 ? (int)rtype : OP_MATCH];
3951 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3953 S_op_varname(aTHX_ left);
3955 Perl_warner(aTHX_ packWARN(WARN_MISC),
3956 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
3957 desc, SVfARG(name), SVfARG(name));
3959 const char * const sample = (isary
3960 ? "@array" : "%hash");
3961 Perl_warner(aTHX_ packWARN(WARN_MISC),
3962 "Applying %s to %s will act on scalar(%s)",
3963 desc, sample, sample);
3967 if (rtype == OP_CONST &&
3968 cSVOPx(right)->op_private & OPpCONST_BARE &&
3969 cSVOPx(right)->op_private & OPpCONST_STRICT)
3971 no_bareword_allowed(right);
3974 /* !~ doesn't make sense with /r, so error on it for now */
3975 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3977 /* diag_listed_as: Using !~ with %s doesn't make sense */
3978 yyerror("Using !~ with s///r doesn't make sense");
3979 if (rtype == OP_TRANSR && type == OP_NOT)
3980 /* diag_listed_as: Using !~ with %s doesn't make sense */
3981 yyerror("Using !~ with tr///r doesn't make sense");
3983 ismatchop = (rtype == OP_MATCH ||
3984 rtype == OP_SUBST ||
3985 rtype == OP_TRANS || rtype == OP_TRANSR)
3986 && !(right->op_flags & OPf_SPECIAL);
3987 if (ismatchop && right->op_private & OPpTARGET_MY) {
3989 right->op_private &= ~OPpTARGET_MY;
3991 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3992 if (left->op_type == OP_PADSV
3993 && !(left->op_private & OPpLVAL_INTRO))
3995 right->op_targ = left->op_targ;
4000 right->op_flags |= OPf_STACKED;
4001 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4002 ! (rtype == OP_TRANS &&
4003 right->op_private & OPpTRANS_IDENTICAL) &&
4004 ! (rtype == OP_SUBST &&
4005 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4006 left = op_lvalue(left, rtype);
4007 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4008 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4010 o = op_prepend_elem(rtype, scalar(left), right);
4013 return newUNOP(OP_NOT, 0, scalar(o));
4017 return bind_match(type, left,
4018 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4022 Perl_invert(pTHX_ OP *o)
4026 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4030 =for apidoc Amx|OP *|op_scope|OP *o
4032 Wraps up an op tree with some additional ops so that at runtime a dynamic
4033 scope will be created. The original ops run in the new dynamic scope,
4034 and then, provided that they exit normally, the scope will be unwound.
4035 The additional ops used to create and unwind the dynamic scope will
4036 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4037 instead if the ops are simple enough to not need the full dynamic scope
4044 Perl_op_scope(pTHX_ OP *o)
4048 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4049 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
4050 OpTYPE_set(o, OP_LEAVE);
4052 else if (o->op_type == OP_LINESEQ) {
4054 OpTYPE_set(o, OP_SCOPE);
4055 kid = ((LISTOP*)o)->op_first;
4056 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4059 /* The following deals with things like 'do {1 for 1}' */
4060 kid = OpSIBLING(kid);
4062 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4067 o = newLISTOP(OP_SCOPE, 0, o, NULL);
4073 Perl_op_unscope(pTHX_ OP *o)
4075 if (o && o->op_type == OP_LINESEQ) {
4076 OP *kid = cLISTOPo->op_first;
4077 for(; kid; kid = OpSIBLING(kid))
4078 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4085 =for apidoc Am|int|block_start|int full
4087 Handles compile-time scope entry.
4088 Arranges for hints to be restored on block
4089 exit and also handles pad sequence numbers to make lexical variables scope
4090 right. Returns a savestack index for use with C<block_end>.
4096 Perl_block_start(pTHX_ int full)
4098 const int retval = PL_savestack_ix;
4100 PL_compiling.cop_seq = PL_cop_seqmax;
4102 pad_block_start(full);
4104 PL_hints &= ~HINT_BLOCK_SCOPE;
4105 SAVECOMPILEWARNINGS();
4106 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4107 SAVEI32(PL_compiling.cop_seq);
4108 PL_compiling.cop_seq = 0;
4110 CALL_BLOCK_HOOKS(bhk_start, full);
4116 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4118 Handles compile-time scope exit. C<floor>
4119 is the savestack index returned by
4120 C<block_start>, and C<seq> is the body of the block. Returns the block,
4127 Perl_block_end(pTHX_ I32 floor, OP *seq)
4129 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4130 OP* retval = scalarseq(seq);
4133 /* XXX Is the null PL_parser check necessary here? */
4134 assert(PL_parser); /* Let’s find out under debugging builds. */
4135 if (PL_parser && PL_parser->parsed_sub) {
4136 o = newSTATEOP(0, NULL, NULL);
4138 retval = op_append_elem(OP_LINESEQ, retval, o);
4141 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4145 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4149 /* pad_leavemy has created a sequence of introcv ops for all my
4150 subs declared in the block. We have to replicate that list with
4151 clonecv ops, to deal with this situation:
4156 sub s1 { state sub foo { \&s2 } }
4159 Originally, I was going to have introcv clone the CV and turn
4160 off the stale flag. Since &s1 is declared before &s2, the
4161 introcv op for &s1 is executed (on sub entry) before the one for
4162 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
4163 cloned, since it is a state sub) closes over &s2 and expects
4164 to see it in its outer CV’s pad. If the introcv op clones &s1,
4165 then &s2 is still marked stale. Since &s1 is not active, and
4166 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4167 ble will not stay shared’ warning. Because it is the same stub
4168 that will be used when the introcv op for &s2 is executed, clos-
4169 ing over it is safe. Hence, we have to turn off the stale flag
4170 on all lexical subs in the block before we clone any of them.
4171 Hence, having introcv clone the sub cannot work. So we create a
4172 list of ops like this:
4196 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4197 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4198 for (;; kid = OpSIBLING(kid)) {
4199 OP *newkid = newOP(OP_CLONECV, 0);
4200 newkid->op_targ = kid->op_targ;
4201 o = op_append_elem(OP_LINESEQ, o, newkid);
4202 if (kid == last) break;
4204 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4207 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4213 =head1 Compile-time scope hooks
4215 =for apidoc Aox||blockhook_register
4217 Register a set of hooks to be called when the Perl lexical scope changes
4218 at compile time. See L<perlguts/"Compile-time scope hooks">.
4224 Perl_blockhook_register(pTHX_ BHK *hk)
4226 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4228 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4232 Perl_newPROG(pTHX_ OP *o)
4236 PERL_ARGS_ASSERT_NEWPROG;
4243 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4244 ((PL_in_eval & EVAL_KEEPERR)
4245 ? OPf_SPECIAL : 0), o);
4248 assert(CxTYPE(cx) == CXt_EVAL);
4250 if ((cx->blk_gimme & G_WANT) == G_VOID)
4251 scalarvoid(PL_eval_root);
4252 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4255 scalar(PL_eval_root);
4257 start = op_linklist(PL_eval_root);
4258 PL_eval_root->op_next = 0;
4259 i = PL_savestack_ix;
4262 S_process_optree(aTHX_ NULL, PL_eval_root, start);
4264 PL_savestack_ix = i;
4267 if (o->op_type == OP_STUB) {
4268 /* This block is entered if nothing is compiled for the main
4269 program. This will be the case for an genuinely empty main
4270 program, or one which only has BEGIN blocks etc, so already
4273 Historically (5.000) the guard above was !o. However, commit
4274 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4275 c71fccf11fde0068, changed perly.y so that newPROG() is now
4276 called with the output of block_end(), which returns a new
4277 OP_STUB for the case of an empty optree. ByteLoader (and
4278 maybe other things) also take this path, because they set up
4279 PL_main_start and PL_main_root directly, without generating an
4282 If the parsing the main program aborts (due to parse errors,
4283 or due to BEGIN or similar calling exit), then newPROG()
4284 isn't even called, and hence this code path and its cleanups
4285 are skipped. This shouldn't make a make a difference:
4286 * a non-zero return from perl_parse is a failure, and
4287 perl_destruct() should be called immediately.
4288 * however, if exit(0) is called during the parse, then
4289 perl_parse() returns 0, and perl_run() is called. As
4290 PL_main_start will be NULL, perl_run() will return
4291 promptly, and the exit code will remain 0.
4294 PL_comppad_name = 0;
4296 S_op_destroy(aTHX_ o);
4299 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4300 PL_curcop = &PL_compiling;
4301 start = LINKLIST(PL_main_root);
4302 PL_main_root->op_next = 0;
4303 S_process_optree(aTHX_ NULL, PL_main_root, start);
4304 cv_forget_slab(PL_compcv);
4307 /* Register with debugger */
4309 CV * const cv = get_cvs("DB::postponed", 0);
4313 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4315 call_sv(MUTABLE_SV(cv), G_DISCARD);
4322 Perl_localize(pTHX_ OP *o, I32 lex)
4324 PERL_ARGS_ASSERT_LOCALIZE;
4326 if (o->op_flags & OPf_PARENS)
4327 /* [perl #17376]: this appears to be premature, and results in code such as
4328 C< our(%x); > executing in list mode rather than void mode */
4335 if ( PL_parser->bufptr > PL_parser->oldbufptr
4336 && PL_parser->bufptr[-1] == ','
4337 && ckWARN(WARN_PARENTHESIS))
4339 char *s = PL_parser->bufptr;
4342 /* some heuristics to detect a potential error */
4343 while (*s && (strchr(", \t\n", *s)))
4347 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4349 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4352 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4354 while (*s && (strchr(", \t\n", *s)))
4360 if (sigil && (*s == ';' || *s == '=')) {
4361 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4362 "Parentheses missing around \"%s\" list",
4364 ? (PL_parser->in_my == KEY_our
4366 : PL_parser->in_my == KEY_state
4376 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4377 PL_parser->in_my = FALSE;
4378 PL_parser->in_my_stash = NULL;
4383 Perl_jmaybe(pTHX_ OP *o)
4385 PERL_ARGS_ASSERT_JMAYBE;
4387 if (o->op_type == OP_LIST) {
4389 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4390 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4395 PERL_STATIC_INLINE OP *
4396 S_op_std_init(pTHX_ OP *o)
4398 I32 type = o->op_type;
4400 PERL_ARGS_ASSERT_OP_STD_INIT;
4402 if (PL_opargs[type] & OA_RETSCALAR)
4404 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4405 o->op_targ = pad_alloc(type, SVs_PADTMP);
4410 PERL_STATIC_INLINE OP *
4411 S_op_integerize(pTHX_ OP *o)
4413 I32 type = o->op_type;
4415 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4417 /* integerize op. */
4418 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4421 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4424 if (type == OP_NEGATE)
4425 /* XXX might want a ck_negate() for this */
4426 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4432 S_fold_constants(pTHX_ OP *const o)
4437 VOL I32 type = o->op_type;
4442 SV * const oldwarnhook = PL_warnhook;
4443 SV * const olddiehook = PL_diehook;
4445 U8 oldwarn = PL_dowarn;
4449 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4451 if (!(PL_opargs[type] & OA_FOLDCONST))
4460 #ifdef USE_LOCALE_CTYPE
4461 if (IN_LC_COMPILETIME(LC_CTYPE))
4470 #ifdef USE_LOCALE_COLLATE
4471 if (IN_LC_COMPILETIME(LC_COLLATE))
4476 /* XXX what about the numeric ops? */
4477 #ifdef USE_LOCALE_NUMERIC
4478 if (IN_LC_COMPILETIME(LC_NUMERIC))
4483 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4484 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4487 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4488 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4490 const char *s = SvPVX_const(sv);
4491 while (s < SvEND(sv)) {
4492 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4499 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4502 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4503 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4507 if (PL_parser && PL_parser->error_count)
4508 goto nope; /* Don't try to run w/ errors */
4510 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4511 switch (curop->op_type) {
4513 if ( (curop->op_private & OPpCONST_BARE)
4514 && (curop->op_private & OPpCONST_STRICT)) {
4515 no_bareword_allowed(curop);
4523 /* Foldable; move to next op in list */
4527 /* No other op types are considered foldable */
4532 curop = LINKLIST(o);
4533 old_next = o->op_next;
4537 old_cxix = cxstack_ix;
4538 create_eval_scope(NULL, G_FAKINGEVAL);
4540 /* Verify that we don't need to save it: */
4541 assert(PL_curcop == &PL_compiling);
4542 StructCopy(&PL_compiling, ¬_compiling, COP);
4543 PL_curcop = ¬_compiling;
4544 /* The above ensures that we run with all the correct hints of the
4545 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4546 assert(IN_PERL_RUNTIME);
4547 PL_warnhook = PERL_WARNHOOK_FATAL;
4551 /* Effective $^W=1. */
4552 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4553 PL_dowarn |= G_WARN_ON;
4558 sv = *(PL_stack_sp--);
4559 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4560 pad_swipe(o->op_targ, FALSE);
4562 else if (SvTEMP(sv)) { /* grab mortal temp? */
4563 SvREFCNT_inc_simple_void(sv);
4566 else { assert(SvIMMORTAL(sv)); }
4569 /* Something tried to die. Abandon constant folding. */
4570 /* Pretend the error never happened. */
4572 o->op_next = old_next;
4576 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4577 PL_warnhook = oldwarnhook;
4578 PL_diehook = olddiehook;
4579 /* XXX note that this croak may fail as we've already blown away
4580 * the stack - eg any nested evals */
4581 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4584 PL_dowarn = oldwarn;
4585 PL_warnhook = oldwarnhook;
4586 PL_diehook = olddiehook;
4587 PL_curcop = &PL_compiling;
4589 /* if we croaked, depending on how we croaked the eval scope
4590 * may or may not have already been popped */
4591 if (cxstack_ix > old_cxix) {
4592 assert(cxstack_ix == old_cxix + 1);
4593 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4594 delete_eval_scope();
4599 /* OP_STRINGIFY and constant folding are used to implement qq.
4600 Here the constant folding is an implementation detail that we
4601 want to hide. If the stringify op is itself already marked
4602 folded, however, then it is actually a folded join. */
4603 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4608 else if (!SvIMMORTAL(sv)) {
4612 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4613 if (!is_stringify) newop->op_folded = 1;
4621 S_gen_constant_list(pTHX_ OP *o)
4624 OP *curop, *old_next;
4625 SV * const oldwarnhook = PL_warnhook;
4626 SV * const olddiehook = PL_diehook;
4628 U8 oldwarn = PL_dowarn;
4638 if (PL_parser && PL_parser->error_count)
4639 return o; /* Don't attempt to run with errors */
4641 curop = LINKLIST(o);
4642 old_next = o->op_next;
4644 op_was_null = o->op_type == OP_NULL;
4645 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
4646 o->op_type = OP_CUSTOM;
4649 o->op_type = OP_NULL;
4650 S_prune_chain_head(&curop);
4653 old_cxix = cxstack_ix;
4654 create_eval_scope(NULL, G_FAKINGEVAL);
4656 old_curcop = PL_curcop;
4657 StructCopy(old_curcop, ¬_compiling, COP);
4658 PL_curcop = ¬_compiling;
4659 /* The above ensures that we run with all the correct hints of the
4660 current COP, but that IN_PERL_RUNTIME is true. */
4661 assert(IN_PERL_RUNTIME);
4662 PL_warnhook = PERL_WARNHOOK_FATAL;
4666 /* Effective $^W=1. */
4667 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4668 PL_dowarn |= G_WARN_ON;
4672 Perl_pp_pushmark(aTHX);
4675 assert (!(curop->op_flags & OPf_SPECIAL));
4676 assert(curop->op_type == OP_RANGE);
4677 Perl_pp_anonlist(aTHX);
4681 o->op_next = old_next;
4685 PL_warnhook = oldwarnhook;
4686 PL_diehook = olddiehook;
4687 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
4692 PL_dowarn = oldwarn;
4693 PL_warnhook = oldwarnhook;
4694 PL_diehook = olddiehook;
4695 PL_curcop = old_curcop;
4697 if (cxstack_ix > old_cxix) {
4698 assert(cxstack_ix == old_cxix + 1);
4699 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4700 delete_eval_scope();
4705 OpTYPE_set(o, OP_RV2AV);
4706 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4707 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4708 o->op_opt = 0; /* needs to be revisited in rpeep() */
4709 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4711 /* replace subtree with an OP_CONST */
4712 curop = ((UNOP*)o)->op_first;
4713 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4716 if (AvFILLp(av) != -1)
4717 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4720 SvREADONLY_on(*svp);
4727 =head1 Optree Manipulation Functions
4730 /* List constructors */
4733 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4735 Append an item to the list of ops contained directly within a list-type
4736 op, returning the lengthened list. C<first> is the list-type op,
4737 and C<last> is the op to append to the list. C<optype> specifies the
4738 intended opcode for the list. If C<first> is not already a list of the
4739 right type, it will be upgraded into one. If either C<first> or C<last>
4740 is null, the other is returned unchanged.
4746 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4754 if (first->op_type != (unsigned)type
4755 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4757 return newLISTOP(type, 0, first, last);
4760 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4761 first->op_flags |= OPf_KIDS;
4766 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4768 Concatenate the lists of ops contained directly within two list-type ops,
4769 returning the combined list. C<first> and C<last> are the list-type ops
4770 to concatenate. C<optype> specifies the intended opcode for the list.
4771 If either C<first> or C<last> is not already a list of the right type,
4772 it will be upgraded into one. If either C<first> or C<last> is null,
4773 the other is returned unchanged.
4779 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4787 if (first->op_type != (unsigned)type)
4788 return op_prepend_elem(type, first, last);
4790 if (last->op_type != (unsigned)type)
4791 return op_append_elem(type, first, last);
4793 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4794 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4795 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4796 first->op_flags |= (last->op_flags & OPf_KIDS);
4798 S_op_destroy(aTHX_ last);
4804 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4806 Prepend an item to the list of ops contained directly within a list-type
4807 op, returning the lengthened list. C<first> is the op to prepend to the
4808 list, and C<last> is the list-type op. C<optype> specifies the intended
4809 opcode for the list. If C<last> is not already a list of the right type,
4810 it will be upgraded into one. If either C<first> or C<last> is null,
4811 the other is returned unchanged.
4817 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4825 if (last->op_type == (unsigned)type) {
4826 if (type == OP_LIST) { /* already a PUSHMARK there */
4827 /* insert 'first' after pushmark */
4828 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4829 if (!(first->op_flags & OPf_PARENS))
4830 last->op_flags &= ~OPf_PARENS;
4833 op_sibling_splice(last, NULL, 0, first);
4834 last->op_flags |= OPf_KIDS;
4838 return newLISTOP(type, 0, first, last);
4842 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4844 Converts C<o> into a list op if it is not one already, and then converts it
4845 into the specified C<type>, calling its check function, allocating a target if
4846 it needs one, and folding constants.
4848 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4849 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4850 C<op_convert_list> to make it the right type.
4856 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4859 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4860 if (!o || o->op_type != OP_LIST)
4861 o = force_list(o, 0);
4864 o->op_flags &= ~OPf_WANT;
4865 o->op_private &= ~OPpLVAL_INTRO;
4868 if (!(PL_opargs[type] & OA_MARK))
4869 op_null(cLISTOPo->op_first);
4871 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4872 if (kid2 && kid2->op_type == OP_COREARGS) {
4873 op_null(cLISTOPo->op_first);
4874 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4878 if (type != OP_SPLIT)
4879 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
4880 * ck_split() create a real PMOP and leave the op's type as listop
4881 * for now. Otherwise op_free() etc will crash.
4883 OpTYPE_set(o, type);
4885 o->op_flags |= flags;
4886 if (flags & OPf_FOLDED)
4889 o = CHECKOP(type, o);
4890 if (o->op_type != (unsigned)type)
4893 return fold_constants(op_integerize(op_std_init(o)));
4900 =head1 Optree construction
4902 =for apidoc Am|OP *|newNULLLIST
4904 Constructs, checks, and returns a new C<stub> op, which represents an
4905 empty list expression.
4911 Perl_newNULLLIST(pTHX)
4913 return newOP(OP_STUB, 0);
4916 /* promote o and any siblings to be a list if its not already; i.e.
4924 * pushmark - o - A - B
4926 * If nullit it true, the list op is nulled.
4930 S_force_list(pTHX_ OP *o, bool nullit)
4932 if (!o || o->op_type != OP_LIST) {
4935 /* manually detach any siblings then add them back later */
4936 rest = OpSIBLING(o);
4937 OpLASTSIB_set(o, NULL);
4939 o = newLISTOP(OP_LIST, 0, o, NULL);
4941 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4949 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4951 Constructs, checks, and returns an op of any list type. C<type> is
4952 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4953 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4954 supply up to two ops to be direct children of the list op; they are
4955 consumed by this function and become part of the constructed op tree.
4957 For most list operators, the check function expects all the kid ops to be
4958 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4959 appropriate. What you want to do in that case is create an op of type
4960 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4961 See L</op_convert_list> for more information.
4968 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4973 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4974 || type == OP_CUSTOM);
4976 NewOp(1101, listop, 1, LISTOP);
4978 OpTYPE_set(listop, type);
4981 listop->op_flags = (U8)flags;
4985 else if (!first && last)
4988 OpMORESIB_set(first, last);
4989 listop->op_first = first;
4990 listop->op_last = last;
4991 if (type == OP_LIST) {
4992 OP* const pushop = newOP(OP_PUSHMARK, 0);
4993 OpMORESIB_set(pushop, first);
4994 listop->op_first = pushop;
4995 listop->op_flags |= OPf_KIDS;
4997 listop->op_last = pushop;
4999 if (listop->op_last)
5000 OpLASTSIB_set(listop->op_last, (OP*)listop);
5002 return CHECKOP(type, listop);
5006 =for apidoc Am|OP *|newOP|I32 type|I32 flags
5008 Constructs, checks, and returns an op of any base type (any type that
5009 has no extra fields). C<type> is the opcode. C<flags> gives the
5010 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5017 Perl_newOP(pTHX_ I32 type, I32 flags)
5022 if (type == -OP_ENTEREVAL) {
5023 type = OP_ENTEREVAL;
5024 flags |= OPpEVAL_BYTES<<8;
5027 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5028 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5029 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5030 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5032 NewOp(1101, o, 1, OP);
5033 OpTYPE_set(o, type);
5034 o->op_flags = (U8)flags;
5037 o->op_private = (U8)(0 | (flags >> 8));
5038 if (PL_opargs[type] & OA_RETSCALAR)
5040 if (PL_opargs[type] & OA_TARGET)
5041 o->op_targ = pad_alloc(type, SVs_PADTMP);
5042 return CHECKOP(type, o);
5046 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
5048 Constructs, checks, and returns an op of any unary type. C<type> is
5049 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5050 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5051 bits, the eight bits of C<op_private>, except that the bit with value 1
5052 is automatically set. C<first> supplies an optional op to be the direct
5053 child of the unary op; it is consumed by this function and become part
5054 of the constructed op tree.
5060 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5065 if (type == -OP_ENTEREVAL) {
5066 type = OP_ENTEREVAL;
5067 flags |= OPpEVAL_BYTES<<8;
5070 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5071 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5072 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5073 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5074 || type == OP_SASSIGN
5075 || type == OP_ENTERTRY
5076 || type == OP_CUSTOM
5077 || type == OP_NULL );
5080 first = newOP(OP_STUB, 0);
5081 if (PL_opargs[type] & OA_MARK)
5082 first = force_list(first, 1);
5084 NewOp(1101, unop, 1, UNOP);
5085 OpTYPE_set(unop, type);
5086 unop->op_first = first;
5087 unop->op_flags = (U8)(flags | OPf_KIDS);
5088 unop->op_private = (U8)(1 | (flags >> 8));
5090 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5091 OpLASTSIB_set(first, (OP*)unop);
5093 unop = (UNOP*) CHECKOP(type, unop);
5097 return fold_constants(op_integerize(op_std_init((OP *) unop)));
5101 =for apidoc newUNOP_AUX
5103 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5104 initialised to C<aux>
5110 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5115 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5116 || type == OP_CUSTOM);
5118 NewOp(1101, unop, 1, UNOP_AUX);
5119 unop->op_type = (OPCODE)type;
5120 unop->op_ppaddr = PL_ppaddr[type];
5121 unop->op_first = first;
5122 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5123 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5126 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5127 OpLASTSIB_set(first, (OP*)unop);
5129 unop = (UNOP_AUX*) CHECKOP(type, unop);
5131 return op_std_init((OP *) unop);
5135 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5137 Constructs, checks, and returns an op of method type with a method name
5138 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
5139 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5140 and, shifted up eight bits, the eight bits of C<op_private>, except that
5141 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
5142 op which evaluates method name; it is consumed by this function and
5143 become part of the constructed op tree.
5144 Supported optypes: C<OP_METHOD>.
5150 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5154 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5155 || type == OP_CUSTOM);
5157 NewOp(1101, methop, 1, METHOP);
5159 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5160 methop->op_flags = (U8)(flags | OPf_KIDS);
5161 methop->op_u.op_first = dynamic_meth;
5162 methop->op_private = (U8)(1 | (flags >> 8));
5164 if (!OpHAS_SIBLING(dynamic_meth))
5165 OpLASTSIB_set(dynamic_meth, (OP*)methop);
5169 methop->op_flags = (U8)(flags & ~OPf_KIDS);
5170 methop->op_u.op_meth_sv = const_meth;
5171 methop->op_private = (U8)(0 | (flags >> 8));
5172 methop->op_next = (OP*)methop;
5176 methop->op_rclass_targ = 0;
5178 methop->op_rclass_sv = NULL;
5181 OpTYPE_set(methop, type);
5182 return CHECKOP(type, methop);
5186 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5187 PERL_ARGS_ASSERT_NEWMETHOP;
5188 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5192 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5194 Constructs, checks, and returns an op of method type with a constant
5195 method name. C<type> is the opcode. C<flags> gives the eight bits of
5196 C<op_flags>, and, shifted up eight bits, the eight bits of
5197 C<op_private>. C<const_meth> supplies a constant method name;
5198 it must be a shared COW string.
5199 Supported optypes: C<OP_METHOD_NAMED>.
5205 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5206 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5207 return newMETHOP_internal(type, flags, NULL, const_meth);
5211 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5213 Constructs, checks, and returns an op of any binary type. C<type>
5214 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
5215 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5216 the eight bits of C<op_private>, except that the bit with value 1 or
5217 2 is automatically set as required. C<first> and C<last> supply up to
5218 two ops to be the direct children of the binary op; they are consumed
5219 by this function and become part of the constructed op tree.
5225 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5230 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5231 || type == OP_NULL || type == OP_CUSTOM);
5233 NewOp(1101, binop, 1, BINOP);
5236 first = newOP(OP_NULL, 0);
5238 OpTYPE_set(binop, type);
5239 binop->op_first = first;
5240 binop->op_flags = (U8)(flags | OPf_KIDS);
5243 binop->op_private = (U8)(1 | (flags >> 8));
5246 binop->op_private = (U8)(2 | (flags >> 8));
5247 OpMORESIB_set(first, last);
5250 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5251 OpLASTSIB_set(last, (OP*)binop);
5253 binop->op_last = OpSIBLING(binop->op_first);
5255 OpLASTSIB_set(binop->op_last, (OP*)binop);
5257 binop = (BINOP*)CHECKOP(type, binop);
5258 if (binop->op_next || binop->op_type != (OPCODE)type)
5261 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5264 static int uvcompare(const void *a, const void *b)
5265 __attribute__nonnull__(1)
5266 __attribute__nonnull__(2)
5267 __attribute__pure__;
5268 static int uvcompare(const void *a, const void *b)
5270 if (*((const UV *)a) < (*(const UV *)b))
5272 if (*((const UV *)a) > (*(const UV *)b))
5274 if (*((const UV *)a+1) < (*(const UV *)b+1))
5276 if (*((const UV *)a+1) > (*(const UV *)b+1))
5282 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5284 SV * const tstr = ((SVOP*)expr)->op_sv;
5286 ((SVOP*)repl)->op_sv;
5289 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5290 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5296 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5297 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5298 I32 del = o->op_private & OPpTRANS_DELETE;
5301 PERL_ARGS_ASSERT_PMTRANS;
5303 PL_hints |= HINT_BLOCK_SCOPE;
5306 o->op_private |= OPpTRANS_FROM_UTF;
5309 o->op_private |= OPpTRANS_TO_UTF;
5311 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5312 SV* const listsv = newSVpvs("# comment\n");
5314 const U8* tend = t + tlen;
5315 const U8* rend = r + rlen;
5331 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5332 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5335 const U32 flags = UTF8_ALLOW_DEFAULT;
5339 t = tsave = bytes_to_utf8(t, &len);
5342 if (!to_utf && rlen) {
5344 r = rsave = bytes_to_utf8(r, &len);
5348 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5349 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5353 U8 tmpbuf[UTF8_MAXBYTES+1];
5356 Newx(cp, 2*tlen, UV);
5358 transv = newSVpvs("");
5360 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5362 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5364 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5368 cp[2*i+1] = cp[2*i];
5372 qsort(cp, i, 2*sizeof(UV), uvcompare);
5373 for (j = 0; j < i; j++) {
5375 diff = val - nextmin;
5377 t = uvchr_to_utf8(tmpbuf,nextmin);
5378 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5380 U8 range_mark = ILLEGAL_UTF8_BYTE;
5381 t = uvchr_to_utf8(tmpbuf, val - 1);
5382 sv_catpvn(transv, (char *)&range_mark, 1);
5383 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5390 t = uvchr_to_utf8(tmpbuf,nextmin);
5391 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5393 U8 range_mark = ILLEGAL_UTF8_BYTE;
5394 sv_catpvn(transv, (char *)&range_mark, 1);
5396 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5397 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5398 t = (const U8*)SvPVX_const(transv);
5399 tlen = SvCUR(transv);
5403 else if (!rlen && !del) {
5404 r = t; rlen = tlen; rend = tend;
5407 if ((!rlen && !del) || t == r ||
5408 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5410 o->op_private |= OPpTRANS_IDENTICAL;
5414 while (t < tend || tfirst <= tlast) {
5415 /* see if we need more "t" chars */
5416 if (tfirst > tlast) {
5417 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5419 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5421 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5428 /* now see if we need more "r" chars */
5429 if (rfirst > rlast) {
5431 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5433 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5435 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5444 rfirst = rlast = 0xffffffff;
5448 /* now see which range will peter out first, if either. */
5449 tdiff = tlast - tfirst;
5450 rdiff = rlast - rfirst;
5451 tcount += tdiff + 1;
5452 rcount += rdiff + 1;
5459 if (rfirst == 0xffffffff) {
5460 diff = tdiff; /* oops, pretend rdiff is infinite */
5462 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5463 (long)tfirst, (long)tlast);
5465 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5469 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5470 (long)tfirst, (long)(tfirst + diff),
5473 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5474 (long)tfirst, (long)rfirst);
5476 if (rfirst + diff > max)
5477 max = rfirst + diff;
5479 grows = (tfirst < rfirst &&
5480 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5492 else if (max > 0xff)
5497 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5499 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5500 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5501 PAD_SETSV(cPADOPo->op_padix, swash);
5503 SvREADONLY_on(swash);
5505 cSVOPo->op_sv = swash;
5507 SvREFCNT_dec(listsv);
5508 SvREFCNT_dec(transv);
5510 if (!del && havefinal && rlen)
5511 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5512 newSVuv((UV)final), 0);
5521 else if (rlast == 0xffffffff)
5527 tbl = (short*)PerlMemShared_calloc(
5528 (o->op_private & OPpTRANS_COMPLEMENT) &&
5529 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5531 cPVOPo->op_pv = (char*)tbl;
5533 for (i = 0; i < (I32)tlen; i++)
5535 for (i = 0, j = 0; i < 256; i++) {
5537 if (j >= (I32)rlen) {
5546 if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
5556 o->op_private |= OPpTRANS_IDENTICAL;
5558 else if (j >= (I32)rlen)
5563 PerlMemShared_realloc(tbl,
5564 (0x101+rlen-j) * sizeof(short));
5565 cPVOPo->op_pv = (char*)tbl;
5567 tbl[0x100] = (short)(rlen - j);
5568 for (i=0; i < (I32)rlen - j; i++)
5569 tbl[0x101+i] = r[j+i];
5573 if (!rlen && !del) {
5576 o->op_private |= OPpTRANS_IDENTICAL;
5578 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5579 o->op_private |= OPpTRANS_IDENTICAL;
5581 for (i = 0; i < 256; i++)
5583 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5584 if (j >= (I32)rlen) {
5586 if (tbl[t[i]] == -1)
5592 if (tbl[t[i]] == -1) {
5593 if ( UVCHR_IS_INVARIANT(t[i])
5594 && ! UVCHR_IS_INVARIANT(r[j]))
5602 if(del && rlen == tlen) {
5603 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5604 } else if(rlen > tlen && !complement) {
5605 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5609 o->op_private |= OPpTRANS_GROWS;
5617 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5619 Constructs, checks, and returns an op of any pattern matching type.
5620 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5621 and, shifted up eight bits, the eight bits of C<op_private>.
5627 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5632 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5633 || type == OP_CUSTOM);
5635 NewOp(1101, pmop, 1, PMOP);
5636 OpTYPE_set(pmop, type);
5637 pmop->op_flags = (U8)flags;
5638 pmop->op_private = (U8)(0 | (flags >> 8));
5639 if (PL_opargs[type] & OA_RETSCALAR)
5642 if (PL_hints & HINT_RE_TAINT)
5643 pmop->op_pmflags |= PMf_RETAINT;
5644 #ifdef USE_LOCALE_CTYPE
5645 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5646 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5651 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5653 if (PL_hints & HINT_RE_FLAGS) {
5654 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5655 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5657 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5658 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5659 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5661 if (reflags && SvOK(reflags)) {
5662 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5668 assert(SvPOK(PL_regex_pad[0]));
5669 if (SvCUR(PL_regex_pad[0])) {
5670 /* Pop off the "packed" IV from the end. */
5671 SV *const repointer_list = PL_regex_pad[0];
5672 const char *p = SvEND(repointer_list) - sizeof(IV);
5673 const IV offset = *((IV*)p);
5675 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5677 SvEND_set(repointer_list, p);
5679 pmop->op_pmoffset = offset;
5680 /* This slot should be free, so assert this: */
5681 assert(PL_regex_pad[offset] == &PL_sv_undef);
5683 SV * const repointer = &PL_sv_undef;
5684 av_push(PL_regex_padav, repointer);
5685 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5686 PL_regex_pad = AvARRAY(PL_regex_padav);
5690 return CHECKOP(type, pmop);
5698 /* Any pad names in scope are potentially lvalues. */
5699 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5700 PADNAME *pn = PAD_COMPNAME_SV(i);
5701 if (!pn || !PadnameLEN(pn))
5703 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5704 S_mark_padname_lvalue(aTHX_ pn);
5708 /* Given some sort of match op o, and an expression expr containing a
5709 * pattern, either compile expr into a regex and attach it to o (if it's
5710 * constant), or convert expr into a runtime regcomp op sequence (if it's
5713 * Flags currently has 2 bits of meaning:
5714 * 1: isreg indicates that the pattern is part of a regex construct, eg
5715 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5716 * split "pattern", which aren't. In the former case, expr will be a list
5717 * if the pattern contains more than one term (eg /a$b/).
5718 * 2: The pattern is for a split.
5720 * When the pattern has been compiled within a new anon CV (for
5721 * qr/(?{...})/ ), then floor indicates the savestack level just before
5722 * the new sub was created
5726 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
5730 I32 repl_has_vars = 0;
5731 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5732 bool is_compiletime;
5734 bool isreg = cBOOL(flags & 1);
5735 bool is_split = cBOOL(flags & 2);
5737 PERL_ARGS_ASSERT_PMRUNTIME;
5740 return pmtrans(o, expr, repl);
5743 /* find whether we have any runtime or code elements;
5744 * at the same time, temporarily set the op_next of each DO block;
5745 * then when we LINKLIST, this will cause the DO blocks to be excluded
5746 * from the op_next chain (and from having LINKLIST recursively
5747 * applied to them). We fix up the DOs specially later */
5751 if (expr->op_type == OP_LIST) {
5753 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5754 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5756 assert(!o->op_next);
5757 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5758 assert(PL_parser && PL_parser->error_count);
5759 /* This can happen with qr/ (?{(^{})/. Just fake up
5760 the op we were expecting to see, to avoid crashing
5762 op_sibling_splice(expr, o, 0,
5763 newSVOP(OP_CONST, 0, &PL_sv_no));
5765 o->op_next = OpSIBLING(o);
5767 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5771 else if (expr->op_type != OP_CONST)
5776 /* fix up DO blocks; treat each one as a separate little sub;
5777 * also, mark any arrays as LIST/REF */
5779 if (expr->op_type == OP_LIST) {
5781 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5783 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5784 assert( !(o->op_flags & OPf_WANT));
5785 /* push the array rather than its contents. The regex
5786 * engine will retrieve and join the elements later */
5787 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5791 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5793 o->op_next = NULL; /* undo temporary hack from above */
5796 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5797 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5799 assert(leaveop->op_first->op_type == OP_ENTER);
5800 assert(OpHAS_SIBLING(leaveop->op_first));
5801 o->op_next = OpSIBLING(leaveop->op_first);
5803 assert(leaveop->op_flags & OPf_KIDS);
5804 assert(leaveop->op_last->op_next == (OP*)leaveop);
5805 leaveop->op_next = NULL; /* stop on last op */
5806 op_null((OP*)leaveop);
5810 OP *scope = cLISTOPo->op_first;
5811 assert(scope->op_type == OP_SCOPE);
5812 assert(scope->op_flags & OPf_KIDS);
5813 scope->op_next = NULL; /* stop on last op */
5816 /* have to peep the DOs individually as we've removed it from
5817 * the op_next chain */
5819 S_prune_chain_head(&(o->op_next));
5821 /* runtime finalizes as part of finalizing whole tree */
5825 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5826 assert( !(expr->op_flags & OPf_WANT));
5827 /* push the array rather than its contents. The regex
5828 * engine will retrieve and join the elements later */
5829 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5832 PL_hints |= HINT_BLOCK_SCOPE;
5834 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5836 if (is_compiletime) {
5837 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5838 regexp_engine const *eng = current_re_engine();
5841 /* make engine handle split ' ' specially */
5842 pm->op_pmflags |= PMf_SPLIT;
5843 rx_flags |= RXf_SPLIT;
5846 /* Skip compiling if parser found an error for this pattern */
5847 if (pm->op_pmflags & PMf_HAS_ERROR) {
5851 if (!has_code || !eng->op_comp) {
5852 /* compile-time simple constant pattern */
5854 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5855 /* whoops! we guessed that a qr// had a code block, but we
5856 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5857 * that isn't required now. Note that we have to be pretty
5858 * confident that nothing used that CV's pad while the
5859 * regex was parsed, except maybe op targets for \Q etc.
5860 * If there were any op targets, though, they should have
5861 * been stolen by constant folding.
5865 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5866 while (++i <= AvFILLp(PL_comppad)) {
5867 # ifdef USE_PAD_RESET
5868 /* under USE_PAD_RESET, pad swipe replaces a swiped
5869 * folded constant with a fresh padtmp */
5870 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
5872 assert(!PL_curpad[i]);
5876 /* But we know that one op is using this CV's slab. */
5877 cv_forget_slab(PL_compcv);
5879 pm->op_pmflags &= ~PMf_HAS_CV;
5884 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5885 rx_flags, pm->op_pmflags)
5886 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5887 rx_flags, pm->op_pmflags)
5892 /* compile-time pattern that includes literal code blocks */
5893 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5896 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5899 if (pm->op_pmflags & PMf_HAS_CV) {
5901 /* this QR op (and the anon sub we embed it in) is never
5902 * actually executed. It's just a placeholder where we can
5903 * squirrel away expr in op_code_list without the peephole
5904 * optimiser etc processing it for a second time */
5905 OP *qr = newPMOP(OP_QR, 0);
5906 ((PMOP*)qr)->op_code_list = expr;
5908 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5909 SvREFCNT_inc_simple_void(PL_compcv);
5910 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5911 ReANY(re)->qr_anoncv = cv;
5913 /* attach the anon CV to the pad so that
5914 * pad_fixup_inner_anons() can find it */
5915 (void)pad_add_anon(cv, o->op_type);
5916 SvREFCNT_inc_simple_void(cv);
5919 pm->op_code_list = expr;
5924 /* runtime pattern: build chain of regcomp etc ops */
5926 PADOFFSET cv_targ = 0;
5928 reglist = isreg && expr->op_type == OP_LIST;
5933 pm->op_code_list = expr;
5934 /* don't free op_code_list; its ops are embedded elsewhere too */
5935 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5939 /* make engine handle split ' ' specially */
5940 pm->op_pmflags |= PMf_SPLIT;
5942 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5943 * to allow its op_next to be pointed past the regcomp and
5944 * preceding stacking ops;
5945 * OP_REGCRESET is there to reset taint before executing the
5947 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5948 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5950 if (pm->op_pmflags & PMf_HAS_CV) {
5951 /* we have a runtime qr with literal code. This means
5952 * that the qr// has been wrapped in a new CV, which
5953 * means that runtime consts, vars etc will have been compiled
5954 * against a new pad. So... we need to execute those ops
5955 * within the environment of the new CV. So wrap them in a call
5956 * to a new anon sub. i.e. for
5960 * we build an anon sub that looks like
5962 * sub { "a", $b, '(?{...})' }
5964 * and call it, passing the returned list to regcomp.
5965 * Or to put it another way, the list of ops that get executed
5969 * ------ -------------------
5970 * pushmark (for regcomp)
5971 * pushmark (for entersub)
5975 * regcreset regcreset
5977 * const("a") const("a")
5979 * const("(?{...})") const("(?{...})")
5984 SvREFCNT_inc_simple_void(PL_compcv);
5985 CvLVALUE_on(PL_compcv);
5986 /* these lines are just an unrolled newANONATTRSUB */
5987 expr = newSVOP(OP_ANONCODE, 0,
5988 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5989 cv_targ = expr->op_targ;
5990 expr = newUNOP(OP_REFGEN, 0, expr);
5992 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5995 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
5996 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5997 | (reglist ? OPf_STACKED : 0);
5998 rcop->op_targ = cv_targ;
6000 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
6001 if (PL_hints & HINT_RE_EVAL)
6002 S_set_haseval(aTHX);
6004 /* establish postfix order */
6005 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
6007 rcop->op_next = expr;
6008 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
6011 rcop->op_next = LINKLIST(expr);
6012 expr->op_next = (OP*)rcop;
6015 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
6021 /* If we are looking at s//.../e with a single statement, get past
6022 the implicit do{}. */
6023 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
6024 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
6025 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
6028 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
6029 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
6030 && !OpHAS_SIBLING(sib))
6033 if (curop->op_type == OP_CONST)
6035 else if (( (curop->op_type == OP_RV2SV ||
6036 curop->op_type == OP_RV2AV ||
6037 curop->op_type == OP_RV2HV ||
6038 curop->op_type == OP_RV2GV)
6039 && cUNOPx(curop)->op_first
6040 && cUNOPx(curop)->op_first->op_type == OP_GV )
6041 || curop->op_type == OP_PADSV
6042 || curop->op_type == OP_PADAV
6043 || curop->op_type == OP_PADHV
6044 || curop->op_type == OP_PADANY) {
6052 || !RX_PRELEN(PM_GETRE(pm))
6053 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
6055 pm->op_pmflags |= PMf_CONST; /* const for long enough */
6056 op_prepend_elem(o->op_type, scalar(repl), o);
6059 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
6060 rcop->op_private = 1;
6062 /* establish postfix order */
6063 rcop->op_next = LINKLIST(repl);
6064 repl->op_next = (OP*)rcop;
6066 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
6067 assert(!(pm->op_pmflags & PMf_ONCE));
6068 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
6077 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
6079 Constructs, checks, and returns an op of any type that involves an
6080 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
6081 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
6082 takes ownership of one reference to it.
6088 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
6093 PERL_ARGS_ASSERT_NEWSVOP;
6095 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6096 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6097 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6098 || type == OP_CUSTOM);
6100 NewOp(1101, svop, 1, SVOP);
6101 OpTYPE_set(svop, type);
6103 svop->op_next = (OP*)svop;
6104 svop->op_flags = (U8)flags;
6105 svop->op_private = (U8)(0 | (flags >> 8));
6106 if (PL_opargs[type] & OA_RETSCALAR)
6108 if (PL_opargs[type] & OA_TARGET)
6109 svop->op_targ = pad_alloc(type, SVs_PADTMP);
6110 return CHECKOP(type, svop);
6114 =for apidoc Am|OP *|newDEFSVOP|
6116 Constructs and returns an op to access C<$_>.
6122 Perl_newDEFSVOP(pTHX)
6124 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
6130 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
6132 Constructs, checks, and returns an op of any type that involves a
6133 reference to a pad element. C<type> is the opcode. C<flags> gives the
6134 eight bits of C<op_flags>. A pad slot is automatically allocated, and
6135 is populated with C<sv>; this function takes ownership of one reference
6138 This function only exists if Perl has been compiled to use ithreads.
6144 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
6149 PERL_ARGS_ASSERT_NEWPADOP;
6151 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6152 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6153 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6154 || type == OP_CUSTOM);
6156 NewOp(1101, padop, 1, PADOP);
6157 OpTYPE_set(padop, type);
6159 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
6160 SvREFCNT_dec(PAD_SVl(padop->op_padix));
6161 PAD_SETSV(padop->op_padix, sv);
6163 padop->op_next = (OP*)padop;
6164 padop->op_flags = (U8)flags;
6165 if (PL_opargs[type] & OA_RETSCALAR)
6167 if (PL_opargs[type] & OA_TARGET)
6168 padop->op_targ = pad_alloc(type, SVs_PADTMP);
6169 return CHECKOP(type, padop);
6172 #endif /* USE_ITHREADS */
6175 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
6177 Constructs, checks, and returns an op of any type that involves an
6178 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
6179 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
6180 reference; calling this function does not transfer ownership of any
6187 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
6189 PERL_ARGS_ASSERT_NEWGVOP;
6192 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6194 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6199 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
6201 Constructs, checks, and returns an op of any type that involves an
6202 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
6203 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
6204 must have been allocated using C<PerlMemShared_malloc>; the memory will
6205 be freed when the op is destroyed.
6211 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
6214 const bool utf8 = cBOOL(flags & SVf_UTF8);
6219 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6220 || type == OP_RUNCV || type == OP_CUSTOM
6221 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6223 NewOp(1101, pvop, 1, PVOP);
6224 OpTYPE_set(pvop, type);
6226 pvop->op_next = (OP*)pvop;
6227 pvop->op_flags = (U8)flags;
6228 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6229 if (PL_opargs[type] & OA_RETSCALAR)
6231 if (PL_opargs[type] & OA_TARGET)
6232 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6233 return CHECKOP(type, pvop);
6237 Perl_package(pTHX_ OP *o)
6239 SV *const sv = cSVOPo->op_sv;
6241 PERL_ARGS_ASSERT_PACKAGE;
6243 SAVEGENERICSV(PL_curstash);
6244 save_item(PL_curstname);
6246 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6248 sv_setsv(PL_curstname, sv);
6250 PL_hints |= HINT_BLOCK_SCOPE;
6251 PL_parser->copline = NOLINE;
6257 Perl_package_version( pTHX_ OP *v )
6259 U32 savehints = PL_hints;
6260 PERL_ARGS_ASSERT_PACKAGE_VERSION;
6261 PL_hints &= ~HINT_STRICT_VARS;
6262 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6263 PL_hints = savehints;
6268 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6273 SV *use_version = NULL;
6275 PERL_ARGS_ASSERT_UTILIZE;
6277 if (idop->op_type != OP_CONST)
6278 Perl_croak(aTHX_ "Module name must be constant");
6283 SV * const vesv = ((SVOP*)version)->op_sv;
6285 if (!arg && !SvNIOKp(vesv)) {
6292 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6293 Perl_croak(aTHX_ "Version number must be a constant number");
6295 /* Make copy of idop so we don't free it twice */
6296 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6298 /* Fake up a method call to VERSION */
6299 meth = newSVpvs_share("VERSION");
6300 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6301 op_append_elem(OP_LIST,
6302 op_prepend_elem(OP_LIST, pack, version),
6303 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6307 /* Fake up an import/unimport */
6308 if (arg && arg->op_type == OP_STUB) {
6309 imop = arg; /* no import on explicit () */
6311 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6312 imop = NULL; /* use 5.0; */
6314 use_version = ((SVOP*)idop)->op_sv;
6316 idop->op_private |= OPpCONST_NOVER;
6321 /* Make copy of idop so we don't free it twice */
6322 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6324 /* Fake up a method call to import/unimport */
6326 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6327 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6328 op_append_elem(OP_LIST,
6329 op_prepend_elem(OP_LIST, pack, arg),
6330 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6334 /* Fake up the BEGIN {}, which does its thing immediately. */
6336 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6339 op_append_elem(OP_LINESEQ,
6340 op_append_elem(OP_LINESEQ,
6341 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6342 newSTATEOP(0, NULL, veop)),
6343 newSTATEOP(0, NULL, imop) ));
6347 * feature bundle that corresponds to the required version. */
6348 use_version = sv_2mortal(new_version(use_version));
6349 S_enable_feature_bundle(aTHX_ use_version);
6351 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6352 if (vcmp(use_version,
6353 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6354 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6355 PL_hints |= HINT_STRICT_REFS;
6356 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6357 PL_hints |= HINT_STRICT_SUBS;
6358 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6359 PL_hints |= HINT_STRICT_VARS;
6361 /* otherwise they are off */
6363 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6364 PL_hints &= ~HINT_STRICT_REFS;
6365 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6366 PL_hints &= ~HINT_STRICT_SUBS;
6367 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6368 PL_hints &= ~HINT_STRICT_VARS;
6372 /* The "did you use incorrect case?" warning used to be here.
6373 * The problem is that on case-insensitive filesystems one
6374 * might get false positives for "use" (and "require"):
6375 * "use Strict" or "require CARP" will work. This causes
6376 * portability problems for the script: in case-strict
6377 * filesystems the script will stop working.
6379 * The "incorrect case" warning checked whether "use Foo"
6380 * imported "Foo" to your namespace, but that is wrong, too:
6381 * there is no requirement nor promise in the language that
6382 * a Foo.pm should or would contain anything in package "Foo".
6384 * There is very little Configure-wise that can be done, either:
6385 * the case-sensitivity of the build filesystem of Perl does not
6386 * help in guessing the case-sensitivity of the runtime environment.
6389 PL_hints |= HINT_BLOCK_SCOPE;
6390 PL_parser->copline = NOLINE;
6391 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6395 =head1 Embedding Functions
6397 =for apidoc load_module
6399 Loads the module whose name is pointed to by the string part of C<name>.
6400 Note that the actual module name, not its filename, should be given.
6401 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
6402 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
6403 trailing arguments can be used to specify arguments to the module's C<import()>
6404 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
6405 on the flags. The flags argument is a bitwise-ORed collection of any of
6406 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6407 (or 0 for no flags).
6409 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
6410 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
6411 the trailing optional arguments may be omitted entirely. Otherwise, if
6412 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
6413 exactly one C<OP*>, containing the op tree that produces the relevant import
6414 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
6415 will be used as import arguments; and the list must be terminated with C<(SV*)
6416 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
6417 set, the trailing C<NULL> pointer is needed even if no import arguments are
6418 desired. The reference count for each specified C<SV*> argument is
6419 decremented. In addition, the C<name> argument is modified.
6421 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
6427 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6431 PERL_ARGS_ASSERT_LOAD_MODULE;
6433 va_start(args, ver);
6434 vload_module(flags, name, ver, &args);
6438 #ifdef PERL_IMPLICIT_CONTEXT
6440 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6444 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6445 va_start(args, ver);
6446 vload_module(flags, name, ver, &args);
6452 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6455 OP * const modname = newSVOP(OP_CONST, 0, name);
6457 PERL_ARGS_ASSERT_VLOAD_MODULE;
6459 modname->op_private |= OPpCONST_BARE;
6461 veop = newSVOP(OP_CONST, 0, ver);
6465 if (flags & PERL_LOADMOD_NOIMPORT) {
6466 imop = sawparens(newNULLLIST());
6468 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6469 imop = va_arg(*args, OP*);
6474 sv = va_arg(*args, SV*);
6476 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6477 sv = va_arg(*args, SV*);
6481 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6482 * that it has a PL_parser to play with while doing that, and also
6483 * that it doesn't mess with any existing parser, by creating a tmp
6484 * new parser with lex_start(). This won't actually be used for much,
6485 * since pp_require() will create another parser for the real work.
6486 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6489 SAVEVPTR(PL_curcop);
6490 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6491 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6492 veop, modname, imop);
6496 PERL_STATIC_INLINE OP *
6497 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6499 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6500 newLISTOP(OP_LIST, 0, arg,
6501 newUNOP(OP_RV2CV, 0,
6502 newGVOP(OP_GV, 0, gv))));
6506 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6511 PERL_ARGS_ASSERT_DOFILE;
6513 if (!force_builtin && (gv = gv_override("do", 2))) {
6514 doop = S_new_entersubop(aTHX_ gv, term);
6517 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6523 =head1 Optree construction
6525 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6527 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6528 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6529 be set automatically, and, shifted up eight bits, the eight bits of
6530 C<op_private>, except that the bit with value 1 or 2 is automatically
6531 set as required. C<listval> and C<subscript> supply the parameters of
6532 the slice; they are consumed by this function and become part of the
6533 constructed op tree.
6539 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6541 return newBINOP(OP_LSLICE, flags,
6542 list(force_list(subscript, 1)),
6543 list(force_list(listval, 1)) );
6546 #define ASSIGN_LIST 1
6547 #define ASSIGN_REF 2
6550 S_assignment_type(pTHX_ const OP *o)
6559 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6560 o = cUNOPo->op_first;
6562 flags = o->op_flags;
6564 if (type == OP_COND_EXPR) {
6565 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6566 const I32 t = assignment_type(sib);
6567 const I32 f = assignment_type(OpSIBLING(sib));
6569 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6571 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6572 yyerror("Assignment to both a list and a scalar");
6576 if (type == OP_SREFGEN)
6578 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6579 type = kid->op_type;
6580 flags |= kid->op_flags;
6581 if (!(flags & OPf_PARENS)
6582 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6583 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6589 if (type == OP_LIST &&
6590 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6591 o->op_private & OPpLVAL_INTRO)
6594 if (type == OP_LIST || flags & OPf_PARENS ||
6595 type == OP_RV2AV || type == OP_RV2HV ||
6596 type == OP_ASLICE || type == OP_HSLICE ||
6597 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6600 if (type == OP_PADAV || type == OP_PADHV)
6603 if (type == OP_RV2SV)
6611 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6613 Constructs, checks, and returns an assignment op. C<left> and C<right>
6614 supply the parameters of the assignment; they are consumed by this
6615 function and become part of the constructed op tree.
6617 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6618 a suitable conditional optree is constructed. If C<optype> is the opcode
6619 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6620 performs the binary operation and assigns the result to the left argument.
6621 Either way, if C<optype> is non-zero then C<flags> has no effect.
6623 If C<optype> is zero, then a plain scalar or list assignment is
6624 constructed. Which type of assignment it is is automatically determined.
6625 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6626 will be set automatically, and, shifted up eight bits, the eight bits
6627 of C<op_private>, except that the bit with value 1 or 2 is automatically
6634 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6640 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6641 right = scalar(right);
6642 return newLOGOP(optype, 0,
6643 op_lvalue(scalar(left), optype),
6644 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
6647 return newBINOP(optype, OPf_STACKED,
6648 op_lvalue(scalar(left), optype), scalar(right));
6652 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6653 static const char no_list_state[] = "Initialization of state variables"
6654 " in list context currently forbidden";
6657 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6658 left->op_private &= ~ OPpSLICEWARNING;
6661 left = op_lvalue(left, OP_AASSIGN);
6662 curop = list(force_list(left, 1));
6663 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6664 o->op_private = (U8)(0 | (flags >> 8));
6666 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6668 OP* lop = ((LISTOP*)left)->op_first;
6670 if ((lop->op_type == OP_PADSV ||
6671 lop->op_type == OP_PADAV ||
6672 lop->op_type == OP_PADHV ||
6673 lop->op_type == OP_PADANY)
6674 && (lop->op_private & OPpPAD_STATE)
6676 yyerror(no_list_state);
6677 lop = OpSIBLING(lop);
6680 else if ( (left->op_private & OPpLVAL_INTRO)
6681 && (left->op_private & OPpPAD_STATE)
6682 && ( left->op_type == OP_PADSV
6683 || left->op_type == OP_PADAV
6684 || left->op_type == OP_PADHV
6685 || left->op_type == OP_PADANY)
6687 /* All single variable list context state assignments, hence
6697 yyerror(no_list_state);
6700 /* optimise @a = split(...) into:
6701 * @{expr}: split(..., @{expr}) (where @a is not flattened)
6702 * @a, my @a, local @a: split(...) (where @a is attached to
6703 * the split op itself)
6707 && right->op_type == OP_SPLIT
6708 /* don't do twice, e.g. @b = (@a = split) */
6709 && !(right->op_private & OPpSPLIT_ASSIGN))
6713 if ( ( left->op_type == OP_RV2AV
6714 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
6715 || left->op_type == OP_PADAV)
6717 /* @pkg or @lex or local @pkg' or 'my @lex' */
6721 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
6722 = cPADOPx(gvop)->op_padix;
6723 cPADOPx(gvop)->op_padix = 0; /* steal it */
6725 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
6726 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
6727 cSVOPx(gvop)->op_sv = NULL; /* steal it */
6729 right->op_private |=
6730 left->op_private & OPpOUR_INTRO;
6733 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
6734 left->op_targ = 0; /* steal it */
6735 right->op_private |= OPpSPLIT_LEX;
6737 right->op_private |= left->op_private & OPpLVAL_INTRO;
6740 tmpop = cUNOPo->op_first; /* to list (nulled) */
6741 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6742 assert(OpSIBLING(tmpop) == right);
6743 assert(!OpHAS_SIBLING(right));
6744 /* detach the split subtreee from the o tree,
6745 * then free the residual o tree */
6746 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
6747 op_free(o); /* blow off assign */
6748 right->op_private |= OPpSPLIT_ASSIGN;
6749 right->op_flags &= ~OPf_WANT;
6750 /* "I don't know and I don't care." */
6753 else if (left->op_type == OP_RV2AV) {
6756 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
6757 assert(OpSIBLING(pushop) == left);
6758 /* Detach the array ... */
6759 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
6760 /* ... and attach it to the split. */
6761 op_sibling_splice(right, cLISTOPx(right)->op_last,
6763 right->op_flags |= OPf_STACKED;
6764 /* Detach split and expunge aassign as above. */
6767 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6768 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6770 /* convert split(...,0) to split(..., PL_modcount+1) */
6772 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6773 SV * const sv = *svp;
6774 if (SvIOK(sv) && SvIVX(sv) == 0)
6776 if (right->op_private & OPpSPLIT_IMPLIM) {
6777 /* our own SV, created in ck_split */
6779 sv_setiv(sv, PL_modcount+1);
6782 /* SV may belong to someone else */
6784 *svp = newSViv(PL_modcount+1);
6791 if (assign_type == ASSIGN_REF)
6792 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6794 right = newOP(OP_UNDEF, 0);
6795 if (right->op_type == OP_READLINE) {
6796 right->op_flags |= OPf_STACKED;
6797 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6801 o = newBINOP(OP_SASSIGN, flags,
6802 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6808 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6810 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6811 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6812 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6813 If C<label> is non-null, it supplies the name of a label to attach to
6814 the state op; this function takes ownership of the memory pointed at by
6815 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6818 If C<o> is null, the state op is returned. Otherwise the state op is
6819 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6820 is consumed by this function and becomes part of the returned op tree.
6826 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6829 const U32 seq = intro_my();
6830 const U32 utf8 = flags & SVf_UTF8;
6833 PL_parser->parsed_sub = 0;
6837 NewOp(1101, cop, 1, COP);
6838 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6839 OpTYPE_set(cop, OP_DBSTATE);
6842 OpTYPE_set(cop, OP_NEXTSTATE);
6844 cop->op_flags = (U8)flags;
6845 CopHINTS_set(cop, PL_hints);
6847 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6849 cop->op_next = (OP*)cop;
6852 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6853 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6855 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6857 PL_hints |= HINT_BLOCK_SCOPE;
6858 /* It seems that we need to defer freeing this pointer, as other parts
6859 of the grammar end up wanting to copy it after this op has been
6864 if (PL_parser->preambling != NOLINE) {
6865 CopLINE_set(cop, PL_parser->preambling);
6866 PL_parser->copline = NOLINE;
6868 else if (PL_parser->copline == NOLINE)
6869 CopLINE_set(cop, CopLINE(PL_curcop));
6871 CopLINE_set(cop, PL_parser->copline);
6872 PL_parser->copline = NOLINE;
6875 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6877 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6879 CopSTASH_set(cop, PL_curstash);
6881 if (cop->op_type == OP_DBSTATE) {
6882 /* this line can have a breakpoint - store the cop in IV */
6883 AV *av = CopFILEAVx(PL_curcop);
6885 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6886 if (svp && *svp != &PL_sv_undef ) {
6887 (void)SvIOK_on(*svp);
6888 SvIV_set(*svp, PTR2IV(cop));
6893 if (flags & OPf_SPECIAL)
6895 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6899 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6901 Constructs, checks, and returns a logical (flow control) op. C<type>
6902 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6903 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6904 the eight bits of C<op_private>, except that the bit with value 1 is
6905 automatically set. C<first> supplies the expression controlling the
6906 flow, and C<other> supplies the side (alternate) chain of ops; they are
6907 consumed by this function and become part of the constructed op tree.
6913 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6915 PERL_ARGS_ASSERT_NEWLOGOP;
6917 return new_logop(type, flags, &first, &other);
6921 S_search_const(pTHX_ OP *o)
6923 PERL_ARGS_ASSERT_SEARCH_CONST;
6925 switch (o->op_type) {
6929 if (o->op_flags & OPf_KIDS)
6930 return search_const(cUNOPo->op_first);
6937 if (!(o->op_flags & OPf_KIDS))
6939 kid = cLISTOPo->op_first;
6941 switch (kid->op_type) {
6945 kid = OpSIBLING(kid);
6948 if (kid != cLISTOPo->op_last)
6954 kid = cLISTOPo->op_last;
6956 return search_const(kid);
6964 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6972 int prepend_not = 0;
6974 PERL_ARGS_ASSERT_NEW_LOGOP;
6979 /* [perl #59802]: Warn about things like "return $a or $b", which
6980 is parsed as "(return $a) or $b" rather than "return ($a or
6981 $b)". NB: This also applies to xor, which is why we do it
6984 switch (first->op_type) {
6988 /* XXX: Perhaps we should emit a stronger warning for these.
6989 Even with the high-precedence operator they don't seem to do
6992 But until we do, fall through here.
6998 /* XXX: Currently we allow people to "shoot themselves in the
6999 foot" by explicitly writing "(return $a) or $b".
7001 Warn unless we are looking at the result from folding or if
7002 the programmer explicitly grouped the operators like this.
7003 The former can occur with e.g.
7005 use constant FEATURE => ( $] >= ... );
7006 sub { not FEATURE and return or do_stuff(); }
7008 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
7009 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7010 "Possible precedence issue with control flow operator");
7011 /* XXX: Should we optimze this to "return $a;" (i.e. remove
7017 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
7018 return newBINOP(type, flags, scalar(first), scalar(other));
7020 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
7021 || type == OP_CUSTOM);
7023 scalarboolean(first);
7025 /* search for a constant op that could let us fold the test */
7026 if ((cstop = search_const(first))) {
7027 if (cstop->op_private & OPpCONST_STRICT)
7028 no_bareword_allowed(cstop);
7029 else if ((cstop->op_private & OPpCONST_BARE))
7030 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
7031 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
7032 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
7033 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
7034 /* Elide the (constant) lhs, since it can't affect the outcome */
7036 if (other->op_type == OP_CONST)
7037 other->op_private |= OPpCONST_SHORTCIRCUIT;
7039 if (other->op_type == OP_LEAVE)
7040 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
7041 else if (other->op_type == OP_MATCH
7042 || other->op_type == OP_SUBST
7043 || other->op_type == OP_TRANSR
7044 || other->op_type == OP_TRANS)
7045 /* Mark the op as being unbindable with =~ */
7046 other->op_flags |= OPf_SPECIAL;
7048 other->op_folded = 1;
7052 /* Elide the rhs, since the outcome is entirely determined by
7053 * the (constant) lhs */
7055 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
7056 const OP *o2 = other;
7057 if ( ! (o2->op_type == OP_LIST
7058 && (( o2 = cUNOPx(o2)->op_first))
7059 && o2->op_type == OP_PUSHMARK
7060 && (( o2 = OpSIBLING(o2))) )
7063 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
7064 || o2->op_type == OP_PADHV)
7065 && o2->op_private & OPpLVAL_INTRO
7066 && !(o2->op_private & OPpPAD_STATE))
7068 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7069 "Deprecated use of my() in false conditional. "
7070 "This will be a fatal error in Perl 5.30");
7074 if (cstop->op_type == OP_CONST)
7075 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
7080 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
7081 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
7083 const OP * const k1 = ((UNOP*)first)->op_first;
7084 const OP * const k2 = OpSIBLING(k1);
7086 switch (first->op_type)
7089 if (k2 && k2->op_type == OP_READLINE
7090 && (k2->op_flags & OPf_STACKED)
7091 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7093 warnop = k2->op_type;
7098 if (k1->op_type == OP_READDIR
7099 || k1->op_type == OP_GLOB
7100 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7101 || k1->op_type == OP_EACH
7102 || k1->op_type == OP_AEACH)
7104 warnop = ((k1->op_type == OP_NULL)
7105 ? (OPCODE)k1->op_targ : k1->op_type);
7110 const line_t oldline = CopLINE(PL_curcop);
7111 /* This ensures that warnings are reported at the first line
7112 of the construction, not the last. */
7113 CopLINE_set(PL_curcop, PL_parser->copline);
7114 Perl_warner(aTHX_ packWARN(WARN_MISC),
7115 "Value of %s%s can be \"0\"; test with defined()",
7117 ((warnop == OP_READLINE || warnop == OP_GLOB)
7118 ? " construct" : "() operator"));
7119 CopLINE_set(PL_curcop, oldline);
7123 /* optimize AND and OR ops that have NOTs as children */
7124 if (first->op_type == OP_NOT
7125 && (first->op_flags & OPf_KIDS)
7126 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
7127 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
7129 if (type == OP_AND || type == OP_OR) {
7135 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
7137 prepend_not = 1; /* prepend a NOT op later */
7142 logop = alloc_LOGOP(type, first, LINKLIST(other));
7143 logop->op_flags |= (U8)flags;
7144 logop->op_private = (U8)(1 | (flags >> 8));
7146 /* establish postfix order */
7147 logop->op_next = LINKLIST(first);
7148 first->op_next = (OP*)logop;
7149 assert(!OpHAS_SIBLING(first));
7150 op_sibling_splice((OP*)logop, first, 0, other);
7152 CHECKOP(type,logop);
7154 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7155 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7163 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7165 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7166 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7167 will be set automatically, and, shifted up eight bits, the eight bits of
7168 C<op_private>, except that the bit with value 1 is automatically set.
7169 C<first> supplies the expression selecting between the two branches,
7170 and C<trueop> and C<falseop> supply the branches; they are consumed by
7171 this function and become part of the constructed op tree.
7177 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7185 PERL_ARGS_ASSERT_NEWCONDOP;
7188 return newLOGOP(OP_AND, 0, first, trueop);
7190 return newLOGOP(OP_OR, 0, first, falseop);
7192 scalarboolean(first);
7193 if ((cstop = search_const(first))) {
7194 /* Left or right arm of the conditional? */
7195 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7196 OP *live = left ? trueop : falseop;
7197 OP *const dead = left ? falseop : trueop;
7198 if (cstop->op_private & OPpCONST_BARE &&
7199 cstop->op_private & OPpCONST_STRICT) {
7200 no_bareword_allowed(cstop);
7204 if (live->op_type == OP_LEAVE)
7205 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7206 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7207 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7208 /* Mark the op as being unbindable with =~ */
7209 live->op_flags |= OPf_SPECIAL;
7210 live->op_folded = 1;
7213 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
7214 logop->op_flags |= (U8)flags;
7215 logop->op_private = (U8)(1 | (flags >> 8));
7216 logop->op_next = LINKLIST(falseop);
7218 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7221 /* establish postfix order */
7222 start = LINKLIST(first);
7223 first->op_next = (OP*)logop;
7225 /* make first, trueop, falseop siblings */
7226 op_sibling_splice((OP*)logop, first, 0, trueop);
7227 op_sibling_splice((OP*)logop, trueop, 0, falseop);
7229 o = newUNOP(OP_NULL, 0, (OP*)logop);
7231 trueop->op_next = falseop->op_next = o;
7238 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7240 Constructs and returns a C<range> op, with subordinate C<flip> and
7241 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
7242 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7243 for both the C<flip> and C<range> ops, except that the bit with value
7244 1 is automatically set. C<left> and C<right> supply the expressions
7245 controlling the endpoints of the range; they are consumed by this function
7246 and become part of the constructed op tree.
7252 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7260 PERL_ARGS_ASSERT_NEWRANGE;
7262 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
7263 range->op_flags = OPf_KIDS;
7264 leftstart = LINKLIST(left);
7265 range->op_private = (U8)(1 | (flags >> 8));
7267 /* make left and right siblings */
7268 op_sibling_splice((OP*)range, left, 0, right);
7270 range->op_next = (OP*)range;
7271 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7272 flop = newUNOP(OP_FLOP, 0, flip);
7273 o = newUNOP(OP_NULL, 0, flop);
7275 range->op_next = leftstart;
7277 left->op_next = flip;
7278 right->op_next = flop;
7281 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7282 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7284 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7285 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7286 SvPADTMP_on(PAD_SV(flip->op_targ));
7288 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7289 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7291 /* check barewords before they might be optimized aways */
7292 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7293 no_bareword_allowed(left);
7294 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7295 no_bareword_allowed(right);
7298 if (!flip->op_private || !flop->op_private)
7299 LINKLIST(o); /* blow off optimizer unless constant */
7305 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7307 Constructs, checks, and returns an op tree expressing a loop. This is
7308 only a loop in the control flow through the op tree; it does not have
7309 the heavyweight loop structure that allows exiting the loop by C<last>
7310 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7311 top-level op, except that some bits will be set automatically as required.
7312 C<expr> supplies the expression controlling loop iteration, and C<block>
7313 supplies the body of the loop; they are consumed by this function and
7314 become part of the constructed op tree. C<debuggable> is currently
7315 unused and should always be 1.
7321 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7325 const bool once = block && block->op_flags & OPf_SPECIAL &&
7326 block->op_type == OP_NULL;
7328 PERL_UNUSED_ARG(debuggable);
7332 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7333 || ( expr->op_type == OP_NOT
7334 && cUNOPx(expr)->op_first->op_type == OP_CONST
7335 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7338 /* Return the block now, so that S_new_logop does not try to
7340 return block; /* do {} while 0 does once */
7341 if (expr->op_type == OP_READLINE
7342 || expr->op_type == OP_READDIR
7343 || expr->op_type == OP_GLOB
7344 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7345 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7346 expr = newUNOP(OP_DEFINED, 0,
7347 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7348 } else if (expr->op_flags & OPf_KIDS) {
7349 const OP * const k1 = ((UNOP*)expr)->op_first;
7350 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7351 switch (expr->op_type) {
7353 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7354 && (k2->op_flags & OPf_STACKED)
7355 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7356 expr = newUNOP(OP_DEFINED, 0, expr);
7360 if (k1 && (k1->op_type == OP_READDIR
7361 || k1->op_type == OP_GLOB
7362 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7363 || k1->op_type == OP_EACH
7364 || k1->op_type == OP_AEACH))
7365 expr = newUNOP(OP_DEFINED, 0, expr);
7371 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7372 * op, in listop. This is wrong. [perl #27024] */
7374 block = newOP(OP_NULL, 0);
7375 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7376 o = new_logop(OP_AND, 0, &expr, &listop);
7383 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7385 if (once && o != listop)
7387 assert(cUNOPo->op_first->op_type == OP_AND
7388 || cUNOPo->op_first->op_type == OP_OR);
7389 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7393 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7395 o->op_flags |= flags;
7397 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7402 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7404 Constructs, checks, and returns an op tree expressing a C<while> loop.
7405 This is a heavyweight loop, with structure that allows exiting the loop
7406 by C<last> and suchlike.
7408 C<loop> is an optional preconstructed C<enterloop> op to use in the
7409 loop; if it is null then a suitable op will be constructed automatically.
7410 C<expr> supplies the loop's controlling expression. C<block> supplies the
7411 main body of the loop, and C<cont> optionally supplies a C<continue> block
7412 that operates as a second half of the body. All of these optree inputs
7413 are consumed by this function and become part of the constructed op tree.
7415 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7416 op and, shifted up eight bits, the eight bits of C<op_private> for
7417 the C<leaveloop> op, except that (in both cases) some bits will be set
7418 automatically. C<debuggable> is currently unused and should always be 1.
7419 C<has_my> can be supplied as true to force the
7420 loop body to be enclosed in its own scope.
7426 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7427 OP *expr, OP *block, OP *cont, I32 has_my)
7436 PERL_UNUSED_ARG(debuggable);
7439 if (expr->op_type == OP_READLINE
7440 || expr->op_type == OP_READDIR
7441 || expr->op_type == OP_GLOB
7442 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7443 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7444 expr = newUNOP(OP_DEFINED, 0,
7445 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7446 } else if (expr->op_flags & OPf_KIDS) {
7447 const OP * const k1 = ((UNOP*)expr)->op_first;
7448 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7449 switch (expr->op_type) {
7451 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7452 && (k2->op_flags & OPf_STACKED)
7453 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7454 expr = newUNOP(OP_DEFINED, 0, expr);
7458 if (k1 && (k1->op_type == OP_READDIR
7459 || k1->op_type == OP_GLOB
7460 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7461 || k1->op_type == OP_EACH
7462 || k1->op_type == OP_AEACH))
7463 expr = newUNOP(OP_DEFINED, 0, expr);
7470 block = newOP(OP_NULL, 0);
7471 else if (cont || has_my) {
7472 block = op_scope(block);
7476 next = LINKLIST(cont);
7479 OP * const unstack = newOP(OP_UNSTACK, 0);
7482 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7486 listop = op_append_list(OP_LINESEQ, block, cont);
7488 redo = LINKLIST(listop);
7492 o = new_logop(OP_AND, 0, &expr, &listop);
7493 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7495 return expr; /* listop already freed by new_logop */
7498 ((LISTOP*)listop)->op_last->op_next =
7499 (o == listop ? redo : LINKLIST(o));
7505 NewOp(1101,loop,1,LOOP);
7506 OpTYPE_set(loop, OP_ENTERLOOP);
7507 loop->op_private = 0;
7508 loop->op_next = (OP*)loop;
7511 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7513 loop->op_redoop = redo;
7514 loop->op_lastop = o;
7515 o->op_private |= loopflags;
7518 loop->op_nextop = next;
7520 loop->op_nextop = o;
7522 o->op_flags |= flags;
7523 o->op_private |= (flags >> 8);
7528 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7530 Constructs, checks, and returns an op tree expressing a C<foreach>
7531 loop (iteration through a list of values). This is a heavyweight loop,
7532 with structure that allows exiting the loop by C<last> and suchlike.
7534 C<sv> optionally supplies the variable that will be aliased to each
7535 item in turn; if null, it defaults to C<$_>.
7536 C<expr> supplies the list of values to iterate over. C<block> supplies
7537 the main body of the loop, and C<cont> optionally supplies a C<continue>
7538 block that operates as a second half of the body. All of these optree
7539 inputs are consumed by this function and become part of the constructed
7542 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7543 op and, shifted up eight bits, the eight bits of C<op_private> for
7544 the C<leaveloop> op, except that (in both cases) some bits will be set
7551 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7556 PADOFFSET padoff = 0;
7560 PERL_ARGS_ASSERT_NEWFOROP;
7563 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7564 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7565 OpTYPE_set(sv, OP_RV2GV);
7567 /* The op_type check is needed to prevent a possible segfault
7568 * if the loop variable is undeclared and 'strict vars' is in
7569 * effect. This is illegal but is nonetheless parsed, so we
7570 * may reach this point with an OP_CONST where we're expecting
7573 if (cUNOPx(sv)->op_first->op_type == OP_GV
7574 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7575 iterpflags |= OPpITER_DEF;
7577 else if (sv->op_type == OP_PADSV) { /* private variable */
7578 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7579 padoff = sv->op_targ;
7583 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7585 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7588 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7590 PADNAME * const pn = PAD_COMPNAME(padoff);
7591 const char * const name = PadnamePV(pn);
7593 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7594 iterpflags |= OPpITER_DEF;
7598 sv = newGVOP(OP_GV, 0, PL_defgv);
7599 iterpflags |= OPpITER_DEF;
7602 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7603 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7604 iterflags |= OPf_STACKED;
7606 else if (expr->op_type == OP_NULL &&
7607 (expr->op_flags & OPf_KIDS) &&
7608 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7610 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7611 * set the STACKED flag to indicate that these values are to be
7612 * treated as min/max values by 'pp_enteriter'.
7614 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7615 LOGOP* const range = (LOGOP*) flip->op_first;
7616 OP* const left = range->op_first;
7617 OP* const right = OpSIBLING(left);
7620 range->op_flags &= ~OPf_KIDS;
7621 /* detach range's children */
7622 op_sibling_splice((OP*)range, NULL, -1, NULL);
7624 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7625 listop->op_first->op_next = range->op_next;
7626 left->op_next = range->op_other;
7627 right->op_next = (OP*)listop;
7628 listop->op_next = listop->op_first;
7631 expr = (OP*)(listop);
7633 iterflags |= OPf_STACKED;
7636 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7639 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7640 op_append_elem(OP_LIST, list(expr),
7642 assert(!loop->op_next);
7643 /* for my $x () sets OPpLVAL_INTRO;
7644 * for our $x () sets OPpOUR_INTRO */
7645 loop->op_private = (U8)iterpflags;
7646 if (loop->op_slabbed
7647 && DIFF(loop, OpSLOT(loop)->opslot_next)
7648 < SIZE_TO_PSIZE(sizeof(LOOP)))
7651 NewOp(1234,tmp,1,LOOP);
7652 Copy(loop,tmp,1,LISTOP);
7653 #ifdef PERL_OP_PARENT
7654 assert(loop->op_last->op_sibparent == (OP*)loop);
7655 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7657 S_op_destroy(aTHX_ (OP*)loop);
7660 else if (!loop->op_slabbed)
7662 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7663 #ifdef PERL_OP_PARENT
7664 OpLASTSIB_set(loop->op_last, (OP*)loop);
7667 loop->op_targ = padoff;
7668 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7673 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7675 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7676 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7677 determining the target of the op; it is consumed by this function and
7678 becomes part of the constructed op tree.
7684 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7688 PERL_ARGS_ASSERT_NEWLOOPEX;
7690 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7691 || type == OP_CUSTOM);
7693 if (type != OP_GOTO) {
7694 /* "last()" means "last" */
7695 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7696 o = newOP(type, OPf_SPECIAL);
7700 /* Check whether it's going to be a goto &function */
7701 if (label->op_type == OP_ENTERSUB
7702 && !(label->op_flags & OPf_STACKED))
7703 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7706 /* Check for a constant argument */
7707 if (label->op_type == OP_CONST) {
7708 SV * const sv = ((SVOP *)label)->op_sv;
7710 const char *s = SvPV_const(sv,l);
7711 if (l == strlen(s)) {
7713 SvUTF8(((SVOP*)label)->op_sv),
7715 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7719 /* If we have already created an op, we do not need the label. */
7722 else o = newUNOP(type, OPf_STACKED, label);
7724 PL_hints |= HINT_BLOCK_SCOPE;
7728 /* if the condition is a literal array or hash
7729 (or @{ ... } etc), make a reference to it.
7732 S_ref_array_or_hash(pTHX_ OP *cond)
7735 && (cond->op_type == OP_RV2AV
7736 || cond->op_type == OP_PADAV
7737 || cond->op_type == OP_RV2HV
7738 || cond->op_type == OP_PADHV))
7740 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7743 && (cond->op_type == OP_ASLICE
7744 || cond->op_type == OP_KVASLICE
7745 || cond->op_type == OP_HSLICE
7746 || cond->op_type == OP_KVHSLICE)) {
7748 /* anonlist now needs a list from this op, was previously used in
7750 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7751 cond->op_flags |= OPf_WANT_LIST;
7753 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7760 /* These construct the optree fragments representing given()
7763 entergiven and enterwhen are LOGOPs; the op_other pointer
7764 points up to the associated leave op. We need this so we
7765 can put it in the context and make break/continue work.
7766 (Also, of course, pp_enterwhen will jump straight to
7767 op_other if the match fails.)
7771 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7772 I32 enter_opcode, I32 leave_opcode,
7773 PADOFFSET entertarg)
7779 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7780 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7782 enterop = alloc_LOGOP(enter_opcode, block, NULL);
7783 enterop->op_targ = 0;
7784 enterop->op_private = 0;
7786 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7789 /* prepend cond if we have one */
7790 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7792 o->op_next = LINKLIST(cond);
7793 cond->op_next = (OP *) enterop;
7796 /* This is a default {} block */
7797 enterop->op_flags |= OPf_SPECIAL;
7798 o ->op_flags |= OPf_SPECIAL;
7800 o->op_next = (OP *) enterop;
7803 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7804 entergiven and enterwhen both
7807 enterop->op_next = LINKLIST(block);
7808 block->op_next = enterop->op_other = o;
7813 /* Does this look like a boolean operation? For these purposes
7814 a boolean operation is:
7815 - a subroutine call [*]
7816 - a logical connective
7817 - a comparison operator
7818 - a filetest operator, with the exception of -s -M -A -C
7819 - defined(), exists() or eof()
7820 - /$re/ or $foo =~ /$re/
7822 [*] possibly surprising
7825 S_looks_like_bool(pTHX_ const OP *o)
7827 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7829 switch(o->op_type) {
7832 return looks_like_bool(cLOGOPo->op_first);
7836 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7839 looks_like_bool(cLOGOPo->op_first)
7840 && looks_like_bool(sibl));
7846 o->op_flags & OPf_KIDS
7847 && looks_like_bool(cUNOPo->op_first));
7851 case OP_NOT: case OP_XOR:
7853 case OP_EQ: case OP_NE: case OP_LT:
7854 case OP_GT: case OP_LE: case OP_GE:
7856 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7857 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7859 case OP_SEQ: case OP_SNE: case OP_SLT:
7860 case OP_SGT: case OP_SLE: case OP_SGE:
7864 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7865 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7866 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7867 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7868 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7869 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7870 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7871 case OP_FTTEXT: case OP_FTBINARY:
7873 case OP_DEFINED: case OP_EXISTS:
7874 case OP_MATCH: case OP_EOF:
7881 /* Detect comparisons that have been optimized away */
7882 if (cSVOPo->op_sv == &PL_sv_yes
7883 || cSVOPo->op_sv == &PL_sv_no)
7896 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7898 Constructs, checks, and returns an op tree expressing a C<given> block.
7899 C<cond> supplies the expression that will be locally assigned to a lexical
7900 variable, and C<block> supplies the body of the C<given> construct; they
7901 are consumed by this function and become part of the constructed op tree.
7902 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7908 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7910 PERL_ARGS_ASSERT_NEWGIVENOP;
7911 PERL_UNUSED_ARG(defsv_off);
7914 return newGIVWHENOP(
7915 ref_array_or_hash(cond),
7917 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7922 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7924 Constructs, checks, and returns an op tree expressing a C<when> block.
7925 C<cond> supplies the test expression, and C<block> supplies the block
7926 that will be executed if the test evaluates to true; they are consumed
7927 by this function and become part of the constructed op tree. C<cond>
7928 will be interpreted DWIMically, often as a comparison against C<$_>,
7929 and may be null to generate a C<default> block.
7935 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7937 const bool cond_llb = (!cond || looks_like_bool(cond));
7940 PERL_ARGS_ASSERT_NEWWHENOP;
7945 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7947 scalar(ref_array_or_hash(cond)));
7950 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7953 /* must not conflict with SVf_UTF8 */
7954 #define CV_CKPROTO_CURSTASH 0x1
7957 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7958 const STRLEN len, const U32 flags)
7960 SV *name = NULL, *msg;
7961 const char * cvp = SvROK(cv)
7962 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7963 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7966 STRLEN clen = CvPROTOLEN(cv), plen = len;
7968 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7970 if (p == NULL && cvp == NULL)
7973 if (!ckWARN_d(WARN_PROTOTYPE))
7977 p = S_strip_spaces(aTHX_ p, &plen);
7978 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7979 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7980 if (plen == clen && memEQ(cvp, p, plen))
7983 if (flags & SVf_UTF8) {
7984 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7988 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7994 msg = sv_newmortal();
7999 gv_efullname3(name = sv_newmortal(), gv, NULL);
8000 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
8001 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
8002 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
8003 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
8004 sv_catpvs(name, "::");
8006 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
8007 assert (CvNAMED(SvRV_const(gv)));
8008 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
8010 else sv_catsv(name, (SV *)gv);
8012 else name = (SV *)gv;
8014 sv_setpvs(msg, "Prototype mismatch:");
8016 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
8018 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
8019 UTF8fARG(SvUTF8(cv),clen,cvp)
8022 sv_catpvs(msg, ": none");
8023 sv_catpvs(msg, " vs ");
8025 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
8027 sv_catpvs(msg, "none");
8028 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
8031 static void const_sv_xsub(pTHX_ CV* cv);
8032 static void const_av_xsub(pTHX_ CV* cv);
8036 =head1 Optree Manipulation Functions
8038 =for apidoc cv_const_sv
8040 If C<cv> is a constant sub eligible for inlining, returns the constant
8041 value returned by the sub. Otherwise, returns C<NULL>.
8043 Constant subs can be created with C<newCONSTSUB> or as described in
8044 L<perlsub/"Constant Functions">.
8049 Perl_cv_const_sv(const CV *const cv)
8054 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
8056 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
8057 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
8062 Perl_cv_const_sv_or_av(const CV * const cv)
8066 if (SvROK(cv)) return SvRV((SV *)cv);
8067 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
8068 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
8071 /* op_const_sv: examine an optree to determine whether it's in-lineable.
8072 * Can be called in 2 ways:
8075 * look for a single OP_CONST with attached value: return the value
8077 * allow_lex && !CvCONST(cv);
8079 * examine the clone prototype, and if contains only a single
8080 * OP_CONST, return the value; or if it contains a single PADSV ref-
8081 * erencing an outer lexical, turn on CvCONST to indicate the CV is
8082 * a candidate for "constizing" at clone time, and return NULL.
8086 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
8094 for (; o; o = o->op_next) {
8095 const OPCODE type = o->op_type;
8097 if (type == OP_NEXTSTATE || type == OP_LINESEQ
8099 || type == OP_PUSHMARK)
8101 if (type == OP_DBSTATE)
8103 if (type == OP_LEAVESUB)
8107 if (type == OP_CONST && cSVOPo->op_sv)
8109 else if (type == OP_UNDEF && !o->op_private) {
8113 else if (allow_lex && type == OP_PADSV) {
8114 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
8116 sv = &PL_sv_undef; /* an arbitrary non-null value */
8134 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
8135 PADNAME * const name, SV ** const const_svp)
8141 if (CvFLAGS(PL_compcv)) {
8142 /* might have had built-in attrs applied */
8143 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
8144 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8145 && ckWARN(WARN_MISC))
8147 /* protect against fatal warnings leaking compcv */
8148 SAVEFREESV(PL_compcv);
8149 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8150 SvREFCNT_inc_simple_void_NN(PL_compcv);
8153 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8154 & ~(CVf_LVALUE * pureperl));
8159 /* redundant check for speed: */
8160 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8161 const line_t oldline = CopLINE(PL_curcop);
8164 : sv_2mortal(newSVpvn_utf8(
8165 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8167 if (PL_parser && PL_parser->copline != NOLINE)
8168 /* This ensures that warnings are reported at the first
8169 line of a redefinition, not the last. */
8170 CopLINE_set(PL_curcop, PL_parser->copline);
8171 /* protect against fatal warnings leaking compcv */
8172 SAVEFREESV(PL_compcv);
8173 report_redefined_cv(namesv, cv, const_svp);
8174 SvREFCNT_inc_simple_void_NN(PL_compcv);
8175 CopLINE_set(PL_curcop, oldline);
8182 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8187 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8190 CV *compcv = PL_compcv;
8193 PADOFFSET pax = o->op_targ;
8194 CV *outcv = CvOUTSIDE(PL_compcv);
8197 bool reusable = FALSE;
8199 #ifdef PERL_DEBUG_READONLY_OPS
8200 OPSLAB *slab = NULL;
8203 PERL_ARGS_ASSERT_NEWMYSUB;
8205 /* Find the pad slot for storing the new sub.
8206 We cannot use PL_comppad, as it is the pad owned by the new sub. We
8207 need to look in CvOUTSIDE and find the pad belonging to the enclos-
8208 ing sub. And then we need to dig deeper if this is a lexical from
8210 my sub foo; sub { sub foo { } }
8213 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8214 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8215 pax = PARENT_PAD_INDEX(name);
8216 outcv = CvOUTSIDE(outcv);
8221 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8222 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8223 spot = (CV **)svspot;
8225 if (!(PL_parser && PL_parser->error_count))
8226 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8229 assert(proto->op_type == OP_CONST);
8230 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8231 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8241 if (PL_parser && PL_parser->error_count) {
8243 SvREFCNT_dec(PL_compcv);
8248 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8250 svspot = (SV **)(spot = &clonee);
8252 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8255 assert (SvTYPE(*spot) == SVt_PVCV);
8257 hek = CvNAME_HEK(*spot);
8261 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8262 CvNAME_HEK_set(*spot, hek =
8265 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8269 CvLEXICAL_on(*spot);
8271 cv = PadnamePROTOCV(name);
8272 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8276 /* This makes sub {}; work as expected. */
8277 if (block->op_type == OP_STUB) {
8278 const line_t l = PL_parser->copline;
8280 block = newSTATEOP(0, NULL, 0);
8281 PL_parser->copline = l;
8283 block = CvLVALUE(compcv)
8284 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8285 ? newUNOP(OP_LEAVESUBLV, 0,
8286 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8287 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8288 start = LINKLIST(block);
8290 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8291 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8299 const bool exists = CvROOT(cv) || CvXSUB(cv);
8301 /* if the subroutine doesn't exist and wasn't pre-declared
8302 * with a prototype, assume it will be AUTOLOADed,
8303 * skipping the prototype check
8305 if (exists || SvPOK(cv))
8306 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8308 /* already defined? */
8310 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
8316 /* just a "sub foo;" when &foo is already defined */
8321 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8328 SvREFCNT_inc_simple_void_NN(const_sv);
8329 SvFLAGS(const_sv) |= SVs_PADTMP;
8331 assert(!CvROOT(cv) && !CvCONST(cv));
8335 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8336 CvFILE_set_from_cop(cv, PL_curcop);
8337 CvSTASH_set(cv, PL_curstash);
8340 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
8341 CvXSUBANY(cv).any_ptr = const_sv;
8342 CvXSUB(cv) = const_sv_xsub;
8346 CvFLAGS(cv) |= CvMETHOD(compcv);
8348 SvREFCNT_dec(compcv);
8353 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8354 determine whether this sub definition is in the same scope as its
8355 declaration. If this sub definition is inside an inner named pack-
8356 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8357 the package sub. So check PadnameOUTER(name) too.
8359 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8360 assert(!CvWEAKOUTSIDE(compcv));
8361 SvREFCNT_dec(CvOUTSIDE(compcv));
8362 CvWEAKOUTSIDE_on(compcv);
8364 /* XXX else do we have a circular reference? */
8366 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8367 /* transfer PL_compcv to cv */
8369 cv_flags_t preserved_flags =
8370 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8371 PADLIST *const temp_padl = CvPADLIST(cv);
8372 CV *const temp_cv = CvOUTSIDE(cv);
8373 const cv_flags_t other_flags =
8374 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8375 OP * const cvstart = CvSTART(cv);
8379 CvFLAGS(compcv) | preserved_flags;
8380 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8381 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8382 CvPADLIST_set(cv, CvPADLIST(compcv));
8383 CvOUTSIDE(compcv) = temp_cv;
8384 CvPADLIST_set(compcv, temp_padl);
8385 CvSTART(cv) = CvSTART(compcv);
8386 CvSTART(compcv) = cvstart;
8387 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8388 CvFLAGS(compcv) |= other_flags;
8390 if (CvFILE(cv) && CvDYNFILE(cv)) {
8391 Safefree(CvFILE(cv));
8394 /* inner references to compcv must be fixed up ... */
8395 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8396 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8397 ++PL_sub_generation;
8400 /* Might have had built-in attributes applied -- propagate them. */
8401 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8403 /* ... before we throw it away */
8404 SvREFCNT_dec(compcv);
8405 PL_compcv = compcv = cv;
8414 if (!CvNAME_HEK(cv)) {
8415 if (hek) (void)share_hek_hek(hek);
8419 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8420 hek = share_hek(PadnamePV(name)+1,
8421 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8424 CvNAME_HEK_set(cv, hek);
8430 CvFILE_set_from_cop(cv, PL_curcop);
8431 CvSTASH_set(cv, PL_curstash);
8434 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8436 SvUTF8_on(MUTABLE_SV(cv));
8440 /* If we assign an optree to a PVCV, then we've defined a
8441 * subroutine that the debugger could be able to set a breakpoint
8442 * in, so signal to pp_entereval that it should not throw away any
8443 * saved lines at scope exit. */
8445 PL_breakable_sub_gen++;
8447 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8448 itself has a refcount. */
8450 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8451 #ifdef PERL_DEBUG_READONLY_OPS
8452 slab = (OPSLAB *)CvSTART(cv);
8454 S_process_optree(aTHX_ cv, block, start);
8459 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8460 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8464 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8465 SV * const tmpstr = sv_newmortal();
8466 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8467 GV_ADDMULTI, SVt_PVHV);
8469 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8472 (long)CopLINE(PL_curcop));
8473 if (HvNAME_HEK(PL_curstash)) {
8474 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8475 sv_catpvs(tmpstr, "::");
8478 sv_setpvs(tmpstr, "__ANON__::");
8480 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8481 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8482 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8483 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8484 hv = GvHVn(db_postponed);
8485 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8486 CV * const pcv = GvCV(db_postponed);
8492 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8500 assert(CvDEPTH(outcv));
8502 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8504 cv_clone_into(clonee, *spot);
8505 else *spot = cv_clone(clonee);
8506 SvREFCNT_dec_NN(clonee);
8510 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8511 PADOFFSET depth = CvDEPTH(outcv);
8514 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8516 *svspot = SvREFCNT_inc_simple_NN(cv);
8517 SvREFCNT_dec(oldcv);
8523 PL_parser->copline = NOLINE;
8525 #ifdef PERL_DEBUG_READONLY_OPS
8536 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8537 OP *block, bool o_is_gv)
8541 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8543 CV *cv = NULL; /* the previous CV with this name, if any */
8545 const bool ec = PL_parser && PL_parser->error_count;
8546 /* If the subroutine has no body, no attributes, and no builtin attributes
8547 then it's just a sub declaration, and we may be able to get away with
8548 storing with a placeholder scalar in the symbol table, rather than a
8549 full CV. If anything is present then it will take a full CV to
8551 const I32 gv_fetch_flags
8552 = ec ? GV_NOADD_NOINIT :
8553 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8554 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8556 const char * const name =
8557 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8559 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8560 bool evanescent = FALSE;
8562 #ifdef PERL_DEBUG_READONLY_OPS
8563 OPSLAB *slab = NULL;
8571 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8572 hek and CvSTASH pointer together can imply the GV. If the name
8573 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8574 CvSTASH, so forego the optimisation if we find any.
8575 Also, we may be called from load_module at run time, so
8576 PL_curstash (which sets CvSTASH) may not point to the stash the
8577 sub is stored in. */
8579 ec ? GV_NOADD_NOINIT
8580 : PL_curstash != CopSTASH(PL_curcop)
8581 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8583 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8584 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8586 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8587 SV * const sv = sv_newmortal();
8588 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
8589 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8590 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8591 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8593 } else if (PL_curstash) {
8594 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8597 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8603 move_proto_attr(&proto, &attrs, gv);
8606 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8611 assert(proto->op_type == OP_CONST);
8612 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8613 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8629 SvREFCNT_dec(PL_compcv);
8634 if (name && block) {
8635 const char *s = strrchr(name, ':');
8637 if (strEQ(s, "BEGIN")) {
8638 if (PL_in_eval & EVAL_KEEPERR)
8639 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8641 SV * const errsv = ERRSV;
8642 /* force display of errors found but not reported */
8643 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8644 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
8651 if (!block && SvTYPE(gv) != SVt_PVGV) {
8652 /* If we are not defining a new sub and the existing one is not a
8654 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8655 /* We are applying attributes to an existing sub, so we need it
8656 upgraded if it is a constant. */
8657 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8658 gv_init_pvn(gv, PL_curstash, name, namlen,
8659 SVf_UTF8 * name_is_utf8);
8661 else { /* Maybe prototype now, and had at maximum
8662 a prototype or const/sub ref before. */
8663 if (SvTYPE(gv) > SVt_NULL) {
8664 cv_ckproto_len_flags((const CV *)gv,
8665 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8671 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8673 SvUTF8_on(MUTABLE_SV(gv));
8676 sv_setiv(MUTABLE_SV(gv), -1);
8679 SvREFCNT_dec(PL_compcv);
8680 cv = PL_compcv = NULL;
8685 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8689 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8695 /* This makes sub {}; work as expected. */
8696 if (block->op_type == OP_STUB) {
8697 const line_t l = PL_parser->copline;
8699 block = newSTATEOP(0, NULL, 0);
8700 PL_parser->copline = l;
8702 block = CvLVALUE(PL_compcv)
8703 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8704 && (!isGV(gv) || !GvASSUMECV(gv)))
8705 ? newUNOP(OP_LEAVESUBLV, 0,
8706 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8707 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8708 start = LINKLIST(block);
8710 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8712 S_op_const_sv(aTHX_ start, PL_compcv,
8713 cBOOL(CvCLONE(PL_compcv)));
8720 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8721 cv_ckproto_len_flags((const CV *)gv,
8722 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8723 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8725 /* All the other code for sub redefinition warnings expects the
8726 clobbered sub to be a CV. Instead of making all those code
8727 paths more complex, just inline the RV version here. */
8728 const line_t oldline = CopLINE(PL_curcop);
8729 assert(IN_PERL_COMPILETIME);
8730 if (PL_parser && PL_parser->copline != NOLINE)
8731 /* This ensures that warnings are reported at the first
8732 line of a redefinition, not the last. */
8733 CopLINE_set(PL_curcop, PL_parser->copline);
8734 /* protect against fatal warnings leaking compcv */
8735 SAVEFREESV(PL_compcv);
8737 if (ckWARN(WARN_REDEFINE)
8738 || ( ckWARN_d(WARN_REDEFINE)
8739 && ( !const_sv || SvRV(gv) == const_sv
8740 || sv_cmp(SvRV(gv), const_sv) ))) {
8742 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8743 "Constant subroutine %" SVf " redefined",
8744 SVfARG(cSVOPo->op_sv));
8747 SvREFCNT_inc_simple_void_NN(PL_compcv);
8748 CopLINE_set(PL_curcop, oldline);
8749 SvREFCNT_dec(SvRV(gv));
8754 const bool exists = CvROOT(cv) || CvXSUB(cv);
8756 /* if the subroutine doesn't exist and wasn't pre-declared
8757 * with a prototype, assume it will be AUTOLOADed,
8758 * skipping the prototype check
8760 if (exists || SvPOK(cv))
8761 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8762 /* already defined (or promised)? */
8763 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8764 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
8770 /* just a "sub foo;" when &foo is already defined */
8771 SAVEFREESV(PL_compcv);
8778 SvREFCNT_inc_simple_void_NN(const_sv);
8779 SvFLAGS(const_sv) |= SVs_PADTMP;
8781 assert(!CvROOT(cv) && !CvCONST(cv));
8783 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
8784 CvXSUBANY(cv).any_ptr = const_sv;
8785 CvXSUB(cv) = const_sv_xsub;
8789 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8792 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8793 if (name && isGV(gv))
8795 cv = newCONSTSUB_flags(
8796 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8799 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8803 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8804 prepare_SV_for_RV((SV *)gv);
8808 SvRV_set(gv, const_sv);
8812 SvREFCNT_dec(PL_compcv);
8817 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
8818 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
8821 if (cv) { /* must reuse cv if autoloaded */
8822 /* transfer PL_compcv to cv */
8824 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8825 PADLIST *const temp_av = CvPADLIST(cv);
8826 CV *const temp_cv = CvOUTSIDE(cv);
8827 const cv_flags_t other_flags =
8828 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8829 OP * const cvstart = CvSTART(cv);
8833 assert(!CvCVGV_RC(cv));
8834 assert(CvGV(cv) == gv);
8839 PERL_HASH(hash, name, namlen);
8849 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8851 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8852 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8853 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8854 CvOUTSIDE(PL_compcv) = temp_cv;
8855 CvPADLIST_set(PL_compcv, temp_av);
8856 CvSTART(cv) = CvSTART(PL_compcv);
8857 CvSTART(PL_compcv) = cvstart;
8858 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8859 CvFLAGS(PL_compcv) |= other_flags;
8861 if (CvFILE(cv) && CvDYNFILE(cv)) {
8862 Safefree(CvFILE(cv));
8864 CvFILE_set_from_cop(cv, PL_curcop);
8865 CvSTASH_set(cv, PL_curstash);
8867 /* inner references to PL_compcv must be fixed up ... */
8868 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8869 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8870 ++PL_sub_generation;
8873 /* Might have had built-in attributes applied -- propagate them. */
8874 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8876 /* ... before we throw it away */
8877 SvREFCNT_dec(PL_compcv);
8882 if (name && isGV(gv)) {
8885 if (HvENAME_HEK(GvSTASH(gv)))
8886 /* sub Foo::bar { (shift)+1 } */
8887 gv_method_changed(gv);
8891 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8892 prepare_SV_for_RV((SV *)gv);
8896 SvRV_set(gv, (SV *)cv);
8906 PERL_HASH(hash, name, namlen);
8907 CvNAME_HEK_set(cv, share_hek(name,
8913 CvFILE_set_from_cop(cv, PL_curcop);
8914 CvSTASH_set(cv, PL_curstash);
8918 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8920 SvUTF8_on(MUTABLE_SV(cv));
8924 /* If we assign an optree to a PVCV, then we've defined a
8925 * subroutine that the debugger could be able to set a breakpoint
8926 * in, so signal to pp_entereval that it should not throw away any
8927 * saved lines at scope exit. */
8929 PL_breakable_sub_gen++;
8931 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8932 itself has a refcount. */
8934 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8935 #ifdef PERL_DEBUG_READONLY_OPS
8936 slab = (OPSLAB *)CvSTART(cv);
8938 S_process_optree(aTHX_ cv, block, start);
8943 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8944 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8949 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8951 SvREFCNT_inc_simple_void_NN(cv);
8954 if (block && has_name) {
8955 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8956 SV * const tmpstr = cv_name(cv,NULL,0);
8957 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8958 GV_ADDMULTI, SVt_PVHV);
8960 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8963 (long)CopLINE(PL_curcop));
8964 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8965 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8966 hv = GvHVn(db_postponed);
8967 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8968 CV * const pcv = GvCV(db_postponed);
8974 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8980 if (PL_parser && PL_parser->error_count)
8981 clear_special_blocks(name, gv, cv);
8984 process_special_blocks(floor, name, gv, cv);
8990 PL_parser->copline = NOLINE;
8994 #ifdef PERL_DEBUG_READONLY_OPS
8998 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8999 pad_add_weakref(cv);
9005 S_clear_special_blocks(pTHX_ const char *const fullname,
9006 GV *const gv, CV *const cv) {
9010 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
9012 colon = strrchr(fullname,':');
9013 name = colon ? colon + 1 : fullname;
9015 if ((*name == 'B' && strEQ(name, "BEGIN"))
9016 || (*name == 'E' && strEQ(name, "END"))
9017 || (*name == 'U' && strEQ(name, "UNITCHECK"))
9018 || (*name == 'C' && strEQ(name, "CHECK"))
9019 || (*name == 'I' && strEQ(name, "INIT"))) {
9025 SvREFCNT_dec_NN(MUTABLE_SV(cv));
9029 /* Returns true if the sub has been freed. */
9031 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
9035 const char *const colon = strrchr(fullname,':');
9036 const char *const name = colon ? colon + 1 : fullname;
9038 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
9041 if (strEQ(name, "BEGIN")) {
9042 const I32 oldscope = PL_scopestack_ix;
9045 if (floor) LEAVE_SCOPE(floor);
9047 PUSHSTACKi(PERLSI_REQUIRE);
9048 SAVECOPFILE(&PL_compiling);
9049 SAVECOPLINE(&PL_compiling);
9050 SAVEVPTR(PL_curcop);
9052 DEBUG_x( dump_sub(gv) );
9053 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
9054 GvCV_set(gv,0); /* cv has been hijacked */
9055 call_list(oldscope, PL_beginav);
9059 return !PL_savebegin;
9065 if strEQ(name, "END") {
9066 DEBUG_x( dump_sub(gv) );
9067 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
9070 } else if (*name == 'U') {
9071 if (strEQ(name, "UNITCHECK")) {
9072 /* It's never too late to run a unitcheck block */
9073 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
9077 } else if (*name == 'C') {
9078 if (strEQ(name, "CHECK")) {
9080 /* diag_listed_as: Too late to run %s block */
9081 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
9082 "Too late to run CHECK block");
9083 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
9087 } else if (*name == 'I') {
9088 if (strEQ(name, "INIT")) {
9090 /* diag_listed_as: Too late to run %s block */
9091 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
9092 "Too late to run INIT block");
9093 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
9099 DEBUG_x( dump_sub(gv) );
9101 GvCV_set(gv,0); /* cv has been hijacked */
9107 =for apidoc newCONSTSUB
9109 See L</newCONSTSUB_flags>.
9115 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
9117 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
9121 =for apidoc newCONSTSUB_flags
9123 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
9124 eligible for inlining at compile-time.
9126 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
9128 The newly created subroutine takes ownership of a reference to the passed in
9131 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
9132 which won't be called if used as a destructor, but will suppress the overhead
9133 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
9140 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
9144 const char *const file = CopFILE(PL_curcop);
9148 if (IN_PERL_RUNTIME) {
9149 /* at runtime, it's not safe to manipulate PL_curcop: it may be
9150 * an op shared between threads. Use a non-shared COP for our
9152 SAVEVPTR(PL_curcop);
9153 SAVECOMPILEWARNINGS();
9154 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9155 PL_curcop = &PL_compiling;
9157 SAVECOPLINE(PL_curcop);
9158 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9161 PL_hints &= ~HINT_BLOCK_SCOPE;
9164 SAVEGENERICSV(PL_curstash);
9165 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9168 /* Protect sv against leakage caused by fatal warnings. */
9169 if (sv) SAVEFREESV(sv);
9171 /* file becomes the CvFILE. For an XS, it's usually static storage,
9172 and so doesn't get free()d. (It's expected to be from the C pre-
9173 processor __FILE__ directive). But we need a dynamically allocated one,
9174 and we need it to get freed. */
9175 cv = newXS_len_flags(name, len,
9176 sv && SvTYPE(sv) == SVt_PVAV
9179 file ? file : "", "",
9180 &sv, XS_DYNAMIC_FILENAME | flags);
9181 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9190 =for apidoc U||newXS
9192 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
9193 static storage, as it is used directly as CvFILE(), without a copy being made.
9199 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9201 PERL_ARGS_ASSERT_NEWXS;
9202 return newXS_len_flags(
9203 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9208 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9209 const char *const filename, const char *const proto,
9212 PERL_ARGS_ASSERT_NEWXS_FLAGS;
9213 return newXS_len_flags(
9214 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9219 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9221 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9222 return newXS_len_flags(
9223 name, strlen(name), subaddr, NULL, NULL, NULL, 0
9228 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9229 XSUBADDR_t subaddr, const char *const filename,
9230 const char *const proto, SV **const_svp,
9234 bool interleave = FALSE;
9236 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9239 GV * const gv = gv_fetchpvn(
9240 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9241 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9242 sizeof("__ANON__::__ANON__") - 1,
9243 GV_ADDMULTI | flags, SVt_PVCV);
9245 if ((cv = (name ? GvCV(gv) : NULL))) {
9247 /* just a cached method */
9251 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9252 /* already defined (or promised) */
9253 /* Redundant check that allows us to avoid creating an SV
9254 most of the time: */
9255 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9256 report_redefined_cv(newSVpvn_flags(
9257 name,len,(flags&SVf_UTF8)|SVs_TEMP
9268 if (cv) /* must reuse cv if autoloaded */
9271 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9275 if (HvENAME_HEK(GvSTASH(gv)))
9276 gv_method_changed(gv); /* newXS */
9282 /* XSUBs can't be perl lang/perl5db.pl debugged
9283 if (PERLDB_LINE_OR_SAVESRC)
9284 (void)gv_fetchfile(filename); */
9285 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9286 if (flags & XS_DYNAMIC_FILENAME) {
9288 CvFILE(cv) = savepv(filename);
9290 /* NOTE: not copied, as it is expected to be an external constant string */
9291 CvFILE(cv) = (char *)filename;
9294 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9295 CvFILE(cv) = (char*)PL_xsubfilename;
9298 CvXSUB(cv) = subaddr;
9299 #ifndef PERL_IMPLICIT_CONTEXT
9300 CvHSCXT(cv) = &PL_stack_sp;
9306 process_special_blocks(0, name, gv, cv);
9309 } /* <- not a conditional branch */
9312 sv_setpv(MUTABLE_SV(cv), proto);
9313 if (interleave) LEAVE;
9318 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9320 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9322 PERL_ARGS_ASSERT_NEWSTUB;
9326 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9327 gv_method_changed(gv);
9329 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9334 CvFILE_set_from_cop(cv, PL_curcop);
9335 CvSTASH_set(cv, PL_curstash);
9341 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9348 if (PL_parser && PL_parser->error_count) {
9354 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9355 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9358 if ((cv = GvFORM(gv))) {
9359 if (ckWARN(WARN_REDEFINE)) {
9360 const line_t oldline = CopLINE(PL_curcop);
9361 if (PL_parser && PL_parser->copline != NOLINE)
9362 CopLINE_set(PL_curcop, PL_parser->copline);
9364 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9365 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
9367 /* diag_listed_as: Format %s redefined */
9368 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9369 "Format STDOUT redefined");
9371 CopLINE_set(PL_curcop, oldline);
9376 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9378 CvFILE_set_from_cop(cv, PL_curcop);
9381 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9383 start = LINKLIST(root);
9385 S_process_optree(aTHX_ cv, root, start);
9391 PL_parser->copline = NOLINE;
9393 PL_compiling.cop_seq = 0;
9397 Perl_newANONLIST(pTHX_ OP *o)
9399 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9403 Perl_newANONHASH(pTHX_ OP *o)
9405 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9409 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9411 return newANONATTRSUB(floor, proto, NULL, block);
9415 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9417 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9419 newSVOP(OP_ANONCODE, 0,
9421 if (CvANONCONST(cv))
9422 anoncode = newUNOP(OP_ANONCONST, 0,
9423 op_convert_list(OP_ENTERSUB,
9424 OPf_STACKED|OPf_WANT_SCALAR,
9426 return newUNOP(OP_REFGEN, 0, anoncode);
9430 Perl_oopsAV(pTHX_ OP *o)
9434 PERL_ARGS_ASSERT_OOPSAV;
9436 switch (o->op_type) {
9439 OpTYPE_set(o, OP_PADAV);
9440 return ref(o, OP_RV2AV);
9444 OpTYPE_set(o, OP_RV2AV);
9449 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9456 Perl_oopsHV(pTHX_ OP *o)
9460 PERL_ARGS_ASSERT_OOPSHV;
9462 switch (o->op_type) {
9465 OpTYPE_set(o, OP_PADHV);
9466 return ref(o, OP_RV2HV);
9470 OpTYPE_set(o, OP_RV2HV);
9475 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9482 Perl_newAVREF(pTHX_ OP *o)
9486 PERL_ARGS_ASSERT_NEWAVREF;
9488 if (o->op_type == OP_PADANY) {
9489 OpTYPE_set(o, OP_PADAV);
9492 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9493 Perl_croak(aTHX_ "Can't use an array as a reference");
9495 return newUNOP(OP_RV2AV, 0, scalar(o));
9499 Perl_newGVREF(pTHX_ I32 type, OP *o)
9501 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9502 return newUNOP(OP_NULL, 0, o);
9503 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9507 Perl_newHVREF(pTHX_ OP *o)
9511 PERL_ARGS_ASSERT_NEWHVREF;
9513 if (o->op_type == OP_PADANY) {
9514 OpTYPE_set(o, OP_PADHV);
9517 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9518 Perl_croak(aTHX_ "Can't use a hash as a reference");
9520 return newUNOP(OP_RV2HV, 0, scalar(o));
9524 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9526 if (o->op_type == OP_PADANY) {
9528 OpTYPE_set(o, OP_PADCV);
9530 return newUNOP(OP_RV2CV, flags, scalar(o));
9534 Perl_newSVREF(pTHX_ OP *o)
9538 PERL_ARGS_ASSERT_NEWSVREF;
9540 if (o->op_type == OP_PADANY) {
9541 OpTYPE_set(o, OP_PADSV);
9545 return newUNOP(OP_RV2SV, 0, scalar(o));
9548 /* Check routines. See the comments at the top of this file for details
9549 * on when these are called */
9552 Perl_ck_anoncode(pTHX_ OP *o)
9554 PERL_ARGS_ASSERT_CK_ANONCODE;
9556 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9557 cSVOPo->op_sv = NULL;
9562 S_io_hints(pTHX_ OP *o)
9564 #if O_BINARY != 0 || O_TEXT != 0
9566 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9568 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9571 const char *d = SvPV_const(*svp, len);
9572 const I32 mode = mode_from_discipline(d, len);
9573 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9575 if (mode & O_BINARY)
9576 o->op_private |= OPpOPEN_IN_RAW;
9580 o->op_private |= OPpOPEN_IN_CRLF;
9584 svp = hv_fetchs(table, "open_OUT", FALSE);
9587 const char *d = SvPV_const(*svp, len);
9588 const I32 mode = mode_from_discipline(d, len);
9589 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9591 if (mode & O_BINARY)
9592 o->op_private |= OPpOPEN_OUT_RAW;
9596 o->op_private |= OPpOPEN_OUT_CRLF;
9601 PERL_UNUSED_CONTEXT;
9607 Perl_ck_backtick(pTHX_ OP *o)
9612 PERL_ARGS_ASSERT_CK_BACKTICK;
9613 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9614 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9615 && (gv = gv_override("readpipe",8)))
9617 /* detach rest of siblings from o and its first child */
9618 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9619 newop = S_new_entersubop(aTHX_ gv, sibl);
9621 else if (!(o->op_flags & OPf_KIDS))
9622 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9627 S_io_hints(aTHX_ o);
9632 Perl_ck_bitop(pTHX_ OP *o)
9634 PERL_ARGS_ASSERT_CK_BITOP;
9636 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9638 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9639 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9640 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9641 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9642 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9643 "The bitwise feature is experimental");
9644 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9645 && OP_IS_INFIX_BIT(o->op_type))
9647 const OP * const left = cBINOPo->op_first;
9648 const OP * const right = OpSIBLING(left);
9649 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9650 (left->op_flags & OPf_PARENS) == 0) ||
9651 (OP_IS_NUMCOMPARE(right->op_type) &&
9652 (right->op_flags & OPf_PARENS) == 0))
9653 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9654 "Possible precedence problem on bitwise %s operator",
9655 o->op_type == OP_BIT_OR
9656 ||o->op_type == OP_NBIT_OR ? "|"
9657 : o->op_type == OP_BIT_AND
9658 ||o->op_type == OP_NBIT_AND ? "&"
9659 : o->op_type == OP_BIT_XOR
9660 ||o->op_type == OP_NBIT_XOR ? "^"
9661 : o->op_type == OP_SBIT_OR ? "|."
9662 : o->op_type == OP_SBIT_AND ? "&." : "^."
9668 PERL_STATIC_INLINE bool
9669 is_dollar_bracket(pTHX_ const OP * const o)
9672 PERL_UNUSED_CONTEXT;
9673 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9674 && (kid = cUNOPx(o)->op_first)
9675 && kid->op_type == OP_GV
9676 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9680 Perl_ck_cmp(pTHX_ OP *o)
9682 PERL_ARGS_ASSERT_CK_CMP;
9683 if (ckWARN(WARN_SYNTAX)) {
9684 const OP *kid = cUNOPo->op_first;
9687 ( is_dollar_bracket(aTHX_ kid)
9688 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9690 || ( kid->op_type == OP_CONST
9691 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9695 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9696 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9702 Perl_ck_concat(pTHX_ OP *o)
9704 const OP * const kid = cUNOPo->op_first;
9706 PERL_ARGS_ASSERT_CK_CONCAT;
9707 PERL_UNUSED_CONTEXT;
9709 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9710 !(kUNOP->op_first->op_flags & OPf_MOD))
9711 o->op_flags |= OPf_STACKED;
9716 Perl_ck_spair(pTHX_ OP *o)
9720 PERL_ARGS_ASSERT_CK_SPAIR;
9722 if (o->op_flags & OPf_KIDS) {
9726 const OPCODE type = o->op_type;
9727 o = modkids(ck_fun(o), type);
9728 kid = cUNOPo->op_first;
9729 kidkid = kUNOP->op_first;
9730 newop = OpSIBLING(kidkid);
9732 const OPCODE type = newop->op_type;
9733 if (OpHAS_SIBLING(newop))
9735 if (o->op_type == OP_REFGEN
9736 && ( type == OP_RV2CV
9737 || ( !(newop->op_flags & OPf_PARENS)
9738 && ( type == OP_RV2AV || type == OP_PADAV
9739 || type == OP_RV2HV || type == OP_PADHV))))
9740 NOOP; /* OK (allow srefgen for \@a and \%h) */
9741 else if (OP_GIMME(newop,0) != G_SCALAR)
9744 /* excise first sibling */
9745 op_sibling_splice(kid, NULL, 1, NULL);
9748 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9749 * and OP_CHOMP into OP_SCHOMP */
9750 o->op_ppaddr = PL_ppaddr[++o->op_type];
9755 Perl_ck_delete(pTHX_ OP *o)
9757 PERL_ARGS_ASSERT_CK_DELETE;
9761 if (o->op_flags & OPf_KIDS) {
9762 OP * const kid = cUNOPo->op_first;
9763 switch (kid->op_type) {
9765 o->op_flags |= OPf_SPECIAL;
9768 o->op_private |= OPpSLICE;
9771 o->op_flags |= OPf_SPECIAL;
9776 o->op_flags |= OPf_SPECIAL;
9779 o->op_private |= OPpKVSLICE;
9782 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9783 "element or slice");
9785 if (kid->op_private & OPpLVAL_INTRO)
9786 o->op_private |= OPpLVAL_INTRO;
9793 Perl_ck_eof(pTHX_ OP *o)
9795 PERL_ARGS_ASSERT_CK_EOF;
9797 if (o->op_flags & OPf_KIDS) {
9799 if (cLISTOPo->op_first->op_type == OP_STUB) {
9801 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9806 kid = cLISTOPo->op_first;
9807 if (kid->op_type == OP_RV2GV)
9808 kid->op_private |= OPpALLOW_FAKE;
9814 Perl_ck_eval(pTHX_ OP *o)
9818 PERL_ARGS_ASSERT_CK_EVAL;
9820 PL_hints |= HINT_BLOCK_SCOPE;
9821 if (o->op_flags & OPf_KIDS) {
9822 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9825 if (o->op_type == OP_ENTERTRY) {
9828 /* cut whole sibling chain free from o */
9829 op_sibling_splice(o, NULL, -1, NULL);
9832 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
9834 /* establish postfix order */
9835 enter->op_next = (OP*)enter;
9837 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9838 OpTYPE_set(o, OP_LEAVETRY);
9839 enter->op_other = o;
9844 S_set_haseval(aTHX);
9848 const U8 priv = o->op_private;
9850 /* the newUNOP will recursively call ck_eval(), which will handle
9851 * all the stuff at the end of this function, like adding
9854 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9856 o->op_targ = (PADOFFSET)PL_hints;
9857 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9858 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9859 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9860 /* Store a copy of %^H that pp_entereval can pick up. */
9861 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9862 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9863 /* append hhop to only child */
9864 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9866 o->op_private |= OPpEVAL_HAS_HH;
9868 if (!(o->op_private & OPpEVAL_BYTES)
9869 && FEATURE_UNIEVAL_IS_ENABLED)
9870 o->op_private |= OPpEVAL_UNICODE;
9875 Perl_ck_exec(pTHX_ OP *o)
9877 PERL_ARGS_ASSERT_CK_EXEC;
9879 if (o->op_flags & OPf_STACKED) {
9882 kid = OpSIBLING(cUNOPo->op_first);
9883 if (kid->op_type == OP_RV2GV)
9892 Perl_ck_exists(pTHX_ OP *o)
9894 PERL_ARGS_ASSERT_CK_EXISTS;
9897 if (o->op_flags & OPf_KIDS) {
9898 OP * const kid = cUNOPo->op_first;
9899 if (kid->op_type == OP_ENTERSUB) {
9900 (void) ref(kid, o->op_type);
9901 if (kid->op_type != OP_RV2CV
9902 && !(PL_parser && PL_parser->error_count))
9904 "exists argument is not a subroutine name");
9905 o->op_private |= OPpEXISTS_SUB;
9907 else if (kid->op_type == OP_AELEM)
9908 o->op_flags |= OPf_SPECIAL;
9909 else if (kid->op_type != OP_HELEM)
9910 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9911 "element or a subroutine");
9918 Perl_ck_rvconst(pTHX_ OP *o)
9921 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9923 PERL_ARGS_ASSERT_CK_RVCONST;
9925 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9927 if (kid->op_type == OP_CONST) {
9930 SV * const kidsv = kid->op_sv;
9932 /* Is it a constant from cv_const_sv()? */
9933 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9936 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9937 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9938 const char *badthing;
9939 switch (o->op_type) {
9941 badthing = "a SCALAR";
9944 badthing = "an ARRAY";
9947 badthing = "a HASH";
9955 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
9956 SVfARG(kidsv), badthing);
9959 * This is a little tricky. We only want to add the symbol if we
9960 * didn't add it in the lexer. Otherwise we get duplicate strict
9961 * warnings. But if we didn't add it in the lexer, we must at
9962 * least pretend like we wanted to add it even if it existed before,
9963 * or we get possible typo warnings. OPpCONST_ENTERED says
9964 * whether the lexer already added THIS instance of this symbol.
9966 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9967 gv = gv_fetchsv(kidsv,
9968 o->op_type == OP_RV2CV
9969 && o->op_private & OPpMAY_RETURN_CONSTANT
9971 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9974 : o->op_type == OP_RV2SV
9976 : o->op_type == OP_RV2AV
9978 : o->op_type == OP_RV2HV
9985 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9986 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9987 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9989 OpTYPE_set(kid, OP_GV);
9990 SvREFCNT_dec(kid->op_sv);
9992 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9993 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9994 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9995 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9996 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9998 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
10000 kid->op_private = 0;
10001 /* FAKE globs in the symbol table cause weird bugs (#77810) */
10009 Perl_ck_ftst(pTHX_ OP *o)
10012 const I32 type = o->op_type;
10014 PERL_ARGS_ASSERT_CK_FTST;
10016 if (o->op_flags & OPf_REF) {
10019 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
10020 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10021 const OPCODE kidtype = kid->op_type;
10023 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
10024 && !kid->op_folded) {
10025 OP * const newop = newGVOP(type, OPf_REF,
10026 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
10031 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
10032 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
10034 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
10035 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
10036 array_passed_to_stat, name);
10039 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
10040 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
10043 scalar((OP *) kid);
10044 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
10045 o->op_private |= OPpFT_ACCESS;
10046 if (type != OP_STAT && type != OP_LSTAT
10047 && PL_check[kidtype] == Perl_ck_ftst
10048 && kidtype != OP_STAT && kidtype != OP_LSTAT
10050 o->op_private |= OPpFT_STACKED;
10051 kid->op_private |= OPpFT_STACKING;
10052 if (kidtype == OP_FTTTY && (
10053 !(kid->op_private & OPpFT_STACKED)
10054 || kid->op_private & OPpFT_AFTER_t
10056 o->op_private |= OPpFT_AFTER_t;
10061 if (type == OP_FTTTY)
10062 o = newGVOP(type, OPf_REF, PL_stdingv);
10064 o = newUNOP(type, 0, newDEFSVOP());
10070 Perl_ck_fun(pTHX_ OP *o)
10072 const int type = o->op_type;
10073 I32 oa = PL_opargs[type] >> OASHIFT;
10075 PERL_ARGS_ASSERT_CK_FUN;
10077 if (o->op_flags & OPf_STACKED) {
10078 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
10079 oa &= ~OA_OPTIONAL;
10081 return no_fh_allowed(o);
10084 if (o->op_flags & OPf_KIDS) {
10085 OP *prev_kid = NULL;
10086 OP *kid = cLISTOPo->op_first;
10088 bool seen_optional = FALSE;
10090 if (kid->op_type == OP_PUSHMARK ||
10091 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
10094 kid = OpSIBLING(kid);
10096 if (kid && kid->op_type == OP_COREARGS) {
10097 bool optional = FALSE;
10100 if (oa & OA_OPTIONAL) optional = TRUE;
10103 if (optional) o->op_private |= numargs;
10108 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
10109 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
10110 kid = newDEFSVOP();
10111 /* append kid to chain */
10112 op_sibling_splice(o, prev_kid, 0, kid);
10114 seen_optional = TRUE;
10121 /* list seen where single (scalar) arg expected? */
10122 if (numargs == 1 && !(oa >> 4)
10123 && kid->op_type == OP_LIST && type != OP_SCALAR)
10125 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10127 if (type != OP_DELETE) scalar(kid);
10138 if ((type == OP_PUSH || type == OP_UNSHIFT)
10139 && !OpHAS_SIBLING(kid))
10140 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10141 "Useless use of %s with no values",
10144 if (kid->op_type == OP_CONST
10145 && ( !SvROK(cSVOPx_sv(kid))
10146 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
10148 bad_type_pv(numargs, "array", o, kid);
10149 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
10150 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
10151 PL_op_desc[type]), 0);
10154 op_lvalue(kid, type);
10158 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
10159 bad_type_pv(numargs, "hash", o, kid);
10160 op_lvalue(kid, type);
10164 /* replace kid with newop in chain */
10166 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10167 newop->op_next = newop;
10172 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10173 if (kid->op_type == OP_CONST &&
10174 (kid->op_private & OPpCONST_BARE))
10176 OP * const newop = newGVOP(OP_GV, 0,
10177 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10178 /* replace kid with newop in chain */
10179 op_sibling_splice(o, prev_kid, 1, newop);
10183 else if (kid->op_type == OP_READLINE) {
10184 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10185 bad_type_pv(numargs, "HANDLE", o, kid);
10188 I32 flags = OPf_SPECIAL;
10190 PADOFFSET targ = 0;
10192 /* is this op a FH constructor? */
10193 if (is_handle_constructor(o,numargs)) {
10194 const char *name = NULL;
10197 bool want_dollar = TRUE;
10200 /* Set a flag to tell rv2gv to vivify
10201 * need to "prove" flag does not mean something
10202 * else already - NI-S 1999/05/07
10205 if (kid->op_type == OP_PADSV) {
10207 = PAD_COMPNAME_SV(kid->op_targ);
10208 name = PadnamePV (pn);
10209 len = PadnameLEN(pn);
10210 name_utf8 = PadnameUTF8(pn);
10212 else if (kid->op_type == OP_RV2SV
10213 && kUNOP->op_first->op_type == OP_GV)
10215 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10217 len = GvNAMELEN(gv);
10218 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10220 else if (kid->op_type == OP_AELEM
10221 || kid->op_type == OP_HELEM)
10224 OP *op = ((BINOP*)kid)->op_first;
10228 const char * const a =
10229 kid->op_type == OP_AELEM ?
10231 if (((op->op_type == OP_RV2AV) ||
10232 (op->op_type == OP_RV2HV)) &&
10233 (firstop = ((UNOP*)op)->op_first) &&
10234 (firstop->op_type == OP_GV)) {
10235 /* packagevar $a[] or $h{} */
10236 GV * const gv = cGVOPx_gv(firstop);
10239 Perl_newSVpvf(aTHX_
10244 else if (op->op_type == OP_PADAV
10245 || op->op_type == OP_PADHV) {
10246 /* lexicalvar $a[] or $h{} */
10247 const char * const padname =
10248 PAD_COMPNAME_PV(op->op_targ);
10251 Perl_newSVpvf(aTHX_
10257 name = SvPV_const(tmpstr, len);
10258 name_utf8 = SvUTF8(tmpstr);
10259 sv_2mortal(tmpstr);
10263 name = "__ANONIO__";
10265 want_dollar = FALSE;
10267 op_lvalue(kid, type);
10271 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10272 namesv = PAD_SVl(targ);
10273 if (want_dollar && *name != '$')
10274 sv_setpvs(namesv, "$");
10277 sv_catpvn(namesv, name, len);
10278 if ( name_utf8 ) SvUTF8_on(namesv);
10282 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10284 kid->op_targ = targ;
10285 kid->op_private |= priv;
10291 if ((type == OP_UNDEF || type == OP_POS)
10292 && numargs == 1 && !(oa >> 4)
10293 && kid->op_type == OP_LIST)
10294 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10295 op_lvalue(scalar(kid), type);
10300 kid = OpSIBLING(kid);
10302 /* FIXME - should the numargs or-ing move after the too many
10303 * arguments check? */
10304 o->op_private |= numargs;
10306 return too_many_arguments_pv(o,OP_DESC(o), 0);
10309 else if (PL_opargs[type] & OA_DEFGV) {
10310 /* Ordering of these two is important to keep f_map.t passing. */
10312 return newUNOP(type, 0, newDEFSVOP());
10316 while (oa & OA_OPTIONAL)
10318 if (oa && oa != OA_LIST)
10319 return too_few_arguments_pv(o,OP_DESC(o), 0);
10325 Perl_ck_glob(pTHX_ OP *o)
10329 PERL_ARGS_ASSERT_CK_GLOB;
10332 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10333 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10335 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10339 * \ null - const(wildcard)
10344 * \ mark - glob - rv2cv
10345 * | \ gv(CORE::GLOBAL::glob)
10347 * \ null - const(wildcard)
10349 o->op_flags |= OPf_SPECIAL;
10350 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10351 o = S_new_entersubop(aTHX_ gv, o);
10352 o = newUNOP(OP_NULL, 0, o);
10353 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10356 else o->op_flags &= ~OPf_SPECIAL;
10357 #if !defined(PERL_EXTERNAL_GLOB)
10358 if (!PL_globhook) {
10360 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10361 newSVpvs("File::Glob"), NULL, NULL, NULL);
10364 #endif /* !PERL_EXTERNAL_GLOB */
10365 gv = (GV *)newSV(0);
10366 gv_init(gv, 0, "", 0, 0);
10368 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10369 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10375 Perl_ck_grep(pTHX_ OP *o)
10379 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10381 PERL_ARGS_ASSERT_CK_GREP;
10383 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10385 if (o->op_flags & OPf_STACKED) {
10386 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10387 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10388 return no_fh_allowed(o);
10389 o->op_flags &= ~OPf_STACKED;
10391 kid = OpSIBLING(cLISTOPo->op_first);
10392 if (type == OP_MAPWHILE)
10397 if (PL_parser && PL_parser->error_count)
10399 kid = OpSIBLING(cLISTOPo->op_first);
10400 if (kid->op_type != OP_NULL)
10401 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10402 kid = kUNOP->op_first;
10404 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
10405 kid->op_next = (OP*)gwop;
10406 o->op_private = gwop->op_private = 0;
10407 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10409 kid = OpSIBLING(cLISTOPo->op_first);
10410 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10411 op_lvalue(kid, OP_GREPSTART);
10417 Perl_ck_index(pTHX_ OP *o)
10419 PERL_ARGS_ASSERT_CK_INDEX;
10421 if (o->op_flags & OPf_KIDS) {
10422 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10424 kid = OpSIBLING(kid); /* get past "big" */
10425 if (kid && kid->op_type == OP_CONST) {
10426 const bool save_taint = TAINT_get;
10427 SV *sv = kSVOP->op_sv;
10428 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10430 sv_copypv(sv, kSVOP->op_sv);
10431 SvREFCNT_dec_NN(kSVOP->op_sv);
10434 if (SvOK(sv)) fbm_compile(sv, 0);
10435 TAINT_set(save_taint);
10436 #ifdef NO_TAINT_SUPPORT
10437 PERL_UNUSED_VAR(save_taint);
10445 Perl_ck_lfun(pTHX_ OP *o)
10447 const OPCODE type = o->op_type;
10449 PERL_ARGS_ASSERT_CK_LFUN;
10451 return modkids(ck_fun(o), type);
10455 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10457 PERL_ARGS_ASSERT_CK_DEFINED;
10459 if ((o->op_flags & OPf_KIDS)) {
10460 switch (cUNOPo->op_first->op_type) {
10463 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10464 " (Maybe you should just omit the defined()?)");
10465 NOT_REACHED; /* NOTREACHED */
10469 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10470 " (Maybe you should just omit the defined()?)");
10471 NOT_REACHED; /* NOTREACHED */
10482 Perl_ck_readline(pTHX_ OP *o)
10484 PERL_ARGS_ASSERT_CK_READLINE;
10486 if (o->op_flags & OPf_KIDS) {
10487 OP *kid = cLISTOPo->op_first;
10488 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10492 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10500 Perl_ck_rfun(pTHX_ OP *o)
10502 const OPCODE type = o->op_type;
10504 PERL_ARGS_ASSERT_CK_RFUN;
10506 return refkids(ck_fun(o), type);
10510 Perl_ck_listiob(pTHX_ OP *o)
10514 PERL_ARGS_ASSERT_CK_LISTIOB;
10516 kid = cLISTOPo->op_first;
10518 o = force_list(o, 1);
10519 kid = cLISTOPo->op_first;
10521 if (kid->op_type == OP_PUSHMARK)
10522 kid = OpSIBLING(kid);
10523 if (kid && o->op_flags & OPf_STACKED)
10524 kid = OpSIBLING(kid);
10525 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10526 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10527 && !kid->op_folded) {
10528 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10530 /* replace old const op with new OP_RV2GV parent */
10531 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10532 OP_RV2GV, OPf_REF);
10533 kid = OpSIBLING(kid);
10538 op_append_elem(o->op_type, o, newDEFSVOP());
10540 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10541 return listkids(o);
10545 Perl_ck_smartmatch(pTHX_ OP *o)
10548 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10549 if (0 == (o->op_flags & OPf_SPECIAL)) {
10550 OP *first = cBINOPo->op_first;
10551 OP *second = OpSIBLING(first);
10553 /* Implicitly take a reference to an array or hash */
10555 /* remove the original two siblings, then add back the
10556 * (possibly different) first and second sibs.
10558 op_sibling_splice(o, NULL, 1, NULL);
10559 op_sibling_splice(o, NULL, 1, NULL);
10560 first = ref_array_or_hash(first);
10561 second = ref_array_or_hash(second);
10562 op_sibling_splice(o, NULL, 0, second);
10563 op_sibling_splice(o, NULL, 0, first);
10565 /* Implicitly take a reference to a regular expression */
10566 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
10567 OpTYPE_set(first, OP_QR);
10569 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
10570 OpTYPE_set(second, OP_QR);
10579 S_maybe_targlex(pTHX_ OP *o)
10581 OP * const kid = cLISTOPo->op_first;
10582 /* has a disposable target? */
10583 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10584 && !(kid->op_flags & OPf_STACKED)
10585 /* Cannot steal the second time! */
10586 && !(kid->op_private & OPpTARGET_MY)
10589 OP * const kkid = OpSIBLING(kid);
10591 /* Can just relocate the target. */
10592 if (kkid && kkid->op_type == OP_PADSV
10593 && (!(kkid->op_private & OPpLVAL_INTRO)
10594 || kkid->op_private & OPpPAD_STATE))
10596 kid->op_targ = kkid->op_targ;
10598 /* Now we do not need PADSV and SASSIGN.
10599 * Detach kid and free the rest. */
10600 op_sibling_splice(o, NULL, 1, NULL);
10602 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10610 Perl_ck_sassign(pTHX_ OP *o)
10613 OP * const kid = cBINOPo->op_first;
10615 PERL_ARGS_ASSERT_CK_SASSIGN;
10617 if (OpHAS_SIBLING(kid)) {
10618 OP *kkid = OpSIBLING(kid);
10619 /* For state variable assignment with attributes, kkid is a list op
10620 whose op_last is a padsv. */
10621 if ((kkid->op_type == OP_PADSV ||
10622 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10623 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10626 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10627 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10628 const PADOFFSET target = kkid->op_targ;
10629 OP *const other = newOP(OP_PADSV,
10631 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10632 OP *const first = newOP(OP_NULL, 0);
10634 newCONDOP(0, first, o, other);
10635 /* XXX targlex disabled for now; see ticket #124160
10636 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10638 OP *const condop = first->op_next;
10640 OpTYPE_set(condop, OP_ONCE);
10641 other->op_targ = target;
10642 nullop->op_flags |= OPf_WANT_SCALAR;
10644 /* Store the initializedness of state vars in a separate
10647 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10648 /* hijacking PADSTALE for uninitialized state variables */
10649 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10654 return S_maybe_targlex(aTHX_ o);
10658 Perl_ck_match(pTHX_ OP *o)
10660 PERL_UNUSED_CONTEXT;
10661 PERL_ARGS_ASSERT_CK_MATCH;
10667 Perl_ck_method(pTHX_ OP *o)
10669 SV *sv, *methsv, *rclass;
10670 const char* method;
10673 STRLEN len, nsplit = 0, i;
10675 OP * const kid = cUNOPo->op_first;
10677 PERL_ARGS_ASSERT_CK_METHOD;
10678 if (kid->op_type != OP_CONST) return o;
10682 /* replace ' with :: */
10683 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10685 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10688 method = SvPVX_const(sv);
10690 utf8 = SvUTF8(sv) ? -1 : 1;
10692 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10697 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10699 if (!nsplit) { /* $proto->method() */
10701 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10704 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10706 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10709 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10710 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10711 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10712 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10714 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10715 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10717 #ifdef USE_ITHREADS
10718 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10720 cMETHOPx(new_op)->op_rclass_sv = rclass;
10727 Perl_ck_null(pTHX_ OP *o)
10729 PERL_ARGS_ASSERT_CK_NULL;
10730 PERL_UNUSED_CONTEXT;
10735 Perl_ck_open(pTHX_ OP *o)
10737 PERL_ARGS_ASSERT_CK_OPEN;
10739 S_io_hints(aTHX_ o);
10741 /* In case of three-arg dup open remove strictness
10742 * from the last arg if it is a bareword. */
10743 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10744 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10748 if ((last->op_type == OP_CONST) && /* The bareword. */
10749 (last->op_private & OPpCONST_BARE) &&
10750 (last->op_private & OPpCONST_STRICT) &&
10751 (oa = OpSIBLING(first)) && /* The fh. */
10752 (oa = OpSIBLING(oa)) && /* The mode. */
10753 (oa->op_type == OP_CONST) &&
10754 SvPOK(((SVOP*)oa)->op_sv) &&
10755 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10756 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10757 (last == OpSIBLING(oa))) /* The bareword. */
10758 last->op_private &= ~OPpCONST_STRICT;
10764 Perl_ck_prototype(pTHX_ OP *o)
10766 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10767 if (!(o->op_flags & OPf_KIDS)) {
10769 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10775 Perl_ck_refassign(pTHX_ OP *o)
10777 OP * const right = cLISTOPo->op_first;
10778 OP * const left = OpSIBLING(right);
10779 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10782 PERL_ARGS_ASSERT_CK_REFASSIGN;
10784 assert (left->op_type == OP_SREFGEN);
10787 /* we use OPpPAD_STATE in refassign to mean either of those things,
10788 * and the code assumes the two flags occupy the same bit position
10789 * in the various ops below */
10790 assert(OPpPAD_STATE == OPpOUR_INTRO);
10792 switch (varop->op_type) {
10794 o->op_private |= OPpLVREF_AV;
10797 o->op_private |= OPpLVREF_HV;
10801 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10802 o->op_targ = varop->op_targ;
10803 varop->op_targ = 0;
10804 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10808 o->op_private |= OPpLVREF_AV;
10810 NOT_REACHED; /* NOTREACHED */
10812 o->op_private |= OPpLVREF_HV;
10816 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10817 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10819 /* Point varop to its GV kid, detached. */
10820 varop = op_sibling_splice(varop, NULL, -1, NULL);
10824 OP * const kidparent =
10825 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10826 OP * const kid = cUNOPx(kidparent)->op_first;
10827 o->op_private |= OPpLVREF_CV;
10828 if (kid->op_type == OP_GV) {
10830 goto detach_and_stack;
10832 if (kid->op_type != OP_PADCV) goto bad;
10833 o->op_targ = kid->op_targ;
10839 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10840 o->op_private |= OPpLVREF_ELEM;
10843 /* Detach varop. */
10844 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10848 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10849 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10854 if (!FEATURE_REFALIASING_IS_ENABLED)
10856 "Experimental aliasing via reference not enabled");
10857 Perl_ck_warner_d(aTHX_
10858 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10859 "Aliasing via reference is experimental");
10861 o->op_flags |= OPf_STACKED;
10862 op_sibling_splice(o, right, 1, varop);
10865 o->op_flags &=~ OPf_STACKED;
10866 op_sibling_splice(o, right, 1, NULL);
10873 Perl_ck_repeat(pTHX_ OP *o)
10875 PERL_ARGS_ASSERT_CK_REPEAT;
10877 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10879 o->op_private |= OPpREPEAT_DOLIST;
10880 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10881 kids = force_list(kids, 1); /* promote it to a list */
10882 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10890 Perl_ck_require(pTHX_ OP *o)
10894 PERL_ARGS_ASSERT_CK_REQUIRE;
10896 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10897 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10901 if (kid->op_type == OP_CONST) {
10902 SV * const sv = kid->op_sv;
10903 U32 const was_readonly = SvREADONLY(sv);
10904 if (kid->op_private & OPpCONST_BARE) {
10909 if (was_readonly) {
10910 SvREADONLY_off(sv);
10912 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10917 /* treat ::foo::bar as foo::bar */
10918 if (len >= 2 && s[0] == ':' && s[1] == ':')
10919 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10921 DIE(aTHX_ "Bareword in require maps to empty filename");
10923 for (; s < end; s++) {
10924 if (*s == ':' && s[1] == ':') {
10926 Move(s+2, s+1, end - s - 1, char);
10930 SvEND_set(sv, end);
10931 sv_catpvs(sv, ".pm");
10932 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10933 hek = share_hek(SvPVX(sv),
10934 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10936 sv_sethek(sv, hek);
10938 SvFLAGS(sv) |= was_readonly;
10940 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10943 if (SvREFCNT(sv) > 1) {
10944 kid->op_sv = newSVpvn_share(
10945 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10946 SvREFCNT_dec_NN(sv);
10951 if (was_readonly) SvREADONLY_off(sv);
10952 PERL_HASH(hash, s, len);
10954 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10956 sv_sethek(sv, hek);
10958 SvFLAGS(sv) |= was_readonly;
10964 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10965 /* handle override, if any */
10966 && (gv = gv_override("require", 7))) {
10968 if (o->op_flags & OPf_KIDS) {
10969 kid = cUNOPo->op_first;
10970 op_sibling_splice(o, NULL, -1, NULL);
10973 kid = newDEFSVOP();
10976 newop = S_new_entersubop(aTHX_ gv, kid);
10984 Perl_ck_return(pTHX_ OP *o)
10988 PERL_ARGS_ASSERT_CK_RETURN;
10990 kid = OpSIBLING(cLISTOPo->op_first);
10991 if (PL_compcv && CvLVALUE(PL_compcv)) {
10992 for (; kid; kid = OpSIBLING(kid))
10993 op_lvalue(kid, OP_LEAVESUBLV);
11000 Perl_ck_select(pTHX_ OP *o)
11005 PERL_ARGS_ASSERT_CK_SELECT;
11007 if (o->op_flags & OPf_KIDS) {
11008 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
11009 if (kid && OpHAS_SIBLING(kid)) {
11010 OpTYPE_set(o, OP_SSELECT);
11012 return fold_constants(op_integerize(op_std_init(o)));
11016 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
11017 if (kid && kid->op_type == OP_RV2GV)
11018 kid->op_private &= ~HINT_STRICT_REFS;
11023 Perl_ck_shift(pTHX_ OP *o)
11025 const I32 type = o->op_type;
11027 PERL_ARGS_ASSERT_CK_SHIFT;
11029 if (!(o->op_flags & OPf_KIDS)) {
11032 if (!CvUNIQUE(PL_compcv)) {
11033 o->op_flags |= OPf_SPECIAL;
11037 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
11039 return newUNOP(type, 0, scalar(argop));
11041 return scalar(ck_fun(o));
11045 Perl_ck_sort(pTHX_ OP *o)
11049 HV * const hinthv =
11050 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
11053 PERL_ARGS_ASSERT_CK_SORT;
11056 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
11058 const I32 sorthints = (I32)SvIV(*svp);
11059 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
11060 o->op_private |= OPpSORT_QSORT;
11061 if ((sorthints & HINT_SORT_STABLE) != 0)
11062 o->op_private |= OPpSORT_STABLE;
11066 if (o->op_flags & OPf_STACKED)
11068 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
11070 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
11071 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
11073 /* if the first arg is a code block, process it and mark sort as
11075 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
11077 if (kid->op_type == OP_LEAVE)
11078 op_null(kid); /* wipe out leave */
11079 /* Prevent execution from escaping out of the sort block. */
11082 /* provide scalar context for comparison function/block */
11083 kid = scalar(firstkid);
11084 kid->op_next = kid;
11085 o->op_flags |= OPf_SPECIAL;
11087 else if (kid->op_type == OP_CONST
11088 && kid->op_private & OPpCONST_BARE) {
11092 const char * const name = SvPV(kSVOP_sv, len);
11094 assert (len < 256);
11095 Copy(name, tmpbuf+1, len, char);
11096 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
11097 if (off != NOT_IN_PAD) {
11098 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
11100 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
11101 sv_catpvs(fq, "::");
11102 sv_catsv(fq, kSVOP_sv);
11103 SvREFCNT_dec_NN(kSVOP_sv);
11107 OP * const padop = newOP(OP_PADCV, 0);
11108 padop->op_targ = off;
11109 /* replace the const op with the pad op */
11110 op_sibling_splice(firstkid, NULL, 1, padop);
11116 firstkid = OpSIBLING(firstkid);
11119 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
11120 /* provide list context for arguments */
11123 op_lvalue(kid, OP_GREPSTART);
11129 /* for sort { X } ..., where X is one of
11130 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
11131 * elide the second child of the sort (the one containing X),
11132 * and set these flags as appropriate
11136 * Also, check and warn on lexical $a, $b.
11140 S_simplify_sort(pTHX_ OP *o)
11142 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
11146 const char *gvname;
11149 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
11151 kid = kUNOP->op_first; /* get past null */
11152 if (!(have_scopeop = kid->op_type == OP_SCOPE)
11153 && kid->op_type != OP_LEAVE)
11155 kid = kLISTOP->op_last; /* get past scope */
11156 switch(kid->op_type) {
11160 if (!have_scopeop) goto padkids;
11165 k = kid; /* remember this node*/
11166 if (kBINOP->op_first->op_type != OP_RV2SV
11167 || kBINOP->op_last ->op_type != OP_RV2SV)
11170 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11171 then used in a comparison. This catches most, but not
11172 all cases. For instance, it catches
11173 sort { my($a); $a <=> $b }
11175 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11176 (although why you'd do that is anyone's guess).
11180 if (!ckWARN(WARN_SYNTAX)) return;
11181 kid = kBINOP->op_first;
11183 if (kid->op_type == OP_PADSV) {
11184 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11185 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11186 && ( PadnamePV(name)[1] == 'a'
11187 || PadnamePV(name)[1] == 'b' ))
11188 /* diag_listed_as: "my %s" used in sort comparison */
11189 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11190 "\"%s %s\" used in sort comparison",
11191 PadnameIsSTATE(name)
11196 } while ((kid = OpSIBLING(kid)));
11199 kid = kBINOP->op_first; /* get past cmp */
11200 if (kUNOP->op_first->op_type != OP_GV)
11202 kid = kUNOP->op_first; /* get past rv2sv */
11204 if (GvSTASH(gv) != PL_curstash)
11206 gvname = GvNAME(gv);
11207 if (*gvname == 'a' && gvname[1] == '\0')
11209 else if (*gvname == 'b' && gvname[1] == '\0')
11214 kid = k; /* back to cmp */
11215 /* already checked above that it is rv2sv */
11216 kid = kBINOP->op_last; /* down to 2nd arg */
11217 if (kUNOP->op_first->op_type != OP_GV)
11219 kid = kUNOP->op_first; /* get past rv2sv */
11221 if (GvSTASH(gv) != PL_curstash)
11223 gvname = GvNAME(gv);
11225 ? !(*gvname == 'a' && gvname[1] == '\0')
11226 : !(*gvname == 'b' && gvname[1] == '\0'))
11228 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11230 o->op_private |= OPpSORT_DESCEND;
11231 if (k->op_type == OP_NCMP)
11232 o->op_private |= OPpSORT_NUMERIC;
11233 if (k->op_type == OP_I_NCMP)
11234 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11235 kid = OpSIBLING(cLISTOPo->op_first);
11236 /* cut out and delete old block (second sibling) */
11237 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11242 Perl_ck_split(pTHX_ OP *o)
11248 PERL_ARGS_ASSERT_CK_SPLIT;
11250 assert(o->op_type == OP_LIST);
11252 if (o->op_flags & OPf_STACKED)
11253 return no_fh_allowed(o);
11255 kid = cLISTOPo->op_first;
11256 /* delete leading NULL node, then add a CONST if no other nodes */
11257 assert(kid->op_type == OP_NULL);
11258 op_sibling_splice(o, NULL, 1,
11259 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11261 kid = cLISTOPo->op_first;
11263 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11264 /* remove match expression, and replace with new optree with
11265 * a match op at its head */
11266 op_sibling_splice(o, NULL, 1, NULL);
11267 /* pmruntime will handle split " " behavior with flag==2 */
11268 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
11269 op_sibling_splice(o, NULL, 0, kid);
11272 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
11274 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11275 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11276 "Use of /g modifier is meaningless in split");
11279 /* eliminate the split op, and move the match op (plus any children)
11280 * into its place, then convert the match op into a split op. i.e.
11282 * SPLIT MATCH SPLIT(ex-MATCH)
11284 * MATCH - A - B - C => R - A - B - C => R - A - B - C
11290 * (R, if it exists, will be a regcomp op)
11293 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
11294 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
11295 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
11296 OpTYPE_set(kid, OP_SPLIT);
11297 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
11298 kid->op_private = o->op_private;
11301 kid = sibs; /* kid is now the string arg of the split */
11304 kid = newDEFSVOP();
11305 op_append_elem(OP_SPLIT, o, kid);
11309 kid = OpSIBLING(kid);
11311 kid = newSVOP(OP_CONST, 0, newSViv(0));
11312 op_append_elem(OP_SPLIT, o, kid);
11313 o->op_private |= OPpSPLIT_IMPLIM;
11317 if (OpHAS_SIBLING(kid))
11318 return too_many_arguments_pv(o,OP_DESC(o), 0);
11324 Perl_ck_stringify(pTHX_ OP *o)
11326 OP * const kid = OpSIBLING(cUNOPo->op_first);
11327 PERL_ARGS_ASSERT_CK_STRINGIFY;
11328 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11329 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11330 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11331 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11333 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11341 Perl_ck_join(pTHX_ OP *o)
11343 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11345 PERL_ARGS_ASSERT_CK_JOIN;
11347 if (kid && kid->op_type == OP_MATCH) {
11348 if (ckWARN(WARN_SYNTAX)) {
11349 const REGEXP *re = PM_GETRE(kPMOP);
11351 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11352 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11353 : newSVpvs_flags( "STRING", SVs_TEMP );
11354 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11355 "/%" SVf "/ should probably be written as \"%" SVf "\"",
11356 SVfARG(msg), SVfARG(msg));
11360 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11361 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11362 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11363 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11365 const OP * const bairn = OpSIBLING(kid); /* the list */
11366 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11367 && OP_GIMME(bairn,0) == G_SCALAR)
11369 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11370 op_sibling_splice(o, kid, 1, NULL));
11380 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11382 Examines an op, which is expected to identify a subroutine at runtime,
11383 and attempts to determine at compile time which subroutine it identifies.
11384 This is normally used during Perl compilation to determine whether
11385 a prototype can be applied to a function call. C<cvop> is the op
11386 being considered, normally an C<rv2cv> op. A pointer to the identified
11387 subroutine is returned, if it could be determined statically, and a null
11388 pointer is returned if it was not possible to determine statically.
11390 Currently, the subroutine can be identified statically if the RV that the
11391 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11392 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11393 suitable if the constant value must be an RV pointing to a CV. Details of
11394 this process may change in future versions of Perl. If the C<rv2cv> op
11395 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11396 the subroutine statically: this flag is used to suppress compile-time
11397 magic on a subroutine call, forcing it to use default runtime behaviour.
11399 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11400 of a GV reference is modified. If a GV was examined and its CV slot was
11401 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11402 If the op is not optimised away, and the CV slot is later populated with
11403 a subroutine having a prototype, that flag eventually triggers the warning
11404 "called too early to check prototype".
11406 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11407 of returning a pointer to the subroutine it returns a pointer to the
11408 GV giving the most appropriate name for the subroutine in this context.
11409 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11410 (C<CvANON>) subroutine that is referenced through a GV it will be the
11411 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11412 A null pointer is returned as usual if there is no statically-determinable
11418 /* shared by toke.c:yylex */
11420 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11422 PADNAME *name = PAD_COMPNAME(off);
11423 CV *compcv = PL_compcv;
11424 while (PadnameOUTER(name)) {
11425 assert(PARENT_PAD_INDEX(name));
11426 compcv = CvOUTSIDE(compcv);
11427 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11428 [off = PARENT_PAD_INDEX(name)];
11430 assert(!PadnameIsOUR(name));
11431 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11432 return PadnamePROTOCV(name);
11434 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11438 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11443 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11444 if (flags & ~RV2CVOPCV_FLAG_MASK)
11445 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11446 if (cvop->op_type != OP_RV2CV)
11448 if (cvop->op_private & OPpENTERSUB_AMPER)
11450 if (!(cvop->op_flags & OPf_KIDS))
11452 rvop = cUNOPx(cvop)->op_first;
11453 switch (rvop->op_type) {
11455 gv = cGVOPx_gv(rvop);
11457 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11458 cv = MUTABLE_CV(SvRV(gv));
11462 if (flags & RV2CVOPCV_RETURN_STUB)
11468 if (flags & RV2CVOPCV_MARK_EARLY)
11469 rvop->op_private |= OPpEARLY_CV;
11474 SV *rv = cSVOPx_sv(rvop);
11477 cv = (CV*)SvRV(rv);
11481 cv = find_lexical_cv(rvop->op_targ);
11486 } NOT_REACHED; /* NOTREACHED */
11488 if (SvTYPE((SV*)cv) != SVt_PVCV)
11490 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11491 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11492 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11501 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11503 Performs the default fixup of the arguments part of an C<entersub>
11504 op tree. This consists of applying list context to each of the
11505 argument ops. This is the standard treatment used on a call marked
11506 with C<&>, or a method call, or a call through a subroutine reference,
11507 or any other call where the callee can't be identified at compile time,
11508 or a call where the callee has no prototype.
11514 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11518 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11520 aop = cUNOPx(entersubop)->op_first;
11521 if (!OpHAS_SIBLING(aop))
11522 aop = cUNOPx(aop)->op_first;
11523 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11524 /* skip the extra attributes->import() call implicitly added in
11525 * something like foo(my $x : bar)
11527 if ( aop->op_type == OP_ENTERSUB
11528 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11532 op_lvalue(aop, OP_ENTERSUB);
11538 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11540 Performs the fixup of the arguments part of an C<entersub> op tree
11541 based on a subroutine prototype. This makes various modifications to
11542 the argument ops, from applying context up to inserting C<refgen> ops,
11543 and checking the number and syntactic types of arguments, as directed by
11544 the prototype. This is the standard treatment used on a subroutine call,
11545 not marked with C<&>, where the callee can be identified at compile time
11546 and has a prototype.
11548 C<protosv> supplies the subroutine prototype to be applied to the call.
11549 It may be a normal defined scalar, of which the string value will be used.
11550 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11551 that has been cast to C<SV*>) which has a prototype. The prototype
11552 supplied, in whichever form, does not need to match the actual callee
11553 referenced by the op tree.
11555 If the argument ops disagree with the prototype, for example by having
11556 an unacceptable number of arguments, a valid op tree is returned anyway.
11557 The error is reflected in the parser state, normally resulting in a single
11558 exception at the top level of parsing which covers all the compilation
11559 errors that occurred. In the error message, the callee is referred to
11560 by the name defined by the C<namegv> parameter.
11566 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11569 const char *proto, *proto_end;
11570 OP *aop, *prev, *cvop, *parent;
11573 I32 contextclass = 0;
11574 const char *e = NULL;
11575 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11576 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11577 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11578 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11579 if (SvTYPE(protosv) == SVt_PVCV)
11580 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11581 else proto = SvPV(protosv, proto_len);
11582 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11583 proto_end = proto + proto_len;
11584 parent = entersubop;
11585 aop = cUNOPx(entersubop)->op_first;
11586 if (!OpHAS_SIBLING(aop)) {
11588 aop = cUNOPx(aop)->op_first;
11591 aop = OpSIBLING(aop);
11592 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11593 while (aop != cvop) {
11596 if (proto >= proto_end)
11598 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11599 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
11600 SVfARG(namesv)), SvUTF8(namesv));
11610 /* _ must be at the end */
11611 if (proto[1] && !strchr(";@%", proto[1]))
11627 if ( o3->op_type != OP_UNDEF
11628 && (o3->op_type != OP_SREFGEN
11629 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11631 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11633 bad_type_gv(arg, namegv, o3,
11634 arg == 1 ? "block or sub {}" : "sub {}");
11637 /* '*' allows any scalar type, including bareword */
11640 if (o3->op_type == OP_RV2GV)
11641 goto wrapref; /* autoconvert GLOB -> GLOBref */
11642 else if (o3->op_type == OP_CONST)
11643 o3->op_private &= ~OPpCONST_STRICT;
11649 if (o3->op_type == OP_RV2AV ||
11650 o3->op_type == OP_PADAV ||
11651 o3->op_type == OP_RV2HV ||
11652 o3->op_type == OP_PADHV
11658 case '[': case ']':
11665 switch (*proto++) {
11667 if (contextclass++ == 0) {
11668 e = strchr(proto, ']');
11669 if (!e || e == proto)
11677 if (contextclass) {
11678 const char *p = proto;
11679 const char *const end = proto;
11681 while (*--p != '[')
11682 /* \[$] accepts any scalar lvalue */
11684 && Perl_op_lvalue_flags(aTHX_
11686 OP_READ, /* not entersub */
11689 bad_type_gv(arg, namegv, o3,
11690 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11695 if (o3->op_type == OP_RV2GV)
11698 bad_type_gv(arg, namegv, o3, "symbol");
11701 if (o3->op_type == OP_ENTERSUB
11702 && !(o3->op_flags & OPf_STACKED))
11705 bad_type_gv(arg, namegv, o3, "subroutine");
11708 if (o3->op_type == OP_RV2SV ||
11709 o3->op_type == OP_PADSV ||
11710 o3->op_type == OP_HELEM ||
11711 o3->op_type == OP_AELEM)
11713 if (!contextclass) {
11714 /* \$ accepts any scalar lvalue */
11715 if (Perl_op_lvalue_flags(aTHX_
11717 OP_READ, /* not entersub */
11720 bad_type_gv(arg, namegv, o3, "scalar");
11724 if (o3->op_type == OP_RV2AV ||
11725 o3->op_type == OP_PADAV)
11727 o3->op_flags &=~ OPf_PARENS;
11731 bad_type_gv(arg, namegv, o3, "array");
11734 if (o3->op_type == OP_RV2HV ||
11735 o3->op_type == OP_PADHV)
11737 o3->op_flags &=~ OPf_PARENS;
11741 bad_type_gv(arg, namegv, o3, "hash");
11744 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11746 if (contextclass && e) {
11751 default: goto oops;
11761 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
11762 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11767 op_lvalue(aop, OP_ENTERSUB);
11769 aop = OpSIBLING(aop);
11771 if (aop == cvop && *proto == '_') {
11772 /* generate an access to $_ */
11773 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11775 if (!optional && proto_end > proto &&
11776 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11778 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11779 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
11780 SVfARG(namesv)), SvUTF8(namesv));
11786 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11788 Performs the fixup of the arguments part of an C<entersub> op tree either
11789 based on a subroutine prototype or using default list-context processing.
11790 This is the standard treatment used on a subroutine call, not marked
11791 with C<&>, where the callee can be identified at compile time.
11793 C<protosv> supplies the subroutine prototype to be applied to the call,
11794 or indicates that there is no prototype. It may be a normal scalar,
11795 in which case if it is defined then the string value will be used
11796 as a prototype, and if it is undefined then there is no prototype.
11797 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11798 that has been cast to C<SV*>), of which the prototype will be used if it
11799 has one. The prototype (or lack thereof) supplied, in whichever form,
11800 does not need to match the actual callee referenced by the op tree.
11802 If the argument ops disagree with the prototype, for example by having
11803 an unacceptable number of arguments, a valid op tree is returned anyway.
11804 The error is reflected in the parser state, normally resulting in a single
11805 exception at the top level of parsing which covers all the compilation
11806 errors that occurred. In the error message, the callee is referred to
11807 by the name defined by the C<namegv> parameter.
11813 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11814 GV *namegv, SV *protosv)
11816 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11817 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11818 return ck_entersub_args_proto(entersubop, namegv, protosv);
11820 return ck_entersub_args_list(entersubop);
11824 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11826 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11827 OP *aop = cUNOPx(entersubop)->op_first;
11829 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11833 if (!OpHAS_SIBLING(aop))
11834 aop = cUNOPx(aop)->op_first;
11835 aop = OpSIBLING(aop);
11836 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11838 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11840 op_free(entersubop);
11841 switch(GvNAME(namegv)[2]) {
11842 case 'F': return newSVOP(OP_CONST, 0,
11843 newSVpv(CopFILE(PL_curcop),0));
11844 case 'L': return newSVOP(
11846 Perl_newSVpvf(aTHX_
11847 "%" IVdf, (IV)CopLINE(PL_curcop)
11850 case 'P': return newSVOP(OP_CONST, 0,
11852 ? newSVhek(HvNAME_HEK(PL_curstash))
11857 NOT_REACHED; /* NOTREACHED */
11860 OP *prev, *cvop, *first, *parent;
11863 parent = entersubop;
11864 if (!OpHAS_SIBLING(aop)) {
11866 aop = cUNOPx(aop)->op_first;
11869 first = prev = aop;
11870 aop = OpSIBLING(aop);
11871 /* find last sibling */
11873 OpHAS_SIBLING(cvop);
11874 prev = cvop, cvop = OpSIBLING(cvop))
11876 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11877 /* Usually, OPf_SPECIAL on an op with no args means that it had
11878 * parens, but these have their own meaning for that flag: */
11879 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11880 && opnum != OP_DELETE && opnum != OP_EXISTS)
11881 flags |= OPf_SPECIAL;
11882 /* excise cvop from end of sibling chain */
11883 op_sibling_splice(parent, prev, 1, NULL);
11885 if (aop == cvop) aop = NULL;
11887 /* detach remaining siblings from the first sibling, then
11888 * dispose of original optree */
11891 op_sibling_splice(parent, first, -1, NULL);
11892 op_free(entersubop);
11894 if (opnum == OP_ENTEREVAL
11895 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11896 flags |= OPpEVAL_BYTES <<8;
11898 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11900 case OA_BASEOP_OR_UNOP:
11901 case OA_FILESTATOP:
11902 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11905 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11908 return opnum == OP_RUNCV
11909 ? newPVOP(OP_RUNCV,0,NULL)
11912 return op_convert_list(opnum,0,aop);
11915 NOT_REACHED; /* NOTREACHED */
11920 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11922 Retrieves the function that will be used to fix up a call to C<cv>.
11923 Specifically, the function is applied to an C<entersub> op tree for a
11924 subroutine call, not marked with C<&>, where the callee can be identified
11925 at compile time as C<cv>.
11927 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11928 argument for it is returned in C<*ckobj_p>. The function is intended
11929 to be called in this manner:
11931 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11933 In this call, C<entersubop> is a pointer to the C<entersub> op,
11934 which may be replaced by the check function, and C<namegv> is a GV
11935 supplying the name that should be used by the check function to refer
11936 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11937 It is permitted to apply the check function in non-standard situations,
11938 such as to a call to a different subroutine or to a method call.
11940 By default, the function is
11941 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11942 and the SV parameter is C<cv> itself. This implements standard
11943 prototype processing. It can be changed, for a particular subroutine,
11944 by L</cv_set_call_checker>.
11950 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11954 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11956 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11957 *ckobj_p = callmg->mg_obj;
11958 if (flagsp) *flagsp = callmg->mg_flags;
11960 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11961 *ckobj_p = (SV*)cv;
11962 if (flagsp) *flagsp = 0;
11967 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11969 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11970 PERL_UNUSED_CONTEXT;
11971 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11975 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11977 Sets the function that will be used to fix up a call to C<cv>.
11978 Specifically, the function is applied to an C<entersub> op tree for a
11979 subroutine call, not marked with C<&>, where the callee can be identified
11980 at compile time as C<cv>.
11982 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11983 for it is supplied in C<ckobj>. The function should be defined like this:
11985 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11987 It is intended to be called in this manner:
11989 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11991 In this call, C<entersubop> is a pointer to the C<entersub> op,
11992 which may be replaced by the check function, and C<namegv> supplies
11993 the name that should be used by the check function to refer
11994 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11995 It is permitted to apply the check function in non-standard situations,
11996 such as to a call to a different subroutine or to a method call.
11998 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11999 CV or other SV instead. Whatever is passed can be used as the first
12000 argument to L</cv_name>. You can force perl to pass a GV by including
12001 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
12003 The current setting for a particular CV can be retrieved by
12004 L</cv_get_call_checker>.
12006 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
12008 The original form of L</cv_set_call_checker_flags>, which passes it the
12009 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
12015 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
12017 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
12018 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
12022 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
12023 SV *ckobj, U32 flags)
12025 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
12026 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
12027 if (SvMAGICAL((SV*)cv))
12028 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
12031 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
12032 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
12034 if (callmg->mg_flags & MGf_REFCOUNTED) {
12035 SvREFCNT_dec(callmg->mg_obj);
12036 callmg->mg_flags &= ~MGf_REFCOUNTED;
12038 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
12039 callmg->mg_obj = ckobj;
12040 if (ckobj != (SV*)cv) {
12041 SvREFCNT_inc_simple_void_NN(ckobj);
12042 callmg->mg_flags |= MGf_REFCOUNTED;
12044 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
12045 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
12050 S_entersub_alloc_targ(pTHX_ OP * const o)
12052 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
12053 o->op_private |= OPpENTERSUB_HASTARG;
12057 Perl_ck_subr(pTHX_ OP *o)
12062 SV **const_class = NULL;
12064 PERL_ARGS_ASSERT_CK_SUBR;
12066 aop = cUNOPx(o)->op_first;
12067 if (!OpHAS_SIBLING(aop))
12068 aop = cUNOPx(aop)->op_first;
12069 aop = OpSIBLING(aop);
12070 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
12071 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
12072 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
12074 o->op_private &= ~1;
12075 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12076 if (PERLDB_SUB && PL_curstash != PL_debstash)
12077 o->op_private |= OPpENTERSUB_DB;
12078 switch (cvop->op_type) {
12080 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
12084 case OP_METHOD_NAMED:
12085 case OP_METHOD_SUPER:
12086 case OP_METHOD_REDIR:
12087 case OP_METHOD_REDIR_SUPER:
12088 o->op_flags |= OPf_REF;
12089 if (aop->op_type == OP_CONST) {
12090 aop->op_private &= ~OPpCONST_STRICT;
12091 const_class = &cSVOPx(aop)->op_sv;
12093 else if (aop->op_type == OP_LIST) {
12094 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
12095 if (sib && sib->op_type == OP_CONST) {
12096 sib->op_private &= ~OPpCONST_STRICT;
12097 const_class = &cSVOPx(sib)->op_sv;
12100 /* make class name a shared cow string to speedup method calls */
12101 /* constant string might be replaced with object, f.e. bigint */
12102 if (const_class && SvPOK(*const_class)) {
12104 const char* str = SvPV(*const_class, len);
12106 SV* const shared = newSVpvn_share(
12107 str, SvUTF8(*const_class)
12108 ? -(SSize_t)len : (SSize_t)len,
12111 if (SvREADONLY(*const_class))
12112 SvREADONLY_on(shared);
12113 SvREFCNT_dec(*const_class);
12114 *const_class = shared;
12121 S_entersub_alloc_targ(aTHX_ o);
12122 return ck_entersub_args_list(o);
12124 Perl_call_checker ckfun;
12127 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
12128 if (CvISXSUB(cv) || !CvROOT(cv))
12129 S_entersub_alloc_targ(aTHX_ o);
12131 /* The original call checker API guarantees that a GV will be
12132 be provided with the right name. So, if the old API was
12133 used (or the REQUIRE_GV flag was passed), we have to reify
12134 the CV’s GV, unless this is an anonymous sub. This is not
12135 ideal for lexical subs, as its stringification will include
12136 the package. But it is the best we can do. */
12137 if (flags & MGf_REQUIRE_GV) {
12138 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
12141 else namegv = MUTABLE_GV(cv);
12142 /* After a syntax error in a lexical sub, the cv that
12143 rv2cv_op_cv returns may be a nameless stub. */
12144 if (!namegv) return ck_entersub_args_list(o);
12147 return ckfun(aTHX_ o, namegv, ckobj);
12152 Perl_ck_svconst(pTHX_ OP *o)
12154 SV * const sv = cSVOPo->op_sv;
12155 PERL_ARGS_ASSERT_CK_SVCONST;
12156 PERL_UNUSED_CONTEXT;
12157 #ifdef PERL_COPY_ON_WRITE
12158 /* Since the read-only flag may be used to protect a string buffer, we
12159 cannot do copy-on-write with existing read-only scalars that are not
12160 already copy-on-write scalars. To allow $_ = "hello" to do COW with
12161 that constant, mark the constant as COWable here, if it is not
12162 already read-only. */
12163 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
12166 # ifdef PERL_DEBUG_READONLY_COW
12176 Perl_ck_trunc(pTHX_ OP *o)
12178 PERL_ARGS_ASSERT_CK_TRUNC;
12180 if (o->op_flags & OPf_KIDS) {
12181 SVOP *kid = (SVOP*)cUNOPo->op_first;
12183 if (kid->op_type == OP_NULL)
12184 kid = (SVOP*)OpSIBLING(kid);
12185 if (kid && kid->op_type == OP_CONST &&
12186 (kid->op_private & OPpCONST_BARE) &&
12189 o->op_flags |= OPf_SPECIAL;
12190 kid->op_private &= ~OPpCONST_STRICT;
12197 Perl_ck_substr(pTHX_ OP *o)
12199 PERL_ARGS_ASSERT_CK_SUBSTR;
12202 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
12203 OP *kid = cLISTOPo->op_first;
12205 if (kid->op_type == OP_NULL)
12206 kid = OpSIBLING(kid);
12208 kid->op_flags |= OPf_MOD;
12215 Perl_ck_tell(pTHX_ OP *o)
12217 PERL_ARGS_ASSERT_CK_TELL;
12219 if (o->op_flags & OPf_KIDS) {
12220 OP *kid = cLISTOPo->op_first;
12221 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12222 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12228 Perl_ck_each(pTHX_ OP *o)
12231 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12232 const unsigned orig_type = o->op_type;
12234 PERL_ARGS_ASSERT_CK_EACH;
12237 switch (kid->op_type) {
12243 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12244 : orig_type == OP_KEYS ? OP_AKEYS
12248 if (kid->op_private == OPpCONST_BARE
12249 || !SvROK(cSVOPx_sv(kid))
12250 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12251 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
12256 qerror(Perl_mess(aTHX_
12257 "Experimental %s on scalar is now forbidden",
12258 PL_op_desc[orig_type]));
12260 bad_type_pv(1, "hash or array", o, kid);
12268 Perl_ck_length(pTHX_ OP *o)
12270 PERL_ARGS_ASSERT_CK_LENGTH;
12274 if (ckWARN(WARN_SYNTAX)) {
12275 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12279 const bool hash = kid->op_type == OP_PADHV
12280 || kid->op_type == OP_RV2HV;
12281 switch (kid->op_type) {
12286 name = S_op_varname(aTHX_ kid);
12292 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12293 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
12295 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12298 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12299 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12300 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12302 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12303 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12304 "length() used on @array (did you mean \"scalar(@array)\"?)");
12314 ---------------------------------------------------------
12316 Common vars in list assignment
12318 There now follows some enums and static functions for detecting
12319 common variables in list assignments. Here is a little essay I wrote
12320 for myself when trying to get my head around this. DAPM.
12324 First some random observations:
12326 * If a lexical var is an alias of something else, e.g.
12327 for my $x ($lex, $pkg, $a[0]) {...}
12328 then the act of aliasing will increase the reference count of the SV
12330 * If a package var is an alias of something else, it may still have a
12331 reference count of 1, depending on how the alias was created, e.g.
12332 in *a = *b, $a may have a refcount of 1 since the GP is shared
12333 with a single GvSV pointer to the SV. So If it's an alias of another
12334 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12335 a lexical var or an array element, then it will have RC > 1.
12337 * There are many ways to create a package alias; ultimately, XS code
12338 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12339 run-time tracing mechanisms are unlikely to be able to catch all cases.
12341 * When the LHS is all my declarations, the same vars can't appear directly
12342 on the RHS, but they can indirectly via closures, aliasing and lvalue
12343 subs. But those techniques all involve an increase in the lexical
12344 scalar's ref count.
12346 * When the LHS is all lexical vars (but not necessarily my declarations),
12347 it is possible for the same lexicals to appear directly on the RHS, and
12348 without an increased ref count, since the stack isn't refcounted.
12349 This case can be detected at compile time by scanning for common lex
12350 vars with PL_generation.
12352 * lvalue subs defeat common var detection, but they do at least
12353 return vars with a temporary ref count increment. Also, you can't
12354 tell at compile time whether a sub call is lvalue.
12359 A: There are a few circumstances where there definitely can't be any
12362 LHS empty: () = (...);
12363 RHS empty: (....) = ();
12364 RHS contains only constants or other 'can't possibly be shared'
12365 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12366 i.e. they only contain ops not marked as dangerous, whose children
12367 are also not dangerous;
12369 LHS contains a single scalar element: e.g. ($x) = (....); because
12370 after $x has been modified, it won't be used again on the RHS;
12371 RHS contains a single element with no aggregate on LHS: e.g.
12372 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12373 won't be used again.
12375 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12378 my ($a, $b, @c) = ...;
12380 Due to closure and goto tricks, these vars may already have content.
12381 For the same reason, an element on the RHS may be a lexical or package
12382 alias of one of the vars on the left, or share common elements, for
12385 my ($x,$y) = f(); # $x and $y on both sides
12386 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12391 my @a = @$ra; # elements of @a on both sides
12392 sub f { @a = 1..4; \@a }
12395 First, just consider scalar vars on LHS:
12397 RHS is safe only if (A), or in addition,
12398 * contains only lexical *scalar* vars, where neither side's
12399 lexicals have been flagged as aliases
12401 If RHS is not safe, then it's always legal to check LHS vars for
12402 RC==1, since the only RHS aliases will always be associated
12405 Note that in particular, RHS is not safe if:
12407 * it contains package scalar vars; e.g.:
12410 my ($x, $y) = (2, $x_alias);
12411 sub f { $x = 1; *x_alias = \$x; }
12413 * It contains other general elements, such as flattened or
12414 * spliced or single array or hash elements, e.g.
12417 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12421 use feature 'refaliasing';
12422 \($a[0], $a[1]) = \($y,$x);
12425 It doesn't matter if the array/hash is lexical or package.
12427 * it contains a function call that happens to be an lvalue
12428 sub which returns one or more of the above, e.g.
12439 (so a sub call on the RHS should be treated the same
12440 as having a package var on the RHS).
12442 * any other "dangerous" thing, such an op or built-in that
12443 returns one of the above, e.g. pp_preinc
12446 If RHS is not safe, what we can do however is at compile time flag
12447 that the LHS are all my declarations, and at run time check whether
12448 all the LHS have RC == 1, and if so skip the full scan.
12450 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12452 Here the issue is whether there can be elements of @a on the RHS
12453 which will get prematurely freed when @a is cleared prior to
12454 assignment. This is only a problem if the aliasing mechanism
12455 is one which doesn't increase the refcount - only if RC == 1
12456 will the RHS element be prematurely freed.
12458 Because the array/hash is being INTROed, it or its elements
12459 can't directly appear on the RHS:
12461 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12463 but can indirectly, e.g.:
12467 sub f { @a = 1..3; \@a }
12469 So if the RHS isn't safe as defined by (A), we must always
12470 mortalise and bump the ref count of any remaining RHS elements
12471 when assigning to a non-empty LHS aggregate.
12473 Lexical scalars on the RHS aren't safe if they've been involved in
12476 use feature 'refaliasing';
12479 \(my $lex) = \$pkg;
12480 my @a = ($lex,3); # equivalent to ($a[0],3)
12487 Similarly with lexical arrays and hashes on the RHS:
12501 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12502 my $a; ($a, my $b) = (....);
12504 The difference between (B) and (C) is that it is now physically
12505 possible for the LHS vars to appear on the RHS too, where they
12506 are not reference counted; but in this case, the compile-time
12507 PL_generation sweep will detect such common vars.
12509 So the rules for (C) differ from (B) in that if common vars are
12510 detected, the runtime "test RC==1" optimisation can no longer be used,
12511 and a full mark and sweep is required
12513 D: As (C), but in addition the LHS may contain package vars.
12515 Since package vars can be aliased without a corresponding refcount
12516 increase, all bets are off. It's only safe if (A). E.g.
12518 my ($x, $y) = (1,2);
12520 for $x_alias ($x) {
12521 ($x_alias, $y) = (3, $x); # whoops
12524 Ditto for LHS aggregate package vars.
12526 E: Any other dangerous ops on LHS, e.g.
12527 (f(), $a[0], @$r) = (...);
12529 this is similar to (E) in that all bets are off. In addition, it's
12530 impossible to determine at compile time whether the LHS
12531 contains a scalar or an aggregate, e.g.
12533 sub f : lvalue { @a }
12536 * ---------------------------------------------------------
12540 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12541 * that at least one of the things flagged was seen.
12545 AAS_MY_SCALAR = 0x001, /* my $scalar */
12546 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12547 AAS_LEX_SCALAR = 0x004, /* $lexical */
12548 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12549 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12550 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12551 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12552 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12553 that's flagged OA_DANGEROUS */
12554 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12555 not in any of the categories above */
12556 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12561 /* helper function for S_aassign_scan().
12562 * check a PAD-related op for commonality and/or set its generation number.
12563 * Returns a boolean indicating whether its shared */
12566 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12568 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12569 /* lexical used in aliasing */
12573 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12575 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12582 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12583 It scans the left or right hand subtree of the aassign op, and returns a
12584 set of flags indicating what sorts of things it found there.
12585 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12586 set PL_generation on lexical vars; if the latter, we see if
12587 PL_generation matches.
12588 'top' indicates whether we're recursing or at the top level.
12589 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12590 This fn will increment it by the number seen. It's not intended to
12591 be an accurate count (especially as many ops can push a variable
12592 number of SVs onto the stack); rather it's used as to test whether there
12593 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12597 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12600 bool kid_top = FALSE;
12602 /* first, look for a solitary @_ on the RHS */
12605 && (o->op_flags & OPf_KIDS)
12606 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12608 OP *kid = cUNOPo->op_first;
12609 if ( ( kid->op_type == OP_PUSHMARK
12610 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12611 && ((kid = OpSIBLING(kid)))
12612 && !OpHAS_SIBLING(kid)
12613 && kid->op_type == OP_RV2AV
12614 && !(kid->op_flags & OPf_REF)
12615 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12616 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12617 && ((kid = cUNOPx(kid)->op_first))
12618 && kid->op_type == OP_GV
12619 && cGVOPx_gv(kid) == PL_defgv
12621 flags |= AAS_DEFAV;
12624 switch (o->op_type) {
12627 return AAS_PKG_SCALAR;
12632 /* if !top, could be e.g. @a[0,1] */
12633 if (top && (o->op_flags & OPf_REF))
12634 return (o->op_private & OPpLVAL_INTRO)
12635 ? AAS_MY_AGG : AAS_LEX_AGG;
12636 return AAS_DANGEROUS;
12640 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12641 ? AAS_LEX_SCALAR_COMM : 0;
12643 return (o->op_private & OPpLVAL_INTRO)
12644 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12650 if (cUNOPx(o)->op_first->op_type != OP_GV)
12651 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12653 /* if !top, could be e.g. @a[0,1] */
12654 if (top && (o->op_flags & OPf_REF))
12655 return AAS_PKG_AGG;
12656 return AAS_DANGEROUS;
12660 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12662 return AAS_DANGEROUS; /* ${expr} */
12664 return AAS_PKG_SCALAR; /* $pkg */
12667 if (o->op_private & OPpSPLIT_ASSIGN) {
12668 /* the assign in @a = split() has been optimised away
12669 * and the @a attached directly to the split op
12670 * Treat the array as appearing on the RHS, i.e.
12671 * ... = (@a = split)
12676 if (o->op_flags & OPf_STACKED)
12677 /* @{expr} = split() - the array expression is tacked
12678 * on as an extra child to split - process kid */
12679 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
12682 /* ... else array is directly attached to split op */
12684 if (PL_op->op_private & OPpSPLIT_LEX)
12685 return (o->op_private & OPpLVAL_INTRO)
12686 ? AAS_MY_AGG : AAS_LEX_AGG;
12688 return AAS_PKG_AGG;
12691 /* other args of split can't be returned */
12692 return AAS_SAFE_SCALAR;
12695 /* undef counts as a scalar on the RHS:
12696 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12697 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12701 flags = AAS_SAFE_SCALAR;
12706 /* these are all no-ops; they don't push a potentially common SV
12707 * onto the stack, so they are neither AAS_DANGEROUS nor
12708 * AAS_SAFE_SCALAR */
12711 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12716 /* these do nothing but may have children; but their children
12717 * should also be treated as top-level */
12722 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12724 flags = AAS_DANGEROUS;
12728 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12729 && (o->op_private & OPpTARGET_MY))
12732 return S_aassign_padcheck(aTHX_ o, rhs)
12733 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12736 /* if its an unrecognised, non-dangerous op, assume that it
12737 * it the cause of at least one safe scalar */
12739 flags = AAS_SAFE_SCALAR;
12743 /* XXX this assumes that all other ops are "transparent" - i.e. that
12744 * they can return some of their children. While this true for e.g.
12745 * sort and grep, it's not true for e.g. map. We really need a
12746 * 'transparent' flag added to regen/opcodes
12748 if (o->op_flags & OPf_KIDS) {
12750 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12751 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12757 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12758 and modify the optree to make them work inplace */
12761 S_inplace_aassign(pTHX_ OP *o) {
12763 OP *modop, *modop_pushmark;
12765 OP *oleft, *oleft_pushmark;
12767 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12769 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12771 assert(cUNOPo->op_first->op_type == OP_NULL);
12772 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12773 assert(modop_pushmark->op_type == OP_PUSHMARK);
12774 modop = OpSIBLING(modop_pushmark);
12776 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12779 /* no other operation except sort/reverse */
12780 if (OpHAS_SIBLING(modop))
12783 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12784 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12786 if (modop->op_flags & OPf_STACKED) {
12787 /* skip sort subroutine/block */
12788 assert(oright->op_type == OP_NULL);
12789 oright = OpSIBLING(oright);
12792 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12793 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12794 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12795 oleft = OpSIBLING(oleft_pushmark);
12797 /* Check the lhs is an array */
12799 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12800 || OpHAS_SIBLING(oleft)
12801 || (oleft->op_private & OPpLVAL_INTRO)
12805 /* Only one thing on the rhs */
12806 if (OpHAS_SIBLING(oright))
12809 /* check the array is the same on both sides */
12810 if (oleft->op_type == OP_RV2AV) {
12811 if (oright->op_type != OP_RV2AV
12812 || !cUNOPx(oright)->op_first
12813 || cUNOPx(oright)->op_first->op_type != OP_GV
12814 || cUNOPx(oleft )->op_first->op_type != OP_GV
12815 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12816 cGVOPx_gv(cUNOPx(oright)->op_first)
12820 else if (oright->op_type != OP_PADAV
12821 || oright->op_targ != oleft->op_targ
12825 /* This actually is an inplace assignment */
12827 modop->op_private |= OPpSORT_INPLACE;
12829 /* transfer MODishness etc from LHS arg to RHS arg */
12830 oright->op_flags = oleft->op_flags;
12832 /* remove the aassign op and the lhs */
12834 op_null(oleft_pushmark);
12835 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12836 op_null(cUNOPx(oleft)->op_first);
12842 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12843 * that potentially represent a series of one or more aggregate derefs
12844 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12845 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12846 * additional ops left in too).
12848 * The caller will have already verified that the first few ops in the
12849 * chain following 'start' indicate a multideref candidate, and will have
12850 * set 'orig_o' to the point further on in the chain where the first index
12851 * expression (if any) begins. 'orig_action' specifies what type of
12852 * beginning has already been determined by the ops between start..orig_o
12853 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12855 * 'hints' contains any hints flags that need adding (currently just
12856 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12860 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12864 UNOP_AUX_item *arg_buf = NULL;
12865 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12866 int index_skip = -1; /* don't output index arg on this action */
12868 /* similar to regex compiling, do two passes; the first pass
12869 * determines whether the op chain is convertible and calculates the
12870 * buffer size; the second pass populates the buffer and makes any
12871 * changes necessary to ops (such as moving consts to the pad on
12872 * threaded builds).
12874 * NB: for things like Coverity, note that both passes take the same
12875 * path through the logic tree (except for 'if (pass)' bits), since
12876 * both passes are following the same op_next chain; and in
12877 * particular, if it would return early on the second pass, it would
12878 * already have returned early on the first pass.
12880 for (pass = 0; pass < 2; pass++) {
12882 UV action = orig_action;
12883 OP *first_elem_op = NULL; /* first seen aelem/helem */
12884 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12885 int action_count = 0; /* number of actions seen so far */
12886 int action_ix = 0; /* action_count % (actions per IV) */
12887 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12888 bool is_last = FALSE; /* no more derefs to follow */
12889 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12890 UNOP_AUX_item *arg = arg_buf;
12891 UNOP_AUX_item *action_ptr = arg_buf;
12894 action_ptr->uv = 0;
12898 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12899 case MDEREF_HV_gvhv_helem:
12900 next_is_hash = TRUE;
12902 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12903 case MDEREF_AV_gvav_aelem:
12905 #ifdef USE_ITHREADS
12906 arg->pad_offset = cPADOPx(start)->op_padix;
12907 /* stop it being swiped when nulled */
12908 cPADOPx(start)->op_padix = 0;
12910 arg->sv = cSVOPx(start)->op_sv;
12911 cSVOPx(start)->op_sv = NULL;
12917 case MDEREF_HV_padhv_helem:
12918 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12919 next_is_hash = TRUE;
12921 case MDEREF_AV_padav_aelem:
12922 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12924 arg->pad_offset = start->op_targ;
12925 /* we skip setting op_targ = 0 for now, since the intact
12926 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12927 reset_start_targ = TRUE;
12932 case MDEREF_HV_pop_rv2hv_helem:
12933 next_is_hash = TRUE;
12935 case MDEREF_AV_pop_rv2av_aelem:
12939 NOT_REACHED; /* NOTREACHED */
12944 /* look for another (rv2av/hv; get index;
12945 * aelem/helem/exists/delele) sequence */
12950 UV index_type = MDEREF_INDEX_none;
12952 if (action_count) {
12953 /* if this is not the first lookup, consume the rv2av/hv */
12955 /* for N levels of aggregate lookup, we normally expect
12956 * that the first N-1 [ah]elem ops will be flagged as
12957 * /DEREF (so they autovivifiy if necessary), and the last
12958 * lookup op not to be.
12959 * For other things (like @{$h{k1}{k2}}) extra scope or
12960 * leave ops can appear, so abandon the effort in that
12962 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12965 /* rv2av or rv2hv sKR/1 */
12967 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12968 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12969 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12972 /* at this point, we wouldn't expect any of these
12973 * possible private flags:
12974 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12975 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12977 ASSUME(!(o->op_private &
12978 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12980 hints = (o->op_private & OPpHINT_STRICT_REFS);
12982 /* make sure the type of the previous /DEREF matches the
12983 * type of the next lookup */
12984 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12987 action = next_is_hash
12988 ? MDEREF_HV_vivify_rv2hv_helem
12989 : MDEREF_AV_vivify_rv2av_aelem;
12993 /* if this is the second pass, and we're at the depth where
12994 * previously we encountered a non-simple index expression,
12995 * stop processing the index at this point */
12996 if (action_count != index_skip) {
12998 /* look for one or more simple ops that return an array
12999 * index or hash key */
13001 switch (o->op_type) {
13003 /* it may be a lexical var index */
13004 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
13005 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13006 ASSUME(!(o->op_private &
13007 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13009 if ( OP_GIMME(o,0) == G_SCALAR
13010 && !(o->op_flags & (OPf_REF|OPf_MOD))
13011 && o->op_private == 0)
13014 arg->pad_offset = o->op_targ;
13016 index_type = MDEREF_INDEX_padsv;
13022 if (next_is_hash) {
13023 /* it's a constant hash index */
13024 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
13025 /* "use constant foo => FOO; $h{+foo}" for
13026 * some weird FOO, can leave you with constants
13027 * that aren't simple strings. It's not worth
13028 * the extra hassle for those edge cases */
13033 OP * helem_op = o->op_next;
13035 ASSUME( helem_op->op_type == OP_HELEM
13036 || helem_op->op_type == OP_NULL);
13037 if (helem_op->op_type == OP_HELEM) {
13038 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
13039 if ( helem_op->op_private & OPpLVAL_INTRO
13040 || rop->op_type != OP_RV2HV
13044 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
13046 #ifdef USE_ITHREADS
13047 /* Relocate sv to the pad for thread safety */
13048 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
13049 arg->pad_offset = o->op_targ;
13052 arg->sv = cSVOPx_sv(o);
13057 /* it's a constant array index */
13059 SV *ix_sv = cSVOPo->op_sv;
13064 if ( action_count == 0
13067 && ( action == MDEREF_AV_padav_aelem
13068 || action == MDEREF_AV_gvav_aelem)
13070 maybe_aelemfast = TRUE;
13074 SvREFCNT_dec_NN(cSVOPo->op_sv);
13078 /* we've taken ownership of the SV */
13079 cSVOPo->op_sv = NULL;
13081 index_type = MDEREF_INDEX_const;
13086 /* it may be a package var index */
13088 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
13089 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
13090 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
13091 || o->op_private != 0
13096 if (kid->op_type != OP_RV2SV)
13099 ASSUME(!(kid->op_flags &
13100 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
13101 |OPf_SPECIAL|OPf_PARENS)));
13102 ASSUME(!(kid->op_private &
13104 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
13105 |OPpDEREF|OPpLVAL_INTRO)));
13106 if( (kid->op_flags &~ OPf_PARENS)
13107 != (OPf_WANT_SCALAR|OPf_KIDS)
13108 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
13113 #ifdef USE_ITHREADS
13114 arg->pad_offset = cPADOPx(o)->op_padix;
13115 /* stop it being swiped when nulled */
13116 cPADOPx(o)->op_padix = 0;
13118 arg->sv = cSVOPx(o)->op_sv;
13119 cSVOPo->op_sv = NULL;
13123 index_type = MDEREF_INDEX_gvsv;
13128 } /* action_count != index_skip */
13130 action |= index_type;
13133 /* at this point we have either:
13134 * * detected what looks like a simple index expression,
13135 * and expect the next op to be an [ah]elem, or
13136 * an nulled [ah]elem followed by a delete or exists;
13137 * * found a more complex expression, so something other
13138 * than the above follows.
13141 /* possibly an optimised away [ah]elem (where op_next is
13142 * exists or delete) */
13143 if (o->op_type == OP_NULL)
13146 /* at this point we're looking for an OP_AELEM, OP_HELEM,
13147 * OP_EXISTS or OP_DELETE */
13149 /* if something like arybase (a.k.a $[ ) is in scope,
13150 * abandon optimisation attempt */
13151 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13152 && PL_check[o->op_type] != Perl_ck_null)
13154 /* similarly for customised exists and delete */
13155 if ( (o->op_type == OP_EXISTS)
13156 && PL_check[o->op_type] != Perl_ck_exists)
13158 if ( (o->op_type == OP_DELETE)
13159 && PL_check[o->op_type] != Perl_ck_delete)
13162 if ( o->op_type != OP_AELEM
13163 || (o->op_private &
13164 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
13166 maybe_aelemfast = FALSE;
13168 /* look for aelem/helem/exists/delete. If it's not the last elem
13169 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
13170 * flags; if it's the last, then it mustn't have
13171 * OPpDEREF_AV/HV, but may have lots of other flags, like
13172 * OPpLVAL_INTRO etc
13175 if ( index_type == MDEREF_INDEX_none
13176 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
13177 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
13181 /* we have aelem/helem/exists/delete with valid simple index */
13183 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
13184 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
13185 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
13187 /* This doesn't make much sense but is legal:
13188 * @{ local $x[0][0] } = 1
13189 * Since scope exit will undo the autovivification,
13190 * don't bother in the first place. The OP_LEAVE
13191 * assertion is in case there are other cases of both
13192 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
13193 * exit that would undo the local - in which case this
13194 * block of code would need rethinking.
13196 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
13198 OP *n = o->op_next;
13199 while (n && ( n->op_type == OP_NULL
13200 || n->op_type == OP_LIST))
13202 assert(n && n->op_type == OP_LEAVE);
13204 o->op_private &= ~OPpDEREF;
13209 ASSUME(!(o->op_flags &
13210 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
13211 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
13213 ok = (o->op_flags &~ OPf_PARENS)
13214 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
13215 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
13217 else if (o->op_type == OP_EXISTS) {
13218 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13219 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13220 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
13221 ok = !(o->op_private & ~OPpARG1_MASK);
13223 else if (o->op_type == OP_DELETE) {
13224 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13225 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
13226 ASSUME(!(o->op_private &
13227 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
13228 /* don't handle slices or 'local delete'; the latter
13229 * is fairly rare, and has a complex runtime */
13230 ok = !(o->op_private & ~OPpARG1_MASK);
13231 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
13232 /* skip handling run-tome error */
13233 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
13236 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
13237 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
13238 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
13239 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
13240 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
13241 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
13246 if (!first_elem_op)
13250 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
13255 action |= MDEREF_FLAG_last;
13259 /* at this point we have something that started
13260 * promisingly enough (with rv2av or whatever), but failed
13261 * to find a simple index followed by an
13262 * aelem/helem/exists/delete. If this is the first action,
13263 * give up; but if we've already seen at least one
13264 * aelem/helem, then keep them and add a new action with
13265 * MDEREF_INDEX_none, which causes it to do the vivify
13266 * from the end of the previous lookup, and do the deref,
13267 * but stop at that point. So $a[0][expr] will do one
13268 * av_fetch, vivify and deref, then continue executing at
13273 index_skip = action_count;
13274 action |= MDEREF_FLAG_last;
13275 if (index_type != MDEREF_INDEX_none)
13280 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
13283 /* if there's no space for the next action, create a new slot
13284 * for it *before* we start adding args for that action */
13285 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
13292 } /* while !is_last */
13300 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
13301 if (index_skip == -1) {
13302 mderef->op_flags = o->op_flags
13303 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
13304 if (o->op_type == OP_EXISTS)
13305 mderef->op_private = OPpMULTIDEREF_EXISTS;
13306 else if (o->op_type == OP_DELETE)
13307 mderef->op_private = OPpMULTIDEREF_DELETE;
13309 mderef->op_private = o->op_private
13310 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
13312 /* accumulate strictness from every level (although I don't think
13313 * they can actually vary) */
13314 mderef->op_private |= hints;
13316 /* integrate the new multideref op into the optree and the
13319 * In general an op like aelem or helem has two child
13320 * sub-trees: the aggregate expression (a_expr) and the
13321 * index expression (i_expr):
13327 * The a_expr returns an AV or HV, while the i-expr returns an
13328 * index. In general a multideref replaces most or all of a
13329 * multi-level tree, e.g.
13345 * With multideref, all the i_exprs will be simple vars or
13346 * constants, except that i_expr1 may be arbitrary in the case
13347 * of MDEREF_INDEX_none.
13349 * The bottom-most a_expr will be either:
13350 * 1) a simple var (so padXv or gv+rv2Xv);
13351 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
13352 * so a simple var with an extra rv2Xv;
13353 * 3) or an arbitrary expression.
13355 * 'start', the first op in the execution chain, will point to
13356 * 1),2): the padXv or gv op;
13357 * 3): the rv2Xv which forms the last op in the a_expr
13358 * execution chain, and the top-most op in the a_expr
13361 * For all cases, the 'start' node is no longer required,
13362 * but we can't free it since one or more external nodes
13363 * may point to it. E.g. consider
13364 * $h{foo} = $a ? $b : $c
13365 * Here, both the op_next and op_other branches of the
13366 * cond_expr point to the gv[*h] of the hash expression, so
13367 * we can't free the 'start' op.
13369 * For expr->[...], we need to save the subtree containing the
13370 * expression; for the other cases, we just need to save the
13372 * So in all cases, we null the start op and keep it around by
13373 * making it the child of the multideref op; for the expr->
13374 * case, the expr will be a subtree of the start node.
13376 * So in the simple 1,2 case the optree above changes to
13382 * ex-gv (or ex-padxv)
13384 * with the op_next chain being
13386 * -> ex-gv -> multideref -> op-following-ex-exists ->
13388 * In the 3 case, we have
13401 * -> rest-of-a_expr subtree ->
13402 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13405 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13406 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13407 * multideref attached as the child, e.g.
13413 * ex-rv2av - i_expr1
13421 /* if we free this op, don't free the pad entry */
13422 if (reset_start_targ)
13423 start->op_targ = 0;
13426 /* Cut the bit we need to save out of the tree and attach to
13427 * the multideref op, then free the rest of the tree */
13429 /* find parent of node to be detached (for use by splice) */
13431 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13432 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13434 /* there is an arbitrary expression preceding us, e.g.
13435 * expr->[..]? so we need to save the 'expr' subtree */
13436 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13437 p = cUNOPx(p)->op_first;
13438 ASSUME( start->op_type == OP_RV2AV
13439 || start->op_type == OP_RV2HV);
13442 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13443 * above for exists/delete. */
13444 while ( (p->op_flags & OPf_KIDS)
13445 && cUNOPx(p)->op_first != start
13447 p = cUNOPx(p)->op_first;
13449 ASSUME(cUNOPx(p)->op_first == start);
13451 /* detach from main tree, and re-attach under the multideref */
13452 op_sibling_splice(mderef, NULL, 0,
13453 op_sibling_splice(p, NULL, 1, NULL));
13456 start->op_next = mderef;
13458 mderef->op_next = index_skip == -1 ? o->op_next : o;
13460 /* excise and free the original tree, and replace with
13461 * the multideref op */
13462 p = op_sibling_splice(top_op, NULL, -1, mderef);
13471 Size_t size = arg - arg_buf;
13473 if (maybe_aelemfast && action_count == 1)
13476 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13477 sizeof(UNOP_AUX_item) * (size + 1));
13478 /* for dumping etc: store the length in a hidden first slot;
13479 * we set the op_aux pointer to the second slot */
13480 arg_buf->uv = size;
13483 } /* for (pass = ...) */
13486 /* See if the ops following o are such that o will always be executed in
13487 * boolean context: that is, the SV which o pushes onto the stack will
13488 * only ever be used by later ops with SvTRUE(sv) or similar.
13489 * If so, set a suitable private flag on o. Normally this will be
13490 * bool_flag; but if it's only possible to determine booleaness at run
13491 * time (e.g. sub f { ....; (%h || $y) }), then set maybe_flag instead.
13495 S_check_for_bool_cxt(pTHX_ OP*o, U8 bool_flag, U8 maybe_flag)
13499 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
13504 switch (lop->op_type) {
13509 /* these two consume the stack argument in the scalar case,
13510 * and treat it as a boolean in the non linenumber case */
13513 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
13514 || (lop->op_private & OPpFLIP_LINENUM))
13520 /* these never leave the original value on the stack */
13525 o->op_private |= bool_flag;
13529 /* OR DOR and AND evaluate their arg as a boolean, but then may
13530 * leave the original scalar value on the stack when following the
13531 * op_next route. If not in void context, we need to ensure
13532 * that whatever follows consumes the arg only in boolean context
13538 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
13539 o->op_private |= bool_flag;
13542 else if (!(lop->op_flags & OPf_WANT)) {
13543 /* unknown context - decide at runtime */
13544 o->op_private |= maybe_flag;
13555 lop = lop->op_next;
13561 /* mechanism for deferring recursion in rpeep() */
13563 #define MAX_DEFERRED 4
13567 if (defer_ix == (MAX_DEFERRED-1)) { \
13568 OP **defer = defer_queue[defer_base]; \
13569 CALL_RPEEP(*defer); \
13570 S_prune_chain_head(defer); \
13571 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13574 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13577 #define IS_AND_OP(o) (o->op_type == OP_AND)
13578 #define IS_OR_OP(o) (o->op_type == OP_OR)
13581 /* A peephole optimizer. We visit the ops in the order they're to execute.
13582 * See the comments at the top of this file for more details about when
13583 * peep() is called */
13586 Perl_rpeep(pTHX_ OP *o)
13590 OP* oldoldop = NULL;
13591 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13592 int defer_base = 0;
13595 if (!o || o->op_opt)
13598 assert(o->op_type != OP_FREED);
13602 SAVEVPTR(PL_curcop);
13603 for (;; o = o->op_next) {
13604 if (o && o->op_opt)
13607 while (defer_ix >= 0) {
13609 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13610 CALL_RPEEP(*defer);
13611 S_prune_chain_head(defer);
13618 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13619 assert(!oldoldop || oldoldop->op_next == oldop);
13620 assert(!oldop || oldop->op_next == o);
13622 /* By default, this op has now been optimised. A couple of cases below
13623 clear this again. */
13627 /* look for a series of 1 or more aggregate derefs, e.g.
13628 * $a[1]{foo}[$i]{$k}
13629 * and replace with a single OP_MULTIDEREF op.
13630 * Each index must be either a const, or a simple variable,
13632 * First, look for likely combinations of starting ops,
13633 * corresponding to (global and lexical variants of)
13635 * $r->[...] $r->{...}
13636 * (preceding expression)->[...]
13637 * (preceding expression)->{...}
13638 * and if so, call maybe_multideref() to do a full inspection
13639 * of the op chain and if appropriate, replace with an
13647 switch (o2->op_type) {
13649 /* $pkg[..] : gv[*pkg]
13650 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13652 /* Fail if there are new op flag combinations that we're
13653 * not aware of, rather than:
13654 * * silently failing to optimise, or
13655 * * silently optimising the flag away.
13656 * If this ASSUME starts failing, examine what new flag
13657 * has been added to the op, and decide whether the
13658 * optimisation should still occur with that flag, then
13659 * update the code accordingly. This applies to all the
13660 * other ASSUMEs in the block of code too.
13662 ASSUME(!(o2->op_flags &
13663 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13664 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13668 if (o2->op_type == OP_RV2AV) {
13669 action = MDEREF_AV_gvav_aelem;
13673 if (o2->op_type == OP_RV2HV) {
13674 action = MDEREF_HV_gvhv_helem;
13678 if (o2->op_type != OP_RV2SV)
13681 /* at this point we've seen gv,rv2sv, so the only valid
13682 * construct left is $pkg->[] or $pkg->{} */
13684 ASSUME(!(o2->op_flags & OPf_STACKED));
13685 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13686 != (OPf_WANT_SCALAR|OPf_MOD))
13689 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13690 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13691 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13693 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13694 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13698 if (o2->op_type == OP_RV2AV) {
13699 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13702 if (o2->op_type == OP_RV2HV) {
13703 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13709 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13711 ASSUME(!(o2->op_flags &
13712 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13713 if ((o2->op_flags &
13714 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13715 != (OPf_WANT_SCALAR|OPf_MOD))
13718 ASSUME(!(o2->op_private &
13719 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13720 /* skip if state or intro, or not a deref */
13721 if ( o2->op_private != OPpDEREF_AV
13722 && o2->op_private != OPpDEREF_HV)
13726 if (o2->op_type == OP_RV2AV) {
13727 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13730 if (o2->op_type == OP_RV2HV) {
13731 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13738 /* $lex[..]: padav[@lex:1,2] sR *
13739 * or $lex{..}: padhv[%lex:1,2] sR */
13740 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13741 OPf_REF|OPf_SPECIAL)));
13742 if ((o2->op_flags &
13743 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13744 != (OPf_WANT_SCALAR|OPf_REF))
13746 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13748 /* OPf_PARENS isn't currently used in this case;
13749 * if that changes, let us know! */
13750 ASSUME(!(o2->op_flags & OPf_PARENS));
13752 /* at this point, we wouldn't expect any of the remaining
13753 * possible private flags:
13754 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13755 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13757 * OPpSLICEWARNING shouldn't affect runtime
13759 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13761 action = o2->op_type == OP_PADAV
13762 ? MDEREF_AV_padav_aelem
13763 : MDEREF_HV_padhv_helem;
13765 S_maybe_multideref(aTHX_ o, o2, action, 0);
13771 action = o2->op_type == OP_RV2AV
13772 ? MDEREF_AV_pop_rv2av_aelem
13773 : MDEREF_HV_pop_rv2hv_helem;
13776 /* (expr)->[...]: rv2av sKR/1;
13777 * (expr)->{...}: rv2hv sKR/1; */
13779 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13781 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13782 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13783 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13786 /* at this point, we wouldn't expect any of these
13787 * possible private flags:
13788 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13789 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13791 ASSUME(!(o2->op_private &
13792 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13794 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13798 S_maybe_multideref(aTHX_ o, o2, action, hints);
13807 switch (o->op_type) {
13809 PL_curcop = ((COP*)o); /* for warnings */
13812 PL_curcop = ((COP*)o); /* for warnings */
13814 /* Optimise a "return ..." at the end of a sub to just be "...".
13815 * This saves 2 ops. Before:
13816 * 1 <;> nextstate(main 1 -e:1) v ->2
13817 * 4 <@> return K ->5
13818 * 2 <0> pushmark s ->3
13819 * - <1> ex-rv2sv sK/1 ->4
13820 * 3 <#> gvsv[*cat] s ->4
13823 * - <@> return K ->-
13824 * - <0> pushmark s ->2
13825 * - <1> ex-rv2sv sK/1 ->-
13826 * 2 <$> gvsv(*cat) s ->3
13829 OP *next = o->op_next;
13830 OP *sibling = OpSIBLING(o);
13831 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13832 && OP_TYPE_IS(sibling, OP_RETURN)
13833 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13834 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13835 ||OP_TYPE_IS(sibling->op_next->op_next,
13837 && cUNOPx(sibling)->op_first == next
13838 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13841 /* Look through the PUSHMARK's siblings for one that
13842 * points to the RETURN */
13843 OP *top = OpSIBLING(next);
13844 while (top && top->op_next) {
13845 if (top->op_next == sibling) {
13846 top->op_next = sibling->op_next;
13847 o->op_next = next->op_next;
13850 top = OpSIBLING(top);
13855 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13857 * This latter form is then suitable for conversion into padrange
13858 * later on. Convert:
13860 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13864 * nextstate1 -> listop -> nextstate3
13866 * pushmark -> padop1 -> padop2
13868 if (o->op_next && (
13869 o->op_next->op_type == OP_PADSV
13870 || o->op_next->op_type == OP_PADAV
13871 || o->op_next->op_type == OP_PADHV
13873 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13874 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13875 && o->op_next->op_next->op_next && (
13876 o->op_next->op_next->op_next->op_type == OP_PADSV
13877 || o->op_next->op_next->op_next->op_type == OP_PADAV
13878 || o->op_next->op_next->op_next->op_type == OP_PADHV
13880 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13881 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13882 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13883 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13885 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13888 ns2 = pad1->op_next;
13889 pad2 = ns2->op_next;
13890 ns3 = pad2->op_next;
13892 /* we assume here that the op_next chain is the same as
13893 * the op_sibling chain */
13894 assert(OpSIBLING(o) == pad1);
13895 assert(OpSIBLING(pad1) == ns2);
13896 assert(OpSIBLING(ns2) == pad2);
13897 assert(OpSIBLING(pad2) == ns3);
13899 /* excise and delete ns2 */
13900 op_sibling_splice(NULL, pad1, 1, NULL);
13903 /* excise pad1 and pad2 */
13904 op_sibling_splice(NULL, o, 2, NULL);
13906 /* create new listop, with children consisting of:
13907 * a new pushmark, pad1, pad2. */
13908 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13909 newop->op_flags |= OPf_PARENS;
13910 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13912 /* insert newop between o and ns3 */
13913 op_sibling_splice(NULL, o, 0, newop);
13915 /*fixup op_next chain */
13916 newpm = cUNOPx(newop)->op_first; /* pushmark */
13917 o ->op_next = newpm;
13918 newpm->op_next = pad1;
13919 pad1 ->op_next = pad2;
13920 pad2 ->op_next = newop; /* listop */
13921 newop->op_next = ns3;
13923 /* Ensure pushmark has this flag if padops do */
13924 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13925 newpm->op_flags |= OPf_MOD;
13931 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13932 to carry two labels. For now, take the easier option, and skip
13933 this optimisation if the first NEXTSTATE has a label. */
13934 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13935 OP *nextop = o->op_next;
13936 while (nextop && nextop->op_type == OP_NULL)
13937 nextop = nextop->op_next;
13939 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13942 oldop->op_next = nextop;
13944 /* Skip (old)oldop assignment since the current oldop's
13945 op_next already points to the next op. */
13952 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13953 if (o->op_next->op_private & OPpTARGET_MY) {
13954 if (o->op_flags & OPf_STACKED) /* chained concats */
13955 break; /* ignore_optimization */
13957 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13958 o->op_targ = o->op_next->op_targ;
13959 o->op_next->op_targ = 0;
13960 o->op_private |= OPpTARGET_MY;
13963 op_null(o->op_next);
13967 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13968 break; /* Scalar stub must produce undef. List stub is noop */
13972 if (o->op_targ == OP_NEXTSTATE
13973 || o->op_targ == OP_DBSTATE)
13975 PL_curcop = ((COP*)o);
13977 /* XXX: We avoid setting op_seq here to prevent later calls
13978 to rpeep() from mistakenly concluding that optimisation
13979 has already occurred. This doesn't fix the real problem,
13980 though (See 20010220.007 (#5874)). AMS 20010719 */
13981 /* op_seq functionality is now replaced by op_opt */
13989 oldop->op_next = o->op_next;
14003 convert repeat into a stub with no kids.
14005 if (o->op_next->op_type == OP_CONST
14006 || ( o->op_next->op_type == OP_PADSV
14007 && !(o->op_next->op_private & OPpLVAL_INTRO))
14008 || ( o->op_next->op_type == OP_GV
14009 && o->op_next->op_next->op_type == OP_RV2SV
14010 && !(o->op_next->op_next->op_private
14011 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
14013 const OP *kid = o->op_next->op_next;
14014 if (o->op_next->op_type == OP_GV)
14015 kid = kid->op_next;
14016 /* kid is now the ex-list. */
14017 if (kid->op_type == OP_NULL
14018 && (kid = kid->op_next)->op_type == OP_CONST
14019 /* kid is now the repeat count. */
14020 && kid->op_next->op_type == OP_REPEAT
14021 && kid->op_next->op_private & OPpREPEAT_DOLIST
14022 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
14023 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
14026 o = kid->op_next; /* repeat */
14027 oldop->op_next = o;
14028 op_free(cBINOPo->op_first);
14029 op_free(cBINOPo->op_last );
14030 o->op_flags &=~ OPf_KIDS;
14031 /* stub is a baseop; repeat is a binop */
14032 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
14033 OpTYPE_set(o, OP_STUB);
14039 /* Convert a series of PAD ops for my vars plus support into a
14040 * single padrange op. Basically
14042 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
14044 * becomes, depending on circumstances, one of
14046 * padrange ----------------------------------> (list) -> rest
14047 * padrange --------------------------------------------> rest
14049 * where all the pad indexes are sequential and of the same type
14051 * We convert the pushmark into a padrange op, then skip
14052 * any other pad ops, and possibly some trailing ops.
14053 * Note that we don't null() the skipped ops, to make it
14054 * easier for Deparse to undo this optimisation (and none of
14055 * the skipped ops are holding any resourses). It also makes
14056 * it easier for find_uninit_var(), as it can just ignore
14057 * padrange, and examine the original pad ops.
14061 OP *followop = NULL; /* the op that will follow the padrange op */
14064 PADOFFSET base = 0; /* init only to stop compiler whining */
14065 bool gvoid = 0; /* init only to stop compiler whining */
14066 bool defav = 0; /* seen (...) = @_ */
14067 bool reuse = 0; /* reuse an existing padrange op */
14069 /* look for a pushmark -> gv[_] -> rv2av */
14074 if ( p->op_type == OP_GV
14075 && cGVOPx_gv(p) == PL_defgv
14076 && (rv2av = p->op_next)
14077 && rv2av->op_type == OP_RV2AV
14078 && !(rv2av->op_flags & OPf_REF)
14079 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14080 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
14082 q = rv2av->op_next;
14083 if (q->op_type == OP_NULL)
14085 if (q->op_type == OP_PUSHMARK) {
14095 /* scan for PAD ops */
14097 for (p = p->op_next; p; p = p->op_next) {
14098 if (p->op_type == OP_NULL)
14101 if (( p->op_type != OP_PADSV
14102 && p->op_type != OP_PADAV
14103 && p->op_type != OP_PADHV
14105 /* any private flag other than INTRO? e.g. STATE */
14106 || (p->op_private & ~OPpLVAL_INTRO)
14110 /* let $a[N] potentially be optimised into AELEMFAST_LEX
14112 if ( p->op_type == OP_PADAV
14114 && p->op_next->op_type == OP_CONST
14115 && p->op_next->op_next
14116 && p->op_next->op_next->op_type == OP_AELEM
14120 /* for 1st padop, note what type it is and the range
14121 * start; for the others, check that it's the same type
14122 * and that the targs are contiguous */
14124 intro = (p->op_private & OPpLVAL_INTRO);
14126 gvoid = OP_GIMME(p,0) == G_VOID;
14129 if ((p->op_private & OPpLVAL_INTRO) != intro)
14131 /* Note that you'd normally expect targs to be
14132 * contiguous in my($a,$b,$c), but that's not the case
14133 * when external modules start doing things, e.g.
14134 * Function::Parameters */
14135 if (p->op_targ != base + count)
14137 assert(p->op_targ == base + count);
14138 /* Either all the padops or none of the padops should
14139 be in void context. Since we only do the optimisa-
14140 tion for av/hv when the aggregate itself is pushed
14141 on to the stack (one item), there is no need to dis-
14142 tinguish list from scalar context. */
14143 if (gvoid != (OP_GIMME(p,0) == G_VOID))
14147 /* for AV, HV, only when we're not flattening */
14148 if ( p->op_type != OP_PADSV
14150 && !(p->op_flags & OPf_REF)
14154 if (count >= OPpPADRANGE_COUNTMASK)
14157 /* there's a biggest base we can fit into a
14158 * SAVEt_CLEARPADRANGE in pp_padrange.
14159 * (The sizeof() stuff will be constant-folded, and is
14160 * intended to avoid getting "comparison is always false"
14161 * compiler warnings. See the comments above
14162 * MEM_WRAP_CHECK for more explanation on why we do this
14163 * in a weird way to avoid compiler warnings.)
14166 && (8*sizeof(base) >
14167 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
14169 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
14171 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
14175 /* Success! We've got another valid pad op to optimise away */
14177 followop = p->op_next;
14180 if (count < 1 || (count == 1 && !defav))
14183 /* pp_padrange in specifically compile-time void context
14184 * skips pushing a mark and lexicals; in all other contexts
14185 * (including unknown till runtime) it pushes a mark and the
14186 * lexicals. We must be very careful then, that the ops we
14187 * optimise away would have exactly the same effect as the
14189 * In particular in void context, we can only optimise to
14190 * a padrange if we see the complete sequence
14191 * pushmark, pad*v, ...., list
14192 * which has the net effect of leaving the markstack as it
14193 * was. Not pushing onto the stack (whereas padsv does touch
14194 * the stack) makes no difference in void context.
14198 if (followop->op_type == OP_LIST
14199 && OP_GIMME(followop,0) == G_VOID
14202 followop = followop->op_next; /* skip OP_LIST */
14204 /* consolidate two successive my(...);'s */
14207 && oldoldop->op_type == OP_PADRANGE
14208 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
14209 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
14210 && !(oldoldop->op_flags & OPf_SPECIAL)
14213 assert(oldoldop->op_next == oldop);
14214 assert( oldop->op_type == OP_NEXTSTATE
14215 || oldop->op_type == OP_DBSTATE);
14216 assert(oldop->op_next == o);
14219 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
14221 /* Do not assume pad offsets for $c and $d are con-
14226 if ( oldoldop->op_targ + old_count == base
14227 && old_count < OPpPADRANGE_COUNTMASK - count) {
14228 base = oldoldop->op_targ;
14229 count += old_count;
14234 /* if there's any immediately following singleton
14235 * my var's; then swallow them and the associated
14237 * my ($a,$b); my $c; my $d;
14239 * my ($a,$b,$c,$d);
14242 while ( ((p = followop->op_next))
14243 && ( p->op_type == OP_PADSV
14244 || p->op_type == OP_PADAV
14245 || p->op_type == OP_PADHV)
14246 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
14247 && (p->op_private & OPpLVAL_INTRO) == intro
14248 && !(p->op_private & ~OPpLVAL_INTRO)
14250 && ( p->op_next->op_type == OP_NEXTSTATE
14251 || p->op_next->op_type == OP_DBSTATE)
14252 && count < OPpPADRANGE_COUNTMASK
14253 && base + count == p->op_targ
14256 followop = p->op_next;
14264 assert(oldoldop->op_type == OP_PADRANGE);
14265 oldoldop->op_next = followop;
14266 oldoldop->op_private = (intro | count);
14272 /* Convert the pushmark into a padrange.
14273 * To make Deparse easier, we guarantee that a padrange was
14274 * *always* formerly a pushmark */
14275 assert(o->op_type == OP_PUSHMARK);
14276 o->op_next = followop;
14277 OpTYPE_set(o, OP_PADRANGE);
14279 /* bit 7: INTRO; bit 6..0: count */
14280 o->op_private = (intro | count);
14281 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
14282 | gvoid * OPf_WANT_VOID
14283 | (defav ? OPf_SPECIAL : 0));
14290 /* see if %h is used in boolean context */
14291 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
14292 S_check_for_bool_cxt(aTHX_ o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
14293 if (o->op_type != OP_PADHV)
14298 /* Skip over state($x) in void context. */
14299 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
14300 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
14302 oldop->op_next = o->op_next;
14303 goto redo_nextstate;
14305 if (o->op_type != OP_PADAV)
14309 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
14310 OP* const pop = (o->op_type == OP_PADAV) ?
14311 o->op_next : o->op_next->op_next;
14313 if (pop && pop->op_type == OP_CONST &&
14314 ((PL_op = pop->op_next)) &&
14315 pop->op_next->op_type == OP_AELEM &&
14316 !(pop->op_next->op_private &
14317 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
14318 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
14321 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
14322 no_bareword_allowed(pop);
14323 if (o->op_type == OP_GV)
14324 op_null(o->op_next);
14325 op_null(pop->op_next);
14327 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
14328 o->op_next = pop->op_next->op_next;
14329 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
14330 o->op_private = (U8)i;
14331 if (o->op_type == OP_GV) {
14334 o->op_type = OP_AELEMFAST;
14337 o->op_type = OP_AELEMFAST_LEX;
14339 if (o->op_type != OP_GV)
14343 /* Remove $foo from the op_next chain in void context. */
14345 && ( o->op_next->op_type == OP_RV2SV
14346 || o->op_next->op_type == OP_RV2AV
14347 || o->op_next->op_type == OP_RV2HV )
14348 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14349 && !(o->op_next->op_private & OPpLVAL_INTRO))
14351 oldop->op_next = o->op_next->op_next;
14352 /* Reprocess the previous op if it is a nextstate, to
14353 allow double-nextstate optimisation. */
14355 if (oldop->op_type == OP_NEXTSTATE) {
14362 o = oldop->op_next;
14365 else if (o->op_next->op_type == OP_RV2SV) {
14366 if (!(o->op_next->op_private & OPpDEREF)) {
14367 op_null(o->op_next);
14368 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
14370 o->op_next = o->op_next->op_next;
14371 OpTYPE_set(o, OP_GVSV);
14374 else if (o->op_next->op_type == OP_READLINE
14375 && o->op_next->op_next->op_type == OP_CONCAT
14376 && (o->op_next->op_next->op_flags & OPf_STACKED))
14378 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
14379 OpTYPE_set(o, OP_RCATLINE);
14380 o->op_flags |= OPf_STACKED;
14381 op_null(o->op_next->op_next);
14382 op_null(o->op_next);
14393 while (cLOGOP->op_other->op_type == OP_NULL)
14394 cLOGOP->op_other = cLOGOP->op_other->op_next;
14395 while (o->op_next && ( o->op_type == o->op_next->op_type
14396 || o->op_next->op_type == OP_NULL))
14397 o->op_next = o->op_next->op_next;
14399 /* If we're an OR and our next is an AND in void context, we'll
14400 follow its op_other on short circuit, same for reverse.
14401 We can't do this with OP_DOR since if it's true, its return
14402 value is the underlying value which must be evaluated
14406 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14407 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14409 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14411 o->op_next = ((LOGOP*)o->op_next)->op_other;
14413 DEFER(cLOGOP->op_other);
14425 case OP_ARGDEFELEM:
14426 while (cLOGOP->op_other->op_type == OP_NULL)
14427 cLOGOP->op_other = cLOGOP->op_other->op_next;
14428 DEFER(cLOGOP->op_other);
14433 while (cLOOP->op_redoop->op_type == OP_NULL)
14434 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14435 while (cLOOP->op_nextop->op_type == OP_NULL)
14436 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14437 while (cLOOP->op_lastop->op_type == OP_NULL)
14438 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14439 /* a while(1) loop doesn't have an op_next that escapes the
14440 * loop, so we have to explicitly follow the op_lastop to
14441 * process the rest of the code */
14442 DEFER(cLOOP->op_lastop);
14446 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14447 DEFER(cLOGOPo->op_other);
14451 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14452 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14453 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14454 cPMOP->op_pmstashstartu.op_pmreplstart
14455 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14456 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14462 if (o->op_flags & OPf_SPECIAL) {
14463 /* first arg is a code block */
14464 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14465 OP * kid = cUNOPx(nullop)->op_first;
14467 assert(nullop->op_type == OP_NULL);
14468 assert(kid->op_type == OP_SCOPE
14469 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14470 /* since OP_SORT doesn't have a handy op_other-style
14471 * field that can point directly to the start of the code
14472 * block, store it in the otherwise-unused op_next field
14473 * of the top-level OP_NULL. This will be quicker at
14474 * run-time, and it will also allow us to remove leading
14475 * OP_NULLs by just messing with op_nexts without
14476 * altering the basic op_first/op_sibling layout. */
14477 kid = kLISTOP->op_first;
14479 (kid->op_type == OP_NULL
14480 && ( kid->op_targ == OP_NEXTSTATE
14481 || kid->op_targ == OP_DBSTATE ))
14482 || kid->op_type == OP_STUB
14483 || kid->op_type == OP_ENTER
14484 || (PL_parser && PL_parser->error_count));
14485 nullop->op_next = kid->op_next;
14486 DEFER(nullop->op_next);
14489 /* check that RHS of sort is a single plain array */
14490 oright = cUNOPo->op_first;
14491 if (!oright || oright->op_type != OP_PUSHMARK)
14494 if (o->op_private & OPpSORT_INPLACE)
14497 /* reverse sort ... can be optimised. */
14498 if (!OpHAS_SIBLING(cUNOPo)) {
14499 /* Nothing follows us on the list. */
14500 OP * const reverse = o->op_next;
14502 if (reverse->op_type == OP_REVERSE &&
14503 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14504 OP * const pushmark = cUNOPx(reverse)->op_first;
14505 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14506 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14507 /* reverse -> pushmark -> sort */
14508 o->op_private |= OPpSORT_REVERSE;
14510 pushmark->op_next = oright->op_next;
14520 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14522 LISTOP *enter, *exlist;
14524 if (o->op_private & OPpSORT_INPLACE)
14527 enter = (LISTOP *) o->op_next;
14530 if (enter->op_type == OP_NULL) {
14531 enter = (LISTOP *) enter->op_next;
14535 /* for $a (...) will have OP_GV then OP_RV2GV here.
14536 for (...) just has an OP_GV. */
14537 if (enter->op_type == OP_GV) {
14538 gvop = (OP *) enter;
14539 enter = (LISTOP *) enter->op_next;
14542 if (enter->op_type == OP_RV2GV) {
14543 enter = (LISTOP *) enter->op_next;
14549 if (enter->op_type != OP_ENTERITER)
14552 iter = enter->op_next;
14553 if (!iter || iter->op_type != OP_ITER)
14556 expushmark = enter->op_first;
14557 if (!expushmark || expushmark->op_type != OP_NULL
14558 || expushmark->op_targ != OP_PUSHMARK)
14561 exlist = (LISTOP *) OpSIBLING(expushmark);
14562 if (!exlist || exlist->op_type != OP_NULL
14563 || exlist->op_targ != OP_LIST)
14566 if (exlist->op_last != o) {
14567 /* Mmm. Was expecting to point back to this op. */
14570 theirmark = exlist->op_first;
14571 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14574 if (OpSIBLING(theirmark) != o) {
14575 /* There's something between the mark and the reverse, eg
14576 for (1, reverse (...))
14581 ourmark = ((LISTOP *)o)->op_first;
14582 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14585 ourlast = ((LISTOP *)o)->op_last;
14586 if (!ourlast || ourlast->op_next != o)
14589 rv2av = OpSIBLING(ourmark);
14590 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14591 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14592 /* We're just reversing a single array. */
14593 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14594 enter->op_flags |= OPf_STACKED;
14597 /* We don't have control over who points to theirmark, so sacrifice
14599 theirmark->op_next = ourmark->op_next;
14600 theirmark->op_flags = ourmark->op_flags;
14601 ourlast->op_next = gvop ? gvop : (OP *) enter;
14604 enter->op_private |= OPpITER_REVERSED;
14605 iter->op_private |= OPpITER_REVERSED;
14609 o = oldop->op_next;
14611 NOT_REACHED; /* NOTREACHED */
14617 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14618 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14623 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14624 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14627 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14629 sv = newRV((SV *)PL_compcv);
14633 OpTYPE_set(o, OP_CONST);
14634 o->op_flags |= OPf_SPECIAL;
14635 cSVOPo->op_sv = sv;
14640 if (OP_GIMME(o,0) == G_VOID
14641 || ( o->op_next->op_type == OP_LINESEQ
14642 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14643 || ( o->op_next->op_next->op_type == OP_RETURN
14644 && !CvLVALUE(PL_compcv)))))
14646 OP *right = cBINOP->op_first;
14665 OP *left = OpSIBLING(right);
14666 if (left->op_type == OP_SUBSTR
14667 && (left->op_private & 7) < 4) {
14669 /* cut out right */
14670 op_sibling_splice(o, NULL, 1, NULL);
14671 /* and insert it as second child of OP_SUBSTR */
14672 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14674 left->op_private |= OPpSUBSTR_REPL_FIRST;
14676 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14683 int l, r, lr, lscalars, rscalars;
14685 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14686 Note that we do this now rather than in newASSIGNOP(),
14687 since only by now are aliased lexicals flagged as such
14689 See the essay "Common vars in list assignment" above for
14690 the full details of the rationale behind all the conditions
14693 PL_generation sorcery:
14694 To detect whether there are common vars, the global var
14695 PL_generation is incremented for each assign op we scan.
14696 Then we run through all the lexical variables on the LHS,
14697 of the assignment, setting a spare slot in each of them to
14698 PL_generation. Then we scan the RHS, and if any lexicals
14699 already have that value, we know we've got commonality.
14700 Also, if the generation number is already set to
14701 PERL_INT_MAX, then the variable is involved in aliasing, so
14702 we also have potential commonality in that case.
14708 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14711 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14715 /* After looking for things which are *always* safe, this main
14716 * if/else chain selects primarily based on the type of the
14717 * LHS, gradually working its way down from the more dangerous
14718 * to the more restrictive and thus safer cases */
14720 if ( !l /* () = ....; */
14721 || !r /* .... = (); */
14722 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14723 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14724 || (lscalars < 2) /* ($x, undef) = ... */
14726 NOOP; /* always safe */
14728 else if (l & AAS_DANGEROUS) {
14729 /* always dangerous */
14730 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14731 o->op_private |= OPpASSIGN_COMMON_AGG;
14733 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14734 /* package vars are always dangerous - too many
14735 * aliasing possibilities */
14736 if (l & AAS_PKG_SCALAR)
14737 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14738 if (l & AAS_PKG_AGG)
14739 o->op_private |= OPpASSIGN_COMMON_AGG;
14741 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14742 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14744 /* LHS contains only lexicals and safe ops */
14746 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14747 o->op_private |= OPpASSIGN_COMMON_AGG;
14749 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14750 if (lr & AAS_LEX_SCALAR_COMM)
14751 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14752 else if ( !(l & AAS_LEX_SCALAR)
14753 && (r & AAS_DEFAV))
14757 * as scalar-safe for performance reasons.
14758 * (it will still have been marked _AGG if necessary */
14761 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14762 /* if there are only lexicals on the LHS and no
14763 * common ones on the RHS, then we assume that the
14764 * only way those lexicals could also get
14765 * on the RHS is via some sort of dereffing or
14768 * ($lex, $x) = (1, $$r)
14769 * and in this case we assume the var must have
14770 * a bumped ref count. So if its ref count is 1,
14771 * it must only be on the LHS.
14773 o->op_private |= OPpASSIGN_COMMON_RC1;
14778 * may have to handle aggregate on LHS, but we can't
14779 * have common scalars. */
14782 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14788 /* see if ref() is used in boolean context */
14789 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
14790 S_check_for_bool_cxt(aTHX_ o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
14794 Perl_cpeep_t cpeep =
14795 XopENTRYCUSTOM(o, xop_peep);
14797 cpeep(aTHX_ o, oldop);
14802 /* did we just null the current op? If so, re-process it to handle
14803 * eliding "empty" ops from the chain */
14804 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14817 Perl_peep(pTHX_ OP *o)
14823 =head1 Custom Operators
14825 =for apidoc Ao||custom_op_xop
14826 Return the XOP structure for a given custom op. This macro should be
14827 considered internal to C<OP_NAME> and the other access macros: use them instead.
14828 This macro does call a function. Prior
14829 to 5.19.6, this was implemented as a
14836 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14842 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14844 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14845 assert(o->op_type == OP_CUSTOM);
14847 /* This is wrong. It assumes a function pointer can be cast to IV,
14848 * which isn't guaranteed, but this is what the old custom OP code
14849 * did. In principle it should be safer to Copy the bytes of the
14850 * pointer into a PV: since the new interface is hidden behind
14851 * functions, this can be changed later if necessary. */
14852 /* Change custom_op_xop if this ever happens */
14853 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14856 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14858 /* assume noone will have just registered a desc */
14859 if (!he && PL_custom_op_names &&
14860 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14865 /* XXX does all this need to be shared mem? */
14866 Newxz(xop, 1, XOP);
14867 pv = SvPV(HeVAL(he), l);
14868 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14869 if (PL_custom_op_descs &&
14870 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14872 pv = SvPV(HeVAL(he), l);
14873 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14875 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14879 xop = (XOP *)&xop_null;
14881 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14885 if(field == XOPe_xop_ptr) {
14888 const U32 flags = XopFLAGS(xop);
14889 if(flags & field) {
14891 case XOPe_xop_name:
14892 any.xop_name = xop->xop_name;
14894 case XOPe_xop_desc:
14895 any.xop_desc = xop->xop_desc;
14897 case XOPe_xop_class:
14898 any.xop_class = xop->xop_class;
14900 case XOPe_xop_peep:
14901 any.xop_peep = xop->xop_peep;
14904 NOT_REACHED; /* NOTREACHED */
14909 case XOPe_xop_name:
14910 any.xop_name = XOPd_xop_name;
14912 case XOPe_xop_desc:
14913 any.xop_desc = XOPd_xop_desc;
14915 case XOPe_xop_class:
14916 any.xop_class = XOPd_xop_class;
14918 case XOPe_xop_peep:
14919 any.xop_peep = XOPd_xop_peep;
14922 NOT_REACHED; /* NOTREACHED */
14927 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14928 * op.c: In function 'Perl_custom_op_get_field':
14929 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14930 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14931 * expands to assert(0), which expands to ((0) ? (void)0 :
14932 * __assert(...)), and gcc doesn't know that __assert can never return. */
14938 =for apidoc Ao||custom_op_register
14939 Register a custom op. See L<perlguts/"Custom Operators">.
14945 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14949 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14951 /* see the comment in custom_op_xop */
14952 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14954 if (!PL_custom_ops)
14955 PL_custom_ops = newHV();
14957 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14958 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14963 =for apidoc core_prototype
14965 This function assigns the prototype of the named core function to C<sv>, or
14966 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14967 C<NULL> if the core function has no prototype. C<code> is a code as returned
14968 by C<keyword()>. It must not be equal to 0.
14974 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14977 int i = 0, n = 0, seen_question = 0, defgv = 0;
14979 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14980 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14981 bool nullret = FALSE;
14983 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14987 if (!sv) sv = sv_newmortal();
14989 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14991 switch (code < 0 ? -code : code) {
14992 case KEY_and : case KEY_chop: case KEY_chomp:
14993 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14994 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14995 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14996 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14997 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14998 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14999 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
15000 case KEY_x : case KEY_xor :
15001 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
15002 case KEY_glob: retsetpvs("_;", OP_GLOB);
15003 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
15004 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
15005 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
15006 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
15007 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
15009 case KEY_evalbytes:
15010 name = "entereval"; break;
15018 while (i < MAXO) { /* The slow way. */
15019 if (strEQ(name, PL_op_name[i])
15020 || strEQ(name, PL_op_desc[i]))
15022 if (nullret) { assert(opnum); *opnum = i; return NULL; }
15029 defgv = PL_opargs[i] & OA_DEFGV;
15030 oa = PL_opargs[i] >> OASHIFT;
15032 if (oa & OA_OPTIONAL && !seen_question && (
15033 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
15038 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
15039 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
15040 /* But globs are already references (kinda) */
15041 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
15045 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
15046 && !scalar_mod_type(NULL, i)) {
15051 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
15055 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
15056 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
15057 str[n-1] = '_'; defgv = 0;
15061 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
15063 sv_setpvn(sv, str, n - 1);
15064 if (opnum) *opnum = i;
15069 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
15072 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
15075 PERL_ARGS_ASSERT_CORESUB_OP;
15079 return op_append_elem(OP_LINESEQ,
15082 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
15089 o = newUNOP(OP_AVHVSWITCH,0,argop);
15090 o->op_private = opnum-OP_EACH;
15092 case OP_SELECT: /* which represents OP_SSELECT as well */
15097 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
15098 newSVOP(OP_CONST, 0, newSVuv(1))
15100 coresub_op(newSVuv((UV)OP_SSELECT), 0,
15102 coresub_op(coreargssv, 0, OP_SELECT)
15106 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
15108 return op_append_elem(
15111 opnum == OP_WANTARRAY || opnum == OP_RUNCV
15112 ? OPpOFFBYONE << 8 : 0)
15114 case OA_BASEOP_OR_UNOP:
15115 if (opnum == OP_ENTEREVAL) {
15116 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
15117 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
15119 else o = newUNOP(opnum,0,argop);
15120 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
15123 if (is_handle_constructor(o, 1))
15124 argop->op_private |= OPpCOREARGS_DEREF1;
15125 if (scalar_mod_type(NULL, opnum))
15126 argop->op_private |= OPpCOREARGS_SCALARMOD;
15130 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
15131 if (is_handle_constructor(o, 2))
15132 argop->op_private |= OPpCOREARGS_DEREF2;
15133 if (opnum == OP_SUBSTR) {
15134 o->op_private |= OPpMAYBE_LVSUB;
15143 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
15144 SV * const *new_const_svp)
15146 const char *hvname;
15147 bool is_const = !!CvCONST(old_cv);
15148 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
15150 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
15152 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
15154 /* They are 2 constant subroutines generated from
15155 the same constant. This probably means that
15156 they are really the "same" proxy subroutine
15157 instantiated in 2 places. Most likely this is
15158 when a constant is exported twice. Don't warn.
15161 (ckWARN(WARN_REDEFINE)
15163 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15164 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15165 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15166 strEQ(hvname, "autouse"))
15170 && ckWARN_d(WARN_REDEFINE)
15171 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
15174 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15176 ? "Constant subroutine %" SVf " redefined"
15177 : "Subroutine %" SVf " redefined",
15182 =head1 Hook manipulation
15184 These functions provide convenient and thread-safe means of manipulating
15191 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
15193 Puts a C function into the chain of check functions for a specified op
15194 type. This is the preferred way to manipulate the L</PL_check> array.
15195 C<opcode> specifies which type of op is to be affected. C<new_checker>
15196 is a pointer to the C function that is to be added to that opcode's
15197 check chain, and C<old_checker_p> points to the storage location where a
15198 pointer to the next function in the chain will be stored. The value of
15199 C<new_pointer> is written into the L</PL_check> array, while the value
15200 previously stored there is written to C<*old_checker_p>.
15202 The function should be defined like this:
15204 static OP *new_checker(pTHX_ OP *op) { ... }
15206 It is intended to be called in this manner:
15208 new_checker(aTHX_ op)
15210 C<old_checker_p> should be defined like this:
15212 static Perl_check_t old_checker_p;
15214 L</PL_check> is global to an entire process, and a module wishing to
15215 hook op checking may find itself invoked more than once per process,
15216 typically in different threads. To handle that situation, this function
15217 is idempotent. The location C<*old_checker_p> must initially (once
15218 per process) contain a null pointer. A C variable of static duration
15219 (declared at file scope, typically also marked C<static> to give
15220 it internal linkage) will be implicitly initialised appropriately,
15221 if it does not have an explicit initialiser. This function will only
15222 actually modify the check chain if it finds C<*old_checker_p> to be null.
15223 This function is also thread safe on the small scale. It uses appropriate
15224 locking to avoid race conditions in accessing L</PL_check>.
15226 When this function is called, the function referenced by C<new_checker>
15227 must be ready to be called, except for C<*old_checker_p> being unfilled.
15228 In a threading situation, C<new_checker> may be called immediately,
15229 even before this function has returned. C<*old_checker_p> will always
15230 be appropriately set before C<new_checker> is called. If C<new_checker>
15231 decides not to do anything special with an op that it is given (which
15232 is the usual case for most uses of op check hooking), it must chain the
15233 check function referenced by C<*old_checker_p>.
15235 If you want to influence compilation of calls to a specific subroutine,
15236 then use L</cv_set_call_checker> rather than hooking checking of all
15243 Perl_wrap_op_checker(pTHX_ Optype opcode,
15244 Perl_check_t new_checker, Perl_check_t *old_checker_p)
15248 PERL_UNUSED_CONTEXT;
15249 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15250 if (*old_checker_p) return;
15251 OP_CHECK_MUTEX_LOCK;
15252 if (!*old_checker_p) {
15253 *old_checker_p = PL_check[opcode];
15254 PL_check[opcode] = new_checker;
15256 OP_CHECK_MUTEX_UNLOCK;
15261 /* Efficient sub that returns a constant scalar value. */
15263 const_sv_xsub(pTHX_ CV* cv)
15266 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15267 PERL_UNUSED_ARG(items);
15277 const_av_xsub(pTHX_ CV* cv)
15280 AV * const av = MUTABLE_AV(XSANY.any_ptr);
15288 if (SvRMAGICAL(av))
15289 Perl_croak(aTHX_ "Magical list constants are not supported");
15290 if (GIMME_V != G_ARRAY) {
15292 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15295 EXTEND(SP, AvFILLp(av)+1);
15296 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15297 XSRETURN(AvFILLp(av)+1);
15302 * ex: set ts=8 sts=4 sw=4 et: