4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
28 * A Perl program is compiled into a tree of OP nodes. Each op contains:
29 * * structural OP pointers to its children and siblings (op_sibling,
30 * op_first etc) that define the tree structure;
31 * * execution order OP pointers (op_next, plus sometimes op_other,
32 * op_lastop etc) that define the execution sequence plus variants;
33 * * a pointer to the C "pp" function that would execute the op;
34 * * any data specific to that op.
35 * For example, an OP_CONST op points to the pp_const() function and to an
36 * SV containing the constant value. When pp_const() is executed, its job
37 * is to push that SV onto the stack.
39 * OPs are mainly created by the newFOO() functions, which are mainly
40 * called from the parser (in perly.y) as the code is parsed. For example
41 * the Perl code $a + $b * $c would cause the equivalent of the following
42 * to be called (oversimplifying a bit):
44 * newBINOP(OP_ADD, flags,
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
49 * As the parser reduces low-level rules, it creates little op subtrees;
50 * as higher-level rules are resolved, these subtrees get joined together
51 * as branches on a bigger subtree, until eventually a top-level rule like
52 * a subroutine definition is reduced, at which point there is one large
55 * The execution order pointers (op_next) are generated as the subtrees
56 * are joined together. Consider this sub-expression: A*B + C/D: at the
57 * point when it's just been parsed, the op tree looks like:
65 * with the intended execution order being:
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
69 * At this point all the nodes' op_next pointers will have been set,
71 * * we don't know what the [NEXT] node will be yet;
72 * * we don't know what the [PREV] node will be yet, but when it gets
73 * created and needs its op_next set, it needs to be set to point to
74 * A, which is non-obvious.
75 * To handle both those cases, we temporarily set the top node's
76 * op_next to point to the first node to be executed in this subtree (A in
77 * this case). This means that initially a subtree's op_next chain,
78 * starting from the top node, will visit each node in execution sequence
79 * then point back at the top node.
80 * When we embed this subtree in a larger tree, its top op_next is used
81 * to get the start node, then is set to point to its new neighbour.
82 * For example the two separate [*],A,B and [/],C,D subtrees would
84 * [*] => A; A => B; B => [*]
86 * [/] => C; C => D; D => [/]
87 * When these two subtrees were joined together to make the [+] subtree,
88 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89 * set to point to [/]'s op_next, i.e. C.
91 * This op_next linking is done by the LINKLIST() macro and its underlying
92 * op_linklist() function. Given a top-level op, if its op_next is
93 * non-null, it's already been linked, so leave it. Otherwise link it with
94 * its children as described above, possibly recursively if any of the
95 * children have a null op_next.
97 * In summary: given a subtree, its top-level node's op_next will either
99 * NULL: the subtree hasn't been LINKLIST()ed yet;
100 * fake: points to the start op for this subtree;
101 * real: once the subtree has been embedded into a larger tree
106 Here's an older description from Larry.
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
112 An execution-order pass
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines. The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order. (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again). As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node. But
130 it's still not the real execution order.
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer. At that point, we can call
135 into peep() to do that code's portion of the 3rd pass. It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140 get the compile time state of %^H for that block. Storing %^H in every
141 block (or even COP) would be very expensive, so a different approach is
142 taken. The (running) state of %^H is serialised into a tree of HE-like
143 structs. Stores into %^H are chained onto the current leaf as a struct
144 refcounted_he * with the key and the value. Deletes from %^H are saved
145 with a value of PL_sv_placeholder. The state of %^H at any point can be
146 turned back into a regular HV by walking back up the tree from that point's
147 leaf, ignoring any key you've already seen (placeholder or not), storing
148 the rest into the HV structure, then removing the placeholders. Hence
149 memory is only used to store the %^H deltas from the enclosing COP, rather
150 than the entire %^H on each COP.
152 To cause actions on %^H to write out the serialisation records, it has
153 magic type 'H'. This magic (itself) does nothing, but its presence causes
154 the values to gain magic type 'h', which has entries for set and clear.
155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158 it will be correctly restored when any inner compiling scope is exited.
164 #include "keywords.h"
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
174 /* Used to avoid recursion through the op tree in scalarvoid() and
178 #define DEFERRED_OP_STEP 100
179 #define DEFER_OP(o) \
181 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
182 defer_stack_alloc += DEFERRED_OP_STEP; \
183 assert(defer_stack_alloc > 0); \
184 Renew(defer_stack, defer_stack_alloc, OP *); \
186 defer_stack[++defer_ix] = o; \
189 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
191 /* remove any leading "empty" ops from the op_next chain whose first
192 * node's address is stored in op_p. Store the updated address of the
193 * first node in op_p.
197 S_prune_chain_head(OP** op_p)
200 && ( (*op_p)->op_type == OP_NULL
201 || (*op_p)->op_type == OP_SCOPE
202 || (*op_p)->op_type == OP_SCALAR
203 || (*op_p)->op_type == OP_LINESEQ)
205 *op_p = (*op_p)->op_next;
209 /* See the explanatory comments above struct opslab in op.h. */
211 #ifdef PERL_DEBUG_READONLY_OPS
212 # define PERL_SLAB_SIZE 128
213 # define PERL_MAX_SLAB_SIZE 4096
214 # include <sys/mman.h>
217 #ifndef PERL_SLAB_SIZE
218 # define PERL_SLAB_SIZE 64
220 #ifndef PERL_MAX_SLAB_SIZE
221 # define PERL_MAX_SLAB_SIZE 2048
224 /* rounds up to nearest pointer */
225 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
226 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
229 S_new_slab(pTHX_ size_t sz)
231 #ifdef PERL_DEBUG_READONLY_OPS
232 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
233 PROT_READ|PROT_WRITE,
234 MAP_ANON|MAP_PRIVATE, -1, 0);
235 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
236 (unsigned long) sz, slab));
237 if (slab == MAP_FAILED) {
238 perror("mmap failed");
241 slab->opslab_size = (U16)sz;
243 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
246 /* The context is unused in non-Windows */
249 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
253 /* requires double parens and aTHX_ */
254 #define DEBUG_S_warn(args) \
256 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
260 Perl_Slab_Alloc(pTHX_ size_t sz)
268 /* We only allocate ops from the slab during subroutine compilation.
269 We find the slab via PL_compcv, hence that must be non-NULL. It could
270 also be pointing to a subroutine which is now fully set up (CvROOT()
271 pointing to the top of the optree for that sub), or a subroutine
272 which isn't using the slab allocator. If our sanity checks aren't met,
273 don't use a slab, but allocate the OP directly from the heap. */
274 if (!PL_compcv || CvROOT(PL_compcv)
275 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
277 o = (OP*)PerlMemShared_calloc(1, sz);
281 /* While the subroutine is under construction, the slabs are accessed via
282 CvSTART(), to avoid needing to expand PVCV by one pointer for something
283 unneeded at runtime. Once a subroutine is constructed, the slabs are
284 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
285 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
287 if (!CvSTART(PL_compcv)) {
289 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
290 CvSLABBED_on(PL_compcv);
291 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
293 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
295 opsz = SIZE_TO_PSIZE(sz);
296 sz = opsz + OPSLOT_HEADER_P;
298 /* The slabs maintain a free list of OPs. In particular, constant folding
299 will free up OPs, so it makes sense to re-use them where possible. A
300 freed up slot is used in preference to a new allocation. */
301 if (slab->opslab_freed) {
302 OP **too = &slab->opslab_freed;
304 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
305 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
306 DEBUG_S_warn((aTHX_ "Alas! too small"));
307 o = *(too = &o->op_next);
308 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
312 Zero(o, opsz, I32 *);
318 #define INIT_OPSLOT \
319 slot->opslot_slab = slab; \
320 slot->opslot_next = slab2->opslab_first; \
321 slab2->opslab_first = slot; \
322 o = &slot->opslot_op; \
325 /* The partially-filled slab is next in the chain. */
326 slab2 = slab->opslab_next ? slab->opslab_next : slab;
327 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
328 /* Remaining space is too small. */
330 /* If we can fit a BASEOP, add it to the free chain, so as not
332 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
333 slot = &slab2->opslab_slots;
335 o->op_type = OP_FREED;
336 o->op_next = slab->opslab_freed;
337 slab->opslab_freed = o;
340 /* Create a new slab. Make this one twice as big. */
341 slot = slab2->opslab_first;
342 while (slot->opslot_next) slot = slot->opslot_next;
343 slab2 = S_new_slab(aTHX_
344 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
346 : (DIFF(slab2, slot)+1)*2);
347 slab2->opslab_next = slab->opslab_next;
348 slab->opslab_next = slab2;
350 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
352 /* Create a new op slot */
353 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
354 assert(slot >= &slab2->opslab_slots);
355 if (DIFF(&slab2->opslab_slots, slot)
356 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
357 slot = &slab2->opslab_slots;
359 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
362 #ifdef PERL_OP_PARENT
363 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
364 assert(!o->op_moresib);
365 assert(!o->op_sibparent);
373 #ifdef PERL_DEBUG_READONLY_OPS
375 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
377 PERL_ARGS_ASSERT_SLAB_TO_RO;
379 if (slab->opslab_readonly) return;
380 slab->opslab_readonly = 1;
381 for (; slab; slab = slab->opslab_next) {
382 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
383 (unsigned long) slab->opslab_size, slab));*/
384 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
385 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
386 (unsigned long)slab->opslab_size, errno);
391 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
395 PERL_ARGS_ASSERT_SLAB_TO_RW;
397 if (!slab->opslab_readonly) return;
399 for (; slab2; slab2 = slab2->opslab_next) {
400 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
401 (unsigned long) size, slab2));*/
402 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
403 PROT_READ|PROT_WRITE)) {
404 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
405 (unsigned long)slab2->opslab_size, errno);
408 slab->opslab_readonly = 0;
412 # define Slab_to_rw(op) NOOP
415 /* This cannot possibly be right, but it was copied from the old slab
416 allocator, to which it was originally added, without explanation, in
419 # define PerlMemShared PerlMem
423 Perl_Slab_Free(pTHX_ void *op)
425 OP * const o = (OP *)op;
428 PERL_ARGS_ASSERT_SLAB_FREE;
430 if (!o->op_slabbed) {
432 PerlMemShared_free(op);
437 /* If this op is already freed, our refcount will get screwy. */
438 assert(o->op_type != OP_FREED);
439 o->op_type = OP_FREED;
440 o->op_next = slab->opslab_freed;
441 slab->opslab_freed = o;
442 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
443 OpslabREFCNT_dec_padok(slab);
447 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
449 const bool havepad = !!PL_comppad;
450 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
453 PAD_SAVE_SETNULLPAD();
460 Perl_opslab_free(pTHX_ OPSLAB *slab)
463 PERL_ARGS_ASSERT_OPSLAB_FREE;
465 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
466 assert(slab->opslab_refcnt == 1);
468 slab2 = slab->opslab_next;
470 slab->opslab_refcnt = ~(size_t)0;
472 #ifdef PERL_DEBUG_READONLY_OPS
473 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
475 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
476 perror("munmap failed");
480 PerlMemShared_free(slab);
487 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
492 size_t savestack_count = 0;
494 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
497 for (slot = slab2->opslab_first;
499 slot = slot->opslot_next) {
500 if (slot->opslot_op.op_type != OP_FREED
501 && !(slot->opslot_op.op_savefree
507 assert(slot->opslot_op.op_slabbed);
508 op_free(&slot->opslot_op);
509 if (slab->opslab_refcnt == 1) goto free;
512 } while ((slab2 = slab2->opslab_next));
513 /* > 1 because the CV still holds a reference count. */
514 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
516 assert(savestack_count == slab->opslab_refcnt-1);
518 /* Remove the CV’s reference count. */
519 slab->opslab_refcnt--;
526 #ifdef PERL_DEBUG_READONLY_OPS
528 Perl_op_refcnt_inc(pTHX_ OP *o)
531 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
532 if (slab && slab->opslab_readonly) {
545 Perl_op_refcnt_dec(pTHX_ OP *o)
548 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
550 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
552 if (slab && slab->opslab_readonly) {
554 result = --o->op_targ;
557 result = --o->op_targ;
563 * In the following definition, the ", (OP*)0" is just to make the compiler
564 * think the expression is of the right type: croak actually does a Siglongjmp.
566 #define CHECKOP(type,o) \
567 ((PL_op_mask && PL_op_mask[type]) \
568 ? ( op_free((OP*)o), \
569 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
571 : PL_check[type](aTHX_ (OP*)o))
573 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
575 #define OpTYPE_set(o,type) \
577 o->op_type = (OPCODE)type; \
578 o->op_ppaddr = PL_ppaddr[type]; \
582 S_no_fh_allowed(pTHX_ OP *o)
584 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
586 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
592 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
594 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
595 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
600 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
602 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
604 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
609 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
611 PERL_ARGS_ASSERT_BAD_TYPE_PV;
613 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
614 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
617 /* remove flags var, its unused in all callers, move to to right end since gv
618 and kid are always the same */
620 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
622 SV * const namesv = cv_name((CV *)gv, NULL, 0);
623 PERL_ARGS_ASSERT_BAD_TYPE_GV;
625 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
626 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
630 S_no_bareword_allowed(pTHX_ OP *o)
632 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
634 qerror(Perl_mess(aTHX_
635 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
637 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
640 /* "register" allocation */
643 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
646 const bool is_our = (PL_parser->in_my == KEY_our);
648 PERL_ARGS_ASSERT_ALLOCMY;
650 if (flags & ~SVf_UTF8)
651 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
654 /* complain about "my $<special_var>" etc etc */
658 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
659 (name[1] == '_' && len > 2)))
661 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
663 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
664 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
665 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
666 PL_parser->in_my == KEY_state ? "state" : "my"));
668 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
669 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
673 /* allocate a spare slot and store the name in that slot */
675 off = pad_add_name_pvn(name, len,
676 (is_our ? padadd_OUR :
677 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
678 PL_parser->in_my_stash,
680 /* $_ is always in main::, even with our */
681 ? (PL_curstash && !memEQs(name,len,"$_")
687 /* anon sub prototypes contains state vars should always be cloned,
688 * otherwise the state var would be shared between anon subs */
690 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
691 CvCLONE_on(PL_compcv);
697 =head1 Optree Manipulation Functions
699 =for apidoc alloccopstash
701 Available only under threaded builds, this function allocates an entry in
702 C<PL_stashpad> for the stash passed to it.
709 Perl_alloccopstash(pTHX_ HV *hv)
711 PADOFFSET off = 0, o = 1;
712 bool found_slot = FALSE;
714 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
716 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
718 for (; o < PL_stashpadmax; ++o) {
719 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
720 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
721 found_slot = TRUE, off = o;
724 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
725 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
726 off = PL_stashpadmax;
727 PL_stashpadmax += 10;
730 PL_stashpad[PL_stashpadix = off] = hv;
735 /* free the body of an op without examining its contents.
736 * Always use this rather than FreeOp directly */
739 S_op_destroy(pTHX_ OP *o)
747 =for apidoc Am|void|op_free|OP *o
749 Free an op. Only use this when an op is no longer linked to from any
756 Perl_op_free(pTHX_ OP *o)
760 SSize_t defer_ix = -1;
761 SSize_t defer_stack_alloc = 0;
762 OP **defer_stack = NULL;
766 /* Though ops may be freed twice, freeing the op after its slab is a
768 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
769 /* During the forced freeing of ops after compilation failure, kidops
770 may be freed before their parents. */
771 if (!o || o->op_type == OP_FREED)
776 /* an op should only ever acquire op_private flags that we know about.
777 * If this fails, you may need to fix something in regen/op_private.
778 * Don't bother testing if:
779 * * the op_ppaddr doesn't match the op; someone may have
780 * overridden the op and be doing strange things with it;
781 * * we've errored, as op flags are often left in an
782 * inconsistent state then. Note that an error when
783 * compiling the main program leaves PL_parser NULL, so
784 * we can't spot faults in the main code, only
785 * evaled/required code */
787 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
789 && !PL_parser->error_count)
791 assert(!(o->op_private & ~PL_op_private_valid[type]));
795 if (o->op_private & OPpREFCOUNTED) {
806 refcnt = OpREFCNT_dec(o);
809 /* Need to find and remove any pattern match ops from the list
810 we maintain for reset(). */
811 find_and_forget_pmops(o);
821 /* Call the op_free hook if it has been set. Do it now so that it's called
822 * at the right time for refcounted ops, but still before all of the kids
826 if (o->op_flags & OPf_KIDS) {
828 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
829 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
830 if (!kid || kid->op_type == OP_FREED)
831 /* During the forced freeing of ops after
832 compilation failure, kidops may be freed before
835 if (!(kid->op_flags & OPf_KIDS))
836 /* If it has no kids, just free it now */
843 type = (OPCODE)o->op_targ;
846 Slab_to_rw(OpSLAB(o));
848 /* COP* is not cleared by op_clear() so that we may track line
849 * numbers etc even after null() */
850 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
856 #ifdef DEBUG_LEAKING_SCALARS
860 } while ( (o = POP_DEFERRED_OP()) );
862 Safefree(defer_stack);
865 /* S_op_clear_gv(): free a GV attached to an OP */
869 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
871 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
875 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
876 || o->op_type == OP_MULTIDEREF)
879 ? ((GV*)PAD_SVl(*ixp)) : NULL;
881 ? (GV*)(*svp) : NULL;
883 /* It's possible during global destruction that the GV is freed
884 before the optree. Whilst the SvREFCNT_inc is happy to bump from
885 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
886 will trigger an assertion failure, because the entry to sv_clear
887 checks that the scalar is not already freed. A check of for
888 !SvIS_FREED(gv) turns out to be invalid, because during global
889 destruction the reference count can be forced down to zero
890 (with SVf_BREAK set). In which case raising to 1 and then
891 dropping to 0 triggers cleanup before it should happen. I
892 *think* that this might actually be a general, systematic,
893 weakness of the whole idea of SVf_BREAK, in that code *is*
894 allowed to raise and lower references during global destruction,
895 so any *valid* code that happens to do this during global
896 destruction might well trigger premature cleanup. */
897 bool still_valid = gv && SvREFCNT(gv);
900 SvREFCNT_inc_simple_void(gv);
903 pad_swipe(*ixp, TRUE);
911 int try_downgrade = SvREFCNT(gv) == 2;
914 gv_try_downgrade(gv);
920 Perl_op_clear(pTHX_ OP *o)
925 PERL_ARGS_ASSERT_OP_CLEAR;
927 switch (o->op_type) {
928 case OP_NULL: /* Was holding old type, if any. */
931 case OP_ENTEREVAL: /* Was holding hints. */
935 if (!(o->op_flags & OPf_REF)
936 || (PL_check[o->op_type] != Perl_ck_ftst))
943 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
945 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
948 case OP_METHOD_REDIR:
949 case OP_METHOD_REDIR_SUPER:
951 if (cMETHOPx(o)->op_rclass_targ) {
952 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
953 cMETHOPx(o)->op_rclass_targ = 0;
956 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
957 cMETHOPx(o)->op_rclass_sv = NULL;
959 case OP_METHOD_NAMED:
960 case OP_METHOD_SUPER:
961 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
962 cMETHOPx(o)->op_u.op_meth_sv = NULL;
965 pad_swipe(o->op_targ, 1);
972 SvREFCNT_dec(cSVOPo->op_sv);
973 cSVOPo->op_sv = NULL;
976 Even if op_clear does a pad_free for the target of the op,
977 pad_free doesn't actually remove the sv that exists in the pad;
978 instead it lives on. This results in that it could be reused as
979 a target later on when the pad was reallocated.
982 pad_swipe(o->op_targ,1);
992 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
997 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
998 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
1000 if (cPADOPo->op_padix > 0) {
1001 pad_swipe(cPADOPo->op_padix, TRUE);
1002 cPADOPo->op_padix = 0;
1005 SvREFCNT_dec(cSVOPo->op_sv);
1006 cSVOPo->op_sv = NULL;
1010 PerlMemShared_free(cPVOPo->op_pv);
1011 cPVOPo->op_pv = NULL;
1015 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1019 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
1020 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1023 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1029 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1030 op_free(cPMOPo->op_code_list);
1031 cPMOPo->op_code_list = NULL;
1032 forget_pmop(cPMOPo);
1033 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1034 /* we use the same protection as the "SAFE" version of the PM_ macros
1035 * here since sv_clean_all might release some PMOPs
1036 * after PL_regex_padav has been cleared
1037 * and the clearing of PL_regex_padav needs to
1038 * happen before sv_clean_all
1041 if(PL_regex_pad) { /* We could be in destruction */
1042 const IV offset = (cPMOPo)->op_pmoffset;
1043 ReREFCNT_dec(PM_GETRE(cPMOPo));
1044 PL_regex_pad[offset] = &PL_sv_undef;
1045 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1049 ReREFCNT_dec(PM_GETRE(cPMOPo));
1050 PM_SETRE(cPMOPo, NULL);
1057 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1058 UV actions = items->uv;
1060 bool is_hash = FALSE;
1063 switch (actions & MDEREF_ACTION_MASK) {
1066 actions = (++items)->uv;
1069 case MDEREF_HV_padhv_helem:
1071 case MDEREF_AV_padav_aelem:
1072 pad_free((++items)->pad_offset);
1075 case MDEREF_HV_gvhv_helem:
1077 case MDEREF_AV_gvav_aelem:
1079 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1081 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1085 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1087 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1089 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1091 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1093 goto do_vivify_rv2xv_elem;
1095 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1097 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1098 pad_free((++items)->pad_offset);
1099 goto do_vivify_rv2xv_elem;
1101 case MDEREF_HV_pop_rv2hv_helem:
1102 case MDEREF_HV_vivify_rv2hv_helem:
1104 do_vivify_rv2xv_elem:
1105 case MDEREF_AV_pop_rv2av_aelem:
1106 case MDEREF_AV_vivify_rv2av_aelem:
1108 switch (actions & MDEREF_INDEX_MASK) {
1109 case MDEREF_INDEX_none:
1112 case MDEREF_INDEX_const:
1116 pad_swipe((++items)->pad_offset, 1);
1118 SvREFCNT_dec((++items)->sv);
1124 case MDEREF_INDEX_padsv:
1125 pad_free((++items)->pad_offset);
1127 case MDEREF_INDEX_gvsv:
1129 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1131 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1136 if (actions & MDEREF_FLAG_last)
1149 actions >>= MDEREF_SHIFT;
1152 /* start of malloc is at op_aux[-1], where the length is
1154 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1159 if (o->op_targ > 0) {
1160 pad_free(o->op_targ);
1166 S_cop_free(pTHX_ COP* cop)
1168 PERL_ARGS_ASSERT_COP_FREE;
1171 if (! specialWARN(cop->cop_warnings))
1172 PerlMemShared_free(cop->cop_warnings);
1173 cophh_free(CopHINTHASH_get(cop));
1174 if (PL_curcop == cop)
1179 S_forget_pmop(pTHX_ PMOP *const o
1182 HV * const pmstash = PmopSTASH(o);
1184 PERL_ARGS_ASSERT_FORGET_PMOP;
1186 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1187 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1189 PMOP **const array = (PMOP**) mg->mg_ptr;
1190 U32 count = mg->mg_len / sizeof(PMOP**);
1194 if (array[i] == o) {
1195 /* Found it. Move the entry at the end to overwrite it. */
1196 array[i] = array[--count];
1197 mg->mg_len = count * sizeof(PMOP**);
1198 /* Could realloc smaller at this point always, but probably
1199 not worth it. Probably worth free()ing if we're the
1202 Safefree(mg->mg_ptr);
1215 S_find_and_forget_pmops(pTHX_ OP *o)
1217 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1219 if (o->op_flags & OPf_KIDS) {
1220 OP *kid = cUNOPo->op_first;
1222 switch (kid->op_type) {
1227 forget_pmop((PMOP*)kid);
1229 find_and_forget_pmops(kid);
1230 kid = OpSIBLING(kid);
1236 =for apidoc Am|void|op_null|OP *o
1238 Neutralizes an op when it is no longer needed, but is still linked to from
1245 Perl_op_null(pTHX_ OP *o)
1249 PERL_ARGS_ASSERT_OP_NULL;
1251 if (o->op_type == OP_NULL)
1254 o->op_targ = o->op_type;
1255 OpTYPE_set(o, OP_NULL);
1259 Perl_op_refcnt_lock(pTHX)
1260 PERL_TSA_ACQUIRE(PL_op_mutex)
1265 PERL_UNUSED_CONTEXT;
1270 Perl_op_refcnt_unlock(pTHX)
1271 PERL_TSA_RELEASE(PL_op_mutex)
1276 PERL_UNUSED_CONTEXT;
1282 =for apidoc op_sibling_splice
1284 A general function for editing the structure of an existing chain of
1285 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1286 you to delete zero or more sequential nodes, replacing them with zero or
1287 more different nodes. Performs the necessary op_first/op_last
1288 housekeeping on the parent node and op_sibling manipulation on the
1289 children. The last deleted node will be marked as as the last node by
1290 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1292 Note that op_next is not manipulated, and nodes are not freed; that is the
1293 responsibility of the caller. It also won't create a new list op for an
1294 empty list etc; use higher-level functions like op_append_elem() for that.
1296 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1297 the splicing doesn't affect the first or last op in the chain.
1299 C<start> is the node preceding the first node to be spliced. Node(s)
1300 following it will be deleted, and ops will be inserted after it. If it is
1301 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1304 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1305 If -1 or greater than or equal to the number of remaining kids, all
1306 remaining kids are deleted.
1308 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1309 If C<NULL>, no nodes are inserted.
1311 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1316 action before after returns
1317 ------ ----- ----- -------
1320 splice(P, A, 2, X-Y-Z) | | B-C
1324 splice(P, NULL, 1, X-Y) | | A
1328 splice(P, NULL, 3, NULL) | | A-B-C
1332 splice(P, B, 0, X-Y) | | NULL
1336 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1337 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1343 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1347 OP *last_del = NULL;
1348 OP *last_ins = NULL;
1351 first = OpSIBLING(start);
1355 first = cLISTOPx(parent)->op_first;
1357 assert(del_count >= -1);
1359 if (del_count && first) {
1361 while (--del_count && OpHAS_SIBLING(last_del))
1362 last_del = OpSIBLING(last_del);
1363 rest = OpSIBLING(last_del);
1364 OpLASTSIB_set(last_del, NULL);
1371 while (OpHAS_SIBLING(last_ins))
1372 last_ins = OpSIBLING(last_ins);
1373 OpMAYBESIB_set(last_ins, rest, NULL);
1379 OpMAYBESIB_set(start, insert, NULL);
1384 cLISTOPx(parent)->op_first = insert;
1386 parent->op_flags |= OPf_KIDS;
1388 parent->op_flags &= ~OPf_KIDS;
1392 /* update op_last etc */
1399 /* ought to use OP_CLASS(parent) here, but that can't handle
1400 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1402 type = parent->op_type;
1403 if (type == OP_CUSTOM) {
1405 type = XopENTRYCUSTOM(parent, xop_class);
1408 if (type == OP_NULL)
1409 type = parent->op_targ;
1410 type = PL_opargs[type] & OA_CLASS_MASK;
1413 lastop = last_ins ? last_ins : start ? start : NULL;
1414 if ( type == OA_BINOP
1415 || type == OA_LISTOP
1419 cLISTOPx(parent)->op_last = lastop;
1422 OpLASTSIB_set(lastop, parent);
1424 return last_del ? first : NULL;
1427 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1431 #ifdef PERL_OP_PARENT
1434 =for apidoc op_parent
1436 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1437 This function is only available on perls built with C<-DPERL_OP_PARENT>.
1443 Perl_op_parent(OP *o)
1445 PERL_ARGS_ASSERT_OP_PARENT;
1446 while (OpHAS_SIBLING(o))
1448 return o->op_sibparent;
1454 /* replace the sibling following start with a new UNOP, which becomes
1455 * the parent of the original sibling; e.g.
1457 * op_sibling_newUNOP(P, A, unop-args...)
1465 * where U is the new UNOP.
1467 * parent and start args are the same as for op_sibling_splice();
1468 * type and flags args are as newUNOP().
1470 * Returns the new UNOP.
1474 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1478 kid = op_sibling_splice(parent, start, 1, NULL);
1479 newop = newUNOP(type, flags, kid);
1480 op_sibling_splice(parent, start, 0, newop);
1485 /* lowest-level newLOGOP-style function - just allocates and populates
1486 * the struct. Higher-level stuff should be done by S_new_logop() /
1487 * newLOGOP(). This function exists mainly to avoid op_first assignment
1488 * being spread throughout this file.
1492 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1497 NewOp(1101, logop, 1, LOGOP);
1498 OpTYPE_set(logop, type);
1499 logop->op_first = first;
1500 logop->op_other = other;
1501 logop->op_flags = OPf_KIDS;
1502 while (kid && OpHAS_SIBLING(kid))
1503 kid = OpSIBLING(kid);
1505 OpLASTSIB_set(kid, (OP*)logop);
1510 /* Contextualizers */
1513 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1515 Applies a syntactic context to an op tree representing an expression.
1516 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1517 or C<G_VOID> to specify the context to apply. The modified op tree
1524 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1526 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1528 case G_SCALAR: return scalar(o);
1529 case G_ARRAY: return list(o);
1530 case G_VOID: return scalarvoid(o);
1532 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1539 =for apidoc Am|OP*|op_linklist|OP *o
1540 This function is the implementation of the L</LINKLIST> macro. It should
1541 not be called directly.
1547 Perl_op_linklist(pTHX_ OP *o)
1551 PERL_ARGS_ASSERT_OP_LINKLIST;
1556 /* establish postfix order */
1557 first = cUNOPo->op_first;
1560 o->op_next = LINKLIST(first);
1563 OP *sibl = OpSIBLING(kid);
1565 kid->op_next = LINKLIST(sibl);
1580 S_scalarkids(pTHX_ OP *o)
1582 if (o && o->op_flags & OPf_KIDS) {
1584 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1591 S_scalarboolean(pTHX_ OP *o)
1593 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1595 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1596 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1597 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1598 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1599 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1600 if (ckWARN(WARN_SYNTAX)) {
1601 const line_t oldline = CopLINE(PL_curcop);
1603 if (PL_parser && PL_parser->copline != NOLINE) {
1604 /* This ensures that warnings are reported at the first line
1605 of the conditional, not the last. */
1606 CopLINE_set(PL_curcop, PL_parser->copline);
1608 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1609 CopLINE_set(PL_curcop, oldline);
1616 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1619 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1620 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1622 const char funny = o->op_type == OP_PADAV
1623 || o->op_type == OP_RV2AV ? '@' : '%';
1624 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1626 if (cUNOPo->op_first->op_type != OP_GV
1627 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1629 return varname(gv, funny, 0, NULL, 0, subscript_type);
1632 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1637 S_op_varname(pTHX_ const OP *o)
1639 return S_op_varname_subscript(aTHX_ o, 1);
1643 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1644 { /* or not so pretty :-) */
1645 if (o->op_type == OP_CONST) {
1647 if (SvPOK(*retsv)) {
1649 *retsv = sv_newmortal();
1650 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1651 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1653 else if (!SvOK(*retsv))
1656 else *retpv = "...";
1660 S_scalar_slice_warning(pTHX_ const OP *o)
1664 o->op_type == OP_HSLICE ? '{' : '[';
1666 o->op_type == OP_HSLICE ? '}' : ']';
1668 SV *keysv = NULL; /* just to silence compiler warnings */
1669 const char *key = NULL;
1671 if (!(o->op_private & OPpSLICEWARNING))
1673 if (PL_parser && PL_parser->error_count)
1674 /* This warning can be nonsensical when there is a syntax error. */
1677 kid = cLISTOPo->op_first;
1678 kid = OpSIBLING(kid); /* get past pushmark */
1679 /* weed out false positives: any ops that can return lists */
1680 switch (kid->op_type) {
1706 /* Don't warn if we have a nulled list either. */
1707 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1710 assert(OpSIBLING(kid));
1711 name = S_op_varname(aTHX_ OpSIBLING(kid));
1712 if (!name) /* XS module fiddling with the op tree */
1714 S_op_pretty(aTHX_ kid, &keysv, &key);
1715 assert(SvPOK(name));
1716 sv_chop(name,SvPVX(name)+1);
1718 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1719 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1720 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1722 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1723 lbrack, key, rbrack);
1725 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1726 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1727 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1729 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1730 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1734 Perl_scalar(pTHX_ OP *o)
1738 /* assumes no premature commitment */
1739 if (!o || (PL_parser && PL_parser->error_count)
1740 || (o->op_flags & OPf_WANT)
1741 || o->op_type == OP_RETURN)
1746 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1748 switch (o->op_type) {
1750 scalar(cBINOPo->op_first);
1751 if (o->op_private & OPpREPEAT_DOLIST) {
1752 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1753 assert(kid->op_type == OP_PUSHMARK);
1754 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1755 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1756 o->op_private &=~ OPpREPEAT_DOLIST;
1763 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1773 if (o->op_flags & OPf_KIDS) {
1774 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1780 kid = cLISTOPo->op_first;
1782 kid = OpSIBLING(kid);
1785 OP *sib = OpSIBLING(kid);
1786 if (sib && kid->op_type != OP_LEAVEWHEN
1787 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1788 || ( sib->op_targ != OP_NEXTSTATE
1789 && sib->op_targ != OP_DBSTATE )))
1795 PL_curcop = &PL_compiling;
1800 kid = cLISTOPo->op_first;
1803 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1808 /* Warn about scalar context */
1809 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1810 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1813 const char *key = NULL;
1815 /* This warning can be nonsensical when there is a syntax error. */
1816 if (PL_parser && PL_parser->error_count)
1819 if (!ckWARN(WARN_SYNTAX)) break;
1821 kid = cLISTOPo->op_first;
1822 kid = OpSIBLING(kid); /* get past pushmark */
1823 assert(OpSIBLING(kid));
1824 name = S_op_varname(aTHX_ OpSIBLING(kid));
1825 if (!name) /* XS module fiddling with the op tree */
1827 S_op_pretty(aTHX_ kid, &keysv, &key);
1828 assert(SvPOK(name));
1829 sv_chop(name,SvPVX(name)+1);
1831 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1832 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1833 "%%%"SVf"%c%s%c in scalar context better written "
1835 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1836 lbrack, key, rbrack);
1838 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1839 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1840 "%%%"SVf"%c%"SVf"%c in scalar context better "
1841 "written as $%"SVf"%c%"SVf"%c",
1842 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1843 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1850 Perl_scalarvoid(pTHX_ OP *arg)
1856 SSize_t defer_stack_alloc = 0;
1857 SSize_t defer_ix = -1;
1858 OP **defer_stack = NULL;
1861 PERL_ARGS_ASSERT_SCALARVOID;
1864 SV *useless_sv = NULL;
1865 const char* useless = NULL;
1867 if (o->op_type == OP_NEXTSTATE
1868 || o->op_type == OP_DBSTATE
1869 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1870 || o->op_targ == OP_DBSTATE)))
1871 PL_curcop = (COP*)o; /* for warning below */
1873 /* assumes no premature commitment */
1874 want = o->op_flags & OPf_WANT;
1875 if ((want && want != OPf_WANT_SCALAR)
1876 || (PL_parser && PL_parser->error_count)
1877 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1882 if ((o->op_private & OPpTARGET_MY)
1883 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1885 /* newASSIGNOP has already applied scalar context, which we
1886 leave, as if this op is inside SASSIGN. */
1890 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1892 switch (o->op_type) {
1894 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1898 if (o->op_flags & OPf_STACKED)
1900 if (o->op_type == OP_REPEAT)
1901 scalar(cBINOPo->op_first);
1904 if (o->op_private == 4)
1939 case OP_GETSOCKNAME:
1940 case OP_GETPEERNAME:
1945 case OP_GETPRIORITY:
1970 useless = OP_DESC(o);
1980 case OP_AELEMFAST_LEX:
1984 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1985 /* Otherwise it's "Useless use of grep iterator" */
1986 useless = OP_DESC(o);
1990 kid = cLISTOPo->op_first;
1991 if (kid && kid->op_type == OP_PUSHRE
1993 && !(o->op_flags & OPf_STACKED)
1995 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
1997 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
2000 useless = OP_DESC(o);
2004 kid = cUNOPo->op_first;
2005 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2006 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2009 useless = "negative pattern binding (!~)";
2013 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2014 useless = "non-destructive substitution (s///r)";
2018 useless = "non-destructive transliteration (tr///r)";
2025 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2026 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2027 useless = "a variable";
2032 if (cSVOPo->op_private & OPpCONST_STRICT)
2033 no_bareword_allowed(o);
2035 if (ckWARN(WARN_VOID)) {
2037 /* don't warn on optimised away booleans, eg
2038 * use constant Foo, 5; Foo || print; */
2039 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2041 /* the constants 0 and 1 are permitted as they are
2042 conventionally used as dummies in constructs like
2043 1 while some_condition_with_side_effects; */
2044 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2046 else if (SvPOK(sv)) {
2047 SV * const dsv = newSVpvs("");
2049 = Perl_newSVpvf(aTHX_
2051 pv_pretty(dsv, SvPVX_const(sv),
2052 SvCUR(sv), 32, NULL, NULL,
2054 | PERL_PV_ESCAPE_NOCLEAR
2055 | PERL_PV_ESCAPE_UNI_DETECT));
2056 SvREFCNT_dec_NN(dsv);
2058 else if (SvOK(sv)) {
2059 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
2062 useless = "a constant (undef)";
2065 op_null(o); /* don't execute or even remember it */
2069 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2073 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2077 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2081 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2086 UNOP *refgen, *rv2cv;
2089 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2092 rv2gv = ((BINOP *)o)->op_last;
2093 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2096 refgen = (UNOP *)((BINOP *)o)->op_first;
2098 if (!refgen || (refgen->op_type != OP_REFGEN
2099 && refgen->op_type != OP_SREFGEN))
2102 exlist = (LISTOP *)refgen->op_first;
2103 if (!exlist || exlist->op_type != OP_NULL
2104 || exlist->op_targ != OP_LIST)
2107 if (exlist->op_first->op_type != OP_PUSHMARK
2108 && exlist->op_first != exlist->op_last)
2111 rv2cv = (UNOP*)exlist->op_last;
2113 if (rv2cv->op_type != OP_RV2CV)
2116 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2117 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2118 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2120 o->op_private |= OPpASSIGN_CV_TO_GV;
2121 rv2gv->op_private |= OPpDONT_INIT_GV;
2122 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2134 kid = cLOGOPo->op_first;
2135 if (kid->op_type == OP_NOT
2136 && (kid->op_flags & OPf_KIDS)) {
2137 if (o->op_type == OP_AND) {
2138 OpTYPE_set(o, OP_OR);
2140 OpTYPE_set(o, OP_AND);
2150 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2151 if (!(kid->op_flags & OPf_KIDS))
2158 if (o->op_flags & OPf_STACKED)
2165 if (!(o->op_flags & OPf_KIDS))
2176 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2177 if (!(kid->op_flags & OPf_KIDS))
2183 /* If the first kid after pushmark is something that the padrange
2184 optimisation would reject, then null the list and the pushmark.
2186 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2187 && ( !(kid = OpSIBLING(kid))
2188 || ( kid->op_type != OP_PADSV
2189 && kid->op_type != OP_PADAV
2190 && kid->op_type != OP_PADHV)
2191 || kid->op_private & ~OPpLVAL_INTRO
2192 || !(kid = OpSIBLING(kid))
2193 || ( kid->op_type != OP_PADSV
2194 && kid->op_type != OP_PADAV
2195 && kid->op_type != OP_PADHV)
2196 || kid->op_private & ~OPpLVAL_INTRO)
2198 op_null(cUNOPo->op_first); /* NULL the pushmark */
2199 op_null(o); /* NULL the list */
2211 /* mortalise it, in case warnings are fatal. */
2212 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2213 "Useless use of %"SVf" in void context",
2214 SVfARG(sv_2mortal(useless_sv)));
2217 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2218 "Useless use of %s in void context",
2221 } while ( (o = POP_DEFERRED_OP()) );
2223 Safefree(defer_stack);
2229 S_listkids(pTHX_ OP *o)
2231 if (o && o->op_flags & OPf_KIDS) {
2233 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2240 Perl_list(pTHX_ OP *o)
2244 /* assumes no premature commitment */
2245 if (!o || (o->op_flags & OPf_WANT)
2246 || (PL_parser && PL_parser->error_count)
2247 || o->op_type == OP_RETURN)
2252 if ((o->op_private & OPpTARGET_MY)
2253 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2255 return o; /* As if inside SASSIGN */
2258 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2260 switch (o->op_type) {
2262 list(cBINOPo->op_first);
2265 if (o->op_private & OPpREPEAT_DOLIST
2266 && !(o->op_flags & OPf_STACKED))
2268 list(cBINOPo->op_first);
2269 kid = cBINOPo->op_last;
2270 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2271 && SvIVX(kSVOP_sv) == 1)
2273 op_null(o); /* repeat */
2274 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2276 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2283 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2291 if (!(o->op_flags & OPf_KIDS))
2293 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2294 list(cBINOPo->op_first);
2295 return gen_constant_list(o);
2301 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2302 op_null(cUNOPo->op_first); /* NULL the pushmark */
2303 op_null(o); /* NULL the list */
2308 kid = cLISTOPo->op_first;
2310 kid = OpSIBLING(kid);
2313 OP *sib = OpSIBLING(kid);
2314 if (sib && kid->op_type != OP_LEAVEWHEN)
2320 PL_curcop = &PL_compiling;
2324 kid = cLISTOPo->op_first;
2331 S_scalarseq(pTHX_ OP *o)
2334 const OPCODE type = o->op_type;
2336 if (type == OP_LINESEQ || type == OP_SCOPE ||
2337 type == OP_LEAVE || type == OP_LEAVETRY)
2340 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2341 if ((sib = OpSIBLING(kid))
2342 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2343 || ( sib->op_targ != OP_NEXTSTATE
2344 && sib->op_targ != OP_DBSTATE )))
2349 PL_curcop = &PL_compiling;
2351 o->op_flags &= ~OPf_PARENS;
2352 if (PL_hints & HINT_BLOCK_SCOPE)
2353 o->op_flags |= OPf_PARENS;
2356 o = newOP(OP_STUB, 0);
2361 S_modkids(pTHX_ OP *o, I32 type)
2363 if (o && o->op_flags & OPf_KIDS) {
2365 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2366 op_lvalue(kid, type);
2372 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2373 * const fields. Also, convert CONST keys to HEK-in-SVs.
2374 * rop is the op that retrieves the hash;
2375 * key_op is the first key
2379 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2385 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2387 if (rop->op_first->op_type == OP_PADSV)
2388 /* @$hash{qw(keys here)} */
2389 rop = (UNOP*)rop->op_first;
2391 /* @{$hash}{qw(keys here)} */
2392 if (rop->op_first->op_type == OP_SCOPE
2393 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2395 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2402 lexname = NULL; /* just to silence compiler warnings */
2403 fields = NULL; /* just to silence compiler warnings */
2407 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2408 SvPAD_TYPED(lexname))
2409 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2410 && isGV(*fields) && GvHV(*fields);
2412 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2414 if (key_op->op_type != OP_CONST)
2416 svp = cSVOPx_svp(key_op);
2418 /* make sure it's not a bareword under strict subs */
2419 if (key_op->op_private & OPpCONST_BARE &&
2420 key_op->op_private & OPpCONST_STRICT)
2422 no_bareword_allowed((OP*)key_op);
2425 /* Make the CONST have a shared SV */
2426 if ( !SvIsCOW_shared_hash(sv = *svp)
2427 && SvTYPE(sv) < SVt_PVMG
2432 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2433 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2434 SvREFCNT_dec_NN(sv);
2439 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2441 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2442 "in variable %"PNf" of type %"HEKf,
2443 SVfARG(*svp), PNfARG(lexname),
2444 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2451 =for apidoc finalize_optree
2453 This function finalizes the optree. Should be called directly after
2454 the complete optree is built. It does some additional
2455 checking which can't be done in the normal C<ck_>xxx functions and makes
2456 the tree thread-safe.
2461 Perl_finalize_optree(pTHX_ OP* o)
2463 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2466 SAVEVPTR(PL_curcop);
2474 /* Relocate sv to the pad for thread safety.
2475 * Despite being a "constant", the SV is written to,
2476 * for reference counts, sv_upgrade() etc. */
2477 PERL_STATIC_INLINE void
2478 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2481 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2483 ix = pad_alloc(OP_CONST, SVf_READONLY);
2484 SvREFCNT_dec(PAD_SVl(ix));
2485 PAD_SETSV(ix, *svp);
2486 /* XXX I don't know how this isn't readonly already. */
2487 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2495 S_finalize_op(pTHX_ OP* o)
2497 PERL_ARGS_ASSERT_FINALIZE_OP;
2500 switch (o->op_type) {
2503 PL_curcop = ((COP*)o); /* for warnings */
2506 if (OpHAS_SIBLING(o)) {
2507 OP *sib = OpSIBLING(o);
2508 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2509 && ckWARN(WARN_EXEC)
2510 && OpHAS_SIBLING(sib))
2512 const OPCODE type = OpSIBLING(sib)->op_type;
2513 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2514 const line_t oldline = CopLINE(PL_curcop);
2515 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2516 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2517 "Statement unlikely to be reached");
2518 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2519 "\t(Maybe you meant system() when you said exec()?)\n");
2520 CopLINE_set(PL_curcop, oldline);
2527 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2528 GV * const gv = cGVOPo_gv;
2529 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2530 /* XXX could check prototype here instead of just carping */
2531 SV * const sv = sv_newmortal();
2532 gv_efullname3(sv, gv, NULL);
2533 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2534 "%"SVf"() called too early to check prototype",
2541 if (cSVOPo->op_private & OPpCONST_STRICT)
2542 no_bareword_allowed(o);
2546 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2551 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2552 case OP_METHOD_NAMED:
2553 case OP_METHOD_SUPER:
2554 case OP_METHOD_REDIR:
2555 case OP_METHOD_REDIR_SUPER:
2556 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2565 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2568 rop = (UNOP*)((BINOP*)o)->op_first;
2573 S_scalar_slice_warning(aTHX_ o);
2577 kid = OpSIBLING(cLISTOPo->op_first);
2578 if (/* I bet there's always a pushmark... */
2579 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2580 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2585 key_op = (SVOP*)(kid->op_type == OP_CONST
2587 : OpSIBLING(kLISTOP->op_first));
2589 rop = (UNOP*)((LISTOP*)o)->op_last;
2592 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2594 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
2598 S_scalar_slice_warning(aTHX_ o);
2602 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2603 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2610 if (o->op_flags & OPf_KIDS) {
2614 /* check that op_last points to the last sibling, and that
2615 * the last op_sibling/op_sibparent field points back to the
2616 * parent, and that the only ops with KIDS are those which are
2617 * entitled to them */
2618 U32 type = o->op_type;
2622 if (type == OP_NULL) {
2624 /* ck_glob creates a null UNOP with ex-type GLOB
2625 * (which is a list op. So pretend it wasn't a listop */
2626 if (type == OP_GLOB)
2629 family = PL_opargs[type] & OA_CLASS_MASK;
2631 has_last = ( family == OA_BINOP
2632 || family == OA_LISTOP
2633 || family == OA_PMOP
2634 || family == OA_LOOP
2636 assert( has_last /* has op_first and op_last, or ...
2637 ... has (or may have) op_first: */
2638 || family == OA_UNOP
2639 || family == OA_UNOP_AUX
2640 || family == OA_LOGOP
2641 || family == OA_BASEOP_OR_UNOP
2642 || family == OA_FILESTATOP
2643 || family == OA_LOOPEXOP
2644 || family == OA_METHOP
2645 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2646 || type == OP_SASSIGN
2647 || type == OP_CUSTOM
2648 || type == OP_NULL /* new_logop does this */
2651 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
2652 # ifdef PERL_OP_PARENT
2653 if (!OpHAS_SIBLING(kid)) {
2655 assert(kid == cLISTOPo->op_last);
2656 assert(kid->op_sibparent == o);
2659 if (has_last && !OpHAS_SIBLING(kid))
2660 assert(kid == cLISTOPo->op_last);
2665 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
2671 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2673 Propagate lvalue ("modifiable") context to an op and its children.
2674 C<type> represents the context type, roughly based on the type of op that
2675 would do the modifying, although C<local()> is represented by C<OP_NULL>,
2676 because it has no op type of its own (it is signalled by a flag on
2679 This function detects things that can't be modified, such as C<$x+1>, and
2680 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2681 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
2683 It also flags things that need to behave specially in an lvalue context,
2684 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2690 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2693 PadnameLVALUE_on(pn);
2694 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2696 /* RT #127786: cv can be NULL due to an eval within the DB package
2697 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2698 * unless they contain an eval, but calling eval within DB
2699 * pretends the eval was done in the caller's scope.
2703 assert(CvPADLIST(cv));
2705 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2706 assert(PadnameLEN(pn));
2707 PadnameLVALUE_on(pn);
2712 S_vivifies(const OPCODE type)
2715 case OP_RV2AV: case OP_ASLICE:
2716 case OP_RV2HV: case OP_KVASLICE:
2717 case OP_RV2SV: case OP_HSLICE:
2718 case OP_AELEMFAST: case OP_KVHSLICE:
2727 S_lvref(pTHX_ OP *o, I32 type)
2731 switch (o->op_type) {
2733 for (kid = OpSIBLING(cUNOPo->op_first); kid;
2734 kid = OpSIBLING(kid))
2735 S_lvref(aTHX_ kid, type);
2740 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2741 o->op_flags |= OPf_STACKED;
2742 if (o->op_flags & OPf_PARENS) {
2743 if (o->op_private & OPpLVAL_INTRO) {
2744 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2745 "localized parenthesized array in list assignment"));
2749 OpTYPE_set(o, OP_LVAVREF);
2750 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2751 o->op_flags |= OPf_MOD|OPf_REF;
2754 o->op_private |= OPpLVREF_AV;
2757 kid = cUNOPo->op_first;
2758 if (kid->op_type == OP_NULL)
2759 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2761 o->op_private = OPpLVREF_CV;
2762 if (kid->op_type == OP_GV)
2763 o->op_flags |= OPf_STACKED;
2764 else if (kid->op_type == OP_PADCV) {
2765 o->op_targ = kid->op_targ;
2767 op_free(cUNOPo->op_first);
2768 cUNOPo->op_first = NULL;
2769 o->op_flags &=~ OPf_KIDS;
2774 if (o->op_flags & OPf_PARENS) {
2776 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2777 "parenthesized hash in list assignment"));
2780 o->op_private |= OPpLVREF_HV;
2784 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2785 o->op_flags |= OPf_STACKED;
2788 if (o->op_flags & OPf_PARENS) goto parenhash;
2789 o->op_private |= OPpLVREF_HV;
2792 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2795 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2796 if (o->op_flags & OPf_PARENS) goto slurpy;
2797 o->op_private |= OPpLVREF_AV;
2801 o->op_private |= OPpLVREF_ELEM;
2802 o->op_flags |= OPf_STACKED;
2806 OpTYPE_set(o, OP_LVREFSLICE);
2807 o->op_private &= OPpLVAL_INTRO;
2810 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2812 else if (!(o->op_flags & OPf_KIDS))
2814 if (o->op_targ != OP_LIST) {
2815 S_lvref(aTHX_ cBINOPo->op_first, type);
2820 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
2821 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2822 S_lvref(aTHX_ kid, type);
2826 if (o->op_flags & OPf_PARENS)
2831 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2832 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2833 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2838 OpTYPE_set(o, OP_LVREF);
2840 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2841 if (type == OP_ENTERLOOP)
2842 o->op_private |= OPpLVREF_ITER;
2845 PERL_STATIC_INLINE bool
2846 S_potential_mod_type(I32 type)
2848 /* Types that only potentially result in modification. */
2849 return type == OP_GREPSTART || type == OP_ENTERSUB
2850 || type == OP_REFGEN || type == OP_LEAVESUBLV;
2854 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2858 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2861 if (!o || (PL_parser && PL_parser->error_count))
2864 if ((o->op_private & OPpTARGET_MY)
2865 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2870 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2872 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2874 switch (o->op_type) {
2879 if ((o->op_flags & OPf_PARENS))
2883 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2884 !(o->op_flags & OPf_STACKED)) {
2885 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
2886 assert(cUNOPo->op_first->op_type == OP_NULL);
2887 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2890 else { /* lvalue subroutine call */
2891 o->op_private |= OPpLVAL_INTRO;
2892 PL_modcount = RETURN_UNLIMITED_NUMBER;
2893 if (S_potential_mod_type(type)) {
2894 o->op_private |= OPpENTERSUB_INARGS;
2897 else { /* Compile-time error message: */
2898 OP *kid = cUNOPo->op_first;
2903 if (kid->op_type != OP_PUSHMARK) {
2904 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2906 "panic: unexpected lvalue entersub "
2907 "args: type/targ %ld:%"UVuf,
2908 (long)kid->op_type, (UV)kid->op_targ);
2909 kid = kLISTOP->op_first;
2911 while (OpHAS_SIBLING(kid))
2912 kid = OpSIBLING(kid);
2913 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2914 break; /* Postpone until runtime */
2917 kid = kUNOP->op_first;
2918 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2919 kid = kUNOP->op_first;
2920 if (kid->op_type == OP_NULL)
2922 "Unexpected constant lvalue entersub "
2923 "entry via type/targ %ld:%"UVuf,
2924 (long)kid->op_type, (UV)kid->op_targ);
2925 if (kid->op_type != OP_GV) {
2932 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2933 ? MUTABLE_CV(SvRV(gv))
2939 if (flags & OP_LVALUE_NO_CROAK)
2942 namesv = cv_name(cv, NULL, 0);
2943 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
2944 "subroutine call of &%"SVf" in %s",
2945 SVfARG(namesv), PL_op_desc[type]),
2953 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2954 /* grep, foreach, subcalls, refgen */
2955 if (S_potential_mod_type(type))
2957 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2958 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2961 type ? PL_op_desc[type] : "local"));
2974 case OP_RIGHT_SHIFT:
2983 if (!(o->op_flags & OPf_STACKED))
2989 if (o->op_flags & OPf_STACKED) {
2993 if (!(o->op_private & OPpREPEAT_DOLIST))
2996 const I32 mods = PL_modcount;
2997 modkids(cBINOPo->op_first, type);
2998 if (type != OP_AASSIGN)
3000 kid = cBINOPo->op_last;
3001 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3002 const IV iv = SvIV(kSVOP_sv);
3003 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3005 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3008 PL_modcount = RETURN_UNLIMITED_NUMBER;
3014 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3015 op_lvalue(kid, type);
3020 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3021 PL_modcount = RETURN_UNLIMITED_NUMBER;
3022 return o; /* Treat \(@foo) like ordinary list. */
3026 if (scalar_mod_type(o, type))
3028 ref(cUNOPo->op_first, o->op_type);
3035 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3036 if (type == OP_LEAVESUBLV && (
3037 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3038 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3040 o->op_private |= OPpMAYBE_LVSUB;
3044 PL_modcount = RETURN_UNLIMITED_NUMBER;
3049 if (type == OP_LEAVESUBLV)
3050 o->op_private |= OPpMAYBE_LVSUB;
3053 if (type == OP_LEAVESUBLV
3054 && (o->op_private & 3) + OP_EACH == OP_KEYS)
3055 o->op_private |= OPpMAYBE_LVSUB;
3058 PL_hints |= HINT_BLOCK_SCOPE;
3059 if (type == OP_LEAVESUBLV)
3060 o->op_private |= OPpMAYBE_LVSUB;
3064 ref(cUNOPo->op_first, o->op_type);
3068 PL_hints |= HINT_BLOCK_SCOPE;
3078 case OP_AELEMFAST_LEX:
3085 PL_modcount = RETURN_UNLIMITED_NUMBER;
3086 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3087 return o; /* Treat \(@foo) like ordinary list. */
3088 if (scalar_mod_type(o, type))
3090 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3091 && type == OP_LEAVESUBLV)
3092 o->op_private |= OPpMAYBE_LVSUB;
3096 if (!type) /* local() */
3097 Perl_croak(aTHX_ "Can't localize lexical variable %"PNf,
3098 PNfARG(PAD_COMPNAME(o->op_targ)));
3099 if (!(o->op_private & OPpLVAL_INTRO)
3100 || ( type != OP_SASSIGN && type != OP_AASSIGN
3101 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3102 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3110 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3114 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3120 if (type == OP_LEAVESUBLV)
3121 o->op_private |= OPpMAYBE_LVSUB;
3122 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3123 /* substr and vec */
3124 /* If this op is in merely potential (non-fatal) modifiable
3125 context, then apply OP_ENTERSUB context to
3126 the kid op (to avoid croaking). Other-
3127 wise pass this op’s own type so the correct op is mentioned
3128 in error messages. */
3129 op_lvalue(OpSIBLING(cBINOPo->op_first),
3130 S_potential_mod_type(type)
3138 ref(cBINOPo->op_first, o->op_type);
3139 if (type == OP_ENTERSUB &&
3140 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3141 o->op_private |= OPpLVAL_DEFER;
3142 if (type == OP_LEAVESUBLV)
3143 o->op_private |= OPpMAYBE_LVSUB;
3150 o->op_private |= OPpLVALUE;
3156 if (o->op_flags & OPf_KIDS)
3157 op_lvalue(cLISTOPo->op_last, type);
3162 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3164 else if (!(o->op_flags & OPf_KIDS))
3166 if (o->op_targ != OP_LIST) {
3167 op_lvalue(cBINOPo->op_first, type);
3173 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3174 /* elements might be in void context because the list is
3175 in scalar context or because they are attribute sub calls */
3176 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
3177 op_lvalue(kid, type);
3185 if (type == OP_LEAVESUBLV
3186 || !S_vivifies(cLOGOPo->op_first->op_type))
3187 op_lvalue(cLOGOPo->op_first, type);
3188 if (type == OP_LEAVESUBLV
3189 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3190 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
3194 if (type == OP_NULL) { /* local */
3196 if (!FEATURE_MYREF_IS_ENABLED)
3197 Perl_croak(aTHX_ "The experimental declared_refs "
3198 "feature is not enabled");
3199 Perl_ck_warner_d(aTHX_
3200 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3201 "Declaring references is experimental");
3202 op_lvalue(cUNOPo->op_first, OP_NULL);
3205 if (type != OP_AASSIGN && type != OP_SASSIGN
3206 && type != OP_ENTERLOOP)
3208 /* Don’t bother applying lvalue context to the ex-list. */
3209 kid = cUNOPx(cUNOPo->op_first)->op_first;
3210 assert (!OpHAS_SIBLING(kid));
3213 if (type == OP_NULL) /* local */
3215 if (type != OP_AASSIGN) goto nomod;
3216 kid = cUNOPo->op_first;
3219 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3220 S_lvref(aTHX_ kid, type);
3221 if (!PL_parser || PL_parser->error_count == ec) {
3222 if (!FEATURE_REFALIASING_IS_ENABLED)
3224 "Experimental aliasing via reference not enabled");
3225 Perl_ck_warner_d(aTHX_
3226 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3227 "Aliasing via reference is experimental");
3230 if (o->op_type == OP_REFGEN)
3231 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3236 kid = cLISTOPo->op_first;
3237 if (kid && kid->op_type == OP_PUSHRE &&
3239 || o->op_flags & OPf_STACKED
3241 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
3243 || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
3246 /* This is actually @array = split. */
3247 PL_modcount = RETURN_UNLIMITED_NUMBER;
3253 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3257 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3258 their argument is a filehandle; thus \stat(".") should not set
3260 if (type == OP_REFGEN &&
3261 PL_check[o->op_type] == Perl_ck_ftst)
3264 if (type != OP_LEAVESUBLV)
3265 o->op_flags |= OPf_MOD;
3267 if (type == OP_AASSIGN || type == OP_SASSIGN)
3268 o->op_flags |= OPf_SPECIAL|OPf_REF;
3269 else if (!type) { /* local() */
3272 o->op_private |= OPpLVAL_INTRO;
3273 o->op_flags &= ~OPf_SPECIAL;
3274 PL_hints |= HINT_BLOCK_SCOPE;
3279 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3280 "Useless localization of %s", OP_DESC(o));
3283 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3284 && type != OP_LEAVESUBLV)
3285 o->op_flags |= OPf_REF;
3290 S_scalar_mod_type(const OP *o, I32 type)
3295 if (o && o->op_type == OP_RV2GV)
3319 case OP_RIGHT_SHIFT:
3348 S_is_handle_constructor(const OP *o, I32 numargs)
3350 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3352 switch (o->op_type) {
3360 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3373 S_refkids(pTHX_ OP *o, I32 type)
3375 if (o && o->op_flags & OPf_KIDS) {
3377 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3384 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3389 PERL_ARGS_ASSERT_DOREF;
3391 if (PL_parser && PL_parser->error_count)
3394 switch (o->op_type) {
3396 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3397 !(o->op_flags & OPf_STACKED)) {
3398 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3399 assert(cUNOPo->op_first->op_type == OP_NULL);
3400 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
3401 o->op_flags |= OPf_SPECIAL;
3403 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3404 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3405 : type == OP_RV2HV ? OPpDEREF_HV
3407 o->op_flags |= OPf_MOD;
3413 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
3414 doref(kid, type, set_op_ref);
3417 if (type == OP_DEFINED)
3418 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3419 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3422 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3423 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3424 : type == OP_RV2HV ? OPpDEREF_HV
3426 o->op_flags |= OPf_MOD;
3433 o->op_flags |= OPf_REF;
3436 if (type == OP_DEFINED)
3437 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3438 doref(cUNOPo->op_first, o->op_type, set_op_ref);
3444 o->op_flags |= OPf_REF;
3449 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3451 doref(cBINOPo->op_first, type, set_op_ref);
3455 doref(cBINOPo->op_first, o->op_type, set_op_ref);
3456 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3457 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3458 : type == OP_RV2HV ? OPpDEREF_HV
3460 o->op_flags |= OPf_MOD;
3470 if (!(o->op_flags & OPf_KIDS))
3472 doref(cLISTOPo->op_last, type, set_op_ref);
3482 S_dup_attrlist(pTHX_ OP *o)
3486 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3488 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3489 * where the first kid is OP_PUSHMARK and the remaining ones
3490 * are OP_CONST. We need to push the OP_CONST values.
3492 if (o->op_type == OP_CONST)
3493 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3495 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3497 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3498 if (o->op_type == OP_CONST)
3499 rop = op_append_elem(OP_LIST, rop,
3500 newSVOP(OP_CONST, o->op_flags,
3501 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3508 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3510 PERL_ARGS_ASSERT_APPLY_ATTRS;
3512 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3514 /* fake up C<use attributes $pkg,$rv,@attrs> */
3516 #define ATTRSMODULE "attributes"
3517 #define ATTRSMODULE_PM "attributes.pm"
3520 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3521 newSVpvs(ATTRSMODULE),
3523 op_prepend_elem(OP_LIST,
3524 newSVOP(OP_CONST, 0, stashsv),
3525 op_prepend_elem(OP_LIST,
3526 newSVOP(OP_CONST, 0,
3528 dup_attrlist(attrs))));
3533 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3535 OP *pack, *imop, *arg;
3536 SV *meth, *stashsv, **svp;
3538 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3543 assert(target->op_type == OP_PADSV ||
3544 target->op_type == OP_PADHV ||
3545 target->op_type == OP_PADAV);
3547 /* Ensure that attributes.pm is loaded. */
3548 /* Don't force the C<use> if we don't need it. */
3549 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3550 if (svp && *svp != &PL_sv_undef)
3551 NOOP; /* already in %INC */
3553 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3554 newSVpvs(ATTRSMODULE), NULL);
3556 /* Need package name for method call. */
3557 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3559 /* Build up the real arg-list. */
3560 stashsv = newSVhek(HvNAME_HEK(stash));
3562 arg = newOP(OP_PADSV, 0);
3563 arg->op_targ = target->op_targ;
3564 arg = op_prepend_elem(OP_LIST,
3565 newSVOP(OP_CONST, 0, stashsv),
3566 op_prepend_elem(OP_LIST,
3567 newUNOP(OP_REFGEN, 0,
3569 dup_attrlist(attrs)));
3571 /* Fake up a method call to import */
3572 meth = newSVpvs_share("import");
3573 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3574 op_append_elem(OP_LIST,
3575 op_prepend_elem(OP_LIST, pack, arg),
3576 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3578 /* Combine the ops. */
3579 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3583 =notfor apidoc apply_attrs_string
3585 Attempts to apply a list of attributes specified by the C<attrstr> and
3586 C<len> arguments to the subroutine identified by the C<cv> argument which
3587 is expected to be associated with the package identified by the C<stashpv>
3588 argument (see L<attributes>). It gets this wrong, though, in that it
3589 does not correctly identify the boundaries of the individual attribute
3590 specifications within C<attrstr>. This is not really intended for the
3591 public API, but has to be listed here for systems such as AIX which
3592 need an explicit export list for symbols. (It's called from XS code
3593 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3594 to respect attribute syntax properly would be welcome.
3600 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3601 const char *attrstr, STRLEN len)
3605 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3608 len = strlen(attrstr);
3612 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3614 const char * const sstr = attrstr;
3615 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3616 attrs = op_append_elem(OP_LIST, attrs,
3617 newSVOP(OP_CONST, 0,
3618 newSVpvn(sstr, attrstr-sstr)));
3622 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3623 newSVpvs(ATTRSMODULE),
3624 NULL, op_prepend_elem(OP_LIST,
3625 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3626 op_prepend_elem(OP_LIST,
3627 newSVOP(OP_CONST, 0,
3628 newRV(MUTABLE_SV(cv))),
3633 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3635 OP *new_proto = NULL;
3640 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3646 if (o->op_type == OP_CONST) {
3647 pv = SvPV(cSVOPo_sv, pvlen);
3648 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3649 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3650 SV ** const tmpo = cSVOPx_svp(o);
3651 SvREFCNT_dec(cSVOPo_sv);
3656 } else if (o->op_type == OP_LIST) {
3658 assert(o->op_flags & OPf_KIDS);
3659 lasto = cLISTOPo->op_first;
3660 assert(lasto->op_type == OP_PUSHMARK);
3661 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3662 if (o->op_type == OP_CONST) {
3663 pv = SvPV(cSVOPo_sv, pvlen);
3664 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3665 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3666 SV ** const tmpo = cSVOPx_svp(o);
3667 SvREFCNT_dec(cSVOPo_sv);
3669 if (new_proto && ckWARN(WARN_MISC)) {
3671 const char * newp = SvPV(cSVOPo_sv, new_len);
3672 Perl_warner(aTHX_ packWARN(WARN_MISC),
3673 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3674 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3680 /* excise new_proto from the list */
3681 op_sibling_splice(*attrs, lasto, 1, NULL);
3688 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3689 would get pulled in with no real need */
3690 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3699 svname = sv_newmortal();
3700 gv_efullname3(svname, name, NULL);
3702 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3703 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3705 svname = (SV *)name;
3706 if (ckWARN(WARN_ILLEGALPROTO))
3707 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3708 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3709 STRLEN old_len, new_len;
3710 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3711 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3713 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3714 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3716 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3717 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3727 S_cant_declare(pTHX_ OP *o)
3729 if (o->op_type == OP_NULL
3730 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3731 o = cUNOPo->op_first;
3732 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3733 o->op_type == OP_NULL
3734 && o->op_flags & OPf_SPECIAL
3737 PL_parser->in_my == KEY_our ? "our" :
3738 PL_parser->in_my == KEY_state ? "state" :
3743 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3746 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3748 PERL_ARGS_ASSERT_MY_KID;
3750 if (!o || (PL_parser && PL_parser->error_count))
3755 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
3757 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3758 my_kid(kid, attrs, imopsp);
3760 } else if (type == OP_UNDEF || type == OP_STUB) {
3762 } else if (type == OP_RV2SV || /* "our" declaration */
3765 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3766 S_cant_declare(aTHX_ o);
3768 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3770 PL_parser->in_my = FALSE;
3771 PL_parser->in_my_stash = NULL;
3772 apply_attrs(GvSTASH(gv),
3773 (type == OP_RV2SV ? GvSV(gv) :
3774 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3775 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3778 o->op_private |= OPpOUR_INTRO;
3781 else if (type == OP_REFGEN || type == OP_SREFGEN) {
3782 if (!FEATURE_MYREF_IS_ENABLED)
3783 Perl_croak(aTHX_ "The experimental declared_refs "
3784 "feature is not enabled");
3785 Perl_ck_warner_d(aTHX_
3786 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3787 "Declaring references is experimental");
3788 /* Kid is a nulled OP_LIST, handled above. */
3789 my_kid(cUNOPo->op_first, attrs, imopsp);
3792 else if (type != OP_PADSV &&
3795 type != OP_PUSHMARK)
3797 S_cant_declare(aTHX_ o);
3800 else if (attrs && type != OP_PUSHMARK) {
3804 PL_parser->in_my = FALSE;
3805 PL_parser->in_my_stash = NULL;
3807 /* check for C<my Dog $spot> when deciding package */
3808 stash = PAD_COMPNAME_TYPE(o->op_targ);
3810 stash = PL_curstash;
3811 apply_attrs_my(stash, o, attrs, imopsp);
3813 o->op_flags |= OPf_MOD;
3814 o->op_private |= OPpLVAL_INTRO;
3816 o->op_private |= OPpPAD_STATE;
3821 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3824 int maybe_scalar = 0;
3826 PERL_ARGS_ASSERT_MY_ATTRS;
3828 /* [perl #17376]: this appears to be premature, and results in code such as
3829 C< our(%x); > executing in list mode rather than void mode */
3831 if (o->op_flags & OPf_PARENS)
3841 o = my_kid(o, attrs, &rops);
3843 if (maybe_scalar && o->op_type == OP_PADSV) {
3844 o = scalar(op_append_list(OP_LIST, rops, o));
3845 o->op_private |= OPpLVAL_INTRO;
3848 /* The listop in rops might have a pushmark at the beginning,
3849 which will mess up list assignment. */
3850 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3851 if (rops->op_type == OP_LIST &&
3852 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3854 OP * const pushmark = lrops->op_first;
3855 /* excise pushmark */
3856 op_sibling_splice(rops, NULL, 1, NULL);
3859 o = op_append_list(OP_LIST, o, rops);
3862 PL_parser->in_my = FALSE;
3863 PL_parser->in_my_stash = NULL;
3868 Perl_sawparens(pTHX_ OP *o)
3870 PERL_UNUSED_CONTEXT;
3872 o->op_flags |= OPf_PARENS;
3877 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3881 const OPCODE ltype = left->op_type;
3882 const OPCODE rtype = right->op_type;
3884 PERL_ARGS_ASSERT_BIND_MATCH;
3886 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3887 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3889 const char * const desc
3891 rtype == OP_SUBST || rtype == OP_TRANS
3892 || rtype == OP_TRANSR
3894 ? (int)rtype : OP_MATCH];
3895 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3897 S_op_varname(aTHX_ left);
3899 Perl_warner(aTHX_ packWARN(WARN_MISC),
3900 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3901 desc, SVfARG(name), SVfARG(name));
3903 const char * const sample = (isary
3904 ? "@array" : "%hash");
3905 Perl_warner(aTHX_ packWARN(WARN_MISC),
3906 "Applying %s to %s will act on scalar(%s)",
3907 desc, sample, sample);
3911 if (rtype == OP_CONST &&
3912 cSVOPx(right)->op_private & OPpCONST_BARE &&
3913 cSVOPx(right)->op_private & OPpCONST_STRICT)
3915 no_bareword_allowed(right);
3918 /* !~ doesn't make sense with /r, so error on it for now */
3919 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3921 /* diag_listed_as: Using !~ with %s doesn't make sense */
3922 yyerror("Using !~ with s///r doesn't make sense");
3923 if (rtype == OP_TRANSR && type == OP_NOT)
3924 /* diag_listed_as: Using !~ with %s doesn't make sense */
3925 yyerror("Using !~ with tr///r doesn't make sense");
3927 ismatchop = (rtype == OP_MATCH ||
3928 rtype == OP_SUBST ||
3929 rtype == OP_TRANS || rtype == OP_TRANSR)
3930 && !(right->op_flags & OPf_SPECIAL);
3931 if (ismatchop && right->op_private & OPpTARGET_MY) {
3933 right->op_private &= ~OPpTARGET_MY;
3935 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
3936 if (left->op_type == OP_PADSV
3937 && !(left->op_private & OPpLVAL_INTRO))
3939 right->op_targ = left->op_targ;
3944 right->op_flags |= OPf_STACKED;
3945 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3946 ! (rtype == OP_TRANS &&
3947 right->op_private & OPpTRANS_IDENTICAL) &&
3948 ! (rtype == OP_SUBST &&
3949 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3950 left = op_lvalue(left, rtype);
3951 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3952 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
3954 o = op_prepend_elem(rtype, scalar(left), right);
3957 return newUNOP(OP_NOT, 0, scalar(o));
3961 return bind_match(type, left,
3962 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
3966 Perl_invert(pTHX_ OP *o)
3970 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3974 =for apidoc Amx|OP *|op_scope|OP *o
3976 Wraps up an op tree with some additional ops so that at runtime a dynamic
3977 scope will be created. The original ops run in the new dynamic scope,
3978 and then, provided that they exit normally, the scope will be unwound.
3979 The additional ops used to create and unwind the dynamic scope will
3980 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3981 instead if the ops are simple enough to not need the full dynamic scope
3988 Perl_op_scope(pTHX_ OP *o)
3992 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3993 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3994 OpTYPE_set(o, OP_LEAVE);
3996 else if (o->op_type == OP_LINESEQ) {
3998 OpTYPE_set(o, OP_SCOPE);
3999 kid = ((LISTOP*)o)->op_first;
4000 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4003 /* The following deals with things like 'do {1 for 1}' */
4004 kid = OpSIBLING(kid);
4006 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4011 o = newLISTOP(OP_SCOPE, 0, o, NULL);
4017 Perl_op_unscope(pTHX_ OP *o)
4019 if (o && o->op_type == OP_LINESEQ) {
4020 OP *kid = cLISTOPo->op_first;
4021 for(; kid; kid = OpSIBLING(kid))
4022 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4029 =for apidoc Am|int|block_start|int full
4031 Handles compile-time scope entry.
4032 Arranges for hints to be restored on block
4033 exit and also handles pad sequence numbers to make lexical variables scope
4034 right. Returns a savestack index for use with C<block_end>.
4040 Perl_block_start(pTHX_ int full)
4042 const int retval = PL_savestack_ix;
4044 PL_compiling.cop_seq = PL_cop_seqmax;
4046 pad_block_start(full);
4048 PL_hints &= ~HINT_BLOCK_SCOPE;
4049 SAVECOMPILEWARNINGS();
4050 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4051 SAVEI32(PL_compiling.cop_seq);
4052 PL_compiling.cop_seq = 0;
4054 CALL_BLOCK_HOOKS(bhk_start, full);
4060 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
4062 Handles compile-time scope exit. C<floor>
4063 is the savestack index returned by
4064 C<block_start>, and C<seq> is the body of the block. Returns the block,
4071 Perl_block_end(pTHX_ I32 floor, OP *seq)
4073 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4074 OP* retval = scalarseq(seq);
4077 /* XXX Is the null PL_parser check necessary here? */
4078 assert(PL_parser); /* Let’s find out under debugging builds. */
4079 if (PL_parser && PL_parser->parsed_sub) {
4080 o = newSTATEOP(0, NULL, NULL);
4082 retval = op_append_elem(OP_LINESEQ, retval, o);
4085 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4089 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4093 /* pad_leavemy has created a sequence of introcv ops for all my
4094 subs declared in the block. We have to replicate that list with
4095 clonecv ops, to deal with this situation:
4100 sub s1 { state sub foo { \&s2 } }
4103 Originally, I was going to have introcv clone the CV and turn
4104 off the stale flag. Since &s1 is declared before &s2, the
4105 introcv op for &s1 is executed (on sub entry) before the one for
4106 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
4107 cloned, since it is a state sub) closes over &s2 and expects
4108 to see it in its outer CV’s pad. If the introcv op clones &s1,
4109 then &s2 is still marked stale. Since &s1 is not active, and
4110 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4111 ble will not stay shared’ warning. Because it is the same stub
4112 that will be used when the introcv op for &s2 is executed, clos-
4113 ing over it is safe. Hence, we have to turn off the stale flag
4114 on all lexical subs in the block before we clone any of them.
4115 Hence, having introcv clone the sub cannot work. So we create a
4116 list of ops like this:
4140 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4141 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4142 for (;; kid = OpSIBLING(kid)) {
4143 OP *newkid = newOP(OP_CLONECV, 0);
4144 newkid->op_targ = kid->op_targ;
4145 o = op_append_elem(OP_LINESEQ, o, newkid);
4146 if (kid == last) break;
4148 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4151 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4157 =head1 Compile-time scope hooks
4159 =for apidoc Aox||blockhook_register
4161 Register a set of hooks to be called when the Perl lexical scope changes
4162 at compile time. See L<perlguts/"Compile-time scope hooks">.
4168 Perl_blockhook_register(pTHX_ BHK *hk)
4170 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4172 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4176 Perl_newPROG(pTHX_ OP *o)
4178 PERL_ARGS_ASSERT_NEWPROG;
4185 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4186 ((PL_in_eval & EVAL_KEEPERR)
4187 ? OPf_SPECIAL : 0), o);
4190 assert(CxTYPE(cx) == CXt_EVAL);
4192 if ((cx->blk_gimme & G_WANT) == G_VOID)
4193 scalarvoid(PL_eval_root);
4194 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
4197 scalar(PL_eval_root);
4199 PL_eval_start = op_linklist(PL_eval_root);
4200 PL_eval_root->op_private |= OPpREFCOUNTED;
4201 OpREFCNT_set(PL_eval_root, 1);
4202 PL_eval_root->op_next = 0;
4203 i = PL_savestack_ix;
4206 CALL_PEEP(PL_eval_start);
4207 finalize_optree(PL_eval_root);
4208 S_prune_chain_head(&PL_eval_start);
4210 PL_savestack_ix = i;
4213 if (o->op_type == OP_STUB) {
4214 /* This block is entered if nothing is compiled for the main
4215 program. This will be the case for an genuinely empty main
4216 program, or one which only has BEGIN blocks etc, so already
4219 Historically (5.000) the guard above was !o. However, commit
4220 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4221 c71fccf11fde0068, changed perly.y so that newPROG() is now
4222 called with the output of block_end(), which returns a new
4223 OP_STUB for the case of an empty optree. ByteLoader (and
4224 maybe other things) also take this path, because they set up
4225 PL_main_start and PL_main_root directly, without generating an
4228 If the parsing the main program aborts (due to parse errors,
4229 or due to BEGIN or similar calling exit), then newPROG()
4230 isn't even called, and hence this code path and its cleanups
4231 are skipped. This shouldn't make a make a difference:
4232 * a non-zero return from perl_parse is a failure, and
4233 perl_destruct() should be called immediately.
4234 * however, if exit(0) is called during the parse, then
4235 perl_parse() returns 0, and perl_run() is called. As
4236 PL_main_start will be NULL, perl_run() will return
4237 promptly, and the exit code will remain 0.
4240 PL_comppad_name = 0;
4242 S_op_destroy(aTHX_ o);
4245 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4246 PL_curcop = &PL_compiling;
4247 PL_main_start = LINKLIST(PL_main_root);
4248 PL_main_root->op_private |= OPpREFCOUNTED;
4249 OpREFCNT_set(PL_main_root, 1);
4250 PL_main_root->op_next = 0;
4251 CALL_PEEP(PL_main_start);
4252 finalize_optree(PL_main_root);
4253 S_prune_chain_head(&PL_main_start);
4254 cv_forget_slab(PL_compcv);
4257 /* Register with debugger */
4259 CV * const cv = get_cvs("DB::postponed", 0);
4263 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4265 call_sv(MUTABLE_SV(cv), G_DISCARD);
4272 Perl_localize(pTHX_ OP *o, I32 lex)
4274 PERL_ARGS_ASSERT_LOCALIZE;
4276 if (o->op_flags & OPf_PARENS)
4277 /* [perl #17376]: this appears to be premature, and results in code such as
4278 C< our(%x); > executing in list mode rather than void mode */
4285 if ( PL_parser->bufptr > PL_parser->oldbufptr
4286 && PL_parser->bufptr[-1] == ','
4287 && ckWARN(WARN_PARENTHESIS))
4289 char *s = PL_parser->bufptr;
4292 /* some heuristics to detect a potential error */
4293 while (*s && (strchr(", \t\n", *s)))
4297 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
4299 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4302 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4304 while (*s && (strchr(", \t\n", *s)))
4310 if (sigil && (*s == ';' || *s == '=')) {
4311 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4312 "Parentheses missing around \"%s\" list",
4314 ? (PL_parser->in_my == KEY_our
4316 : PL_parser->in_my == KEY_state
4326 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4327 PL_parser->in_my = FALSE;
4328 PL_parser->in_my_stash = NULL;
4333 Perl_jmaybe(pTHX_ OP *o)
4335 PERL_ARGS_ASSERT_JMAYBE;
4337 if (o->op_type == OP_LIST) {
4339 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4340 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4345 PERL_STATIC_INLINE OP *
4346 S_op_std_init(pTHX_ OP *o)
4348 I32 type = o->op_type;
4350 PERL_ARGS_ASSERT_OP_STD_INIT;
4352 if (PL_opargs[type] & OA_RETSCALAR)
4354 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4355 o->op_targ = pad_alloc(type, SVs_PADTMP);
4360 PERL_STATIC_INLINE OP *
4361 S_op_integerize(pTHX_ OP *o)
4363 I32 type = o->op_type;
4365 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4367 /* integerize op. */
4368 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4371 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4374 if (type == OP_NEGATE)
4375 /* XXX might want a ck_negate() for this */
4376 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4382 S_fold_constants(pTHX_ OP *o)
4387 VOL I32 type = o->op_type;
4392 SV * const oldwarnhook = PL_warnhook;
4393 SV * const olddiehook = PL_diehook;
4395 U8 oldwarn = PL_dowarn;
4399 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4401 if (!(PL_opargs[type] & OA_FOLDCONST))
4410 #ifdef USE_LOCALE_CTYPE
4411 if (IN_LC_COMPILETIME(LC_CTYPE))
4420 #ifdef USE_LOCALE_COLLATE
4421 if (IN_LC_COMPILETIME(LC_COLLATE))
4426 /* XXX what about the numeric ops? */
4427 #ifdef USE_LOCALE_NUMERIC
4428 if (IN_LC_COMPILETIME(LC_NUMERIC))
4433 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4434 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4437 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4438 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4440 const char *s = SvPVX_const(sv);
4441 while (s < SvEND(sv)) {
4442 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4449 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4452 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4453 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4457 if (PL_parser && PL_parser->error_count)
4458 goto nope; /* Don't try to run w/ errors */
4460 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4461 switch (curop->op_type) {
4463 if ( (curop->op_private & OPpCONST_BARE)
4464 && (curop->op_private & OPpCONST_STRICT)) {
4465 no_bareword_allowed(curop);
4473 /* Foldable; move to next op in list */
4477 /* No other op types are considered foldable */
4482 curop = LINKLIST(o);
4483 old_next = o->op_next;
4487 old_cxix = cxstack_ix;
4488 create_eval_scope(NULL, G_FAKINGEVAL);
4490 /* Verify that we don't need to save it: */
4491 assert(PL_curcop == &PL_compiling);
4492 StructCopy(&PL_compiling, ¬_compiling, COP);
4493 PL_curcop = ¬_compiling;
4494 /* The above ensures that we run with all the correct hints of the
4495 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4496 assert(IN_PERL_RUNTIME);
4497 PL_warnhook = PERL_WARNHOOK_FATAL;
4501 /* Effective $^W=1. */
4502 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4503 PL_dowarn |= G_WARN_ON;
4508 sv = *(PL_stack_sp--);
4509 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4510 pad_swipe(o->op_targ, FALSE);
4512 else if (SvTEMP(sv)) { /* grab mortal temp? */
4513 SvREFCNT_inc_simple_void(sv);
4516 else { assert(SvIMMORTAL(sv)); }
4519 /* Something tried to die. Abandon constant folding. */
4520 /* Pretend the error never happened. */
4522 o->op_next = old_next;
4526 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4527 PL_warnhook = oldwarnhook;
4528 PL_diehook = olddiehook;
4529 /* XXX note that this croak may fail as we've already blown away
4530 * the stack - eg any nested evals */
4531 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4534 PL_dowarn = oldwarn;
4535 PL_warnhook = oldwarnhook;
4536 PL_diehook = olddiehook;
4537 PL_curcop = &PL_compiling;
4539 /* if we croaked, depending on how we croaked the eval scope
4540 * may or may not have already been popped */
4541 if (cxstack_ix > old_cxix) {
4542 assert(cxstack_ix == old_cxix + 1);
4543 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4544 delete_eval_scope();
4549 /* OP_STRINGIFY and constant folding are used to implement qq.
4550 Here the constant folding is an implementation detail that we
4551 want to hide. If the stringify op is itself already marked
4552 folded, however, then it is actually a folded join. */
4553 is_stringify = type == OP_STRINGIFY && !o->op_folded;
4558 else if (!SvIMMORTAL(sv)) {
4562 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4563 if (!is_stringify) newop->op_folded = 1;
4571 S_gen_constant_list(pTHX_ OP *o)
4575 const SSize_t oldtmps_floor = PL_tmps_floor;
4580 if (PL_parser && PL_parser->error_count)
4581 return o; /* Don't attempt to run with errors */
4583 curop = LINKLIST(o);
4586 S_prune_chain_head(&curop);
4588 Perl_pp_pushmark(aTHX);
4591 assert (!(curop->op_flags & OPf_SPECIAL));
4592 assert(curop->op_type == OP_RANGE);
4593 Perl_pp_anonlist(aTHX);
4594 PL_tmps_floor = oldtmps_floor;
4596 OpTYPE_set(o, OP_RV2AV);
4597 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4598 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4599 o->op_opt = 0; /* needs to be revisited in rpeep() */
4600 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4602 /* replace subtree with an OP_CONST */
4603 curop = ((UNOP*)o)->op_first;
4604 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4607 if (AvFILLp(av) != -1)
4608 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4611 SvREADONLY_on(*svp);
4618 =head1 Optree Manipulation Functions
4621 /* List constructors */
4624 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4626 Append an item to the list of ops contained directly within a list-type
4627 op, returning the lengthened list. C<first> is the list-type op,
4628 and C<last> is the op to append to the list. C<optype> specifies the
4629 intended opcode for the list. If C<first> is not already a list of the
4630 right type, it will be upgraded into one. If either C<first> or C<last>
4631 is null, the other is returned unchanged.
4637 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4645 if (first->op_type != (unsigned)type
4646 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4648 return newLISTOP(type, 0, first, last);
4651 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4652 first->op_flags |= OPf_KIDS;
4657 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4659 Concatenate the lists of ops contained directly within two list-type ops,
4660 returning the combined list. C<first> and C<last> are the list-type ops
4661 to concatenate. C<optype> specifies the intended opcode for the list.
4662 If either C<first> or C<last> is not already a list of the right type,
4663 it will be upgraded into one. If either C<first> or C<last> is null,
4664 the other is returned unchanged.
4670 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4678 if (first->op_type != (unsigned)type)
4679 return op_prepend_elem(type, first, last);
4681 if (last->op_type != (unsigned)type)
4682 return op_append_elem(type, first, last);
4684 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4685 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4686 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
4687 first->op_flags |= (last->op_flags & OPf_KIDS);
4689 S_op_destroy(aTHX_ last);
4695 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4697 Prepend an item to the list of ops contained directly within a list-type
4698 op, returning the lengthened list. C<first> is the op to prepend to the
4699 list, and C<last> is the list-type op. C<optype> specifies the intended
4700 opcode for the list. If C<last> is not already a list of the right type,
4701 it will be upgraded into one. If either C<first> or C<last> is null,
4702 the other is returned unchanged.
4708 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4716 if (last->op_type == (unsigned)type) {
4717 if (type == OP_LIST) { /* already a PUSHMARK there */
4718 /* insert 'first' after pushmark */
4719 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4720 if (!(first->op_flags & OPf_PARENS))
4721 last->op_flags &= ~OPf_PARENS;
4724 op_sibling_splice(last, NULL, 0, first);
4725 last->op_flags |= OPf_KIDS;
4729 return newLISTOP(type, 0, first, last);
4733 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
4735 Converts C<o> into a list op if it is not one already, and then converts it
4736 into the specified C<type>, calling its check function, allocating a target if
4737 it needs one, and folding constants.
4739 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
4740 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
4741 C<op_convert_list> to make it the right type.
4747 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
4750 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4751 if (!o || o->op_type != OP_LIST)
4752 o = force_list(o, 0);
4755 o->op_flags &= ~OPf_WANT;
4756 o->op_private &= ~OPpLVAL_INTRO;
4759 if (!(PL_opargs[type] & OA_MARK))
4760 op_null(cLISTOPo->op_first);
4762 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
4763 if (kid2 && kid2->op_type == OP_COREARGS) {
4764 op_null(cLISTOPo->op_first);
4765 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4769 OpTYPE_set(o, type);
4770 o->op_flags |= flags;
4771 if (flags & OPf_FOLDED)
4774 o = CHECKOP(type, o);
4775 if (o->op_type != (unsigned)type)
4778 return fold_constants(op_integerize(op_std_init(o)));
4785 =head1 Optree construction
4787 =for apidoc Am|OP *|newNULLLIST
4789 Constructs, checks, and returns a new C<stub> op, which represents an
4790 empty list expression.
4796 Perl_newNULLLIST(pTHX)
4798 return newOP(OP_STUB, 0);
4801 /* promote o and any siblings to be a list if its not already; i.e.
4809 * pushmark - o - A - B
4811 * If nullit it true, the list op is nulled.
4815 S_force_list(pTHX_ OP *o, bool nullit)
4817 if (!o || o->op_type != OP_LIST) {
4820 /* manually detach any siblings then add them back later */
4821 rest = OpSIBLING(o);
4822 OpLASTSIB_set(o, NULL);
4824 o = newLISTOP(OP_LIST, 0, o, NULL);
4826 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4834 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4836 Constructs, checks, and returns an op of any list type. C<type> is
4837 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4838 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
4839 supply up to two ops to be direct children of the list op; they are
4840 consumed by this function and become part of the constructed op tree.
4842 For most list operators, the check function expects all the kid ops to be
4843 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
4844 appropriate. What you want to do in that case is create an op of type
4845 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
4846 See L</op_convert_list> for more information.
4853 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4858 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
4859 || type == OP_CUSTOM);
4861 NewOp(1101, listop, 1, LISTOP);
4863 OpTYPE_set(listop, type);
4866 listop->op_flags = (U8)flags;
4870 else if (!first && last)
4873 OpMORESIB_set(first, last);
4874 listop->op_first = first;
4875 listop->op_last = last;
4876 if (type == OP_LIST) {
4877 OP* const pushop = newOP(OP_PUSHMARK, 0);
4878 OpMORESIB_set(pushop, first);
4879 listop->op_first = pushop;
4880 listop->op_flags |= OPf_KIDS;
4882 listop->op_last = pushop;
4884 if (listop->op_last)
4885 OpLASTSIB_set(listop->op_last, (OP*)listop);
4887 return CHECKOP(type, listop);
4891 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4893 Constructs, checks, and returns an op of any base type (any type that
4894 has no extra fields). C<type> is the opcode. C<flags> gives the
4895 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4902 Perl_newOP(pTHX_ I32 type, I32 flags)
4907 if (type == -OP_ENTEREVAL) {
4908 type = OP_ENTEREVAL;
4909 flags |= OPpEVAL_BYTES<<8;
4912 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4913 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4914 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4915 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4917 NewOp(1101, o, 1, OP);
4918 OpTYPE_set(o, type);
4919 o->op_flags = (U8)flags;
4922 o->op_private = (U8)(0 | (flags >> 8));
4923 if (PL_opargs[type] & OA_RETSCALAR)
4925 if (PL_opargs[type] & OA_TARGET)
4926 o->op_targ = pad_alloc(type, SVs_PADTMP);
4927 return CHECKOP(type, o);
4931 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4933 Constructs, checks, and returns an op of any unary type. C<type> is
4934 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
4935 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4936 bits, the eight bits of C<op_private>, except that the bit with value 1
4937 is automatically set. C<first> supplies an optional op to be the direct
4938 child of the unary op; it is consumed by this function and become part
4939 of the constructed op tree.
4945 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4950 if (type == -OP_ENTEREVAL) {
4951 type = OP_ENTEREVAL;
4952 flags |= OPpEVAL_BYTES<<8;
4955 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4956 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4957 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4958 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4959 || type == OP_SASSIGN
4960 || type == OP_ENTERTRY
4961 || type == OP_CUSTOM
4962 || type == OP_NULL );
4965 first = newOP(OP_STUB, 0);
4966 if (PL_opargs[type] & OA_MARK)
4967 first = force_list(first, 1);
4969 NewOp(1101, unop, 1, UNOP);
4970 OpTYPE_set(unop, type);
4971 unop->op_first = first;
4972 unop->op_flags = (U8)(flags | OPf_KIDS);
4973 unop->op_private = (U8)(1 | (flags >> 8));
4975 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
4976 OpLASTSIB_set(first, (OP*)unop);
4978 unop = (UNOP*) CHECKOP(type, unop);
4982 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4986 =for apidoc newUNOP_AUX
4988 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
4989 initialised to C<aux>
4995 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5000 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5001 || type == OP_CUSTOM);
5003 NewOp(1101, unop, 1, UNOP_AUX);
5004 unop->op_type = (OPCODE)type;
5005 unop->op_ppaddr = PL_ppaddr[type];
5006 unop->op_first = first;
5007 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5008 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5011 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5012 OpLASTSIB_set(first, (OP*)unop);
5014 unop = (UNOP_AUX*) CHECKOP(type, unop);
5016 return op_std_init((OP *) unop);
5020 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
5022 Constructs, checks, and returns an op of method type with a method name
5023 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
5024 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5025 and, shifted up eight bits, the eight bits of C<op_private>, except that
5026 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
5027 op which evaluates method name; it is consumed by this function and
5028 become part of the constructed op tree.
5029 Supported optypes: C<OP_METHOD>.
5035 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5039 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5040 || type == OP_CUSTOM);
5042 NewOp(1101, methop, 1, METHOP);
5044 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
5045 methop->op_flags = (U8)(flags | OPf_KIDS);
5046 methop->op_u.op_first = dynamic_meth;
5047 methop->op_private = (U8)(1 | (flags >> 8));
5049 if (!OpHAS_SIBLING(dynamic_meth))
5050 OpLASTSIB_set(dynamic_meth, (OP*)methop);
5054 methop->op_flags = (U8)(flags & ~OPf_KIDS);
5055 methop->op_u.op_meth_sv = const_meth;
5056 methop->op_private = (U8)(0 | (flags >> 8));
5057 methop->op_next = (OP*)methop;
5061 methop->op_rclass_targ = 0;
5063 methop->op_rclass_sv = NULL;
5066 OpTYPE_set(methop, type);
5067 return CHECKOP(type, methop);
5071 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5072 PERL_ARGS_ASSERT_NEWMETHOP;
5073 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5077 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
5079 Constructs, checks, and returns an op of method type with a constant
5080 method name. C<type> is the opcode. C<flags> gives the eight bits of
5081 C<op_flags>, and, shifted up eight bits, the eight bits of
5082 C<op_private>. C<const_meth> supplies a constant method name;
5083 it must be a shared COW string.
5084 Supported optypes: C<OP_METHOD_NAMED>.
5090 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5091 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5092 return newMETHOP_internal(type, flags, NULL, const_meth);
5096 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
5098 Constructs, checks, and returns an op of any binary type. C<type>
5099 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
5100 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5101 the eight bits of C<op_private>, except that the bit with value 1 or
5102 2 is automatically set as required. C<first> and C<last> supply up to
5103 two ops to be the direct children of the binary op; they are consumed
5104 by this function and become part of the constructed op tree.
5110 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5115 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5116 || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM);
5118 NewOp(1101, binop, 1, BINOP);
5121 first = newOP(OP_NULL, 0);
5123 OpTYPE_set(binop, type);
5124 binop->op_first = first;
5125 binop->op_flags = (U8)(flags | OPf_KIDS);
5128 binop->op_private = (U8)(1 | (flags >> 8));
5131 binop->op_private = (U8)(2 | (flags >> 8));
5132 OpMORESIB_set(first, last);
5135 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5136 OpLASTSIB_set(last, (OP*)binop);
5138 binop->op_last = OpSIBLING(binop->op_first);
5140 OpLASTSIB_set(binop->op_last, (OP*)binop);
5142 binop = (BINOP*)CHECKOP(type, binop);
5143 if (binop->op_next || binop->op_type != (OPCODE)type)
5146 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5149 static int uvcompare(const void *a, const void *b)
5150 __attribute__nonnull__(1)
5151 __attribute__nonnull__(2)
5152 __attribute__pure__;
5153 static int uvcompare(const void *a, const void *b)
5155 if (*((const UV *)a) < (*(const UV *)b))
5157 if (*((const UV *)a) > (*(const UV *)b))
5159 if (*((const UV *)a+1) < (*(const UV *)b+1))
5161 if (*((const UV *)a+1) > (*(const UV *)b+1))
5167 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5169 SV * const tstr = ((SVOP*)expr)->op_sv;
5171 ((SVOP*)repl)->op_sv;
5174 const U8 *t = (U8*)SvPV_const(tstr, tlen);
5175 const U8 *r = (U8*)SvPV_const(rstr, rlen);
5181 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
5182 const I32 squash = o->op_private & OPpTRANS_SQUASH;
5183 I32 del = o->op_private & OPpTRANS_DELETE;
5186 PERL_ARGS_ASSERT_PMTRANS;
5188 PL_hints |= HINT_BLOCK_SCOPE;
5191 o->op_private |= OPpTRANS_FROM_UTF;
5194 o->op_private |= OPpTRANS_TO_UTF;
5196 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
5197 SV* const listsv = newSVpvs("# comment\n");
5199 const U8* tend = t + tlen;
5200 const U8* rend = r + rlen;
5216 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
5217 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
5220 const U32 flags = UTF8_ALLOW_DEFAULT;
5224 t = tsave = bytes_to_utf8(t, &len);
5227 if (!to_utf && rlen) {
5229 r = rsave = bytes_to_utf8(r, &len);
5233 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
5234 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
5238 U8 tmpbuf[UTF8_MAXBYTES+1];
5241 Newx(cp, 2*tlen, UV);
5243 transv = newSVpvs("");
5245 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5247 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
5249 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
5253 cp[2*i+1] = cp[2*i];
5257 qsort(cp, i, 2*sizeof(UV), uvcompare);
5258 for (j = 0; j < i; j++) {
5260 diff = val - nextmin;
5262 t = uvchr_to_utf8(tmpbuf,nextmin);
5263 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5265 U8 range_mark = ILLEGAL_UTF8_BYTE;
5266 t = uvchr_to_utf8(tmpbuf, val - 1);
5267 sv_catpvn(transv, (char *)&range_mark, 1);
5268 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5275 t = uvchr_to_utf8(tmpbuf,nextmin);
5276 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5278 U8 range_mark = ILLEGAL_UTF8_BYTE;
5279 sv_catpvn(transv, (char *)&range_mark, 1);
5281 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
5282 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
5283 t = (const U8*)SvPVX_const(transv);
5284 tlen = SvCUR(transv);
5288 else if (!rlen && !del) {
5289 r = t; rlen = tlen; rend = tend;
5292 if ((!rlen && !del) || t == r ||
5293 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
5295 o->op_private |= OPpTRANS_IDENTICAL;
5299 while (t < tend || tfirst <= tlast) {
5300 /* see if we need more "t" chars */
5301 if (tfirst > tlast) {
5302 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5304 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5306 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
5313 /* now see if we need more "r" chars */
5314 if (rfirst > rlast) {
5316 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5318 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
5320 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
5329 rfirst = rlast = 0xffffffff;
5333 /* now see which range will peter out first, if either. */
5334 tdiff = tlast - tfirst;
5335 rdiff = rlast - rfirst;
5336 tcount += tdiff + 1;
5337 rcount += rdiff + 1;
5344 if (rfirst == 0xffffffff) {
5345 diff = tdiff; /* oops, pretend rdiff is infinite */
5347 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
5348 (long)tfirst, (long)tlast);
5350 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
5354 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
5355 (long)tfirst, (long)(tfirst + diff),
5358 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
5359 (long)tfirst, (long)rfirst);
5361 if (rfirst + diff > max)
5362 max = rfirst + diff;
5364 grows = (tfirst < rfirst &&
5365 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
5377 else if (max > 0xff)
5382 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
5384 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
5385 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
5386 PAD_SETSV(cPADOPo->op_padix, swash);
5388 SvREADONLY_on(swash);
5390 cSVOPo->op_sv = swash;
5392 SvREFCNT_dec(listsv);
5393 SvREFCNT_dec(transv);
5395 if (!del && havefinal && rlen)
5396 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
5397 newSVuv((UV)final), 0);
5406 else if (rlast == 0xffffffff)
5412 tbl = (short*)PerlMemShared_calloc(
5413 (o->op_private & OPpTRANS_COMPLEMENT) &&
5414 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
5416 cPVOPo->op_pv = (char*)tbl;
5418 for (i = 0; i < (I32)tlen; i++)
5420 for (i = 0, j = 0; i < 256; i++) {
5422 if (j >= (I32)rlen) {
5431 if (i < 128 && r[j] >= 128)
5441 o->op_private |= OPpTRANS_IDENTICAL;
5443 else if (j >= (I32)rlen)
5448 PerlMemShared_realloc(tbl,
5449 (0x101+rlen-j) * sizeof(short));
5450 cPVOPo->op_pv = (char*)tbl;
5452 tbl[0x100] = (short)(rlen - j);
5453 for (i=0; i < (I32)rlen - j; i++)
5454 tbl[0x101+i] = r[j+i];
5458 if (!rlen && !del) {
5461 o->op_private |= OPpTRANS_IDENTICAL;
5463 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
5464 o->op_private |= OPpTRANS_IDENTICAL;
5466 for (i = 0; i < 256; i++)
5468 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
5469 if (j >= (I32)rlen) {
5471 if (tbl[t[i]] == -1)
5477 if (tbl[t[i]] == -1) {
5478 if (t[i] < 128 && r[j] >= 128)
5486 if(del && rlen == tlen) {
5487 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
5488 } else if(rlen > tlen && !complement) {
5489 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
5493 o->op_private |= OPpTRANS_GROWS;
5501 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
5503 Constructs, checks, and returns an op of any pattern matching type.
5504 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
5505 and, shifted up eight bits, the eight bits of C<op_private>.
5511 Perl_newPMOP(pTHX_ I32 type, I32 flags)
5516 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
5517 || type == OP_CUSTOM);
5519 NewOp(1101, pmop, 1, PMOP);
5520 OpTYPE_set(pmop, type);
5521 pmop->op_flags = (U8)flags;
5522 pmop->op_private = (U8)(0 | (flags >> 8));
5523 if (PL_opargs[type] & OA_RETSCALAR)
5526 if (PL_hints & HINT_RE_TAINT)
5527 pmop->op_pmflags |= PMf_RETAINT;
5528 #ifdef USE_LOCALE_CTYPE
5529 if (IN_LC_COMPILETIME(LC_CTYPE)) {
5530 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
5535 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5537 if (PL_hints & HINT_RE_FLAGS) {
5538 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5539 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5541 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5542 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5543 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5545 if (reflags && SvOK(reflags)) {
5546 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5552 assert(SvPOK(PL_regex_pad[0]));
5553 if (SvCUR(PL_regex_pad[0])) {
5554 /* Pop off the "packed" IV from the end. */
5555 SV *const repointer_list = PL_regex_pad[0];
5556 const char *p = SvEND(repointer_list) - sizeof(IV);
5557 const IV offset = *((IV*)p);
5559 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5561 SvEND_set(repointer_list, p);
5563 pmop->op_pmoffset = offset;
5564 /* This slot should be free, so assert this: */
5565 assert(PL_regex_pad[offset] == &PL_sv_undef);
5567 SV * const repointer = &PL_sv_undef;
5568 av_push(PL_regex_padav, repointer);
5569 pmop->op_pmoffset = av_tindex(PL_regex_padav);
5570 PL_regex_pad = AvARRAY(PL_regex_padav);
5574 return CHECKOP(type, pmop);
5582 /* Any pad names in scope are potentially lvalues. */
5583 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
5584 PADNAME *pn = PAD_COMPNAME_SV(i);
5585 if (!pn || !PadnameLEN(pn))
5587 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
5588 S_mark_padname_lvalue(aTHX_ pn);
5592 /* Given some sort of match op o, and an expression expr containing a
5593 * pattern, either compile expr into a regex and attach it to o (if it's
5594 * constant), or convert expr into a runtime regcomp op sequence (if it's
5597 * isreg indicates that the pattern is part of a regex construct, eg
5598 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5599 * split "pattern", which aren't. In the former case, expr will be a list
5600 * if the pattern contains more than one term (eg /a$b/).
5602 * When the pattern has been compiled within a new anon CV (for
5603 * qr/(?{...})/ ), then floor indicates the savestack level just before
5604 * the new sub was created
5608 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor)
5612 I32 repl_has_vars = 0;
5613 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5614 bool is_compiletime;
5617 PERL_ARGS_ASSERT_PMRUNTIME;
5620 return pmtrans(o, expr, repl);
5623 /* find whether we have any runtime or code elements;
5624 * at the same time, temporarily set the op_next of each DO block;
5625 * then when we LINKLIST, this will cause the DO blocks to be excluded
5626 * from the op_next chain (and from having LINKLIST recursively
5627 * applied to them). We fix up the DOs specially later */
5631 if (expr->op_type == OP_LIST) {
5633 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5634 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5636 assert(!o->op_next);
5637 if (UNLIKELY(!OpHAS_SIBLING(o))) {
5638 assert(PL_parser && PL_parser->error_count);
5639 /* This can happen with qr/ (?{(^{})/. Just fake up
5640 the op we were expecting to see, to avoid crashing
5642 op_sibling_splice(expr, o, 0,
5643 newSVOP(OP_CONST, 0, &PL_sv_no));
5645 o->op_next = OpSIBLING(o);
5647 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5651 else if (expr->op_type != OP_CONST)
5656 /* fix up DO blocks; treat each one as a separate little sub;
5657 * also, mark any arrays as LIST/REF */
5659 if (expr->op_type == OP_LIST) {
5661 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
5663 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5664 assert( !(o->op_flags & OPf_WANT));
5665 /* push the array rather than its contents. The regex
5666 * engine will retrieve and join the elements later */
5667 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5671 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5673 o->op_next = NULL; /* undo temporary hack from above */
5676 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5677 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5679 assert(leaveop->op_first->op_type == OP_ENTER);
5680 assert(OpHAS_SIBLING(leaveop->op_first));
5681 o->op_next = OpSIBLING(leaveop->op_first);
5683 assert(leaveop->op_flags & OPf_KIDS);
5684 assert(leaveop->op_last->op_next == (OP*)leaveop);
5685 leaveop->op_next = NULL; /* stop on last op */
5686 op_null((OP*)leaveop);
5690 OP *scope = cLISTOPo->op_first;
5691 assert(scope->op_type == OP_SCOPE);
5692 assert(scope->op_flags & OPf_KIDS);
5693 scope->op_next = NULL; /* stop on last op */
5696 /* have to peep the DOs individually as we've removed it from
5697 * the op_next chain */
5699 S_prune_chain_head(&(o->op_next));
5701 /* runtime finalizes as part of finalizing whole tree */
5705 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5706 assert( !(expr->op_flags & OPf_WANT));
5707 /* push the array rather than its contents. The regex
5708 * engine will retrieve and join the elements later */
5709 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5712 PL_hints |= HINT_BLOCK_SCOPE;
5714 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5716 if (is_compiletime) {
5717 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5718 regexp_engine const *eng = current_re_engine();
5720 if (o->op_flags & OPf_SPECIAL)
5721 rx_flags |= RXf_SPLIT;
5723 if (!has_code || !eng->op_comp) {
5724 /* compile-time simple constant pattern */
5726 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5727 /* whoops! we guessed that a qr// had a code block, but we
5728 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5729 * that isn't required now. Note that we have to be pretty
5730 * confident that nothing used that CV's pad while the
5731 * regex was parsed, except maybe op targets for \Q etc.
5732 * If there were any op targets, though, they should have
5733 * been stolen by constant folding.
5737 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
5738 while (++i <= AvFILLp(PL_comppad)) {
5739 assert(!PL_curpad[i]);
5742 /* But we know that one op is using this CV's slab. */
5743 cv_forget_slab(PL_compcv);
5745 pm->op_pmflags &= ~PMf_HAS_CV;
5750 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5751 rx_flags, pm->op_pmflags)
5752 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5753 rx_flags, pm->op_pmflags)
5758 /* compile-time pattern that includes literal code blocks */
5759 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5762 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5765 if (pm->op_pmflags & PMf_HAS_CV) {
5767 /* this QR op (and the anon sub we embed it in) is never
5768 * actually executed. It's just a placeholder where we can
5769 * squirrel away expr in op_code_list without the peephole
5770 * optimiser etc processing it for a second time */
5771 OP *qr = newPMOP(OP_QR, 0);
5772 ((PMOP*)qr)->op_code_list = expr;
5774 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5775 SvREFCNT_inc_simple_void(PL_compcv);
5776 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5777 ReANY(re)->qr_anoncv = cv;
5779 /* attach the anon CV to the pad so that
5780 * pad_fixup_inner_anons() can find it */
5781 (void)pad_add_anon(cv, o->op_type);
5782 SvREFCNT_inc_simple_void(cv);
5785 pm->op_code_list = expr;
5790 /* runtime pattern: build chain of regcomp etc ops */
5792 PADOFFSET cv_targ = 0;
5794 reglist = isreg && expr->op_type == OP_LIST;
5799 pm->op_code_list = expr;
5800 /* don't free op_code_list; its ops are embedded elsewhere too */
5801 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5804 if (o->op_flags & OPf_SPECIAL)
5805 pm->op_pmflags |= PMf_SPLIT;
5807 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5808 * to allow its op_next to be pointed past the regcomp and
5809 * preceding stacking ops;
5810 * OP_REGCRESET is there to reset taint before executing the
5812 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5813 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5815 if (pm->op_pmflags & PMf_HAS_CV) {
5816 /* we have a runtime qr with literal code. This means
5817 * that the qr// has been wrapped in a new CV, which
5818 * means that runtime consts, vars etc will have been compiled
5819 * against a new pad. So... we need to execute those ops
5820 * within the environment of the new CV. So wrap them in a call
5821 * to a new anon sub. i.e. for
5825 * we build an anon sub that looks like
5827 * sub { "a", $b, '(?{...})' }
5829 * and call it, passing the returned list to regcomp.
5830 * Or to put it another way, the list of ops that get executed
5834 * ------ -------------------
5835 * pushmark (for regcomp)
5836 * pushmark (for entersub)
5840 * regcreset regcreset
5842 * const("a") const("a")
5844 * const("(?{...})") const("(?{...})")
5849 SvREFCNT_inc_simple_void(PL_compcv);
5850 CvLVALUE_on(PL_compcv);
5851 /* these lines are just an unrolled newANONATTRSUB */
5852 expr = newSVOP(OP_ANONCODE, 0,
5853 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5854 cv_targ = expr->op_targ;
5855 expr = newUNOP(OP_REFGEN, 0, expr);
5857 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5860 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5861 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5862 | (reglist ? OPf_STACKED : 0);
5863 rcop->op_targ = cv_targ;
5865 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5866 if (PL_hints & HINT_RE_EVAL)
5867 S_set_haseval(aTHX);
5869 /* establish postfix order */
5870 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5872 rcop->op_next = expr;
5873 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5876 rcop->op_next = LINKLIST(expr);
5877 expr->op_next = (OP*)rcop;
5880 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5886 /* If we are looking at s//.../e with a single statement, get past
5887 the implicit do{}. */
5888 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5889 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5890 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5893 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5894 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
5895 && !OpHAS_SIBLING(sib))
5898 if (curop->op_type == OP_CONST)
5900 else if (( (curop->op_type == OP_RV2SV ||
5901 curop->op_type == OP_RV2AV ||
5902 curop->op_type == OP_RV2HV ||
5903 curop->op_type == OP_RV2GV)
5904 && cUNOPx(curop)->op_first
5905 && cUNOPx(curop)->op_first->op_type == OP_GV )
5906 || curop->op_type == OP_PADSV
5907 || curop->op_type == OP_PADAV
5908 || curop->op_type == OP_PADHV
5909 || curop->op_type == OP_PADANY) {
5917 || !RX_PRELEN(PM_GETRE(pm))
5918 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5920 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5921 op_prepend_elem(o->op_type, scalar(repl), o);
5924 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5925 rcop->op_private = 1;
5927 /* establish postfix order */
5928 rcop->op_next = LINKLIST(repl);
5929 repl->op_next = (OP*)rcop;
5931 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5932 assert(!(pm->op_pmflags & PMf_ONCE));
5933 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5942 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5944 Constructs, checks, and returns an op of any type that involves an
5945 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
5946 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
5947 takes ownership of one reference to it.
5953 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5958 PERL_ARGS_ASSERT_NEWSVOP;
5960 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5961 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5962 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5963 || type == OP_CUSTOM);
5965 NewOp(1101, svop, 1, SVOP);
5966 OpTYPE_set(svop, type);
5968 svop->op_next = (OP*)svop;
5969 svop->op_flags = (U8)flags;
5970 svop->op_private = (U8)(0 | (flags >> 8));
5971 if (PL_opargs[type] & OA_RETSCALAR)
5973 if (PL_opargs[type] & OA_TARGET)
5974 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5975 return CHECKOP(type, svop);
5979 =for apidoc Am|OP *|newDEFSVOP|
5981 Constructs and returns an op to access C<$_>.
5987 Perl_newDEFSVOP(pTHX)
5989 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
5995 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5997 Constructs, checks, and returns an op of any type that involves a
5998 reference to a pad element. C<type> is the opcode. C<flags> gives the
5999 eight bits of C<op_flags>. A pad slot is automatically allocated, and
6000 is populated with C<sv>; this function takes ownership of one reference
6003 This function only exists if Perl has been compiled to use ithreads.
6009 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
6014 PERL_ARGS_ASSERT_NEWPADOP;
6016 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
6017 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6018 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6019 || type == OP_CUSTOM);
6021 NewOp(1101, padop, 1, PADOP);
6022 OpTYPE_set(padop, type);
6024 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
6025 SvREFCNT_dec(PAD_SVl(padop->op_padix));
6026 PAD_SETSV(padop->op_padix, sv);
6028 padop->op_next = (OP*)padop;
6029 padop->op_flags = (U8)flags;
6030 if (PL_opargs[type] & OA_RETSCALAR)
6032 if (PL_opargs[type] & OA_TARGET)
6033 padop->op_targ = pad_alloc(type, SVs_PADTMP);
6034 return CHECKOP(type, padop);
6037 #endif /* USE_ITHREADS */
6040 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
6042 Constructs, checks, and returns an op of any type that involves an
6043 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
6044 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
6045 reference; calling this function does not transfer ownership of any
6052 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
6054 PERL_ARGS_ASSERT_NEWGVOP;
6057 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6059 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
6064 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
6066 Constructs, checks, and returns an op of any type that involves an
6067 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
6068 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
6069 must have been allocated using C<PerlMemShared_malloc>; the memory will
6070 be freed when the op is destroyed.
6076 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
6079 const bool utf8 = cBOOL(flags & SVf_UTF8);
6084 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
6085 || type == OP_RUNCV || type == OP_CUSTOM
6086 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6088 NewOp(1101, pvop, 1, PVOP);
6089 OpTYPE_set(pvop, type);
6091 pvop->op_next = (OP*)pvop;
6092 pvop->op_flags = (U8)flags;
6093 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
6094 if (PL_opargs[type] & OA_RETSCALAR)
6096 if (PL_opargs[type] & OA_TARGET)
6097 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
6098 return CHECKOP(type, pvop);
6102 Perl_package(pTHX_ OP *o)
6104 SV *const sv = cSVOPo->op_sv;
6106 PERL_ARGS_ASSERT_PACKAGE;
6108 SAVEGENERICSV(PL_curstash);
6109 save_item(PL_curstname);
6111 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
6113 sv_setsv(PL_curstname, sv);
6115 PL_hints |= HINT_BLOCK_SCOPE;
6116 PL_parser->copline = NOLINE;
6122 Perl_package_version( pTHX_ OP *v )
6124 U32 savehints = PL_hints;
6125 PERL_ARGS_ASSERT_PACKAGE_VERSION;
6126 PL_hints &= ~HINT_STRICT_VARS;
6127 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
6128 PL_hints = savehints;
6133 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
6138 SV *use_version = NULL;
6140 PERL_ARGS_ASSERT_UTILIZE;
6142 if (idop->op_type != OP_CONST)
6143 Perl_croak(aTHX_ "Module name must be constant");
6148 SV * const vesv = ((SVOP*)version)->op_sv;
6150 if (!arg && !SvNIOKp(vesv)) {
6157 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
6158 Perl_croak(aTHX_ "Version number must be a constant number");
6160 /* Make copy of idop so we don't free it twice */
6161 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6163 /* Fake up a method call to VERSION */
6164 meth = newSVpvs_share("VERSION");
6165 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6166 op_append_elem(OP_LIST,
6167 op_prepend_elem(OP_LIST, pack, version),
6168 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
6172 /* Fake up an import/unimport */
6173 if (arg && arg->op_type == OP_STUB) {
6174 imop = arg; /* no import on explicit () */
6176 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
6177 imop = NULL; /* use 5.0; */
6179 use_version = ((SVOP*)idop)->op_sv;
6181 idop->op_private |= OPpCONST_NOVER;
6186 /* Make copy of idop so we don't free it twice */
6187 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
6189 /* Fake up a method call to import/unimport */
6191 ? newSVpvs_share("import") : newSVpvs_share("unimport");
6192 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
6193 op_append_elem(OP_LIST,
6194 op_prepend_elem(OP_LIST, pack, arg),
6195 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
6199 /* Fake up the BEGIN {}, which does its thing immediately. */
6201 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
6204 op_append_elem(OP_LINESEQ,
6205 op_append_elem(OP_LINESEQ,
6206 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
6207 newSTATEOP(0, NULL, veop)),
6208 newSTATEOP(0, NULL, imop) ));
6212 * feature bundle that corresponds to the required version. */
6213 use_version = sv_2mortal(new_version(use_version));
6214 S_enable_feature_bundle(aTHX_ use_version);
6216 /* If a version >= 5.11.0 is requested, strictures are on by default! */
6217 if (vcmp(use_version,
6218 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
6219 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6220 PL_hints |= HINT_STRICT_REFS;
6221 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6222 PL_hints |= HINT_STRICT_SUBS;
6223 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6224 PL_hints |= HINT_STRICT_VARS;
6226 /* otherwise they are off */
6228 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
6229 PL_hints &= ~HINT_STRICT_REFS;
6230 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
6231 PL_hints &= ~HINT_STRICT_SUBS;
6232 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
6233 PL_hints &= ~HINT_STRICT_VARS;
6237 /* The "did you use incorrect case?" warning used to be here.
6238 * The problem is that on case-insensitive filesystems one
6239 * might get false positives for "use" (and "require"):
6240 * "use Strict" or "require CARP" will work. This causes
6241 * portability problems for the script: in case-strict
6242 * filesystems the script will stop working.
6244 * The "incorrect case" warning checked whether "use Foo"
6245 * imported "Foo" to your namespace, but that is wrong, too:
6246 * there is no requirement nor promise in the language that
6247 * a Foo.pm should or would contain anything in package "Foo".
6249 * There is very little Configure-wise that can be done, either:
6250 * the case-sensitivity of the build filesystem of Perl does not
6251 * help in guessing the case-sensitivity of the runtime environment.
6254 PL_hints |= HINT_BLOCK_SCOPE;
6255 PL_parser->copline = NOLINE;
6256 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
6260 =head1 Embedding Functions
6262 =for apidoc load_module
6264 Loads the module whose name is pointed to by the string part of name.
6265 Note that the actual module name, not its filename, should be given.
6266 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
6267 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
6268 (or 0 for no flags). ver, if specified
6269 and not NULL, provides version semantics
6270 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
6271 arguments can be used to specify arguments to the module's C<import()>
6272 method, similar to C<use Foo::Bar VERSION LIST>. They must be
6273 terminated with a final C<NULL> pointer. Note that this list can only
6274 be omitted when the C<PERL_LOADMOD_NOIMPORT> flag has been used.
6275 Otherwise at least a single C<NULL> pointer to designate the default
6276 import list is required.
6278 The reference count for each specified C<SV*> parameter is decremented.
6283 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
6287 PERL_ARGS_ASSERT_LOAD_MODULE;
6289 va_start(args, ver);
6290 vload_module(flags, name, ver, &args);
6294 #ifdef PERL_IMPLICIT_CONTEXT
6296 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
6300 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
6301 va_start(args, ver);
6302 vload_module(flags, name, ver, &args);
6308 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
6311 OP * const modname = newSVOP(OP_CONST, 0, name);
6313 PERL_ARGS_ASSERT_VLOAD_MODULE;
6315 modname->op_private |= OPpCONST_BARE;
6317 veop = newSVOP(OP_CONST, 0, ver);
6321 if (flags & PERL_LOADMOD_NOIMPORT) {
6322 imop = sawparens(newNULLLIST());
6324 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
6325 imop = va_arg(*args, OP*);
6330 sv = va_arg(*args, SV*);
6332 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
6333 sv = va_arg(*args, SV*);
6337 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
6338 * that it has a PL_parser to play with while doing that, and also
6339 * that it doesn't mess with any existing parser, by creating a tmp
6340 * new parser with lex_start(). This won't actually be used for much,
6341 * since pp_require() will create another parser for the real work.
6342 * The ENTER/LEAVE pair protect callers from any side effects of use. */
6345 SAVEVPTR(PL_curcop);
6346 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
6347 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
6348 veop, modname, imop);
6352 PERL_STATIC_INLINE OP *
6353 S_new_entersubop(pTHX_ GV *gv, OP *arg)
6355 return newUNOP(OP_ENTERSUB, OPf_STACKED,
6356 newLISTOP(OP_LIST, 0, arg,
6357 newUNOP(OP_RV2CV, 0,
6358 newGVOP(OP_GV, 0, gv))));
6362 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
6367 PERL_ARGS_ASSERT_DOFILE;
6369 if (!force_builtin && (gv = gv_override("do", 2))) {
6370 doop = S_new_entersubop(aTHX_ gv, term);
6373 doop = newUNOP(OP_DOFILE, 0, scalar(term));
6379 =head1 Optree construction
6381 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
6383 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
6384 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
6385 be set automatically, and, shifted up eight bits, the eight bits of
6386 C<op_private>, except that the bit with value 1 or 2 is automatically
6387 set as required. C<listval> and C<subscript> supply the parameters of
6388 the slice; they are consumed by this function and become part of the
6389 constructed op tree.
6395 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
6397 return newBINOP(OP_LSLICE, flags,
6398 list(force_list(subscript, 1)),
6399 list(force_list(listval, 1)) );
6402 #define ASSIGN_LIST 1
6403 #define ASSIGN_REF 2
6406 S_assignment_type(pTHX_ const OP *o)
6415 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
6416 o = cUNOPo->op_first;
6418 flags = o->op_flags;
6420 if (type == OP_COND_EXPR) {
6421 OP * const sib = OpSIBLING(cLOGOPo->op_first);
6422 const I32 t = assignment_type(sib);
6423 const I32 f = assignment_type(OpSIBLING(sib));
6425 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
6427 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
6428 yyerror("Assignment to both a list and a scalar");
6432 if (type == OP_SREFGEN)
6434 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
6435 type = kid->op_type;
6436 flags |= kid->op_flags;
6437 if (!(flags & OPf_PARENS)
6438 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
6439 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
6445 if (type == OP_LIST &&
6446 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
6447 o->op_private & OPpLVAL_INTRO)
6450 if (type == OP_LIST || flags & OPf_PARENS ||
6451 type == OP_RV2AV || type == OP_RV2HV ||
6452 type == OP_ASLICE || type == OP_HSLICE ||
6453 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
6456 if (type == OP_PADAV || type == OP_PADHV)
6459 if (type == OP_RV2SV)
6467 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6469 Constructs, checks, and returns an assignment op. C<left> and C<right>
6470 supply the parameters of the assignment; they are consumed by this
6471 function and become part of the constructed op tree.
6473 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6474 a suitable conditional optree is constructed. If C<optype> is the opcode
6475 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6476 performs the binary operation and assigns the result to the left argument.
6477 Either way, if C<optype> is non-zero then C<flags> has no effect.
6479 If C<optype> is zero, then a plain scalar or list assignment is
6480 constructed. Which type of assignment it is is automatically determined.
6481 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6482 will be set automatically, and, shifted up eight bits, the eight bits
6483 of C<op_private>, except that the bit with value 1 or 2 is automatically
6490 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6496 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6497 return newLOGOP(optype, 0,
6498 op_lvalue(scalar(left), optype),
6499 newUNOP(OP_SASSIGN, 0, scalar(right)));
6502 return newBINOP(optype, OPf_STACKED,
6503 op_lvalue(scalar(left), optype), scalar(right));
6507 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6508 static const char no_list_state[] = "Initialization of state variables"
6509 " in list context currently forbidden";
6512 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6513 left->op_private &= ~ OPpSLICEWARNING;
6516 left = op_lvalue(left, OP_AASSIGN);
6517 curop = list(force_list(left, 1));
6518 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6519 o->op_private = (U8)(0 | (flags >> 8));
6521 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6523 OP* lop = ((LISTOP*)left)->op_first;
6525 if ((lop->op_type == OP_PADSV ||
6526 lop->op_type == OP_PADAV ||
6527 lop->op_type == OP_PADHV ||
6528 lop->op_type == OP_PADANY)
6529 && (lop->op_private & OPpPAD_STATE)
6531 yyerror(no_list_state);
6532 lop = OpSIBLING(lop);
6535 else if ( (left->op_private & OPpLVAL_INTRO)
6536 && (left->op_private & OPpPAD_STATE)
6537 && ( left->op_type == OP_PADSV
6538 || left->op_type == OP_PADAV
6539 || left->op_type == OP_PADHV
6540 || left->op_type == OP_PADANY)
6542 /* All single variable list context state assignments, hence
6552 yyerror(no_list_state);
6555 if (right && right->op_type == OP_SPLIT
6556 && !(right->op_flags & OPf_STACKED)) {
6557 OP* tmpop = ((LISTOP*)right)->op_first;
6558 PMOP * const pm = (PMOP*)tmpop;
6559 assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6562 !pm->op_pmreplrootu.op_pmtargetoff
6564 !pm->op_pmreplrootu.op_pmtargetgv
6568 if (!(left->op_private & OPpLVAL_INTRO) &&
6569 ( (left->op_type == OP_RV2AV &&
6570 (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6571 || left->op_type == OP_PADAV )
6573 if (tmpop != (OP *)pm) {
6575 pm->op_pmreplrootu.op_pmtargetoff
6576 = cPADOPx(tmpop)->op_padix;
6577 cPADOPx(tmpop)->op_padix = 0; /* steal it */
6579 pm->op_pmreplrootu.op_pmtargetgv
6580 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6581 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
6583 right->op_private |=
6584 left->op_private & OPpOUR_INTRO;
6587 pm->op_targ = left->op_targ;
6588 left->op_targ = 0; /* filch it */
6591 tmpop = cUNOPo->op_first; /* to list (nulled) */
6592 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6593 /* detach rest of siblings from o subtree,
6594 * and free subtree */
6595 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6596 op_free(o); /* blow off assign */
6597 right->op_flags &= ~OPf_WANT;
6598 /* "I don't know and I don't care." */
6601 else if (left->op_type == OP_RV2AV
6602 || left->op_type == OP_PADAV)
6604 /* Detach the array. */
6608 op_sibling_splice(cBINOPo->op_last,
6609 cUNOPx(cBINOPo->op_last)
6610 ->op_first, 1, NULL);
6611 assert(ary == left);
6612 /* Attach it to the split. */
6613 op_sibling_splice(right, cLISTOPx(right)->op_last,
6615 right->op_flags |= OPf_STACKED;
6616 /* Detach split and expunge aassign as above. */
6619 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6620 ((LISTOP*)right)->op_last->op_type == OP_CONST)
6623 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6624 SV * const sv = *svp;
6625 if (SvIOK(sv) && SvIVX(sv) == 0)
6627 if (right->op_private & OPpSPLIT_IMPLIM) {
6628 /* our own SV, created in ck_split */
6630 sv_setiv(sv, PL_modcount+1);
6633 /* SV may belong to someone else */
6635 *svp = newSViv(PL_modcount+1);
6643 if (assign_type == ASSIGN_REF)
6644 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6646 right = newOP(OP_UNDEF, 0);
6647 if (right->op_type == OP_READLINE) {
6648 right->op_flags |= OPf_STACKED;
6649 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6653 o = newBINOP(OP_SASSIGN, flags,
6654 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6660 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6662 Constructs a state op (COP). The state op is normally a C<nextstate> op,
6663 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6664 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6665 If C<label> is non-null, it supplies the name of a label to attach to
6666 the state op; this function takes ownership of the memory pointed at by
6667 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
6670 If C<o> is null, the state op is returned. Otherwise the state op is
6671 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
6672 is consumed by this function and becomes part of the returned op tree.
6678 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6681 const U32 seq = intro_my();
6682 const U32 utf8 = flags & SVf_UTF8;
6685 PL_parser->parsed_sub = 0;
6689 NewOp(1101, cop, 1, COP);
6690 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6691 OpTYPE_set(cop, OP_DBSTATE);
6694 OpTYPE_set(cop, OP_NEXTSTATE);
6696 cop->op_flags = (U8)flags;
6697 CopHINTS_set(cop, PL_hints);
6699 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6701 cop->op_next = (OP*)cop;
6704 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6705 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6707 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6709 PL_hints |= HINT_BLOCK_SCOPE;
6710 /* It seems that we need to defer freeing this pointer, as other parts
6711 of the grammar end up wanting to copy it after this op has been
6716 if (PL_parser->preambling != NOLINE) {
6717 CopLINE_set(cop, PL_parser->preambling);
6718 PL_parser->copline = NOLINE;
6720 else if (PL_parser->copline == NOLINE)
6721 CopLINE_set(cop, CopLINE(PL_curcop));
6723 CopLINE_set(cop, PL_parser->copline);
6724 PL_parser->copline = NOLINE;
6727 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
6729 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6731 CopSTASH_set(cop, PL_curstash);
6733 if (cop->op_type == OP_DBSTATE) {
6734 /* this line can have a breakpoint - store the cop in IV */
6735 AV *av = CopFILEAVx(PL_curcop);
6737 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6738 if (svp && *svp != &PL_sv_undef ) {
6739 (void)SvIOK_on(*svp);
6740 SvIV_set(*svp, PTR2IV(cop));
6745 if (flags & OPf_SPECIAL)
6747 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6751 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6753 Constructs, checks, and returns a logical (flow control) op. C<type>
6754 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6755 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6756 the eight bits of C<op_private>, except that the bit with value 1 is
6757 automatically set. C<first> supplies the expression controlling the
6758 flow, and C<other> supplies the side (alternate) chain of ops; they are
6759 consumed by this function and become part of the constructed op tree.
6765 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6767 PERL_ARGS_ASSERT_NEWLOGOP;
6769 return new_logop(type, flags, &first, &other);
6773 S_search_const(pTHX_ OP *o)
6775 PERL_ARGS_ASSERT_SEARCH_CONST;
6777 switch (o->op_type) {
6781 if (o->op_flags & OPf_KIDS)
6782 return search_const(cUNOPo->op_first);
6789 if (!(o->op_flags & OPf_KIDS))
6791 kid = cLISTOPo->op_first;
6793 switch (kid->op_type) {
6797 kid = OpSIBLING(kid);
6800 if (kid != cLISTOPo->op_last)
6806 kid = cLISTOPo->op_last;
6808 return search_const(kid);
6816 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6824 int prepend_not = 0;
6826 PERL_ARGS_ASSERT_NEW_LOGOP;
6831 /* [perl #59802]: Warn about things like "return $a or $b", which
6832 is parsed as "(return $a) or $b" rather than "return ($a or
6833 $b)". NB: This also applies to xor, which is why we do it
6836 switch (first->op_type) {
6840 /* XXX: Perhaps we should emit a stronger warning for these.
6841 Even with the high-precedence operator they don't seem to do
6844 But until we do, fall through here.
6850 /* XXX: Currently we allow people to "shoot themselves in the
6851 foot" by explicitly writing "(return $a) or $b".
6853 Warn unless we are looking at the result from folding or if
6854 the programmer explicitly grouped the operators like this.
6855 The former can occur with e.g.
6857 use constant FEATURE => ( $] >= ... );
6858 sub { not FEATURE and return or do_stuff(); }
6860 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6861 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6862 "Possible precedence issue with control flow operator");
6863 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6869 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6870 return newBINOP(type, flags, scalar(first), scalar(other));
6872 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
6873 || type == OP_CUSTOM);
6875 scalarboolean(first);
6877 /* search for a constant op that could let us fold the test */
6878 if ((cstop = search_const(first))) {
6879 if (cstop->op_private & OPpCONST_STRICT)
6880 no_bareword_allowed(cstop);
6881 else if ((cstop->op_private & OPpCONST_BARE))
6882 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6883 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6884 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6885 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6886 /* Elide the (constant) lhs, since it can't affect the outcome */
6888 if (other->op_type == OP_CONST)
6889 other->op_private |= OPpCONST_SHORTCIRCUIT;
6891 if (other->op_type == OP_LEAVE)
6892 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6893 else if (other->op_type == OP_MATCH
6894 || other->op_type == OP_SUBST
6895 || other->op_type == OP_TRANSR
6896 || other->op_type == OP_TRANS)
6897 /* Mark the op as being unbindable with =~ */
6898 other->op_flags |= OPf_SPECIAL;
6900 other->op_folded = 1;
6904 /* Elide the rhs, since the outcome is entirely determined by
6905 * the (constant) lhs */
6907 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6908 const OP *o2 = other;
6909 if ( ! (o2->op_type == OP_LIST
6910 && (( o2 = cUNOPx(o2)->op_first))
6911 && o2->op_type == OP_PUSHMARK
6912 && (( o2 = OpSIBLING(o2))) )
6915 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6916 || o2->op_type == OP_PADHV)
6917 && o2->op_private & OPpLVAL_INTRO
6918 && !(o2->op_private & OPpPAD_STATE))
6920 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6921 "Deprecated use of my() in false conditional");
6925 if (cstop->op_type == OP_CONST)
6926 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6931 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6932 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6934 const OP * const k1 = ((UNOP*)first)->op_first;
6935 const OP * const k2 = OpSIBLING(k1);
6937 switch (first->op_type)
6940 if (k2 && k2->op_type == OP_READLINE
6941 && (k2->op_flags & OPf_STACKED)
6942 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6944 warnop = k2->op_type;
6949 if (k1->op_type == OP_READDIR
6950 || k1->op_type == OP_GLOB
6951 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6952 || k1->op_type == OP_EACH
6953 || k1->op_type == OP_AEACH)
6955 warnop = ((k1->op_type == OP_NULL)
6956 ? (OPCODE)k1->op_targ : k1->op_type);
6961 const line_t oldline = CopLINE(PL_curcop);
6962 /* This ensures that warnings are reported at the first line
6963 of the construction, not the last. */
6964 CopLINE_set(PL_curcop, PL_parser->copline);
6965 Perl_warner(aTHX_ packWARN(WARN_MISC),
6966 "Value of %s%s can be \"0\"; test with defined()",
6968 ((warnop == OP_READLINE || warnop == OP_GLOB)
6969 ? " construct" : "() operator"));
6970 CopLINE_set(PL_curcop, oldline);
6974 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6975 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6977 /* optimize AND and OR ops that have NOTs as children */
6978 if (first->op_type == OP_NOT
6979 && (first->op_flags & OPf_KIDS)
6980 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6981 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6983 if (type == OP_AND || type == OP_OR) {
6989 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6991 prepend_not = 1; /* prepend a NOT op later */
6996 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6997 logop->op_flags |= (U8)flags;
6998 logop->op_private = (U8)(1 | (flags >> 8));
7000 /* establish postfix order */
7001 logop->op_next = LINKLIST(first);
7002 first->op_next = (OP*)logop;
7003 assert(!OpHAS_SIBLING(first));
7004 op_sibling_splice((OP*)logop, first, 0, other);
7006 CHECKOP(type,logop);
7008 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
7009 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
7017 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
7019 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
7020 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7021 will be set automatically, and, shifted up eight bits, the eight bits of
7022 C<op_private>, except that the bit with value 1 is automatically set.
7023 C<first> supplies the expression selecting between the two branches,
7024 and C<trueop> and C<falseop> supply the branches; they are consumed by
7025 this function and become part of the constructed op tree.
7031 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
7039 PERL_ARGS_ASSERT_NEWCONDOP;
7042 return newLOGOP(OP_AND, 0, first, trueop);
7044 return newLOGOP(OP_OR, 0, first, falseop);
7046 scalarboolean(first);
7047 if ((cstop = search_const(first))) {
7048 /* Left or right arm of the conditional? */
7049 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
7050 OP *live = left ? trueop : falseop;
7051 OP *const dead = left ? falseop : trueop;
7052 if (cstop->op_private & OPpCONST_BARE &&
7053 cstop->op_private & OPpCONST_STRICT) {
7054 no_bareword_allowed(cstop);
7058 if (live->op_type == OP_LEAVE)
7059 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
7060 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
7061 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
7062 /* Mark the op as being unbindable with =~ */
7063 live->op_flags |= OPf_SPECIAL;
7064 live->op_folded = 1;
7067 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
7068 logop->op_flags |= (U8)flags;
7069 logop->op_private = (U8)(1 | (flags >> 8));
7070 logop->op_next = LINKLIST(falseop);
7072 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
7075 /* establish postfix order */
7076 start = LINKLIST(first);
7077 first->op_next = (OP*)logop;
7079 /* make first, trueop, falseop siblings */
7080 op_sibling_splice((OP*)logop, first, 0, trueop);
7081 op_sibling_splice((OP*)logop, trueop, 0, falseop);
7083 o = newUNOP(OP_NULL, 0, (OP*)logop);
7085 trueop->op_next = falseop->op_next = o;
7092 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
7094 Constructs and returns a C<range> op, with subordinate C<flip> and
7095 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
7096 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
7097 for both the C<flip> and C<range> ops, except that the bit with value
7098 1 is automatically set. C<left> and C<right> supply the expressions
7099 controlling the endpoints of the range; they are consumed by this function
7100 and become part of the constructed op tree.
7106 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
7114 PERL_ARGS_ASSERT_NEWRANGE;
7116 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
7117 range->op_flags = OPf_KIDS;
7118 leftstart = LINKLIST(left);
7119 range->op_private = (U8)(1 | (flags >> 8));
7121 /* make left and right siblings */
7122 op_sibling_splice((OP*)range, left, 0, right);
7124 range->op_next = (OP*)range;
7125 flip = newUNOP(OP_FLIP, flags, (OP*)range);
7126 flop = newUNOP(OP_FLOP, 0, flip);
7127 o = newUNOP(OP_NULL, 0, flop);
7129 range->op_next = leftstart;
7131 left->op_next = flip;
7132 right->op_next = flop;
7135 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
7136 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
7138 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
7139 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
7140 SvPADTMP_on(PAD_SV(flip->op_targ));
7142 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7143 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
7145 /* check barewords before they might be optimized aways */
7146 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
7147 no_bareword_allowed(left);
7148 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
7149 no_bareword_allowed(right);
7152 if (!flip->op_private || !flop->op_private)
7153 LINKLIST(o); /* blow off optimizer unless constant */
7159 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
7161 Constructs, checks, and returns an op tree expressing a loop. This is
7162 only a loop in the control flow through the op tree; it does not have
7163 the heavyweight loop structure that allows exiting the loop by C<last>
7164 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
7165 top-level op, except that some bits will be set automatically as required.
7166 C<expr> supplies the expression controlling loop iteration, and C<block>
7167 supplies the body of the loop; they are consumed by this function and
7168 become part of the constructed op tree. C<debuggable> is currently
7169 unused and should always be 1.
7175 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
7179 const bool once = block && block->op_flags & OPf_SPECIAL &&
7180 block->op_type == OP_NULL;
7182 PERL_UNUSED_ARG(debuggable);
7186 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
7187 || ( expr->op_type == OP_NOT
7188 && cUNOPx(expr)->op_first->op_type == OP_CONST
7189 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
7192 /* Return the block now, so that S_new_logop does not try to
7194 return block; /* do {} while 0 does once */
7195 if (expr->op_type == OP_READLINE
7196 || expr->op_type == OP_READDIR
7197 || expr->op_type == OP_GLOB
7198 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7199 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7200 expr = newUNOP(OP_DEFINED, 0,
7201 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7202 } else if (expr->op_flags & OPf_KIDS) {
7203 const OP * const k1 = ((UNOP*)expr)->op_first;
7204 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
7205 switch (expr->op_type) {
7207 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7208 && (k2->op_flags & OPf_STACKED)
7209 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7210 expr = newUNOP(OP_DEFINED, 0, expr);
7214 if (k1 && (k1->op_type == OP_READDIR
7215 || k1->op_type == OP_GLOB
7216 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7217 || k1->op_type == OP_EACH
7218 || k1->op_type == OP_AEACH))
7219 expr = newUNOP(OP_DEFINED, 0, expr);
7225 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
7226 * op, in listop. This is wrong. [perl #27024] */
7228 block = newOP(OP_NULL, 0);
7229 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
7230 o = new_logop(OP_AND, 0, &expr, &listop);
7237 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
7239 if (once && o != listop)
7241 assert(cUNOPo->op_first->op_type == OP_AND
7242 || cUNOPo->op_first->op_type == OP_OR);
7243 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
7247 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
7249 o->op_flags |= flags;
7251 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
7256 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
7258 Constructs, checks, and returns an op tree expressing a C<while> loop.
7259 This is a heavyweight loop, with structure that allows exiting the loop
7260 by C<last> and suchlike.
7262 C<loop> is an optional preconstructed C<enterloop> op to use in the
7263 loop; if it is null then a suitable op will be constructed automatically.
7264 C<expr> supplies the loop's controlling expression. C<block> supplies the
7265 main body of the loop, and C<cont> optionally supplies a C<continue> block
7266 that operates as a second half of the body. All of these optree inputs
7267 are consumed by this function and become part of the constructed op tree.
7269 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7270 op and, shifted up eight bits, the eight bits of C<op_private> for
7271 the C<leaveloop> op, except that (in both cases) some bits will be set
7272 automatically. C<debuggable> is currently unused and should always be 1.
7273 C<has_my> can be supplied as true to force the
7274 loop body to be enclosed in its own scope.
7280 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
7281 OP *expr, OP *block, OP *cont, I32 has_my)
7290 PERL_UNUSED_ARG(debuggable);
7293 if (expr->op_type == OP_READLINE
7294 || expr->op_type == OP_READDIR
7295 || expr->op_type == OP_GLOB
7296 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
7297 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
7298 expr = newUNOP(OP_DEFINED, 0,
7299 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
7300 } else if (expr->op_flags & OPf_KIDS) {
7301 const OP * const k1 = ((UNOP*)expr)->op_first;
7302 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
7303 switch (expr->op_type) {
7305 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
7306 && (k2->op_flags & OPf_STACKED)
7307 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
7308 expr = newUNOP(OP_DEFINED, 0, expr);
7312 if (k1 && (k1->op_type == OP_READDIR
7313 || k1->op_type == OP_GLOB
7314 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
7315 || k1->op_type == OP_EACH
7316 || k1->op_type == OP_AEACH))
7317 expr = newUNOP(OP_DEFINED, 0, expr);
7324 block = newOP(OP_NULL, 0);
7325 else if (cont || has_my) {
7326 block = op_scope(block);
7330 next = LINKLIST(cont);
7333 OP * const unstack = newOP(OP_UNSTACK, 0);
7336 cont = op_append_elem(OP_LINESEQ, cont, unstack);
7340 listop = op_append_list(OP_LINESEQ, block, cont);
7342 redo = LINKLIST(listop);
7346 o = new_logop(OP_AND, 0, &expr, &listop);
7347 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
7349 return expr; /* listop already freed by new_logop */
7352 ((LISTOP*)listop)->op_last->op_next =
7353 (o == listop ? redo : LINKLIST(o));
7359 NewOp(1101,loop,1,LOOP);
7360 OpTYPE_set(loop, OP_ENTERLOOP);
7361 loop->op_private = 0;
7362 loop->op_next = (OP*)loop;
7365 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
7367 loop->op_redoop = redo;
7368 loop->op_lastop = o;
7369 o->op_private |= loopflags;
7372 loop->op_nextop = next;
7374 loop->op_nextop = o;
7376 o->op_flags |= flags;
7377 o->op_private |= (flags >> 8);
7382 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
7384 Constructs, checks, and returns an op tree expressing a C<foreach>
7385 loop (iteration through a list of values). This is a heavyweight loop,
7386 with structure that allows exiting the loop by C<last> and suchlike.
7388 C<sv> optionally supplies the variable that will be aliased to each
7389 item in turn; if null, it defaults to C<$_>.
7390 C<expr> supplies the list of values to iterate over. C<block> supplies
7391 the main body of the loop, and C<cont> optionally supplies a C<continue>
7392 block that operates as a second half of the body. All of these optree
7393 inputs are consumed by this function and become part of the constructed
7396 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
7397 op and, shifted up eight bits, the eight bits of C<op_private> for
7398 the C<leaveloop> op, except that (in both cases) some bits will be set
7405 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
7410 PADOFFSET padoff = 0;
7414 PERL_ARGS_ASSERT_NEWFOROP;
7417 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
7418 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
7419 OpTYPE_set(sv, OP_RV2GV);
7421 /* The op_type check is needed to prevent a possible segfault
7422 * if the loop variable is undeclared and 'strict vars' is in
7423 * effect. This is illegal but is nonetheless parsed, so we
7424 * may reach this point with an OP_CONST where we're expecting
7427 if (cUNOPx(sv)->op_first->op_type == OP_GV
7428 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
7429 iterpflags |= OPpITER_DEF;
7431 else if (sv->op_type == OP_PADSV) { /* private variable */
7432 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
7433 padoff = sv->op_targ;
7437 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
7439 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
7442 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
7444 PADNAME * const pn = PAD_COMPNAME(padoff);
7445 const char * const name = PadnamePV(pn);
7447 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
7448 iterpflags |= OPpITER_DEF;
7452 sv = newGVOP(OP_GV, 0, PL_defgv);
7453 iterpflags |= OPpITER_DEF;
7456 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
7457 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
7458 iterflags |= OPf_STACKED;
7460 else if (expr->op_type == OP_NULL &&
7461 (expr->op_flags & OPf_KIDS) &&
7462 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
7464 /* Basically turn for($x..$y) into the same as for($x,$y), but we
7465 * set the STACKED flag to indicate that these values are to be
7466 * treated as min/max values by 'pp_enteriter'.
7468 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
7469 LOGOP* const range = (LOGOP*) flip->op_first;
7470 OP* const left = range->op_first;
7471 OP* const right = OpSIBLING(left);
7474 range->op_flags &= ~OPf_KIDS;
7475 /* detach range's children */
7476 op_sibling_splice((OP*)range, NULL, -1, NULL);
7478 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
7479 listop->op_first->op_next = range->op_next;
7480 left->op_next = range->op_other;
7481 right->op_next = (OP*)listop;
7482 listop->op_next = listop->op_first;
7485 expr = (OP*)(listop);
7487 iterflags |= OPf_STACKED;
7490 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
7493 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
7494 op_append_elem(OP_LIST, list(expr),
7496 assert(!loop->op_next);
7497 /* for my $x () sets OPpLVAL_INTRO;
7498 * for our $x () sets OPpOUR_INTRO */
7499 loop->op_private = (U8)iterpflags;
7500 if (loop->op_slabbed
7501 && DIFF(loop, OpSLOT(loop)->opslot_next)
7502 < SIZE_TO_PSIZE(sizeof(LOOP)))
7505 NewOp(1234,tmp,1,LOOP);
7506 Copy(loop,tmp,1,LISTOP);
7507 #ifdef PERL_OP_PARENT
7508 assert(loop->op_last->op_sibparent == (OP*)loop);
7509 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
7511 S_op_destroy(aTHX_ (OP*)loop);
7514 else if (!loop->op_slabbed)
7516 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
7517 #ifdef PERL_OP_PARENT
7518 OpLASTSIB_set(loop->op_last, (OP*)loop);
7521 loop->op_targ = padoff;
7522 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
7527 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
7529 Constructs, checks, and returns a loop-exiting op (such as C<goto>
7530 or C<last>). C<type> is the opcode. C<label> supplies the parameter
7531 determining the target of the op; it is consumed by this function and
7532 becomes part of the constructed op tree.
7538 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
7542 PERL_ARGS_ASSERT_NEWLOOPEX;
7544 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
7545 || type == OP_CUSTOM);
7547 if (type != OP_GOTO) {
7548 /* "last()" means "last" */
7549 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
7550 o = newOP(type, OPf_SPECIAL);
7554 /* Check whether it's going to be a goto &function */
7555 if (label->op_type == OP_ENTERSUB
7556 && !(label->op_flags & OPf_STACKED))
7557 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
7560 /* Check for a constant argument */
7561 if (label->op_type == OP_CONST) {
7562 SV * const sv = ((SVOP *)label)->op_sv;
7564 const char *s = SvPV_const(sv,l);
7565 if (l == strlen(s)) {
7567 SvUTF8(((SVOP*)label)->op_sv),
7569 SvPV_nolen_const(((SVOP*)label)->op_sv)));
7573 /* If we have already created an op, we do not need the label. */
7576 else o = newUNOP(type, OPf_STACKED, label);
7578 PL_hints |= HINT_BLOCK_SCOPE;
7582 /* if the condition is a literal array or hash
7583 (or @{ ... } etc), make a reference to it.
7586 S_ref_array_or_hash(pTHX_ OP *cond)
7589 && (cond->op_type == OP_RV2AV
7590 || cond->op_type == OP_PADAV
7591 || cond->op_type == OP_RV2HV
7592 || cond->op_type == OP_PADHV))
7594 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
7597 && (cond->op_type == OP_ASLICE
7598 || cond->op_type == OP_KVASLICE
7599 || cond->op_type == OP_HSLICE
7600 || cond->op_type == OP_KVHSLICE)) {
7602 /* anonlist now needs a list from this op, was previously used in
7604 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
7605 cond->op_flags |= OPf_WANT_LIST;
7607 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
7614 /* These construct the optree fragments representing given()
7617 entergiven and enterwhen are LOGOPs; the op_other pointer
7618 points up to the associated leave op. We need this so we
7619 can put it in the context and make break/continue work.
7620 (Also, of course, pp_enterwhen will jump straight to
7621 op_other if the match fails.)
7625 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
7626 I32 enter_opcode, I32 leave_opcode,
7627 PADOFFSET entertarg)
7633 PERL_ARGS_ASSERT_NEWGIVWHENOP;
7634 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
7636 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
7637 enterop->op_targ = 0;
7638 enterop->op_private = 0;
7640 o = newUNOP(leave_opcode, 0, (OP *) enterop);
7643 /* prepend cond if we have one */
7644 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
7646 o->op_next = LINKLIST(cond);
7647 cond->op_next = (OP *) enterop;
7650 /* This is a default {} block */
7651 enterop->op_flags |= OPf_SPECIAL;
7652 o ->op_flags |= OPf_SPECIAL;
7654 o->op_next = (OP *) enterop;
7657 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7658 entergiven and enterwhen both
7661 enterop->op_next = LINKLIST(block);
7662 block->op_next = enterop->op_other = o;
7667 /* Does this look like a boolean operation? For these purposes
7668 a boolean operation is:
7669 - a subroutine call [*]
7670 - a logical connective
7671 - a comparison operator
7672 - a filetest operator, with the exception of -s -M -A -C
7673 - defined(), exists() or eof()
7674 - /$re/ or $foo =~ /$re/
7676 [*] possibly surprising
7679 S_looks_like_bool(pTHX_ const OP *o)
7681 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7683 switch(o->op_type) {
7686 return looks_like_bool(cLOGOPo->op_first);
7690 OP* sibl = OpSIBLING(cLOGOPo->op_first);
7693 looks_like_bool(cLOGOPo->op_first)
7694 && looks_like_bool(sibl));
7700 o->op_flags & OPf_KIDS
7701 && looks_like_bool(cUNOPo->op_first));
7705 case OP_NOT: case OP_XOR:
7707 case OP_EQ: case OP_NE: case OP_LT:
7708 case OP_GT: case OP_LE: case OP_GE:
7710 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
7711 case OP_I_GT: case OP_I_LE: case OP_I_GE:
7713 case OP_SEQ: case OP_SNE: case OP_SLT:
7714 case OP_SGT: case OP_SLE: case OP_SGE:
7718 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
7719 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
7720 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
7721 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
7722 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
7723 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
7724 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
7725 case OP_FTTEXT: case OP_FTBINARY:
7727 case OP_DEFINED: case OP_EXISTS:
7728 case OP_MATCH: case OP_EOF:
7735 /* Detect comparisons that have been optimized away */
7736 if (cSVOPo->op_sv == &PL_sv_yes
7737 || cSVOPo->op_sv == &PL_sv_no)
7750 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7752 Constructs, checks, and returns an op tree expressing a C<given> block.
7753 C<cond> supplies the expression that will be locally assigned to a lexical
7754 variable, and C<block> supplies the body of the C<given> construct; they
7755 are consumed by this function and become part of the constructed op tree.
7756 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
7762 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7764 PERL_ARGS_ASSERT_NEWGIVENOP;
7765 PERL_UNUSED_ARG(defsv_off);
7768 return newGIVWHENOP(
7769 ref_array_or_hash(cond),
7771 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7776 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7778 Constructs, checks, and returns an op tree expressing a C<when> block.
7779 C<cond> supplies the test expression, and C<block> supplies the block
7780 that will be executed if the test evaluates to true; they are consumed
7781 by this function and become part of the constructed op tree. C<cond>
7782 will be interpreted DWIMically, often as a comparison against C<$_>,
7783 and may be null to generate a C<default> block.
7789 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7791 const bool cond_llb = (!cond || looks_like_bool(cond));
7794 PERL_ARGS_ASSERT_NEWWHENOP;
7799 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7801 scalar(ref_array_or_hash(cond)));
7804 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7807 /* must not conflict with SVf_UTF8 */
7808 #define CV_CKPROTO_CURSTASH 0x1
7811 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7812 const STRLEN len, const U32 flags)
7814 SV *name = NULL, *msg;
7815 const char * cvp = SvROK(cv)
7816 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7817 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7820 STRLEN clen = CvPROTOLEN(cv), plen = len;
7822 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7824 if (p == NULL && cvp == NULL)
7827 if (!ckWARN_d(WARN_PROTOTYPE))
7831 p = S_strip_spaces(aTHX_ p, &plen);
7832 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7833 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7834 if (plen == clen && memEQ(cvp, p, plen))
7837 if (flags & SVf_UTF8) {
7838 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7842 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7848 msg = sv_newmortal();
7853 gv_efullname3(name = sv_newmortal(), gv, NULL);
7854 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7855 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7856 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7857 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7858 sv_catpvs(name, "::");
7860 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7861 assert (CvNAMED(SvRV_const(gv)));
7862 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7864 else sv_catsv(name, (SV *)gv);
7866 else name = (SV *)gv;
7868 sv_setpvs(msg, "Prototype mismatch:");
7870 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7872 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7873 UTF8fARG(SvUTF8(cv),clen,cvp)
7876 sv_catpvs(msg, ": none");
7877 sv_catpvs(msg, " vs ");
7879 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7881 sv_catpvs(msg, "none");
7882 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7885 static void const_sv_xsub(pTHX_ CV* cv);
7886 static void const_av_xsub(pTHX_ CV* cv);
7890 =head1 Optree Manipulation Functions
7892 =for apidoc cv_const_sv
7894 If C<cv> is a constant sub eligible for inlining, returns the constant
7895 value returned by the sub. Otherwise, returns C<NULL>.
7897 Constant subs can be created with C<newCONSTSUB> or as described in
7898 L<perlsub/"Constant Functions">.
7903 Perl_cv_const_sv(const CV *const cv)
7908 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7910 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7911 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7916 Perl_cv_const_sv_or_av(const CV * const cv)
7920 if (SvROK(cv)) return SvRV((SV *)cv);
7921 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7922 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7925 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7926 * Can be called in 2 ways:
7929 * look for a single OP_CONST with attached value: return the value
7931 * allow_lex && !CvCONST(cv);
7933 * examine the clone prototype, and if contains only a single
7934 * OP_CONST, return the value; or if it contains a single PADSV ref-
7935 * erencing an outer lexical, turn on CvCONST to indicate the CV is
7936 * a candidate for "constizing" at clone time, and return NULL.
7940 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
7948 for (; o; o = o->op_next) {
7949 const OPCODE type = o->op_type;
7951 if (type == OP_NEXTSTATE || type == OP_LINESEQ
7953 || type == OP_PUSHMARK)
7955 if (type == OP_DBSTATE)
7957 if (type == OP_LEAVESUB)
7961 if (type == OP_CONST && cSVOPo->op_sv)
7963 else if (type == OP_UNDEF && !o->op_private) {
7967 else if (allow_lex && type == OP_PADSV) {
7968 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
7970 sv = &PL_sv_undef; /* an arbitrary non-null value */
7988 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7989 PADNAME * const name, SV ** const const_svp)
7996 if (CvFLAGS(PL_compcv)) {
7997 /* might have had built-in attrs applied */
7998 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7999 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
8000 && ckWARN(WARN_MISC))
8002 /* protect against fatal warnings leaking compcv */
8003 SAVEFREESV(PL_compcv);
8004 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
8005 SvREFCNT_inc_simple_void_NN(PL_compcv);
8008 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
8009 & ~(CVf_LVALUE * pureperl));
8014 /* redundant check for speed: */
8015 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8016 const line_t oldline = CopLINE(PL_curcop);
8019 : sv_2mortal(newSVpvn_utf8(
8020 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
8022 if (PL_parser && PL_parser->copline != NOLINE)
8023 /* This ensures that warnings are reported at the first
8024 line of a redefinition, not the last. */
8025 CopLINE_set(PL_curcop, PL_parser->copline);
8026 /* protect against fatal warnings leaking compcv */
8027 SAVEFREESV(PL_compcv);
8028 report_redefined_cv(namesv, cv, const_svp);
8029 SvREFCNT_inc_simple_void_NN(PL_compcv);
8030 CopLINE_set(PL_curcop, oldline);
8037 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
8042 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8045 CV *compcv = PL_compcv;
8048 PADOFFSET pax = o->op_targ;
8049 CV *outcv = CvOUTSIDE(PL_compcv);
8052 bool reusable = FALSE;
8054 #ifdef PERL_DEBUG_READONLY_OPS
8055 OPSLAB *slab = NULL;
8058 PERL_ARGS_ASSERT_NEWMYSUB;
8060 /* Find the pad slot for storing the new sub.
8061 We cannot use PL_comppad, as it is the pad owned by the new sub. We
8062 need to look in CvOUTSIDE and find the pad belonging to the enclos-
8063 ing sub. And then we need to dig deeper if this is a lexical from
8065 my sub foo; sub { sub foo { } }
8068 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
8069 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
8070 pax = PARENT_PAD_INDEX(name);
8071 outcv = CvOUTSIDE(outcv);
8076 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
8077 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
8078 spot = (CV **)svspot;
8080 if (!(PL_parser && PL_parser->error_count))
8081 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name));
8084 assert(proto->op_type == OP_CONST);
8085 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8086 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8096 if (PL_parser && PL_parser->error_count) {
8098 SvREFCNT_dec(PL_compcv);
8103 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8105 svspot = (SV **)(spot = &clonee);
8107 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
8110 assert (SvTYPE(*spot) == SVt_PVCV);
8112 hek = CvNAME_HEK(*spot);
8116 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8117 CvNAME_HEK_set(*spot, hek =
8120 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8124 CvLEXICAL_on(*spot);
8126 cv = PadnamePROTOCV(name);
8127 svspot = (SV **)(spot = &PadnamePROTOCV(name));
8131 /* This makes sub {}; work as expected. */
8132 if (block->op_type == OP_STUB) {
8133 const line_t l = PL_parser->copline;
8135 block = newSTATEOP(0, NULL, 0);
8136 PL_parser->copline = l;
8138 block = CvLVALUE(compcv)
8139 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
8140 ? newUNOP(OP_LEAVESUBLV, 0,
8141 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8142 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8143 start = LINKLIST(block);
8145 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
8146 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
8154 const bool exists = CvROOT(cv) || CvXSUB(cv);
8156 /* if the subroutine doesn't exist and wasn't pre-declared
8157 * with a prototype, assume it will be AUTOLOADed,
8158 * skipping the prototype check
8160 if (exists || SvPOK(cv))
8161 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
8163 /* already defined? */
8165 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
8168 if (attrs) goto attrs;
8169 /* just a "sub foo;" when &foo is already defined */
8174 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
8180 SvREFCNT_inc_simple_void_NN(const_sv);
8181 SvFLAGS(const_sv) |= SVs_PADTMP;
8183 assert(!CvROOT(cv) && !CvCONST(cv));
8187 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8188 CvFILE_set_from_cop(cv, PL_curcop);
8189 CvSTASH_set(cv, PL_curstash);
8192 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8193 CvXSUBANY(cv).any_ptr = const_sv;
8194 CvXSUB(cv) = const_sv_xsub;
8198 CvFLAGS(cv) |= CvMETHOD(compcv);
8200 SvREFCNT_dec(compcv);
8204 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
8205 determine whether this sub definition is in the same scope as its
8206 declaration. If this sub definition is inside an inner named pack-
8207 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
8208 the package sub. So check PadnameOUTER(name) too.
8210 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
8211 assert(!CvWEAKOUTSIDE(compcv));
8212 SvREFCNT_dec(CvOUTSIDE(compcv));
8213 CvWEAKOUTSIDE_on(compcv);
8215 /* XXX else do we have a circular reference? */
8216 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
8217 /* transfer PL_compcv to cv */
8220 cv_flags_t preserved_flags =
8221 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
8222 PADLIST *const temp_padl = CvPADLIST(cv);
8223 CV *const temp_cv = CvOUTSIDE(cv);
8224 const cv_flags_t other_flags =
8225 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8226 OP * const cvstart = CvSTART(cv);
8230 CvFLAGS(compcv) | preserved_flags;
8231 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
8232 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
8233 CvPADLIST_set(cv, CvPADLIST(compcv));
8234 CvOUTSIDE(compcv) = temp_cv;
8235 CvPADLIST_set(compcv, temp_padl);
8236 CvSTART(cv) = CvSTART(compcv);
8237 CvSTART(compcv) = cvstart;
8238 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8239 CvFLAGS(compcv) |= other_flags;
8241 if (CvFILE(cv) && CvDYNFILE(cv)) {
8242 Safefree(CvFILE(cv));
8245 /* inner references to compcv must be fixed up ... */
8246 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
8247 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8248 ++PL_sub_generation;
8251 /* Might have had built-in attributes applied -- propagate them. */
8252 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
8254 /* ... before we throw it away */
8255 SvREFCNT_dec(compcv);
8256 PL_compcv = compcv = cv;
8264 if (!CvNAME_HEK(cv)) {
8265 if (hek) (void)share_hek_hek(hek);
8269 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
8270 hek = share_hek(PadnamePV(name)+1,
8271 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
8274 CvNAME_HEK_set(cv, hek);
8276 if (const_sv) goto clone;
8278 CvFILE_set_from_cop(cv, PL_curcop);
8279 CvSTASH_set(cv, PL_curstash);
8282 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8283 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8289 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8290 the debugger could be able to set a breakpoint in, so signal to
8291 pp_entereval that it should not throw away any saved lines at scope
8294 PL_breakable_sub_gen++;
8296 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8297 OpREFCNT_set(CvROOT(cv), 1);
8298 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8299 itself has a refcount. */
8301 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8302 #ifdef PERL_DEBUG_READONLY_OPS
8303 slab = (OPSLAB *)CvSTART(cv);
8305 CvSTART(cv) = start;
8307 finalize_optree(CvROOT(cv));
8308 S_prune_chain_head(&CvSTART(cv));
8310 /* now that optimizer has done its work, adjust pad values */
8312 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8316 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8317 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
8321 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8322 SV * const tmpstr = sv_newmortal();
8323 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8324 GV_ADDMULTI, SVt_PVHV);
8326 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8329 (long)CopLINE(PL_curcop));
8330 if (HvNAME_HEK(PL_curstash)) {
8331 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
8332 sv_catpvs(tmpstr, "::");
8334 else sv_setpvs(tmpstr, "__ANON__::");
8335 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
8336 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
8337 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8338 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8339 hv = GvHVn(db_postponed);
8340 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8341 CV * const pcv = GvCV(db_postponed);
8347 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8355 assert(CvDEPTH(outcv));
8357 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
8358 if (reusable) cv_clone_into(clonee, *spot);
8359 else *spot = cv_clone(clonee);
8360 SvREFCNT_dec_NN(clonee);
8363 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
8364 PADOFFSET depth = CvDEPTH(outcv);
8367 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
8369 *svspot = SvREFCNT_inc_simple_NN(cv);
8370 SvREFCNT_dec(oldcv);
8376 PL_parser->copline = NOLINE;
8378 #ifdef PERL_DEBUG_READONLY_OPS
8388 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
8389 OP *block, bool o_is_gv)
8393 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
8397 const bool ec = PL_parser && PL_parser->error_count;
8398 /* If the subroutine has no body, no attributes, and no builtin attributes
8399 then it's just a sub declaration, and we may be able to get away with
8400 storing with a placeholder scalar in the symbol table, rather than a
8401 full CV. If anything is present then it will take a full CV to
8403 const I32 gv_fetch_flags
8404 = ec ? GV_NOADD_NOINIT :
8405 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
8406 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
8408 const char * const name =
8409 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
8411 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
8412 bool evanescent = FALSE;
8414 #ifdef PERL_DEBUG_READONLY_OPS
8415 OPSLAB *slab = NULL;
8423 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
8424 hek and CvSTASH pointer together can imply the GV. If the name
8425 contains a package name, then GvSTASH(CvGV(cv)) may differ from
8426 CvSTASH, so forego the optimisation if we find any.
8427 Also, we may be called from load_module at run time, so
8428 PL_curstash (which sets CvSTASH) may not point to the stash the
8429 sub is stored in. */
8431 ec ? GV_NOADD_NOINIT
8432 : PL_curstash != CopSTASH(PL_curcop)
8433 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
8435 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
8436 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
8438 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
8439 SV * const sv = sv_newmortal();
8440 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
8441 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8442 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
8443 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
8445 } else if (PL_curstash) {
8446 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
8449 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
8454 move_proto_attr(&proto, &attrs, gv);
8457 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv);
8462 assert(proto->op_type == OP_CONST);
8463 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
8464 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
8478 if (name) SvREFCNT_dec(PL_compcv);
8479 else cv = PL_compcv;
8481 if (name && block) {
8482 const char *s = strrchr(name, ':');
8484 if (strEQ(s, "BEGIN")) {
8485 if (PL_in_eval & EVAL_KEEPERR)
8486 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
8488 SV * const errsv = ERRSV;
8489 /* force display of errors found but not reported */
8490 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
8491 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
8498 if (!block && SvTYPE(gv) != SVt_PVGV) {
8499 /* If we are not defining a new sub and the existing one is not a
8501 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
8502 /* We are applying attributes to an existing sub, so we need it
8503 upgraded if it is a constant. */
8504 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
8505 gv_init_pvn(gv, PL_curstash, name, namlen,
8506 SVf_UTF8 * name_is_utf8);
8508 else { /* Maybe prototype now, and had at maximum
8509 a prototype or const/sub ref before. */
8510 if (SvTYPE(gv) > SVt_NULL) {
8511 cv_ckproto_len_flags((const CV *)gv,
8512 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8517 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
8518 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
8521 sv_setiv(MUTABLE_SV(gv), -1);
8524 SvREFCNT_dec(PL_compcv);
8525 cv = PL_compcv = NULL;
8530 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
8534 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
8540 /* This makes sub {}; work as expected. */
8541 if (block->op_type == OP_STUB) {
8542 const line_t l = PL_parser->copline;
8544 block = newSTATEOP(0, NULL, 0);
8545 PL_parser->copline = l;
8547 block = CvLVALUE(PL_compcv)
8548 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
8549 && (!isGV(gv) || !GvASSUMECV(gv)))
8550 ? newUNOP(OP_LEAVESUBLV, 0,
8551 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8552 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8553 start = LINKLIST(block);
8555 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
8557 S_op_const_sv(aTHX_ start, PL_compcv,
8558 cBOOL(CvCLONE(PL_compcv)));
8565 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
8566 cv_ckproto_len_flags((const CV *)gv,
8567 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
8568 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
8570 /* All the other code for sub redefinition warnings expects the
8571 clobbered sub to be a CV. Instead of making all those code
8572 paths more complex, just inline the RV version here. */
8573 const line_t oldline = CopLINE(PL_curcop);
8574 assert(IN_PERL_COMPILETIME);
8575 if (PL_parser && PL_parser->copline != NOLINE)
8576 /* This ensures that warnings are reported at the first
8577 line of a redefinition, not the last. */
8578 CopLINE_set(PL_curcop, PL_parser->copline);
8579 /* protect against fatal warnings leaking compcv */
8580 SAVEFREESV(PL_compcv);
8582 if (ckWARN(WARN_REDEFINE)
8583 || ( ckWARN_d(WARN_REDEFINE)
8584 && ( !const_sv || SvRV(gv) == const_sv
8585 || sv_cmp(SvRV(gv), const_sv) ))) {
8587 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8588 "Constant subroutine %"SVf" redefined",
8589 SVfARG(cSVOPo->op_sv));
8592 SvREFCNT_inc_simple_void_NN(PL_compcv);
8593 CopLINE_set(PL_curcop, oldline);
8594 SvREFCNT_dec(SvRV(gv));
8599 const bool exists = CvROOT(cv) || CvXSUB(cv);
8601 /* if the subroutine doesn't exist and wasn't pre-declared
8602 * with a prototype, assume it will be AUTOLOADed,
8603 * skipping the prototype check
8605 if (exists || SvPOK(cv))
8606 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
8607 /* already defined (or promised)? */
8608 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
8609 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
8612 if (attrs) goto attrs;
8613 /* just a "sub foo;" when &foo is already defined */
8614 SAVEFREESV(PL_compcv);
8620 SvREFCNT_inc_simple_void_NN(const_sv);
8621 SvFLAGS(const_sv) |= SVs_PADTMP;
8623 assert(!CvROOT(cv) && !CvCONST(cv));
8625 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
8626 CvXSUBANY(cv).any_ptr = const_sv;
8627 CvXSUB(cv) = const_sv_xsub;
8631 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8634 if (isGV(gv) || CvMETHOD(PL_compcv)) {
8635 if (name && isGV(gv))
8637 cv = newCONSTSUB_flags(
8638 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
8641 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
8645 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8646 prepare_SV_for_RV((SV *)gv);
8650 SvRV_set(gv, const_sv);
8654 SvREFCNT_dec(PL_compcv);
8658 if (cv) { /* must reuse cv if autoloaded */
8659 /* transfer PL_compcv to cv */
8662 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
8663 PADLIST *const temp_av = CvPADLIST(cv);
8664 CV *const temp_cv = CvOUTSIDE(cv);
8665 const cv_flags_t other_flags =
8666 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
8667 OP * const cvstart = CvSTART(cv);
8671 assert(!CvCVGV_RC(cv));
8672 assert(CvGV(cv) == gv);
8677 PERL_HASH(hash, name, namlen);
8687 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
8689 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
8690 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
8691 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
8692 CvOUTSIDE(PL_compcv) = temp_cv;
8693 CvPADLIST_set(PL_compcv, temp_av);
8694 CvSTART(cv) = CvSTART(PL_compcv);
8695 CvSTART(PL_compcv) = cvstart;
8696 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
8697 CvFLAGS(PL_compcv) |= other_flags;
8699 if (CvFILE(cv) && CvDYNFILE(cv)) {
8700 Safefree(CvFILE(cv));
8702 CvFILE_set_from_cop(cv, PL_curcop);
8703 CvSTASH_set(cv, PL_curstash);
8705 /* inner references to PL_compcv must be fixed up ... */
8706 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
8707 if (PERLDB_INTER)/* Advice debugger on the new sub. */
8708 ++PL_sub_generation;
8711 /* Might have had built-in attributes applied -- propagate them. */
8712 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
8714 /* ... before we throw it away */
8715 SvREFCNT_dec(PL_compcv);
8720 if (name && isGV(gv)) {
8723 if (HvENAME_HEK(GvSTASH(gv)))
8724 /* sub Foo::bar { (shift)+1 } */
8725 gv_method_changed(gv);
8729 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
8730 prepare_SV_for_RV((SV *)gv);
8734 SvRV_set(gv, (SV *)cv);
8738 if (isGV(gv)) CvGV_set(cv, gv);
8742 PERL_HASH(hash, name, namlen);
8743 CvNAME_HEK_set(cv, share_hek(name,
8749 CvFILE_set_from_cop(cv, PL_curcop);
8750 CvSTASH_set(cv, PL_curstash);
8754 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
8755 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8761 /* If we assign an optree to a PVCV, then we've defined a subroutine that
8762 the debugger could be able to set a breakpoint in, so signal to
8763 pp_entereval that it should not throw away any saved lines at scope
8766 PL_breakable_sub_gen++;
8768 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8769 OpREFCNT_set(CvROOT(cv), 1);
8770 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8771 itself has a refcount. */
8773 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8774 #ifdef PERL_DEBUG_READONLY_OPS
8775 slab = (OPSLAB *)CvSTART(cv);
8777 CvSTART(cv) = start;
8779 finalize_optree(CvROOT(cv));
8780 S_prune_chain_head(&CvSTART(cv));
8782 /* now that optimizer has done its work, adjust pad values */
8784 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8788 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8789 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8792 if (!name) SAVEFREESV(cv);
8793 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8794 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8797 if (block && has_name) {
8798 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8799 SV * const tmpstr = cv_name(cv,NULL,0);
8800 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8801 GV_ADDMULTI, SVt_PVHV);
8803 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8806 (long)CopLINE(PL_curcop));
8807 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8808 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8809 hv = GvHVn(db_postponed);
8810 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8811 CV * const pcv = GvCV(db_postponed);
8817 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8823 if (PL_parser && PL_parser->error_count)
8824 clear_special_blocks(name, gv, cv);
8827 process_special_blocks(floor, name, gv, cv);
8833 PL_parser->copline = NOLINE;
8836 #ifdef PERL_DEBUG_READONLY_OPS
8840 if (cv && name && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
8841 pad_add_weakref(cv);
8847 S_clear_special_blocks(pTHX_ const char *const fullname,
8848 GV *const gv, CV *const cv) {
8852 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8854 colon = strrchr(fullname,':');
8855 name = colon ? colon + 1 : fullname;
8857 if ((*name == 'B' && strEQ(name, "BEGIN"))
8858 || (*name == 'E' && strEQ(name, "END"))
8859 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8860 || (*name == 'C' && strEQ(name, "CHECK"))
8861 || (*name == 'I' && strEQ(name, "INIT"))) {
8867 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8871 /* Returns true if the sub has been freed. */
8873 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8877 const char *const colon = strrchr(fullname,':');
8878 const char *const name = colon ? colon + 1 : fullname;
8880 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8883 if (strEQ(name, "BEGIN")) {
8884 const I32 oldscope = PL_scopestack_ix;
8887 if (floor) LEAVE_SCOPE(floor);
8889 PUSHSTACKi(PERLSI_REQUIRE);
8890 SAVECOPFILE(&PL_compiling);
8891 SAVECOPLINE(&PL_compiling);
8892 SAVEVPTR(PL_curcop);
8894 DEBUG_x( dump_sub(gv) );
8895 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8896 GvCV_set(gv,0); /* cv has been hijacked */
8897 call_list(oldscope, PL_beginav);
8901 return !PL_savebegin;
8907 if strEQ(name, "END") {
8908 DEBUG_x( dump_sub(gv) );
8909 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8912 } else if (*name == 'U') {
8913 if (strEQ(name, "UNITCHECK")) {
8914 /* It's never too late to run a unitcheck block */
8915 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8919 } else if (*name == 'C') {
8920 if (strEQ(name, "CHECK")) {
8922 /* diag_listed_as: Too late to run %s block */
8923 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8924 "Too late to run CHECK block");
8925 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8929 } else if (*name == 'I') {
8930 if (strEQ(name, "INIT")) {
8932 /* diag_listed_as: Too late to run %s block */
8933 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8934 "Too late to run INIT block");
8935 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8941 DEBUG_x( dump_sub(gv) );
8943 GvCV_set(gv,0); /* cv has been hijacked */
8949 =for apidoc newCONSTSUB
8951 See L</newCONSTSUB_flags>.
8957 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8959 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8963 =for apidoc newCONSTSUB_flags
8965 Creates a constant sub equivalent to Perl S<C<sub FOO () { 123 }>> which is
8966 eligible for inlining at compile-time.
8968 Currently, the only useful value for C<flags> is C<SVf_UTF8>.
8970 The newly created subroutine takes ownership of a reference to the passed in
8973 Passing C<NULL> for SV creates a constant sub equivalent to S<C<sub BAR () {}>>,
8974 which won't be called if used as a destructor, but will suppress the overhead
8975 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8982 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8986 const char *const file = CopFILE(PL_curcop);
8990 if (IN_PERL_RUNTIME) {
8991 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8992 * an op shared between threads. Use a non-shared COP for our
8994 SAVEVPTR(PL_curcop);
8995 SAVECOMPILEWARNINGS();
8996 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8997 PL_curcop = &PL_compiling;
8999 SAVECOPLINE(PL_curcop);
9000 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
9003 PL_hints &= ~HINT_BLOCK_SCOPE;
9006 SAVEGENERICSV(PL_curstash);
9007 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
9010 /* Protect sv against leakage caused by fatal warnings. */
9011 if (sv) SAVEFREESV(sv);
9013 /* file becomes the CvFILE. For an XS, it's usually static storage,
9014 and so doesn't get free()d. (It's expected to be from the C pre-
9015 processor __FILE__ directive). But we need a dynamically allocated one,
9016 and we need it to get freed. */
9017 cv = newXS_len_flags(name, len,
9018 sv && SvTYPE(sv) == SVt_PVAV
9021 file ? file : "", "",
9022 &sv, XS_DYNAMIC_FILENAME | flags);
9023 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
9032 =for apidoc U||newXS
9034 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
9035 static storage, as it is used directly as CvFILE(), without a copy being made.
9041 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
9043 PERL_ARGS_ASSERT_NEWXS;
9044 return newXS_len_flags(
9045 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
9050 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
9051 const char *const filename, const char *const proto,
9054 PERL_ARGS_ASSERT_NEWXS_FLAGS;
9055 return newXS_len_flags(
9056 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
9061 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
9063 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
9064 return newXS_len_flags(
9065 name, strlen(name), subaddr, NULL, NULL, NULL, 0
9070 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
9071 XSUBADDR_t subaddr, const char *const filename,
9072 const char *const proto, SV **const_svp,
9076 bool interleave = FALSE;
9078 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
9081 GV * const gv = gv_fetchpvn(
9082 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9083 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
9084 sizeof("__ANON__::__ANON__") - 1,
9085 GV_ADDMULTI | flags, SVt_PVCV);
9087 if ((cv = (name ? GvCV(gv) : NULL))) {
9089 /* just a cached method */
9093 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
9094 /* already defined (or promised) */
9095 /* Redundant check that allows us to avoid creating an SV
9096 most of the time: */
9097 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9098 report_redefined_cv(newSVpvn_flags(
9099 name,len,(flags&SVf_UTF8)|SVs_TEMP
9110 if (cv) /* must reuse cv if autoloaded */
9113 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9117 if (HvENAME_HEK(GvSTASH(gv)))
9118 gv_method_changed(gv); /* newXS */
9124 /* XSUBs can't be perl lang/perl5db.pl debugged
9125 if (PERLDB_LINE_OR_SAVESRC)
9126 (void)gv_fetchfile(filename); */
9127 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
9128 if (flags & XS_DYNAMIC_FILENAME) {
9130 CvFILE(cv) = savepv(filename);
9132 /* NOTE: not copied, as it is expected to be an external constant string */
9133 CvFILE(cv) = (char *)filename;
9136 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
9137 CvFILE(cv) = (char*)PL_xsubfilename;
9140 CvXSUB(cv) = subaddr;
9141 #ifndef PERL_IMPLICIT_CONTEXT
9142 CvHSCXT(cv) = &PL_stack_sp;
9148 process_special_blocks(0, name, gv, cv);
9151 } /* <- not a conditional branch */
9154 sv_setpv(MUTABLE_SV(cv), proto);
9155 if (interleave) LEAVE;
9160 Perl_newSTUB(pTHX_ GV *gv, bool fake)
9162 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9164 PERL_ARGS_ASSERT_NEWSTUB;
9168 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
9169 gv_method_changed(gv);
9171 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
9176 CvFILE_set_from_cop(cv, PL_curcop);
9177 CvSTASH_set(cv, PL_curstash);
9183 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
9189 if (PL_parser && PL_parser->error_count) {
9195 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
9196 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
9199 if ((cv = GvFORM(gv))) {
9200 if (ckWARN(WARN_REDEFINE)) {
9201 const line_t oldline = CopLINE(PL_curcop);
9202 if (PL_parser && PL_parser->copline != NOLINE)
9203 CopLINE_set(PL_curcop, PL_parser->copline);
9205 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9206 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
9208 /* diag_listed_as: Format %s redefined */
9209 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
9210 "Format STDOUT redefined");
9212 CopLINE_set(PL_curcop, oldline);
9217 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
9219 CvFILE_set_from_cop(cv, PL_curcop);
9222 pad_tidy(padtidy_FORMAT);
9223 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
9224 CvROOT(cv)->op_private |= OPpREFCOUNTED;
9225 OpREFCNT_set(CvROOT(cv), 1);
9226 CvSTART(cv) = LINKLIST(CvROOT(cv));
9227 CvROOT(cv)->op_next = 0;
9228 CALL_PEEP(CvSTART(cv));
9229 finalize_optree(CvROOT(cv));
9230 S_prune_chain_head(&CvSTART(cv));
9236 PL_parser->copline = NOLINE;
9238 PL_compiling.cop_seq = 0;
9242 Perl_newANONLIST(pTHX_ OP *o)
9244 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
9248 Perl_newANONHASH(pTHX_ OP *o)
9250 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
9254 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
9256 return newANONATTRSUB(floor, proto, NULL, block);
9260 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
9262 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
9264 newSVOP(OP_ANONCODE, 0,
9266 if (CvANONCONST(cv))
9267 anoncode = newUNOP(OP_ANONCONST, 0,
9268 op_convert_list(OP_ENTERSUB,
9269 OPf_STACKED|OPf_WANT_SCALAR,
9271 return newUNOP(OP_REFGEN, 0, anoncode);
9275 Perl_oopsAV(pTHX_ OP *o)
9279 PERL_ARGS_ASSERT_OOPSAV;
9281 switch (o->op_type) {
9284 OpTYPE_set(o, OP_PADAV);
9285 return ref(o, OP_RV2AV);
9289 OpTYPE_set(o, OP_RV2AV);
9294 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
9301 Perl_oopsHV(pTHX_ OP *o)
9305 PERL_ARGS_ASSERT_OOPSHV;
9307 switch (o->op_type) {
9310 OpTYPE_set(o, OP_PADHV);
9311 return ref(o, OP_RV2HV);
9315 OpTYPE_set(o, OP_RV2HV);
9320 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
9327 Perl_newAVREF(pTHX_ OP *o)
9331 PERL_ARGS_ASSERT_NEWAVREF;
9333 if (o->op_type == OP_PADANY) {
9334 OpTYPE_set(o, OP_PADAV);
9337 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
9338 Perl_croak(aTHX_ "Can't use an array as a reference");
9340 return newUNOP(OP_RV2AV, 0, scalar(o));
9344 Perl_newGVREF(pTHX_ I32 type, OP *o)
9346 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
9347 return newUNOP(OP_NULL, 0, o);
9348 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
9352 Perl_newHVREF(pTHX_ OP *o)
9356 PERL_ARGS_ASSERT_NEWHVREF;
9358 if (o->op_type == OP_PADANY) {
9359 OpTYPE_set(o, OP_PADHV);
9362 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
9363 Perl_croak(aTHX_ "Can't use a hash as a reference");
9365 return newUNOP(OP_RV2HV, 0, scalar(o));
9369 Perl_newCVREF(pTHX_ I32 flags, OP *o)
9371 if (o->op_type == OP_PADANY) {
9373 OpTYPE_set(o, OP_PADCV);
9375 return newUNOP(OP_RV2CV, flags, scalar(o));
9379 Perl_newSVREF(pTHX_ OP *o)
9383 PERL_ARGS_ASSERT_NEWSVREF;
9385 if (o->op_type == OP_PADANY) {
9386 OpTYPE_set(o, OP_PADSV);
9390 return newUNOP(OP_RV2SV, 0, scalar(o));
9393 /* Check routines. See the comments at the top of this file for details
9394 * on when these are called */
9397 Perl_ck_anoncode(pTHX_ OP *o)
9399 PERL_ARGS_ASSERT_CK_ANONCODE;
9401 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
9402 cSVOPo->op_sv = NULL;
9407 S_io_hints(pTHX_ OP *o)
9409 #if O_BINARY != 0 || O_TEXT != 0
9411 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
9413 SV **svp = hv_fetchs(table, "open_IN", FALSE);
9416 const char *d = SvPV_const(*svp, len);
9417 const I32 mode = mode_from_discipline(d, len);
9418 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9420 if (mode & O_BINARY)
9421 o->op_private |= OPpOPEN_IN_RAW;
9425 o->op_private |= OPpOPEN_IN_CRLF;
9429 svp = hv_fetchs(table, "open_OUT", FALSE);
9432 const char *d = SvPV_const(*svp, len);
9433 const I32 mode = mode_from_discipline(d, len);
9434 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
9436 if (mode & O_BINARY)
9437 o->op_private |= OPpOPEN_OUT_RAW;
9441 o->op_private |= OPpOPEN_OUT_CRLF;
9446 PERL_UNUSED_CONTEXT;
9452 Perl_ck_backtick(pTHX_ OP *o)
9457 PERL_ARGS_ASSERT_CK_BACKTICK;
9458 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
9459 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
9460 && (gv = gv_override("readpipe",8)))
9462 /* detach rest of siblings from o and its first child */
9463 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
9464 newop = S_new_entersubop(aTHX_ gv, sibl);
9466 else if (!(o->op_flags & OPf_KIDS))
9467 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9472 S_io_hints(aTHX_ o);
9477 Perl_ck_bitop(pTHX_ OP *o)
9479 PERL_ARGS_ASSERT_CK_BITOP;
9481 o->op_private = (U8)(PL_hints & HINT_INTEGER);
9483 if (o->op_type == OP_NBIT_OR || o->op_type == OP_SBIT_OR
9484 || o->op_type == OP_NBIT_XOR || o->op_type == OP_SBIT_XOR
9485 || o->op_type == OP_NBIT_AND || o->op_type == OP_SBIT_AND
9486 || o->op_type == OP_NCOMPLEMENT || o->op_type == OP_SCOMPLEMENT)
9487 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__BITWISE),
9488 "The bitwise feature is experimental");
9489 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
9490 && OP_IS_INFIX_BIT(o->op_type))
9492 const OP * const left = cBINOPo->op_first;
9493 const OP * const right = OpSIBLING(left);
9494 if ((OP_IS_NUMCOMPARE(left->op_type) &&
9495 (left->op_flags & OPf_PARENS) == 0) ||
9496 (OP_IS_NUMCOMPARE(right->op_type) &&
9497 (right->op_flags & OPf_PARENS) == 0))
9498 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
9499 "Possible precedence problem on bitwise %s operator",
9500 o->op_type == OP_BIT_OR
9501 ||o->op_type == OP_NBIT_OR ? "|"
9502 : o->op_type == OP_BIT_AND
9503 ||o->op_type == OP_NBIT_AND ? "&"
9504 : o->op_type == OP_BIT_XOR
9505 ||o->op_type == OP_NBIT_XOR ? "^"
9506 : o->op_type == OP_SBIT_OR ? "|."
9507 : o->op_type == OP_SBIT_AND ? "&." : "^."
9513 PERL_STATIC_INLINE bool
9514 is_dollar_bracket(pTHX_ const OP * const o)
9517 PERL_UNUSED_CONTEXT;
9518 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
9519 && (kid = cUNOPx(o)->op_first)
9520 && kid->op_type == OP_GV
9521 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
9525 Perl_ck_cmp(pTHX_ OP *o)
9527 PERL_ARGS_ASSERT_CK_CMP;
9528 if (ckWARN(WARN_SYNTAX)) {
9529 const OP *kid = cUNOPo->op_first;
9532 ( is_dollar_bracket(aTHX_ kid)
9533 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
9535 || ( kid->op_type == OP_CONST
9536 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
9540 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9541 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
9547 Perl_ck_concat(pTHX_ OP *o)
9549 const OP * const kid = cUNOPo->op_first;
9551 PERL_ARGS_ASSERT_CK_CONCAT;
9552 PERL_UNUSED_CONTEXT;
9554 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
9555 !(kUNOP->op_first->op_flags & OPf_MOD))
9556 o->op_flags |= OPf_STACKED;
9561 Perl_ck_spair(pTHX_ OP *o)
9565 PERL_ARGS_ASSERT_CK_SPAIR;
9567 if (o->op_flags & OPf_KIDS) {
9571 const OPCODE type = o->op_type;
9572 o = modkids(ck_fun(o), type);
9573 kid = cUNOPo->op_first;
9574 kidkid = kUNOP->op_first;
9575 newop = OpSIBLING(kidkid);
9577 const OPCODE type = newop->op_type;
9578 if (OpHAS_SIBLING(newop))
9580 if (o->op_type == OP_REFGEN
9581 && ( type == OP_RV2CV
9582 || ( !(newop->op_flags & OPf_PARENS)
9583 && ( type == OP_RV2AV || type == OP_PADAV
9584 || type == OP_RV2HV || type == OP_PADHV))))
9585 NOOP; /* OK (allow srefgen for \@a and \%h) */
9586 else if (OP_GIMME(newop,0) != G_SCALAR)
9589 /* excise first sibling */
9590 op_sibling_splice(kid, NULL, 1, NULL);
9593 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
9594 * and OP_CHOMP into OP_SCHOMP */
9595 o->op_ppaddr = PL_ppaddr[++o->op_type];
9600 Perl_ck_delete(pTHX_ OP *o)
9602 PERL_ARGS_ASSERT_CK_DELETE;
9606 if (o->op_flags & OPf_KIDS) {
9607 OP * const kid = cUNOPo->op_first;
9608 switch (kid->op_type) {
9610 o->op_flags |= OPf_SPECIAL;
9613 o->op_private |= OPpSLICE;
9616 o->op_flags |= OPf_SPECIAL;
9621 Perl_croak(aTHX_ "delete argument is index/value array slice,"
9622 " use array slice");
9624 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
9627 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
9628 "element or slice");
9630 if (kid->op_private & OPpLVAL_INTRO)
9631 o->op_private |= OPpLVAL_INTRO;
9638 Perl_ck_eof(pTHX_ OP *o)
9640 PERL_ARGS_ASSERT_CK_EOF;
9642 if (o->op_flags & OPf_KIDS) {
9644 if (cLISTOPo->op_first->op_type == OP_STUB) {
9646 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
9651 kid = cLISTOPo->op_first;
9652 if (kid->op_type == OP_RV2GV)
9653 kid->op_private |= OPpALLOW_FAKE;
9659 Perl_ck_eval(pTHX_ OP *o)
9663 PERL_ARGS_ASSERT_CK_EVAL;
9665 PL_hints |= HINT_BLOCK_SCOPE;
9666 if (o->op_flags & OPf_KIDS) {
9667 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9670 if (o->op_type == OP_ENTERTRY) {
9673 /* cut whole sibling chain free from o */
9674 op_sibling_splice(o, NULL, -1, NULL);
9677 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
9679 /* establish postfix order */
9680 enter->op_next = (OP*)enter;
9682 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
9683 OpTYPE_set(o, OP_LEAVETRY);
9684 enter->op_other = o;
9689 S_set_haseval(aTHX);
9693 const U8 priv = o->op_private;
9695 /* the newUNOP will recursively call ck_eval(), which will handle
9696 * all the stuff at the end of this function, like adding
9699 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
9701 o->op_targ = (PADOFFSET)PL_hints;
9702 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
9703 if ((PL_hints & HINT_LOCALIZE_HH) != 0
9704 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
9705 /* Store a copy of %^H that pp_entereval can pick up. */
9706 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
9707 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
9708 /* append hhop to only child */
9709 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
9711 o->op_private |= OPpEVAL_HAS_HH;
9713 if (!(o->op_private & OPpEVAL_BYTES)
9714 && FEATURE_UNIEVAL_IS_ENABLED)
9715 o->op_private |= OPpEVAL_UNICODE;
9720 Perl_ck_exec(pTHX_ OP *o)
9722 PERL_ARGS_ASSERT_CK_EXEC;
9724 if (o->op_flags & OPf_STACKED) {
9727 kid = OpSIBLING(cUNOPo->op_first);
9728 if (kid->op_type == OP_RV2GV)
9737 Perl_ck_exists(pTHX_ OP *o)
9739 PERL_ARGS_ASSERT_CK_EXISTS;
9742 if (o->op_flags & OPf_KIDS) {
9743 OP * const kid = cUNOPo->op_first;
9744 if (kid->op_type == OP_ENTERSUB) {
9745 (void) ref(kid, o->op_type);
9746 if (kid->op_type != OP_RV2CV
9747 && !(PL_parser && PL_parser->error_count))
9749 "exists argument is not a subroutine name");
9750 o->op_private |= OPpEXISTS_SUB;
9752 else if (kid->op_type == OP_AELEM)
9753 o->op_flags |= OPf_SPECIAL;
9754 else if (kid->op_type != OP_HELEM)
9755 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
9756 "element or a subroutine");
9763 Perl_ck_rvconst(pTHX_ OP *o)
9766 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9768 PERL_ARGS_ASSERT_CK_RVCONST;
9770 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9772 if (kid->op_type == OP_CONST) {
9775 SV * const kidsv = kid->op_sv;
9777 /* Is it a constant from cv_const_sv()? */
9778 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
9781 if (SvTYPE(kidsv) == SVt_PVAV) return o;
9782 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9783 const char *badthing;
9784 switch (o->op_type) {
9786 badthing = "a SCALAR";
9789 badthing = "an ARRAY";
9792 badthing = "a HASH";
9800 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9801 SVfARG(kidsv), badthing);
9804 * This is a little tricky. We only want to add the symbol if we
9805 * didn't add it in the lexer. Otherwise we get duplicate strict
9806 * warnings. But if we didn't add it in the lexer, we must at
9807 * least pretend like we wanted to add it even if it existed before,
9808 * or we get possible typo warnings. OPpCONST_ENTERED says
9809 * whether the lexer already added THIS instance of this symbol.
9811 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9812 gv = gv_fetchsv(kidsv,
9813 o->op_type == OP_RV2CV
9814 && o->op_private & OPpMAY_RETURN_CONSTANT
9816 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9819 : o->op_type == OP_RV2SV
9821 : o->op_type == OP_RV2AV
9823 : o->op_type == OP_RV2HV
9830 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9831 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9832 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9834 OpTYPE_set(kid, OP_GV);
9835 SvREFCNT_dec(kid->op_sv);
9837 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9838 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
9839 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9840 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9841 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9843 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9845 kid->op_private = 0;
9846 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9854 Perl_ck_ftst(pTHX_ OP *o)
9857 const I32 type = o->op_type;
9859 PERL_ARGS_ASSERT_CK_FTST;
9861 if (o->op_flags & OPf_REF) {
9864 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9865 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9866 const OPCODE kidtype = kid->op_type;
9868 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9869 && !kid->op_folded) {
9870 OP * const newop = newGVOP(type, OPf_REF,
9871 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9876 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
9877 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
9879 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9880 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
9881 array_passed_to_stat, name);
9884 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
9885 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
9889 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9890 o->op_private |= OPpFT_ACCESS;
9891 if (type != OP_STAT && type != OP_LSTAT
9892 && PL_check[kidtype] == Perl_ck_ftst
9893 && kidtype != OP_STAT && kidtype != OP_LSTAT
9895 o->op_private |= OPpFT_STACKED;
9896 kid->op_private |= OPpFT_STACKING;
9897 if (kidtype == OP_FTTTY && (
9898 !(kid->op_private & OPpFT_STACKED)
9899 || kid->op_private & OPpFT_AFTER_t
9901 o->op_private |= OPpFT_AFTER_t;
9906 if (type == OP_FTTTY)
9907 o = newGVOP(type, OPf_REF, PL_stdingv);
9909 o = newUNOP(type, 0, newDEFSVOP());
9915 Perl_ck_fun(pTHX_ OP *o)
9917 const int type = o->op_type;
9918 I32 oa = PL_opargs[type] >> OASHIFT;
9920 PERL_ARGS_ASSERT_CK_FUN;
9922 if (o->op_flags & OPf_STACKED) {
9923 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9926 return no_fh_allowed(o);
9929 if (o->op_flags & OPf_KIDS) {
9930 OP *prev_kid = NULL;
9931 OP *kid = cLISTOPo->op_first;
9933 bool seen_optional = FALSE;
9935 if (kid->op_type == OP_PUSHMARK ||
9936 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9939 kid = OpSIBLING(kid);
9941 if (kid && kid->op_type == OP_COREARGS) {
9942 bool optional = FALSE;
9945 if (oa & OA_OPTIONAL) optional = TRUE;
9948 if (optional) o->op_private |= numargs;
9953 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9954 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9956 /* append kid to chain */
9957 op_sibling_splice(o, prev_kid, 0, kid);
9959 seen_optional = TRUE;
9966 /* list seen where single (scalar) arg expected? */
9967 if (numargs == 1 && !(oa >> 4)
9968 && kid->op_type == OP_LIST && type != OP_SCALAR)
9970 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9972 if (type != OP_DELETE) scalar(kid);
9983 if ((type == OP_PUSH || type == OP_UNSHIFT)
9984 && !OpHAS_SIBLING(kid))
9985 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9986 "Useless use of %s with no values",
9989 if (kid->op_type == OP_CONST
9990 && ( !SvROK(cSVOPx_sv(kid))
9991 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9993 bad_type_pv(numargs, "array", o, kid);
9994 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
9995 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
9996 PL_op_desc[type]), 0);
9999 op_lvalue(kid, type);
10003 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
10004 bad_type_pv(numargs, "hash", o, kid);
10005 op_lvalue(kid, type);
10009 /* replace kid with newop in chain */
10011 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
10012 newop->op_next = newop;
10017 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
10018 if (kid->op_type == OP_CONST &&
10019 (kid->op_private & OPpCONST_BARE))
10021 OP * const newop = newGVOP(OP_GV, 0,
10022 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
10023 /* replace kid with newop in chain */
10024 op_sibling_splice(o, prev_kid, 1, newop);
10028 else if (kid->op_type == OP_READLINE) {
10029 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
10030 bad_type_pv(numargs, "HANDLE", o, kid);
10033 I32 flags = OPf_SPECIAL;
10035 PADOFFSET targ = 0;
10037 /* is this op a FH constructor? */
10038 if (is_handle_constructor(o,numargs)) {
10039 const char *name = NULL;
10042 bool want_dollar = TRUE;
10045 /* Set a flag to tell rv2gv to vivify
10046 * need to "prove" flag does not mean something
10047 * else already - NI-S 1999/05/07
10050 if (kid->op_type == OP_PADSV) {
10052 = PAD_COMPNAME_SV(kid->op_targ);
10053 name = PadnamePV (pn);
10054 len = PadnameLEN(pn);
10055 name_utf8 = PadnameUTF8(pn);
10057 else if (kid->op_type == OP_RV2SV
10058 && kUNOP->op_first->op_type == OP_GV)
10060 GV * const gv = cGVOPx_gv(kUNOP->op_first);
10062 len = GvNAMELEN(gv);
10063 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
10065 else if (kid->op_type == OP_AELEM
10066 || kid->op_type == OP_HELEM)
10069 OP *op = ((BINOP*)kid)->op_first;
10073 const char * const a =
10074 kid->op_type == OP_AELEM ?
10076 if (((op->op_type == OP_RV2AV) ||
10077 (op->op_type == OP_RV2HV)) &&
10078 (firstop = ((UNOP*)op)->op_first) &&
10079 (firstop->op_type == OP_GV)) {
10080 /* packagevar $a[] or $h{} */
10081 GV * const gv = cGVOPx_gv(firstop);
10084 Perl_newSVpvf(aTHX_
10089 else if (op->op_type == OP_PADAV
10090 || op->op_type == OP_PADHV) {
10091 /* lexicalvar $a[] or $h{} */
10092 const char * const padname =
10093 PAD_COMPNAME_PV(op->op_targ);
10096 Perl_newSVpvf(aTHX_
10102 name = SvPV_const(tmpstr, len);
10103 name_utf8 = SvUTF8(tmpstr);
10104 sv_2mortal(tmpstr);
10108 name = "__ANONIO__";
10110 want_dollar = FALSE;
10112 op_lvalue(kid, type);
10116 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
10117 namesv = PAD_SVl(targ);
10118 if (want_dollar && *name != '$')
10119 sv_setpvs(namesv, "$");
10121 sv_setpvs(namesv, "");
10122 sv_catpvn(namesv, name, len);
10123 if ( name_utf8 ) SvUTF8_on(namesv);
10127 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
10129 kid->op_targ = targ;
10130 kid->op_private |= priv;
10136 if ((type == OP_UNDEF || type == OP_POS)
10137 && numargs == 1 && !(oa >> 4)
10138 && kid->op_type == OP_LIST)
10139 return too_many_arguments_pv(o,PL_op_desc[type], 0);
10140 op_lvalue(scalar(kid), type);
10145 kid = OpSIBLING(kid);
10147 /* FIXME - should the numargs or-ing move after the too many
10148 * arguments check? */
10149 o->op_private |= numargs;
10151 return too_many_arguments_pv(o,OP_DESC(o), 0);
10154 else if (PL_opargs[type] & OA_DEFGV) {
10155 /* Ordering of these two is important to keep f_map.t passing. */
10157 return newUNOP(type, 0, newDEFSVOP());
10161 while (oa & OA_OPTIONAL)
10163 if (oa && oa != OA_LIST)
10164 return too_few_arguments_pv(o,OP_DESC(o), 0);
10170 Perl_ck_glob(pTHX_ OP *o)
10174 PERL_ARGS_ASSERT_CK_GLOB;
10177 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
10178 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
10180 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
10184 * \ null - const(wildcard)
10189 * \ mark - glob - rv2cv
10190 * | \ gv(CORE::GLOBAL::glob)
10192 * \ null - const(wildcard)
10194 o->op_flags |= OPf_SPECIAL;
10195 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
10196 o = S_new_entersubop(aTHX_ gv, o);
10197 o = newUNOP(OP_NULL, 0, o);
10198 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
10201 else o->op_flags &= ~OPf_SPECIAL;
10202 #if !defined(PERL_EXTERNAL_GLOB)
10203 if (!PL_globhook) {
10205 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
10206 newSVpvs("File::Glob"), NULL, NULL, NULL);
10209 #endif /* !PERL_EXTERNAL_GLOB */
10210 gv = (GV *)newSV(0);
10211 gv_init(gv, 0, "", 0, 0);
10213 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
10214 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
10220 Perl_ck_grep(pTHX_ OP *o)
10224 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
10226 PERL_ARGS_ASSERT_CK_GREP;
10228 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
10230 if (o->op_flags & OPf_STACKED) {
10231 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
10232 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
10233 return no_fh_allowed(o);
10234 o->op_flags &= ~OPf_STACKED;
10236 kid = OpSIBLING(cLISTOPo->op_first);
10237 if (type == OP_MAPWHILE)
10242 if (PL_parser && PL_parser->error_count)
10244 kid = OpSIBLING(cLISTOPo->op_first);
10245 if (kid->op_type != OP_NULL)
10246 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
10247 kid = kUNOP->op_first;
10249 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
10250 kid->op_next = (OP*)gwop;
10251 o->op_private = gwop->op_private = 0;
10252 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
10254 kid = OpSIBLING(cLISTOPo->op_first);
10255 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
10256 op_lvalue(kid, OP_GREPSTART);
10262 Perl_ck_index(pTHX_ OP *o)
10264 PERL_ARGS_ASSERT_CK_INDEX;
10266 if (o->op_flags & OPf_KIDS) {
10267 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10269 kid = OpSIBLING(kid); /* get past "big" */
10270 if (kid && kid->op_type == OP_CONST) {
10271 const bool save_taint = TAINT_get;
10272 SV *sv = kSVOP->op_sv;
10273 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
10275 sv_copypv(sv, kSVOP->op_sv);
10276 SvREFCNT_dec_NN(kSVOP->op_sv);
10279 if (SvOK(sv)) fbm_compile(sv, 0);
10280 TAINT_set(save_taint);
10281 #ifdef NO_TAINT_SUPPORT
10282 PERL_UNUSED_VAR(save_taint);
10290 Perl_ck_lfun(pTHX_ OP *o)
10292 const OPCODE type = o->op_type;
10294 PERL_ARGS_ASSERT_CK_LFUN;
10296 return modkids(ck_fun(o), type);
10300 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
10302 PERL_ARGS_ASSERT_CK_DEFINED;
10304 if ((o->op_flags & OPf_KIDS)) {
10305 switch (cUNOPo->op_first->op_type) {
10308 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
10309 " (Maybe you should just omit the defined()?)");
10313 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
10314 " (Maybe you should just omit the defined()?)");
10325 Perl_ck_readline(pTHX_ OP *o)
10327 PERL_ARGS_ASSERT_CK_READLINE;
10329 if (o->op_flags & OPf_KIDS) {
10330 OP *kid = cLISTOPo->op_first;
10331 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10335 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
10343 Perl_ck_rfun(pTHX_ OP *o)
10345 const OPCODE type = o->op_type;
10347 PERL_ARGS_ASSERT_CK_RFUN;
10349 return refkids(ck_fun(o), type);
10353 Perl_ck_listiob(pTHX_ OP *o)
10357 PERL_ARGS_ASSERT_CK_LISTIOB;
10359 kid = cLISTOPo->op_first;
10361 o = force_list(o, 1);
10362 kid = cLISTOPo->op_first;
10364 if (kid->op_type == OP_PUSHMARK)
10365 kid = OpSIBLING(kid);
10366 if (kid && o->op_flags & OPf_STACKED)
10367 kid = OpSIBLING(kid);
10368 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
10369 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
10370 && !kid->op_folded) {
10371 o->op_flags |= OPf_STACKED; /* make it a filehandle */
10373 /* replace old const op with new OP_RV2GV parent */
10374 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
10375 OP_RV2GV, OPf_REF);
10376 kid = OpSIBLING(kid);
10381 op_append_elem(o->op_type, o, newDEFSVOP());
10383 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
10384 return listkids(o);
10388 Perl_ck_smartmatch(pTHX_ OP *o)
10391 PERL_ARGS_ASSERT_CK_SMARTMATCH;
10392 if (0 == (o->op_flags & OPf_SPECIAL)) {
10393 OP *first = cBINOPo->op_first;
10394 OP *second = OpSIBLING(first);
10396 /* Implicitly take a reference to an array or hash */
10398 /* remove the original two siblings, then add back the
10399 * (possibly different) first and second sibs.
10401 op_sibling_splice(o, NULL, 1, NULL);
10402 op_sibling_splice(o, NULL, 1, NULL);
10403 first = ref_array_or_hash(first);
10404 second = ref_array_or_hash(second);
10405 op_sibling_splice(o, NULL, 0, second);
10406 op_sibling_splice(o, NULL, 0, first);
10408 /* Implicitly take a reference to a regular expression */
10409 if (first->op_type == OP_MATCH) {
10410 OpTYPE_set(first, OP_QR);
10412 if (second->op_type == OP_MATCH) {
10413 OpTYPE_set(second, OP_QR);
10422 S_maybe_targlex(pTHX_ OP *o)
10424 OP * const kid = cLISTOPo->op_first;
10425 /* has a disposable target? */
10426 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
10427 && !(kid->op_flags & OPf_STACKED)
10428 /* Cannot steal the second time! */
10429 && !(kid->op_private & OPpTARGET_MY)
10432 OP * const kkid = OpSIBLING(kid);
10434 /* Can just relocate the target. */
10435 if (kkid && kkid->op_type == OP_PADSV
10436 && (!(kkid->op_private & OPpLVAL_INTRO)
10437 || kkid->op_private & OPpPAD_STATE))
10439 kid->op_targ = kkid->op_targ;
10441 /* Now we do not need PADSV and SASSIGN.
10442 * Detach kid and free the rest. */
10443 op_sibling_splice(o, NULL, 1, NULL);
10445 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
10453 Perl_ck_sassign(pTHX_ OP *o)
10456 OP * const kid = cLISTOPo->op_first;
10458 PERL_ARGS_ASSERT_CK_SASSIGN;
10460 if (OpHAS_SIBLING(kid)) {
10461 OP *kkid = OpSIBLING(kid);
10462 /* For state variable assignment with attributes, kkid is a list op
10463 whose op_last is a padsv. */
10464 if ((kkid->op_type == OP_PADSV ||
10465 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
10466 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
10469 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
10470 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
10471 const PADOFFSET target = kkid->op_targ;
10472 OP *const other = newOP(OP_PADSV,
10474 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
10475 OP *const first = newOP(OP_NULL, 0);
10477 newCONDOP(0, first, o, other);
10478 /* XXX targlex disabled for now; see ticket #124160
10479 newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
10481 OP *const condop = first->op_next;
10483 OpTYPE_set(condop, OP_ONCE);
10484 other->op_targ = target;
10485 nullop->op_flags |= OPf_WANT_SCALAR;
10487 /* Store the initializedness of state vars in a separate
10490 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
10491 /* hijacking PADSTALE for uninitialized state variables */
10492 SvPADSTALE_on(PAD_SVl(condop->op_targ));
10497 return S_maybe_targlex(aTHX_ o);
10501 Perl_ck_match(pTHX_ OP *o)
10503 PERL_UNUSED_CONTEXT;
10504 PERL_ARGS_ASSERT_CK_MATCH;
10506 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
10507 o->op_private |= OPpRUNTIME;
10512 Perl_ck_method(pTHX_ OP *o)
10514 SV *sv, *methsv, *rclass;
10515 const char* method;
10518 STRLEN len, nsplit = 0, i;
10520 OP * const kid = cUNOPo->op_first;
10522 PERL_ARGS_ASSERT_CK_METHOD;
10523 if (kid->op_type != OP_CONST) return o;
10527 /* replace ' with :: */
10528 while ((compatptr = strchr(SvPVX(sv), '\''))) {
10530 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
10533 method = SvPVX_const(sv);
10535 utf8 = SvUTF8(sv) ? -1 : 1;
10537 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
10542 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
10544 if (!nsplit) { /* $proto->method() */
10546 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
10549 if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
10551 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
10554 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
10555 if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
10556 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
10557 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
10559 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
10560 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
10562 #ifdef USE_ITHREADS
10563 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
10565 cMETHOPx(new_op)->op_rclass_sv = rclass;
10572 Perl_ck_null(pTHX_ OP *o)
10574 PERL_ARGS_ASSERT_CK_NULL;
10575 PERL_UNUSED_CONTEXT;
10580 Perl_ck_open(pTHX_ OP *o)
10582 PERL_ARGS_ASSERT_CK_OPEN;
10584 S_io_hints(aTHX_ o);
10586 /* In case of three-arg dup open remove strictness
10587 * from the last arg if it is a bareword. */
10588 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
10589 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
10593 if ((last->op_type == OP_CONST) && /* The bareword. */
10594 (last->op_private & OPpCONST_BARE) &&
10595 (last->op_private & OPpCONST_STRICT) &&
10596 (oa = OpSIBLING(first)) && /* The fh. */
10597 (oa = OpSIBLING(oa)) && /* The mode. */
10598 (oa->op_type == OP_CONST) &&
10599 SvPOK(((SVOP*)oa)->op_sv) &&
10600 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
10601 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
10602 (last == OpSIBLING(oa))) /* The bareword. */
10603 last->op_private &= ~OPpCONST_STRICT;
10609 Perl_ck_prototype(pTHX_ OP *o)
10611 PERL_ARGS_ASSERT_CK_PROTOTYPE;
10612 if (!(o->op_flags & OPf_KIDS)) {
10614 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
10620 Perl_ck_refassign(pTHX_ OP *o)
10622 OP * const right = cLISTOPo->op_first;
10623 OP * const left = OpSIBLING(right);
10624 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
10627 PERL_ARGS_ASSERT_CK_REFASSIGN;
10629 assert (left->op_type == OP_SREFGEN);
10632 /* we use OPpPAD_STATE in refassign to mean either of those things,
10633 * and the code assumes the two flags occupy the same bit position
10634 * in the various ops below */
10635 assert(OPpPAD_STATE == OPpOUR_INTRO);
10637 switch (varop->op_type) {
10639 o->op_private |= OPpLVREF_AV;
10642 o->op_private |= OPpLVREF_HV;
10646 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
10647 o->op_targ = varop->op_targ;
10648 varop->op_targ = 0;
10649 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
10653 o->op_private |= OPpLVREF_AV;
10655 NOT_REACHED; /* NOTREACHED */
10657 o->op_private |= OPpLVREF_HV;
10661 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
10662 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
10664 /* Point varop to its GV kid, detached. */
10665 varop = op_sibling_splice(varop, NULL, -1, NULL);
10669 OP * const kidparent =
10670 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
10671 OP * const kid = cUNOPx(kidparent)->op_first;
10672 o->op_private |= OPpLVREF_CV;
10673 if (kid->op_type == OP_GV) {
10675 goto detach_and_stack;
10677 if (kid->op_type != OP_PADCV) goto bad;
10678 o->op_targ = kid->op_targ;
10684 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
10685 o->op_private |= OPpLVREF_ELEM;
10688 /* Detach varop. */
10689 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
10693 /* diag_listed_as: Can't modify reference to %s in %s assignment */
10694 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
10699 if (!FEATURE_REFALIASING_IS_ENABLED)
10701 "Experimental aliasing via reference not enabled");
10702 Perl_ck_warner_d(aTHX_
10703 packWARN(WARN_EXPERIMENTAL__REFALIASING),
10704 "Aliasing via reference is experimental");
10706 o->op_flags |= OPf_STACKED;
10707 op_sibling_splice(o, right, 1, varop);
10710 o->op_flags &=~ OPf_STACKED;
10711 op_sibling_splice(o, right, 1, NULL);
10718 Perl_ck_repeat(pTHX_ OP *o)
10720 PERL_ARGS_ASSERT_CK_REPEAT;
10722 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
10724 o->op_private |= OPpREPEAT_DOLIST;
10725 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
10726 kids = force_list(kids, 1); /* promote it to a list */
10727 op_sibling_splice(o, NULL, 0, kids); /* and add back */
10735 Perl_ck_require(pTHX_ OP *o)
10739 PERL_ARGS_ASSERT_CK_REQUIRE;
10741 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
10742 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10747 if (kid->op_type == OP_CONST) {
10748 SV * const sv = kid->op_sv;
10749 U32 const was_readonly = SvREADONLY(sv);
10750 if (kid->op_private & OPpCONST_BARE) {
10754 if (was_readonly) {
10755 SvREADONLY_off(sv);
10757 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
10762 /* treat ::foo::bar as foo::bar */
10763 if (len >= 2 && s[0] == ':' && s[1] == ':')
10764 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
10766 DIE(aTHX_ "Bareword in require maps to empty filename");
10768 for (; s < end; s++) {
10769 if (*s == ':' && s[1] == ':') {
10771 Move(s+2, s+1, end - s - 1, char);
10775 SvEND_set(sv, end);
10776 sv_catpvs(sv, ".pm");
10777 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
10778 hek = share_hek(SvPVX(sv),
10779 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
10781 sv_sethek(sv, hek);
10783 SvFLAGS(sv) |= was_readonly;
10785 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
10788 if (SvREFCNT(sv) > 1) {
10789 kid->op_sv = newSVpvn_share(
10790 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
10791 SvREFCNT_dec_NN(sv);
10795 if (was_readonly) SvREADONLY_off(sv);
10796 PERL_HASH(hash, s, len);
10798 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
10800 sv_sethek(sv, hek);
10802 SvFLAGS(sv) |= was_readonly;
10808 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
10809 /* handle override, if any */
10810 && (gv = gv_override("require", 7))) {
10812 if (o->op_flags & OPf_KIDS) {
10813 kid = cUNOPo->op_first;
10814 op_sibling_splice(o, NULL, -1, NULL);
10817 kid = newDEFSVOP();
10820 newop = S_new_entersubop(aTHX_ gv, kid);
10828 Perl_ck_return(pTHX_ OP *o)
10832 PERL_ARGS_ASSERT_CK_RETURN;
10834 kid = OpSIBLING(cLISTOPo->op_first);
10835 if (CvLVALUE(PL_compcv)) {
10836 for (; kid; kid = OpSIBLING(kid))
10837 op_lvalue(kid, OP_LEAVESUBLV);
10844 Perl_ck_select(pTHX_ OP *o)
10849 PERL_ARGS_ASSERT_CK_SELECT;
10851 if (o->op_flags & OPf_KIDS) {
10852 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10853 if (kid && OpHAS_SIBLING(kid)) {
10854 OpTYPE_set(o, OP_SSELECT);
10856 return fold_constants(op_integerize(op_std_init(o)));
10860 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10861 if (kid && kid->op_type == OP_RV2GV)
10862 kid->op_private &= ~HINT_STRICT_REFS;
10867 Perl_ck_shift(pTHX_ OP *o)
10869 const I32 type = o->op_type;
10871 PERL_ARGS_ASSERT_CK_SHIFT;
10873 if (!(o->op_flags & OPf_KIDS)) {
10876 if (!CvUNIQUE(PL_compcv)) {
10877 o->op_flags |= OPf_SPECIAL;
10881 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10883 return newUNOP(type, 0, scalar(argop));
10885 return scalar(ck_fun(o));
10889 Perl_ck_sort(pTHX_ OP *o)
10893 HV * const hinthv =
10894 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10897 PERL_ARGS_ASSERT_CK_SORT;
10900 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10902 const I32 sorthints = (I32)SvIV(*svp);
10903 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10904 o->op_private |= OPpSORT_QSORT;
10905 if ((sorthints & HINT_SORT_STABLE) != 0)
10906 o->op_private |= OPpSORT_STABLE;
10910 if (o->op_flags & OPf_STACKED)
10912 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10914 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
10915 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
10917 /* if the first arg is a code block, process it and mark sort as
10919 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10921 if (kid->op_type == OP_LEAVE)
10922 op_null(kid); /* wipe out leave */
10923 /* Prevent execution from escaping out of the sort block. */
10926 /* provide scalar context for comparison function/block */
10927 kid = scalar(firstkid);
10928 kid->op_next = kid;
10929 o->op_flags |= OPf_SPECIAL;
10931 else if (kid->op_type == OP_CONST
10932 && kid->op_private & OPpCONST_BARE) {
10936 const char * const name = SvPV(kSVOP_sv, len);
10938 assert (len < 256);
10939 Copy(name, tmpbuf+1, len, char);
10940 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
10941 if (off != NOT_IN_PAD) {
10942 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
10944 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
10945 sv_catpvs(fq, "::");
10946 sv_catsv(fq, kSVOP_sv);
10947 SvREFCNT_dec_NN(kSVOP_sv);
10951 OP * const padop = newOP(OP_PADCV, 0);
10952 padop->op_targ = off;
10953 /* replace the const op with the pad op */
10954 op_sibling_splice(firstkid, NULL, 1, padop);
10960 firstkid = OpSIBLING(firstkid);
10963 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
10964 /* provide list context for arguments */
10967 op_lvalue(kid, OP_GREPSTART);
10973 /* for sort { X } ..., where X is one of
10974 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10975 * elide the second child of the sort (the one containing X),
10976 * and set these flags as appropriate
10980 * Also, check and warn on lexical $a, $b.
10984 S_simplify_sort(pTHX_ OP *o)
10986 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
10990 const char *gvname;
10993 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10995 kid = kUNOP->op_first; /* get past null */
10996 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10997 && kid->op_type != OP_LEAVE)
10999 kid = kLISTOP->op_last; /* get past scope */
11000 switch(kid->op_type) {
11004 if (!have_scopeop) goto padkids;
11009 k = kid; /* remember this node*/
11010 if (kBINOP->op_first->op_type != OP_RV2SV
11011 || kBINOP->op_last ->op_type != OP_RV2SV)
11014 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
11015 then used in a comparison. This catches most, but not
11016 all cases. For instance, it catches
11017 sort { my($a); $a <=> $b }
11019 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
11020 (although why you'd do that is anyone's guess).
11024 if (!ckWARN(WARN_SYNTAX)) return;
11025 kid = kBINOP->op_first;
11027 if (kid->op_type == OP_PADSV) {
11028 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
11029 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
11030 && ( PadnamePV(name)[1] == 'a'
11031 || PadnamePV(name)[1] == 'b' ))
11032 /* diag_listed_as: "my %s" used in sort comparison */
11033 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11034 "\"%s %s\" used in sort comparison",
11035 PadnameIsSTATE(name)
11040 } while ((kid = OpSIBLING(kid)));
11043 kid = kBINOP->op_first; /* get past cmp */
11044 if (kUNOP->op_first->op_type != OP_GV)
11046 kid = kUNOP->op_first; /* get past rv2sv */
11048 if (GvSTASH(gv) != PL_curstash)
11050 gvname = GvNAME(gv);
11051 if (*gvname == 'a' && gvname[1] == '\0')
11053 else if (*gvname == 'b' && gvname[1] == '\0')
11058 kid = k; /* back to cmp */
11059 /* already checked above that it is rv2sv */
11060 kid = kBINOP->op_last; /* down to 2nd arg */
11061 if (kUNOP->op_first->op_type != OP_GV)
11063 kid = kUNOP->op_first; /* get past rv2sv */
11065 if (GvSTASH(gv) != PL_curstash)
11067 gvname = GvNAME(gv);
11069 ? !(*gvname == 'a' && gvname[1] == '\0')
11070 : !(*gvname == 'b' && gvname[1] == '\0'))
11072 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
11074 o->op_private |= OPpSORT_DESCEND;
11075 if (k->op_type == OP_NCMP)
11076 o->op_private |= OPpSORT_NUMERIC;
11077 if (k->op_type == OP_I_NCMP)
11078 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
11079 kid = OpSIBLING(cLISTOPo->op_first);
11080 /* cut out and delete old block (second sibling) */
11081 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
11086 Perl_ck_split(pTHX_ OP *o)
11091 PERL_ARGS_ASSERT_CK_SPLIT;
11093 if (o->op_flags & OPf_STACKED)
11094 return no_fh_allowed(o);
11096 kid = cLISTOPo->op_first;
11097 if (kid->op_type != OP_NULL)
11098 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
11099 /* delete leading NULL node, then add a CONST if no other nodes */
11100 op_sibling_splice(o, NULL, 1,
11101 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
11103 kid = cLISTOPo->op_first;
11105 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
11106 /* remove kid, and replace with new optree */
11107 op_sibling_splice(o, NULL, 1, NULL);
11108 /* OPf_SPECIAL is used to trigger split " " behavior */
11109 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0);
11110 op_sibling_splice(o, NULL, 0, kid);
11112 OpTYPE_set(kid, OP_PUSHRE);
11113 /* target implies @ary=..., so wipe it */
11116 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
11117 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11118 "Use of /g modifier is meaningless in split");
11121 if (!OpHAS_SIBLING(kid))
11122 op_append_elem(OP_SPLIT, o, newDEFSVOP());
11124 kid = OpSIBLING(kid);
11128 if (!OpHAS_SIBLING(kid))
11130 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
11131 o->op_private |= OPpSPLIT_IMPLIM;
11133 assert(OpHAS_SIBLING(kid));
11135 kid = OpSIBLING(kid);
11138 if (OpHAS_SIBLING(kid))
11139 return too_many_arguments_pv(o,OP_DESC(o), 0);
11145 Perl_ck_stringify(pTHX_ OP *o)
11147 OP * const kid = OpSIBLING(cUNOPo->op_first);
11148 PERL_ARGS_ASSERT_CK_STRINGIFY;
11149 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
11150 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
11151 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
11152 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
11154 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11162 Perl_ck_join(pTHX_ OP *o)
11164 OP * const kid = OpSIBLING(cLISTOPo->op_first);
11166 PERL_ARGS_ASSERT_CK_JOIN;
11168 if (kid && kid->op_type == OP_MATCH) {
11169 if (ckWARN(WARN_SYNTAX)) {
11170 const REGEXP *re = PM_GETRE(kPMOP);
11172 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
11173 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
11174 : newSVpvs_flags( "STRING", SVs_TEMP );
11175 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11176 "/%"SVf"/ should probably be written as \"%"SVf"\"",
11177 SVfARG(msg), SVfARG(msg));
11181 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
11182 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
11183 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
11184 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
11186 const OP * const bairn = OpSIBLING(kid); /* the list */
11187 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
11188 && OP_GIMME(bairn,0) == G_SCALAR)
11190 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
11191 op_sibling_splice(o, kid, 1, NULL));
11201 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
11203 Examines an op, which is expected to identify a subroutine at runtime,
11204 and attempts to determine at compile time which subroutine it identifies.
11205 This is normally used during Perl compilation to determine whether
11206 a prototype can be applied to a function call. C<cvop> is the op
11207 being considered, normally an C<rv2cv> op. A pointer to the identified
11208 subroutine is returned, if it could be determined statically, and a null
11209 pointer is returned if it was not possible to determine statically.
11211 Currently, the subroutine can be identified statically if the RV that the
11212 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
11213 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
11214 suitable if the constant value must be an RV pointing to a CV. Details of
11215 this process may change in future versions of Perl. If the C<rv2cv> op
11216 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
11217 the subroutine statically: this flag is used to suppress compile-time
11218 magic on a subroutine call, forcing it to use default runtime behaviour.
11220 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
11221 of a GV reference is modified. If a GV was examined and its CV slot was
11222 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
11223 If the op is not optimised away, and the CV slot is later populated with
11224 a subroutine having a prototype, that flag eventually triggers the warning
11225 "called too early to check prototype".
11227 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
11228 of returning a pointer to the subroutine it returns a pointer to the
11229 GV giving the most appropriate name for the subroutine in this context.
11230 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
11231 (C<CvANON>) subroutine that is referenced through a GV it will be the
11232 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
11233 A null pointer is returned as usual if there is no statically-determinable
11239 /* shared by toke.c:yylex */
11241 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
11243 PADNAME *name = PAD_COMPNAME(off);
11244 CV *compcv = PL_compcv;
11245 while (PadnameOUTER(name)) {
11246 assert(PARENT_PAD_INDEX(name));
11247 compcv = CvOUTSIDE(compcv);
11248 name = PadlistNAMESARRAY(CvPADLIST(compcv))
11249 [off = PARENT_PAD_INDEX(name)];
11251 assert(!PadnameIsOUR(name));
11252 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
11253 return PadnamePROTOCV(name);
11255 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
11259 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
11264 PERL_ARGS_ASSERT_RV2CV_OP_CV;
11265 if (flags & ~RV2CVOPCV_FLAG_MASK)
11266 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
11267 if (cvop->op_type != OP_RV2CV)
11269 if (cvop->op_private & OPpENTERSUB_AMPER)
11271 if (!(cvop->op_flags & OPf_KIDS))
11273 rvop = cUNOPx(cvop)->op_first;
11274 switch (rvop->op_type) {
11276 gv = cGVOPx_gv(rvop);
11278 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
11279 cv = MUTABLE_CV(SvRV(gv));
11283 if (flags & RV2CVOPCV_RETURN_STUB)
11289 if (flags & RV2CVOPCV_MARK_EARLY)
11290 rvop->op_private |= OPpEARLY_CV;
11295 SV *rv = cSVOPx_sv(rvop);
11298 cv = (CV*)SvRV(rv);
11302 cv = find_lexical_cv(rvop->op_targ);
11307 } NOT_REACHED; /* NOTREACHED */
11309 if (SvTYPE((SV*)cv) != SVt_PVCV)
11311 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
11312 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
11313 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
11322 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
11324 Performs the default fixup of the arguments part of an C<entersub>
11325 op tree. This consists of applying list context to each of the
11326 argument ops. This is the standard treatment used on a call marked
11327 with C<&>, or a method call, or a call through a subroutine reference,
11328 or any other call where the callee can't be identified at compile time,
11329 or a call where the callee has no prototype.
11335 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
11339 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
11341 aop = cUNOPx(entersubop)->op_first;
11342 if (!OpHAS_SIBLING(aop))
11343 aop = cUNOPx(aop)->op_first;
11344 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
11345 /* skip the extra attributes->import() call implicitly added in
11346 * something like foo(my $x : bar)
11348 if ( aop->op_type == OP_ENTERSUB
11349 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
11353 op_lvalue(aop, OP_ENTERSUB);
11359 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
11361 Performs the fixup of the arguments part of an C<entersub> op tree
11362 based on a subroutine prototype. This makes various modifications to
11363 the argument ops, from applying context up to inserting C<refgen> ops,
11364 and checking the number and syntactic types of arguments, as directed by
11365 the prototype. This is the standard treatment used on a subroutine call,
11366 not marked with C<&>, where the callee can be identified at compile time
11367 and has a prototype.
11369 C<protosv> supplies the subroutine prototype to be applied to the call.
11370 It may be a normal defined scalar, of which the string value will be used.
11371 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11372 that has been cast to C<SV*>) which has a prototype. The prototype
11373 supplied, in whichever form, does not need to match the actual callee
11374 referenced by the op tree.
11376 If the argument ops disagree with the prototype, for example by having
11377 an unacceptable number of arguments, a valid op tree is returned anyway.
11378 The error is reflected in the parser state, normally resulting in a single
11379 exception at the top level of parsing which covers all the compilation
11380 errors that occurred. In the error message, the callee is referred to
11381 by the name defined by the C<namegv> parameter.
11387 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11390 const char *proto, *proto_end;
11391 OP *aop, *prev, *cvop, *parent;
11394 I32 contextclass = 0;
11395 const char *e = NULL;
11396 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
11397 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
11398 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
11399 "flags=%lx", (unsigned long) SvFLAGS(protosv));
11400 if (SvTYPE(protosv) == SVt_PVCV)
11401 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
11402 else proto = SvPV(protosv, proto_len);
11403 proto = S_strip_spaces(aTHX_ proto, &proto_len);
11404 proto_end = proto + proto_len;
11405 parent = entersubop;
11406 aop = cUNOPx(entersubop)->op_first;
11407 if (!OpHAS_SIBLING(aop)) {
11409 aop = cUNOPx(aop)->op_first;
11412 aop = OpSIBLING(aop);
11413 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11414 while (aop != cvop) {
11417 if (proto >= proto_end)
11419 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11420 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
11421 SVfARG(namesv)), SvUTF8(namesv));
11431 /* _ must be at the end */
11432 if (proto[1] && !strchr(";@%", proto[1]))
11448 if ( o3->op_type != OP_UNDEF
11449 && (o3->op_type != OP_SREFGEN
11450 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11452 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
11454 bad_type_gv(arg, namegv, o3,
11455 arg == 1 ? "block or sub {}" : "sub {}");
11458 /* '*' allows any scalar type, including bareword */
11461 if (o3->op_type == OP_RV2GV)
11462 goto wrapref; /* autoconvert GLOB -> GLOBref */
11463 else if (o3->op_type == OP_CONST)
11464 o3->op_private &= ~OPpCONST_STRICT;
11470 if (o3->op_type == OP_RV2AV ||
11471 o3->op_type == OP_PADAV ||
11472 o3->op_type == OP_RV2HV ||
11473 o3->op_type == OP_PADHV
11479 case '[': case ']':
11486 switch (*proto++) {
11488 if (contextclass++ == 0) {
11489 e = strchr(proto, ']');
11490 if (!e || e == proto)
11498 if (contextclass) {
11499 const char *p = proto;
11500 const char *const end = proto;
11502 while (*--p != '[')
11503 /* \[$] accepts any scalar lvalue */
11505 && Perl_op_lvalue_flags(aTHX_
11507 OP_READ, /* not entersub */
11510 bad_type_gv(arg, namegv, o3,
11511 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
11516 if (o3->op_type == OP_RV2GV)
11519 bad_type_gv(arg, namegv, o3, "symbol");
11522 if (o3->op_type == OP_ENTERSUB
11523 && !(o3->op_flags & OPf_STACKED))
11526 bad_type_gv(arg, namegv, o3, "subroutine");
11529 if (o3->op_type == OP_RV2SV ||
11530 o3->op_type == OP_PADSV ||
11531 o3->op_type == OP_HELEM ||
11532 o3->op_type == OP_AELEM)
11534 if (!contextclass) {
11535 /* \$ accepts any scalar lvalue */
11536 if (Perl_op_lvalue_flags(aTHX_
11538 OP_READ, /* not entersub */
11541 bad_type_gv(arg, namegv, o3, "scalar");
11545 if (o3->op_type == OP_RV2AV ||
11546 o3->op_type == OP_PADAV)
11548 o3->op_flags &=~ OPf_PARENS;
11552 bad_type_gv(arg, namegv, o3, "array");
11555 if (o3->op_type == OP_RV2HV ||
11556 o3->op_type == OP_PADHV)
11558 o3->op_flags &=~ OPf_PARENS;
11562 bad_type_gv(arg, namegv, o3, "hash");
11565 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
11567 if (contextclass && e) {
11572 default: goto oops;
11582 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
11583 SVfARG(cv_name((CV *)namegv, NULL, 0)),
11588 op_lvalue(aop, OP_ENTERSUB);
11590 aop = OpSIBLING(aop);
11592 if (aop == cvop && *proto == '_') {
11593 /* generate an access to $_ */
11594 op_sibling_splice(parent, prev, 0, newDEFSVOP());
11596 if (!optional && proto_end > proto &&
11597 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
11599 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
11600 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
11601 SVfARG(namesv)), SvUTF8(namesv));
11607 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
11609 Performs the fixup of the arguments part of an C<entersub> op tree either
11610 based on a subroutine prototype or using default list-context processing.
11611 This is the standard treatment used on a subroutine call, not marked
11612 with C<&>, where the callee can be identified at compile time.
11614 C<protosv> supplies the subroutine prototype to be applied to the call,
11615 or indicates that there is no prototype. It may be a normal scalar,
11616 in which case if it is defined then the string value will be used
11617 as a prototype, and if it is undefined then there is no prototype.
11618 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
11619 that has been cast to C<SV*>), of which the prototype will be used if it
11620 has one. The prototype (or lack thereof) supplied, in whichever form,
11621 does not need to match the actual callee referenced by the op tree.
11623 If the argument ops disagree with the prototype, for example by having
11624 an unacceptable number of arguments, a valid op tree is returned anyway.
11625 The error is reflected in the parser state, normally resulting in a single
11626 exception at the top level of parsing which covers all the compilation
11627 errors that occurred. In the error message, the callee is referred to
11628 by the name defined by the C<namegv> parameter.
11634 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
11635 GV *namegv, SV *protosv)
11637 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
11638 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
11639 return ck_entersub_args_proto(entersubop, namegv, protosv);
11641 return ck_entersub_args_list(entersubop);
11645 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
11647 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
11648 OP *aop = cUNOPx(entersubop)->op_first;
11650 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
11654 if (!OpHAS_SIBLING(aop))
11655 aop = cUNOPx(aop)->op_first;
11656 aop = OpSIBLING(aop);
11657 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11659 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
11661 op_free(entersubop);
11662 switch(GvNAME(namegv)[2]) {
11663 case 'F': return newSVOP(OP_CONST, 0,
11664 newSVpv(CopFILE(PL_curcop),0));
11665 case 'L': return newSVOP(
11667 Perl_newSVpvf(aTHX_
11668 "%"IVdf, (IV)CopLINE(PL_curcop)
11671 case 'P': return newSVOP(OP_CONST, 0,
11673 ? newSVhek(HvNAME_HEK(PL_curstash))
11678 NOT_REACHED; /* NOTREACHED */
11681 OP *prev, *cvop, *first, *parent;
11684 parent = entersubop;
11685 if (!OpHAS_SIBLING(aop)) {
11687 aop = cUNOPx(aop)->op_first;
11690 first = prev = aop;
11691 aop = OpSIBLING(aop);
11692 /* find last sibling */
11694 OpHAS_SIBLING(cvop);
11695 prev = cvop, cvop = OpSIBLING(cvop))
11697 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
11698 /* Usually, OPf_SPECIAL on an op with no args means that it had
11699 * parens, but these have their own meaning for that flag: */
11700 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
11701 && opnum != OP_DELETE && opnum != OP_EXISTS)
11702 flags |= OPf_SPECIAL;
11703 /* excise cvop from end of sibling chain */
11704 op_sibling_splice(parent, prev, 1, NULL);
11706 if (aop == cvop) aop = NULL;
11708 /* detach remaining siblings from the first sibling, then
11709 * dispose of original optree */
11712 op_sibling_splice(parent, first, -1, NULL);
11713 op_free(entersubop);
11715 if (opnum == OP_ENTEREVAL
11716 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
11717 flags |= OPpEVAL_BYTES <<8;
11719 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11721 case OA_BASEOP_OR_UNOP:
11722 case OA_FILESTATOP:
11723 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
11726 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
11729 return opnum == OP_RUNCV
11730 ? newPVOP(OP_RUNCV,0,NULL)
11733 return op_convert_list(opnum,0,aop);
11736 NOT_REACHED; /* NOTREACHED */
11741 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
11743 Retrieves the function that will be used to fix up a call to C<cv>.
11744 Specifically, the function is applied to an C<entersub> op tree for a
11745 subroutine call, not marked with C<&>, where the callee can be identified
11746 at compile time as C<cv>.
11748 The C-level function pointer is returned in C<*ckfun_p>, and an SV
11749 argument for it is returned in C<*ckobj_p>. The function is intended
11750 to be called in this manner:
11752 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
11754 In this call, C<entersubop> is a pointer to the C<entersub> op,
11755 which may be replaced by the check function, and C<namegv> is a GV
11756 supplying the name that should be used by the check function to refer
11757 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11758 It is permitted to apply the check function in non-standard situations,
11759 such as to a call to a different subroutine or to a method call.
11761 By default, the function is
11762 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
11763 and the SV parameter is C<cv> itself. This implements standard
11764 prototype processing. It can be changed, for a particular subroutine,
11765 by L</cv_set_call_checker>.
11771 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
11775 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
11777 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
11778 *ckobj_p = callmg->mg_obj;
11779 if (flagsp) *flagsp = callmg->mg_flags;
11781 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
11782 *ckobj_p = (SV*)cv;
11783 if (flagsp) *flagsp = 0;
11788 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
11790 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
11791 PERL_UNUSED_CONTEXT;
11792 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
11796 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
11798 Sets the function that will be used to fix up a call to C<cv>.
11799 Specifically, the function is applied to an C<entersub> op tree for a
11800 subroutine call, not marked with C<&>, where the callee can be identified
11801 at compile time as C<cv>.
11803 The C-level function pointer is supplied in C<ckfun>, and an SV argument
11804 for it is supplied in C<ckobj>. The function should be defined like this:
11806 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
11808 It is intended to be called in this manner:
11810 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
11812 In this call, C<entersubop> is a pointer to the C<entersub> op,
11813 which may be replaced by the check function, and C<namegv> supplies
11814 the name that should be used by the check function to refer
11815 to the callee of the C<entersub> op if it needs to emit any diagnostics.
11816 It is permitted to apply the check function in non-standard situations,
11817 such as to a call to a different subroutine or to a method call.
11819 C<namegv> may not actually be a GV. For efficiency, perl may pass a
11820 CV or other SV instead. Whatever is passed can be used as the first
11821 argument to L</cv_name>. You can force perl to pass a GV by including
11822 C<CALL_CHECKER_REQUIRE_GV> in the C<flags>.
11824 The current setting for a particular CV can be retrieved by
11825 L</cv_get_call_checker>.
11827 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
11829 The original form of L</cv_set_call_checker_flags>, which passes it the
11830 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
11836 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
11838 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
11839 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
11843 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
11844 SV *ckobj, U32 flags)
11846 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
11847 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
11848 if (SvMAGICAL((SV*)cv))
11849 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
11852 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
11853 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
11855 if (callmg->mg_flags & MGf_REFCOUNTED) {
11856 SvREFCNT_dec(callmg->mg_obj);
11857 callmg->mg_flags &= ~MGf_REFCOUNTED;
11859 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
11860 callmg->mg_obj = ckobj;
11861 if (ckobj != (SV*)cv) {
11862 SvREFCNT_inc_simple_void_NN(ckobj);
11863 callmg->mg_flags |= MGf_REFCOUNTED;
11865 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
11866 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
11871 S_entersub_alloc_targ(pTHX_ OP * const o)
11873 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
11874 o->op_private |= OPpENTERSUB_HASTARG;
11878 Perl_ck_subr(pTHX_ OP *o)
11883 SV **const_class = NULL;
11885 PERL_ARGS_ASSERT_CK_SUBR;
11887 aop = cUNOPx(o)->op_first;
11888 if (!OpHAS_SIBLING(aop))
11889 aop = cUNOPx(aop)->op_first;
11890 aop = OpSIBLING(aop);
11891 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
11892 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
11893 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
11895 o->op_private &= ~1;
11896 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11897 if (PERLDB_SUB && PL_curstash != PL_debstash)
11898 o->op_private |= OPpENTERSUB_DB;
11899 switch (cvop->op_type) {
11901 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
11905 case OP_METHOD_NAMED:
11906 case OP_METHOD_SUPER:
11907 case OP_METHOD_REDIR:
11908 case OP_METHOD_REDIR_SUPER:
11909 if (aop->op_type == OP_CONST) {
11910 aop->op_private &= ~OPpCONST_STRICT;
11911 const_class = &cSVOPx(aop)->op_sv;
11913 else if (aop->op_type == OP_LIST) {
11914 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
11915 if (sib && sib->op_type == OP_CONST) {
11916 sib->op_private &= ~OPpCONST_STRICT;
11917 const_class = &cSVOPx(sib)->op_sv;
11920 /* make class name a shared cow string to speedup method calls */
11921 /* constant string might be replaced with object, f.e. bigint */
11922 if (const_class && SvPOK(*const_class)) {
11924 const char* str = SvPV(*const_class, len);
11926 SV* const shared = newSVpvn_share(
11927 str, SvUTF8(*const_class)
11928 ? -(SSize_t)len : (SSize_t)len,
11931 if (SvREADONLY(*const_class))
11932 SvREADONLY_on(shared);
11933 SvREFCNT_dec(*const_class);
11934 *const_class = shared;
11941 S_entersub_alloc_targ(aTHX_ o);
11942 return ck_entersub_args_list(o);
11944 Perl_call_checker ckfun;
11947 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
11948 if (CvISXSUB(cv) || !CvROOT(cv))
11949 S_entersub_alloc_targ(aTHX_ o);
11951 /* The original call checker API guarantees that a GV will be
11952 be provided with the right name. So, if the old API was
11953 used (or the REQUIRE_GV flag was passed), we have to reify
11954 the CV’s GV, unless this is an anonymous sub. This is not
11955 ideal for lexical subs, as its stringification will include
11956 the package. But it is the best we can do. */
11957 if (flags & MGf_REQUIRE_GV) {
11958 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
11961 else namegv = MUTABLE_GV(cv);
11962 /* After a syntax error in a lexical sub, the cv that
11963 rv2cv_op_cv returns may be a nameless stub. */
11964 if (!namegv) return ck_entersub_args_list(o);
11967 return ckfun(aTHX_ o, namegv, ckobj);
11972 Perl_ck_svconst(pTHX_ OP *o)
11974 SV * const sv = cSVOPo->op_sv;
11975 PERL_ARGS_ASSERT_CK_SVCONST;
11976 PERL_UNUSED_CONTEXT;
11977 #ifdef PERL_COPY_ON_WRITE
11978 /* Since the read-only flag may be used to protect a string buffer, we
11979 cannot do copy-on-write with existing read-only scalars that are not
11980 already copy-on-write scalars. To allow $_ = "hello" to do COW with
11981 that constant, mark the constant as COWable here, if it is not
11982 already read-only. */
11983 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11986 # ifdef PERL_DEBUG_READONLY_COW
11996 Perl_ck_trunc(pTHX_ OP *o)
11998 PERL_ARGS_ASSERT_CK_TRUNC;
12000 if (o->op_flags & OPf_KIDS) {
12001 SVOP *kid = (SVOP*)cUNOPo->op_first;
12003 if (kid->op_type == OP_NULL)
12004 kid = (SVOP*)OpSIBLING(kid);
12005 if (kid && kid->op_type == OP_CONST &&
12006 (kid->op_private & OPpCONST_BARE) &&
12009 o->op_flags |= OPf_SPECIAL;
12010 kid->op_private &= ~OPpCONST_STRICT;
12017 Perl_ck_substr(pTHX_ OP *o)
12019 PERL_ARGS_ASSERT_CK_SUBSTR;
12022 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
12023 OP *kid = cLISTOPo->op_first;
12025 if (kid->op_type == OP_NULL)
12026 kid = OpSIBLING(kid);
12028 kid->op_flags |= OPf_MOD;
12035 Perl_ck_tell(pTHX_ OP *o)
12037 PERL_ARGS_ASSERT_CK_TELL;
12039 if (o->op_flags & OPf_KIDS) {
12040 OP *kid = cLISTOPo->op_first;
12041 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
12042 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12048 Perl_ck_each(pTHX_ OP *o)
12051 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
12052 const unsigned orig_type = o->op_type;
12054 PERL_ARGS_ASSERT_CK_EACH;
12057 switch (kid->op_type) {
12063 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
12064 : orig_type == OP_KEYS ? OP_AKEYS
12068 if (kid->op_private == OPpCONST_BARE
12069 || !SvROK(cSVOPx_sv(kid))
12070 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
12071 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
12075 qerror(Perl_mess(aTHX_
12076 "Experimental %s on scalar is now forbidden",
12077 PL_op_desc[orig_type]));
12079 bad_type_pv(1, "hash or array", o, kid);
12087 Perl_ck_length(pTHX_ OP *o)
12089 PERL_ARGS_ASSERT_CK_LENGTH;
12093 if (ckWARN(WARN_SYNTAX)) {
12094 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
12098 const bool hash = kid->op_type == OP_PADHV
12099 || kid->op_type == OP_RV2HV;
12100 switch (kid->op_type) {
12105 name = S_op_varname(aTHX_ kid);
12111 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12112 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
12114 SVfARG(name), hash ? "keys " : "", SVfARG(name)
12117 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12118 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12119 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
12121 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
12122 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12123 "length() used on @array (did you mean \"scalar(@array)\"?)");
12133 ---------------------------------------------------------
12135 Common vars in list assignment
12137 There now follows some enums and static functions for detecting
12138 common variables in list assignments. Here is a little essay I wrote
12139 for myself when trying to get my head around this. DAPM.
12143 First some random observations:
12145 * If a lexical var is an alias of something else, e.g.
12146 for my $x ($lex, $pkg, $a[0]) {...}
12147 then the act of aliasing will increase the reference count of the SV
12149 * If a package var is an alias of something else, it may still have a
12150 reference count of 1, depending on how the alias was created, e.g.
12151 in *a = *b, $a may have a refcount of 1 since the GP is shared
12152 with a single GvSV pointer to the SV. So If it's an alias of another
12153 package var, then RC may be 1; if it's an alias of another scalar, e.g.
12154 a lexical var or an array element, then it will have RC > 1.
12156 * There are many ways to create a package alias; ultimately, XS code
12157 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
12158 run-time tracing mechanisms are unlikely to be able to catch all cases.
12160 * When the LHS is all my declarations, the same vars can't appear directly
12161 on the RHS, but they can indirectly via closures, aliasing and lvalue
12162 subs. But those techniques all involve an increase in the lexical
12163 scalar's ref count.
12165 * When the LHS is all lexical vars (but not necessarily my declarations),
12166 it is possible for the same lexicals to appear directly on the RHS, and
12167 without an increased ref count, since the stack isn't refcounted.
12168 This case can be detected at compile time by scanning for common lex
12169 vars with PL_generation.
12171 * lvalue subs defeat common var detection, but they do at least
12172 return vars with a temporary ref count increment. Also, you can't
12173 tell at compile time whether a sub call is lvalue.
12178 A: There are a few circumstances where there definitely can't be any
12181 LHS empty: () = (...);
12182 RHS empty: (....) = ();
12183 RHS contains only constants or other 'can't possibly be shared'
12184 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
12185 i.e. they only contain ops not marked as dangerous, whose children
12186 are also not dangerous;
12188 LHS contains a single scalar element: e.g. ($x) = (....); because
12189 after $x has been modified, it won't be used again on the RHS;
12190 RHS contains a single element with no aggregate on LHS: e.g.
12191 ($a,$b,$c) = ($x); again, once $a has been modified, its value
12192 won't be used again.
12194 B: If LHS are all 'my' lexical var declarations (or safe ops, which
12197 my ($a, $b, @c) = ...;
12199 Due to closure and goto tricks, these vars may already have content.
12200 For the same reason, an element on the RHS may be a lexical or package
12201 alias of one of the vars on the left, or share common elements, for
12204 my ($x,$y) = f(); # $x and $y on both sides
12205 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
12210 my @a = @$ra; # elements of @a on both sides
12211 sub f { @a = 1..4; \@a }
12214 First, just consider scalar vars on LHS:
12216 RHS is safe only if (A), or in addition,
12217 * contains only lexical *scalar* vars, where neither side's
12218 lexicals have been flagged as aliases
12220 If RHS is not safe, then it's always legal to check LHS vars for
12221 RC==1, since the only RHS aliases will always be associated
12224 Note that in particular, RHS is not safe if:
12226 * it contains package scalar vars; e.g.:
12229 my ($x, $y) = (2, $x_alias);
12230 sub f { $x = 1; *x_alias = \$x; }
12232 * It contains other general elements, such as flattened or
12233 * spliced or single array or hash elements, e.g.
12236 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
12240 use feature 'refaliasing';
12241 \($a[0], $a[1]) = \($y,$x);
12244 It doesn't matter if the array/hash is lexical or package.
12246 * it contains a function call that happens to be an lvalue
12247 sub which returns one or more of the above, e.g.
12258 (so a sub call on the RHS should be treated the same
12259 as having a package var on the RHS).
12261 * any other "dangerous" thing, such an op or built-in that
12262 returns one of the above, e.g. pp_preinc
12265 If RHS is not safe, what we can do however is at compile time flag
12266 that the LHS are all my declarations, and at run time check whether
12267 all the LHS have RC == 1, and if so skip the full scan.
12269 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
12271 Here the issue is whether there can be elements of @a on the RHS
12272 which will get prematurely freed when @a is cleared prior to
12273 assignment. This is only a problem if the aliasing mechanism
12274 is one which doesn't increase the refcount - only if RC == 1
12275 will the RHS element be prematurely freed.
12277 Because the array/hash is being INTROed, it or its elements
12278 can't directly appear on the RHS:
12280 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
12282 but can indirectly, e.g.:
12286 sub f { @a = 1..3; \@a }
12288 So if the RHS isn't safe as defined by (A), we must always
12289 mortalise and bump the ref count of any remaining RHS elements
12290 when assigning to a non-empty LHS aggregate.
12292 Lexical scalars on the RHS aren't safe if they've been involved in
12295 use feature 'refaliasing';
12298 \(my $lex) = \$pkg;
12299 my @a = ($lex,3); # equivalent to ($a[0],3)
12306 Similarly with lexical arrays and hashes on the RHS:
12320 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
12321 my $a; ($a, my $b) = (....);
12323 The difference between (B) and (C) is that it is now physically
12324 possible for the LHS vars to appear on the RHS too, where they
12325 are not reference counted; but in this case, the compile-time
12326 PL_generation sweep will detect such common vars.
12328 So the rules for (C) differ from (B) in that if common vars are
12329 detected, the runtime "test RC==1" optimisation can no longer be used,
12330 and a full mark and sweep is required
12332 D: As (C), but in addition the LHS may contain package vars.
12334 Since package vars can be aliased without a corresponding refcount
12335 increase, all bets are off. It's only safe if (A). E.g.
12337 my ($x, $y) = (1,2);
12339 for $x_alias ($x) {
12340 ($x_alias, $y) = (3, $x); # whoops
12343 Ditto for LHS aggregate package vars.
12345 E: Any other dangerous ops on LHS, e.g.
12346 (f(), $a[0], @$r) = (...);
12348 this is similar to (E) in that all bets are off. In addition, it's
12349 impossible to determine at compile time whether the LHS
12350 contains a scalar or an aggregate, e.g.
12352 sub f : lvalue { @a }
12355 * ---------------------------------------------------------
12359 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
12360 * that at least one of the things flagged was seen.
12364 AAS_MY_SCALAR = 0x001, /* my $scalar */
12365 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
12366 AAS_LEX_SCALAR = 0x004, /* $lexical */
12367 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
12368 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
12369 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
12370 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
12371 AAS_DANGEROUS = 0x080, /* an op (other than the above)
12372 that's flagged OA_DANGEROUS */
12373 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
12374 not in any of the categories above */
12375 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
12380 /* helper function for S_aassign_scan().
12381 * check a PAD-related op for commonality and/or set its generation number.
12382 * Returns a boolean indicating whether its shared */
12385 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
12387 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
12388 /* lexical used in aliasing */
12392 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
12394 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
12401 Helper function for OPpASSIGN_COMMON* detection in rpeep().
12402 It scans the left or right hand subtree of the aassign op, and returns a
12403 set of flags indicating what sorts of things it found there.
12404 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
12405 set PL_generation on lexical vars; if the latter, we see if
12406 PL_generation matches.
12407 'top' indicates whether we're recursing or at the top level.
12408 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
12409 This fn will increment it by the number seen. It's not intended to
12410 be an accurate count (especially as many ops can push a variable
12411 number of SVs onto the stack); rather it's used as to test whether there
12412 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
12416 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
12419 bool kid_top = FALSE;
12421 /* first, look for a solitary @_ on the RHS */
12424 && (o->op_flags & OPf_KIDS)
12425 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
12427 OP *kid = cUNOPo->op_first;
12428 if ( ( kid->op_type == OP_PUSHMARK
12429 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
12430 && ((kid = OpSIBLING(kid)))
12431 && !OpHAS_SIBLING(kid)
12432 && kid->op_type == OP_RV2AV
12433 && !(kid->op_flags & OPf_REF)
12434 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
12435 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
12436 && ((kid = cUNOPx(kid)->op_first))
12437 && kid->op_type == OP_GV
12438 && cGVOPx_gv(kid) == PL_defgv
12440 flags |= AAS_DEFAV;
12443 switch (o->op_type) {
12446 return AAS_PKG_SCALAR;
12451 if (top && (o->op_flags & OPf_REF))
12452 return (o->op_private & OPpLVAL_INTRO)
12453 ? AAS_MY_AGG : AAS_LEX_AGG;
12454 return AAS_DANGEROUS;
12458 int comm = S_aassign_padcheck(aTHX_ o, rhs)
12459 ? AAS_LEX_SCALAR_COMM : 0;
12461 return (o->op_private & OPpLVAL_INTRO)
12462 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
12468 if (cUNOPx(o)->op_first->op_type != OP_GV)
12469 return AAS_DANGEROUS; /* @{expr}, %{expr} */
12471 if (top && (o->op_flags & OPf_REF))
12472 return AAS_PKG_AGG;
12473 return AAS_DANGEROUS;
12477 if (cUNOPx(o)->op_first->op_type != OP_GV) {
12479 return AAS_DANGEROUS; /* ${expr} */
12481 return AAS_PKG_SCALAR; /* $pkg */
12484 if (cLISTOPo->op_first->op_type == OP_PUSHRE) {
12485 /* "@foo = split... " optimises away the aassign and stores its
12486 * destination array in the OP_PUSHRE that precedes it.
12487 * A flattened array is always dangerous.
12490 return AAS_DANGEROUS;
12495 /* undef counts as a scalar on the RHS:
12496 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
12497 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
12501 flags = AAS_SAFE_SCALAR;
12506 /* these are all no-ops; they don't push a potentially common SV
12507 * onto the stack, so they are neither AAS_DANGEROUS nor
12508 * AAS_SAFE_SCALAR */
12511 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
12516 /* these do nothing but may have children; but their children
12517 * should also be treated as top-level */
12522 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
12524 flags = AAS_DANGEROUS;
12528 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
12529 && (o->op_private & OPpTARGET_MY))
12532 return S_aassign_padcheck(aTHX_ o, rhs)
12533 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
12536 /* if its an unrecognised, non-dangerous op, assume that it
12537 * it the cause of at least one safe scalar */
12539 flags = AAS_SAFE_SCALAR;
12543 if (o->op_flags & OPf_KIDS) {
12545 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
12546 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
12552 /* Check for in place reverse and sort assignments like "@a = reverse @a"
12553 and modify the optree to make them work inplace */
12556 S_inplace_aassign(pTHX_ OP *o) {
12558 OP *modop, *modop_pushmark;
12560 OP *oleft, *oleft_pushmark;
12562 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
12564 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
12566 assert(cUNOPo->op_first->op_type == OP_NULL);
12567 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
12568 assert(modop_pushmark->op_type == OP_PUSHMARK);
12569 modop = OpSIBLING(modop_pushmark);
12571 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
12574 /* no other operation except sort/reverse */
12575 if (OpHAS_SIBLING(modop))
12578 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
12579 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
12581 if (modop->op_flags & OPf_STACKED) {
12582 /* skip sort subroutine/block */
12583 assert(oright->op_type == OP_NULL);
12584 oright = OpSIBLING(oright);
12587 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
12588 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
12589 assert(oleft_pushmark->op_type == OP_PUSHMARK);
12590 oleft = OpSIBLING(oleft_pushmark);
12592 /* Check the lhs is an array */
12594 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
12595 || OpHAS_SIBLING(oleft)
12596 || (oleft->op_private & OPpLVAL_INTRO)
12600 /* Only one thing on the rhs */
12601 if (OpHAS_SIBLING(oright))
12604 /* check the array is the same on both sides */
12605 if (oleft->op_type == OP_RV2AV) {
12606 if (oright->op_type != OP_RV2AV
12607 || !cUNOPx(oright)->op_first
12608 || cUNOPx(oright)->op_first->op_type != OP_GV
12609 || cUNOPx(oleft )->op_first->op_type != OP_GV
12610 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
12611 cGVOPx_gv(cUNOPx(oright)->op_first)
12615 else if (oright->op_type != OP_PADAV
12616 || oright->op_targ != oleft->op_targ
12620 /* This actually is an inplace assignment */
12622 modop->op_private |= OPpSORT_INPLACE;
12624 /* transfer MODishness etc from LHS arg to RHS arg */
12625 oright->op_flags = oleft->op_flags;
12627 /* remove the aassign op and the lhs */
12629 op_null(oleft_pushmark);
12630 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
12631 op_null(cUNOPx(oleft)->op_first);
12637 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
12638 * that potentially represent a series of one or more aggregate derefs
12639 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
12640 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
12641 * additional ops left in too).
12643 * The caller will have already verified that the first few ops in the
12644 * chain following 'start' indicate a multideref candidate, and will have
12645 * set 'orig_o' to the point further on in the chain where the first index
12646 * expression (if any) begins. 'orig_action' specifies what type of
12647 * beginning has already been determined by the ops between start..orig_o
12648 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
12650 * 'hints' contains any hints flags that need adding (currently just
12651 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
12655 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
12659 UNOP_AUX_item *arg_buf = NULL;
12660 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
12661 int index_skip = -1; /* don't output index arg on this action */
12663 /* similar to regex compiling, do two passes; the first pass
12664 * determines whether the op chain is convertible and calculates the
12665 * buffer size; the second pass populates the buffer and makes any
12666 * changes necessary to ops (such as moving consts to the pad on
12667 * threaded builds).
12669 * NB: for things like Coverity, note that both passes take the same
12670 * path through the logic tree (except for 'if (pass)' bits), since
12671 * both passes are following the same op_next chain; and in
12672 * particular, if it would return early on the second pass, it would
12673 * already have returned early on the first pass.
12675 for (pass = 0; pass < 2; pass++) {
12677 UV action = orig_action;
12678 OP *first_elem_op = NULL; /* first seen aelem/helem */
12679 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
12680 int action_count = 0; /* number of actions seen so far */
12681 int action_ix = 0; /* action_count % (actions per IV) */
12682 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
12683 bool is_last = FALSE; /* no more derefs to follow */
12684 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
12685 UNOP_AUX_item *arg = arg_buf;
12686 UNOP_AUX_item *action_ptr = arg_buf;
12689 action_ptr->uv = 0;
12693 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
12694 case MDEREF_HV_gvhv_helem:
12695 next_is_hash = TRUE;
12697 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
12698 case MDEREF_AV_gvav_aelem:
12700 #ifdef USE_ITHREADS
12701 arg->pad_offset = cPADOPx(start)->op_padix;
12702 /* stop it being swiped when nulled */
12703 cPADOPx(start)->op_padix = 0;
12705 arg->sv = cSVOPx(start)->op_sv;
12706 cSVOPx(start)->op_sv = NULL;
12712 case MDEREF_HV_padhv_helem:
12713 case MDEREF_HV_padsv_vivify_rv2hv_helem:
12714 next_is_hash = TRUE;
12716 case MDEREF_AV_padav_aelem:
12717 case MDEREF_AV_padsv_vivify_rv2av_aelem:
12719 arg->pad_offset = start->op_targ;
12720 /* we skip setting op_targ = 0 for now, since the intact
12721 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
12722 reset_start_targ = TRUE;
12727 case MDEREF_HV_pop_rv2hv_helem:
12728 next_is_hash = TRUE;
12730 case MDEREF_AV_pop_rv2av_aelem:
12734 NOT_REACHED; /* NOTREACHED */
12739 /* look for another (rv2av/hv; get index;
12740 * aelem/helem/exists/delele) sequence */
12745 UV index_type = MDEREF_INDEX_none;
12747 if (action_count) {
12748 /* if this is not the first lookup, consume the rv2av/hv */
12750 /* for N levels of aggregate lookup, we normally expect
12751 * that the first N-1 [ah]elem ops will be flagged as
12752 * /DEREF (so they autovivifiy if necessary), and the last
12753 * lookup op not to be.
12754 * For other things (like @{$h{k1}{k2}}) extra scope or
12755 * leave ops can appear, so abandon the effort in that
12757 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
12760 /* rv2av or rv2hv sKR/1 */
12762 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12763 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12764 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
12767 /* at this point, we wouldn't expect any of these
12768 * possible private flags:
12769 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
12770 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
12772 ASSUME(!(o->op_private &
12773 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
12775 hints = (o->op_private & OPpHINT_STRICT_REFS);
12777 /* make sure the type of the previous /DEREF matches the
12778 * type of the next lookup */
12779 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
12782 action = next_is_hash
12783 ? MDEREF_HV_vivify_rv2hv_helem
12784 : MDEREF_AV_vivify_rv2av_aelem;
12788 /* if this is the second pass, and we're at the depth where
12789 * previously we encountered a non-simple index expression,
12790 * stop processing the index at this point */
12791 if (action_count != index_skip) {
12793 /* look for one or more simple ops that return an array
12794 * index or hash key */
12796 switch (o->op_type) {
12798 /* it may be a lexical var index */
12799 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
12800 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12801 ASSUME(!(o->op_private &
12802 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
12804 if ( OP_GIMME(o,0) == G_SCALAR
12805 && !(o->op_flags & (OPf_REF|OPf_MOD))
12806 && o->op_private == 0)
12809 arg->pad_offset = o->op_targ;
12811 index_type = MDEREF_INDEX_padsv;
12817 if (next_is_hash) {
12818 /* it's a constant hash index */
12819 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
12820 /* "use constant foo => FOO; $h{+foo}" for
12821 * some weird FOO, can leave you with constants
12822 * that aren't simple strings. It's not worth
12823 * the extra hassle for those edge cases */
12828 OP * helem_op = o->op_next;
12830 ASSUME( helem_op->op_type == OP_HELEM
12831 || helem_op->op_type == OP_NULL);
12832 if (helem_op->op_type == OP_HELEM) {
12833 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
12834 if ( helem_op->op_private & OPpLVAL_INTRO
12835 || rop->op_type != OP_RV2HV
12839 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
12841 #ifdef USE_ITHREADS
12842 /* Relocate sv to the pad for thread safety */
12843 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
12844 arg->pad_offset = o->op_targ;
12847 arg->sv = cSVOPx_sv(o);
12852 /* it's a constant array index */
12854 SV *ix_sv = cSVOPo->op_sv;
12859 if ( action_count == 0
12862 && ( action == MDEREF_AV_padav_aelem
12863 || action == MDEREF_AV_gvav_aelem)
12865 maybe_aelemfast = TRUE;
12869 SvREFCNT_dec_NN(cSVOPo->op_sv);
12873 /* we've taken ownership of the SV */
12874 cSVOPo->op_sv = NULL;
12876 index_type = MDEREF_INDEX_const;
12881 /* it may be a package var index */
12883 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_SPECIAL)));
12884 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
12885 if ( (o->op_flags &~ OPf_SPECIAL) != OPf_WANT_SCALAR
12886 || o->op_private != 0
12891 if (kid->op_type != OP_RV2SV)
12894 ASSUME(!(kid->op_flags &
12895 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
12896 |OPf_SPECIAL|OPf_PARENS)));
12897 ASSUME(!(kid->op_private &
12899 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
12900 |OPpDEREF|OPpLVAL_INTRO)));
12901 if( (kid->op_flags &~ OPf_PARENS)
12902 != (OPf_WANT_SCALAR|OPf_KIDS)
12903 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
12908 #ifdef USE_ITHREADS
12909 arg->pad_offset = cPADOPx(o)->op_padix;
12910 /* stop it being swiped when nulled */
12911 cPADOPx(o)->op_padix = 0;
12913 arg->sv = cSVOPx(o)->op_sv;
12914 cSVOPo->op_sv = NULL;
12918 index_type = MDEREF_INDEX_gvsv;
12923 } /* action_count != index_skip */
12925 action |= index_type;
12928 /* at this point we have either:
12929 * * detected what looks like a simple index expression,
12930 * and expect the next op to be an [ah]elem, or
12931 * an nulled [ah]elem followed by a delete or exists;
12932 * * found a more complex expression, so something other
12933 * than the above follows.
12936 /* possibly an optimised away [ah]elem (where op_next is
12937 * exists or delete) */
12938 if (o->op_type == OP_NULL)
12941 /* at this point we're looking for an OP_AELEM, OP_HELEM,
12942 * OP_EXISTS or OP_DELETE */
12944 /* if something like arybase (a.k.a $[ ) is in scope,
12945 * abandon optimisation attempt */
12946 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12947 && PL_check[o->op_type] != Perl_ck_null)
12950 if ( o->op_type != OP_AELEM
12951 || (o->op_private &
12952 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
12954 maybe_aelemfast = FALSE;
12956 /* look for aelem/helem/exists/delete. If it's not the last elem
12957 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
12958 * flags; if it's the last, then it mustn't have
12959 * OPpDEREF_AV/HV, but may have lots of other flags, like
12960 * OPpLVAL_INTRO etc
12963 if ( index_type == MDEREF_INDEX_none
12964 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
12965 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
12969 /* we have aelem/helem/exists/delete with valid simple index */
12971 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
12972 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
12973 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
12976 ASSUME(!(o->op_flags &
12977 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
12978 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
12980 ok = (o->op_flags &~ OPf_PARENS)
12981 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
12982 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
12984 else if (o->op_type == OP_EXISTS) {
12985 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12986 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12987 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
12988 ok = !(o->op_private & ~OPpARG1_MASK);
12990 else if (o->op_type == OP_DELETE) {
12991 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
12992 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
12993 ASSUME(!(o->op_private &
12994 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
12995 /* don't handle slices or 'local delete'; the latter
12996 * is fairly rare, and has a complex runtime */
12997 ok = !(o->op_private & ~OPpARG1_MASK);
12998 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
12999 /* skip handling run-tome error */
13000 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
13003 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
13004 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
13005 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
13006 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
13007 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
13008 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
13013 if (!first_elem_op)
13017 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
13022 action |= MDEREF_FLAG_last;
13026 /* at this point we have something that started
13027 * promisingly enough (with rv2av or whatever), but failed
13028 * to find a simple index followed by an
13029 * aelem/helem/exists/delete. If this is the first action,
13030 * give up; but if we've already seen at least one
13031 * aelem/helem, then keep them and add a new action with
13032 * MDEREF_INDEX_none, which causes it to do the vivify
13033 * from the end of the previous lookup, and do the deref,
13034 * but stop at that point. So $a[0][expr] will do one
13035 * av_fetch, vivify and deref, then continue executing at
13040 index_skip = action_count;
13041 action |= MDEREF_FLAG_last;
13045 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
13048 /* if there's no space for the next action, create a new slot
13049 * for it *before* we start adding args for that action */
13050 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
13057 } /* while !is_last */
13065 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
13066 if (index_skip == -1) {
13067 mderef->op_flags = o->op_flags
13068 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
13069 if (o->op_type == OP_EXISTS)
13070 mderef->op_private = OPpMULTIDEREF_EXISTS;
13071 else if (o->op_type == OP_DELETE)
13072 mderef->op_private = OPpMULTIDEREF_DELETE;
13074 mderef->op_private = o->op_private
13075 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
13077 /* accumulate strictness from every level (although I don't think
13078 * they can actually vary) */
13079 mderef->op_private |= hints;
13081 /* integrate the new multideref op into the optree and the
13084 * In general an op like aelem or helem has two child
13085 * sub-trees: the aggregate expression (a_expr) and the
13086 * index expression (i_expr):
13092 * The a_expr returns an AV or HV, while the i-expr returns an
13093 * index. In general a multideref replaces most or all of a
13094 * multi-level tree, e.g.
13110 * With multideref, all the i_exprs will be simple vars or
13111 * constants, except that i_expr1 may be arbitrary in the case
13112 * of MDEREF_INDEX_none.
13114 * The bottom-most a_expr will be either:
13115 * 1) a simple var (so padXv or gv+rv2Xv);
13116 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
13117 * so a simple var with an extra rv2Xv;
13118 * 3) or an arbitrary expression.
13120 * 'start', the first op in the execution chain, will point to
13121 * 1),2): the padXv or gv op;
13122 * 3): the rv2Xv which forms the last op in the a_expr
13123 * execution chain, and the top-most op in the a_expr
13126 * For all cases, the 'start' node is no longer required,
13127 * but we can't free it since one or more external nodes
13128 * may point to it. E.g. consider
13129 * $h{foo} = $a ? $b : $c
13130 * Here, both the op_next and op_other branches of the
13131 * cond_expr point to the gv[*h] of the hash expression, so
13132 * we can't free the 'start' op.
13134 * For expr->[...], we need to save the subtree containing the
13135 * expression; for the other cases, we just need to save the
13137 * So in all cases, we null the start op and keep it around by
13138 * making it the child of the multideref op; for the expr->
13139 * case, the expr will be a subtree of the start node.
13141 * So in the simple 1,2 case the optree above changes to
13147 * ex-gv (or ex-padxv)
13149 * with the op_next chain being
13151 * -> ex-gv -> multideref -> op-following-ex-exists ->
13153 * In the 3 case, we have
13166 * -> rest-of-a_expr subtree ->
13167 * ex-rv2xv -> multideref -> op-following-ex-exists ->
13170 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
13171 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
13172 * multideref attached as the child, e.g.
13178 * ex-rv2av - i_expr1
13186 /* if we free this op, don't free the pad entry */
13187 if (reset_start_targ)
13188 start->op_targ = 0;
13191 /* Cut the bit we need to save out of the tree and attach to
13192 * the multideref op, then free the rest of the tree */
13194 /* find parent of node to be detached (for use by splice) */
13196 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
13197 || orig_action == MDEREF_HV_pop_rv2hv_helem)
13199 /* there is an arbitrary expression preceding us, e.g.
13200 * expr->[..]? so we need to save the 'expr' subtree */
13201 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
13202 p = cUNOPx(p)->op_first;
13203 ASSUME( start->op_type == OP_RV2AV
13204 || start->op_type == OP_RV2HV);
13207 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
13208 * above for exists/delete. */
13209 while ( (p->op_flags & OPf_KIDS)
13210 && cUNOPx(p)->op_first != start
13212 p = cUNOPx(p)->op_first;
13214 ASSUME(cUNOPx(p)->op_first == start);
13216 /* detach from main tree, and re-attach under the multideref */
13217 op_sibling_splice(mderef, NULL, 0,
13218 op_sibling_splice(p, NULL, 1, NULL));
13221 start->op_next = mderef;
13223 mderef->op_next = index_skip == -1 ? o->op_next : o;
13225 /* excise and free the original tree, and replace with
13226 * the multideref op */
13227 p = op_sibling_splice(top_op, NULL, -1, mderef);
13236 Size_t size = arg - arg_buf;
13238 if (maybe_aelemfast && action_count == 1)
13241 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
13242 sizeof(UNOP_AUX_item) * (size + 1));
13243 /* for dumping etc: store the length in a hidden first slot;
13244 * we set the op_aux pointer to the second slot */
13245 arg_buf->uv = size;
13248 } /* for (pass = ...) */
13253 /* mechanism for deferring recursion in rpeep() */
13255 #define MAX_DEFERRED 4
13259 if (defer_ix == (MAX_DEFERRED-1)) { \
13260 OP **defer = defer_queue[defer_base]; \
13261 CALL_RPEEP(*defer); \
13262 S_prune_chain_head(defer); \
13263 defer_base = (defer_base + 1) % MAX_DEFERRED; \
13266 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
13269 #define IS_AND_OP(o) (o->op_type == OP_AND)
13270 #define IS_OR_OP(o) (o->op_type == OP_OR)
13273 /* A peephole optimizer. We visit the ops in the order they're to execute.
13274 * See the comments at the top of this file for more details about when
13275 * peep() is called */
13278 Perl_rpeep(pTHX_ OP *o)
13282 OP* oldoldop = NULL;
13283 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
13284 int defer_base = 0;
13289 if (!o || o->op_opt)
13293 SAVEVPTR(PL_curcop);
13294 for (;; o = o->op_next) {
13295 if (o && o->op_opt)
13298 while (defer_ix >= 0) {
13300 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
13301 CALL_RPEEP(*defer);
13302 S_prune_chain_head(defer);
13309 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
13310 assert(!oldoldop || oldoldop->op_next == oldop);
13311 assert(!oldop || oldop->op_next == o);
13313 /* By default, this op has now been optimised. A couple of cases below
13314 clear this again. */
13318 /* look for a series of 1 or more aggregate derefs, e.g.
13319 * $a[1]{foo}[$i]{$k}
13320 * and replace with a single OP_MULTIDEREF op.
13321 * Each index must be either a const, or a simple variable,
13323 * First, look for likely combinations of starting ops,
13324 * corresponding to (global and lexical variants of)
13326 * $r->[...] $r->{...}
13327 * (preceding expression)->[...]
13328 * (preceding expression)->{...}
13329 * and if so, call maybe_multideref() to do a full inspection
13330 * of the op chain and if appropriate, replace with an
13338 switch (o2->op_type) {
13340 /* $pkg[..] : gv[*pkg]
13341 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
13343 /* Fail if there are new op flag combinations that we're
13344 * not aware of, rather than:
13345 * * silently failing to optimise, or
13346 * * silently optimising the flag away.
13347 * If this ASSUME starts failing, examine what new flag
13348 * has been added to the op, and decide whether the
13349 * optimisation should still occur with that flag, then
13350 * update the code accordingly. This applies to all the
13351 * other ASSUMEs in the block of code too.
13353 ASSUME(!(o2->op_flags &
13354 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
13355 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
13359 if (o2->op_type == OP_RV2AV) {
13360 action = MDEREF_AV_gvav_aelem;
13364 if (o2->op_type == OP_RV2HV) {
13365 action = MDEREF_HV_gvhv_helem;
13369 if (o2->op_type != OP_RV2SV)
13372 /* at this point we've seen gv,rv2sv, so the only valid
13373 * construct left is $pkg->[] or $pkg->{} */
13375 ASSUME(!(o2->op_flags & OPf_STACKED));
13376 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13377 != (OPf_WANT_SCALAR|OPf_MOD))
13380 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
13381 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
13382 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
13384 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
13385 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
13389 if (o2->op_type == OP_RV2AV) {
13390 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
13393 if (o2->op_type == OP_RV2HV) {
13394 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
13400 /* $lex->[...]: padsv[$lex] sM/DREFAV */
13402 ASSUME(!(o2->op_flags &
13403 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
13404 if ((o2->op_flags &
13405 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13406 != (OPf_WANT_SCALAR|OPf_MOD))
13409 ASSUME(!(o2->op_private &
13410 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
13411 /* skip if state or intro, or not a deref */
13412 if ( o2->op_private != OPpDEREF_AV
13413 && o2->op_private != OPpDEREF_HV)
13417 if (o2->op_type == OP_RV2AV) {
13418 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
13421 if (o2->op_type == OP_RV2HV) {
13422 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
13429 /* $lex[..]: padav[@lex:1,2] sR *
13430 * or $lex{..}: padhv[%lex:1,2] sR */
13431 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
13432 OPf_REF|OPf_SPECIAL)));
13433 if ((o2->op_flags &
13434 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
13435 != (OPf_WANT_SCALAR|OPf_REF))
13437 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
13439 /* OPf_PARENS isn't currently used in this case;
13440 * if that changes, let us know! */
13441 ASSUME(!(o2->op_flags & OPf_PARENS));
13443 /* at this point, we wouldn't expect any of the remaining
13444 * possible private flags:
13445 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
13446 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
13448 * OPpSLICEWARNING shouldn't affect runtime
13450 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
13452 action = o2->op_type == OP_PADAV
13453 ? MDEREF_AV_padav_aelem
13454 : MDEREF_HV_padhv_helem;
13456 S_maybe_multideref(aTHX_ o, o2, action, 0);
13462 action = o2->op_type == OP_RV2AV
13463 ? MDEREF_AV_pop_rv2av_aelem
13464 : MDEREF_HV_pop_rv2hv_helem;
13467 /* (expr)->[...]: rv2av sKR/1;
13468 * (expr)->{...}: rv2hv sKR/1; */
13470 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
13472 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
13473 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
13474 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
13477 /* at this point, we wouldn't expect any of these
13478 * possible private flags:
13479 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
13480 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
13482 ASSUME(!(o2->op_private &
13483 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
13485 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
13489 S_maybe_multideref(aTHX_ o, o2, action, hints);
13498 switch (o->op_type) {
13500 PL_curcop = ((COP*)o); /* for warnings */
13503 PL_curcop = ((COP*)o); /* for warnings */
13505 /* Optimise a "return ..." at the end of a sub to just be "...".
13506 * This saves 2 ops. Before:
13507 * 1 <;> nextstate(main 1 -e:1) v ->2
13508 * 4 <@> return K ->5
13509 * 2 <0> pushmark s ->3
13510 * - <1> ex-rv2sv sK/1 ->4
13511 * 3 <#> gvsv[*cat] s ->4
13514 * - <@> return K ->-
13515 * - <0> pushmark s ->2
13516 * - <1> ex-rv2sv sK/1 ->-
13517 * 2 <$> gvsv(*cat) s ->3
13520 OP *next = o->op_next;
13521 OP *sibling = OpSIBLING(o);
13522 if ( OP_TYPE_IS(next, OP_PUSHMARK)
13523 && OP_TYPE_IS(sibling, OP_RETURN)
13524 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
13525 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
13526 ||OP_TYPE_IS(sibling->op_next->op_next,
13528 && cUNOPx(sibling)->op_first == next
13529 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
13532 /* Look through the PUSHMARK's siblings for one that
13533 * points to the RETURN */
13534 OP *top = OpSIBLING(next);
13535 while (top && top->op_next) {
13536 if (top->op_next == sibling) {
13537 top->op_next = sibling->op_next;
13538 o->op_next = next->op_next;
13541 top = OpSIBLING(top);
13546 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
13548 * This latter form is then suitable for conversion into padrange
13549 * later on. Convert:
13551 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
13555 * nextstate1 -> listop -> nextstate3
13557 * pushmark -> padop1 -> padop2
13559 if (o->op_next && (
13560 o->op_next->op_type == OP_PADSV
13561 || o->op_next->op_type == OP_PADAV
13562 || o->op_next->op_type == OP_PADHV
13564 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
13565 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
13566 && o->op_next->op_next->op_next && (
13567 o->op_next->op_next->op_next->op_type == OP_PADSV
13568 || o->op_next->op_next->op_next->op_type == OP_PADAV
13569 || o->op_next->op_next->op_next->op_type == OP_PADHV
13571 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
13572 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
13573 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
13574 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
13576 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
13579 ns2 = pad1->op_next;
13580 pad2 = ns2->op_next;
13581 ns3 = pad2->op_next;
13583 /* we assume here that the op_next chain is the same as
13584 * the op_sibling chain */
13585 assert(OpSIBLING(o) == pad1);
13586 assert(OpSIBLING(pad1) == ns2);
13587 assert(OpSIBLING(ns2) == pad2);
13588 assert(OpSIBLING(pad2) == ns3);
13590 /* excise and delete ns2 */
13591 op_sibling_splice(NULL, pad1, 1, NULL);
13594 /* excise pad1 and pad2 */
13595 op_sibling_splice(NULL, o, 2, NULL);
13597 /* create new listop, with children consisting of:
13598 * a new pushmark, pad1, pad2. */
13599 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
13600 newop->op_flags |= OPf_PARENS;
13601 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
13603 /* insert newop between o and ns3 */
13604 op_sibling_splice(NULL, o, 0, newop);
13606 /*fixup op_next chain */
13607 newpm = cUNOPx(newop)->op_first; /* pushmark */
13608 o ->op_next = newpm;
13609 newpm->op_next = pad1;
13610 pad1 ->op_next = pad2;
13611 pad2 ->op_next = newop; /* listop */
13612 newop->op_next = ns3;
13614 /* Ensure pushmark has this flag if padops do */
13615 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
13616 newpm->op_flags |= OPf_MOD;
13622 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
13623 to carry two labels. For now, take the easier option, and skip
13624 this optimisation if the first NEXTSTATE has a label. */
13625 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
13626 OP *nextop = o->op_next;
13627 while (nextop && nextop->op_type == OP_NULL)
13628 nextop = nextop->op_next;
13630 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
13633 oldop->op_next = nextop;
13635 /* Skip (old)oldop assignment since the current oldop's
13636 op_next already points to the next op. */
13643 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
13644 if (o->op_next->op_private & OPpTARGET_MY) {
13645 if (o->op_flags & OPf_STACKED) /* chained concats */
13646 break; /* ignore_optimization */
13648 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
13649 o->op_targ = o->op_next->op_targ;
13650 o->op_next->op_targ = 0;
13651 o->op_private |= OPpTARGET_MY;
13654 op_null(o->op_next);
13658 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
13659 break; /* Scalar stub must produce undef. List stub is noop */
13663 if (o->op_targ == OP_NEXTSTATE
13664 || o->op_targ == OP_DBSTATE)
13666 PL_curcop = ((COP*)o);
13668 /* XXX: We avoid setting op_seq here to prevent later calls
13669 to rpeep() from mistakenly concluding that optimisation
13670 has already occurred. This doesn't fix the real problem,
13671 though (See 20010220.007 (#5874)). AMS 20010719 */
13672 /* op_seq functionality is now replaced by op_opt */
13680 oldop->op_next = o->op_next;
13694 convert repeat into a stub with no kids.
13696 if (o->op_next->op_type == OP_CONST
13697 || ( o->op_next->op_type == OP_PADSV
13698 && !(o->op_next->op_private & OPpLVAL_INTRO))
13699 || ( o->op_next->op_type == OP_GV
13700 && o->op_next->op_next->op_type == OP_RV2SV
13701 && !(o->op_next->op_next->op_private
13702 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
13704 const OP *kid = o->op_next->op_next;
13705 if (o->op_next->op_type == OP_GV)
13706 kid = kid->op_next;
13707 /* kid is now the ex-list. */
13708 if (kid->op_type == OP_NULL
13709 && (kid = kid->op_next)->op_type == OP_CONST
13710 /* kid is now the repeat count. */
13711 && kid->op_next->op_type == OP_REPEAT
13712 && kid->op_next->op_private & OPpREPEAT_DOLIST
13713 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
13714 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
13716 o = kid->op_next; /* repeat */
13718 oldop->op_next = o;
13719 op_free(cBINOPo->op_first);
13720 op_free(cBINOPo->op_last );
13721 o->op_flags &=~ OPf_KIDS;
13722 /* stub is a baseop; repeat is a binop */
13723 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
13724 OpTYPE_set(o, OP_STUB);
13730 /* Convert a series of PAD ops for my vars plus support into a
13731 * single padrange op. Basically
13733 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
13735 * becomes, depending on circumstances, one of
13737 * padrange ----------------------------------> (list) -> rest
13738 * padrange --------------------------------------------> rest
13740 * where all the pad indexes are sequential and of the same type
13742 * We convert the pushmark into a padrange op, then skip
13743 * any other pad ops, and possibly some trailing ops.
13744 * Note that we don't null() the skipped ops, to make it
13745 * easier for Deparse to undo this optimisation (and none of
13746 * the skipped ops are holding any resourses). It also makes
13747 * it easier for find_uninit_var(), as it can just ignore
13748 * padrange, and examine the original pad ops.
13752 OP *followop = NULL; /* the op that will follow the padrange op */
13755 PADOFFSET base = 0; /* init only to stop compiler whining */
13756 bool gvoid = 0; /* init only to stop compiler whining */
13757 bool defav = 0; /* seen (...) = @_ */
13758 bool reuse = 0; /* reuse an existing padrange op */
13760 /* look for a pushmark -> gv[_] -> rv2av */
13765 if ( p->op_type == OP_GV
13766 && cGVOPx_gv(p) == PL_defgv
13767 && (rv2av = p->op_next)
13768 && rv2av->op_type == OP_RV2AV
13769 && !(rv2av->op_flags & OPf_REF)
13770 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
13771 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
13773 q = rv2av->op_next;
13774 if (q->op_type == OP_NULL)
13776 if (q->op_type == OP_PUSHMARK) {
13786 /* scan for PAD ops */
13788 for (p = p->op_next; p; p = p->op_next) {
13789 if (p->op_type == OP_NULL)
13792 if (( p->op_type != OP_PADSV
13793 && p->op_type != OP_PADAV
13794 && p->op_type != OP_PADHV
13796 /* any private flag other than INTRO? e.g. STATE */
13797 || (p->op_private & ~OPpLVAL_INTRO)
13801 /* let $a[N] potentially be optimised into AELEMFAST_LEX
13803 if ( p->op_type == OP_PADAV
13805 && p->op_next->op_type == OP_CONST
13806 && p->op_next->op_next
13807 && p->op_next->op_next->op_type == OP_AELEM
13811 /* for 1st padop, note what type it is and the range
13812 * start; for the others, check that it's the same type
13813 * and that the targs are contiguous */
13815 intro = (p->op_private & OPpLVAL_INTRO);
13817 gvoid = OP_GIMME(p,0) == G_VOID;
13820 if ((p->op_private & OPpLVAL_INTRO) != intro)
13822 /* Note that you'd normally expect targs to be
13823 * contiguous in my($a,$b,$c), but that's not the case
13824 * when external modules start doing things, e.g.
13825 * Function::Parameters */
13826 if (p->op_targ != base + count)
13828 assert(p->op_targ == base + count);
13829 /* Either all the padops or none of the padops should
13830 be in void context. Since we only do the optimisa-
13831 tion for av/hv when the aggregate itself is pushed
13832 on to the stack (one item), there is no need to dis-
13833 tinguish list from scalar context. */
13834 if (gvoid != (OP_GIMME(p,0) == G_VOID))
13838 /* for AV, HV, only when we're not flattening */
13839 if ( p->op_type != OP_PADSV
13841 && !(p->op_flags & OPf_REF)
13845 if (count >= OPpPADRANGE_COUNTMASK)
13848 /* there's a biggest base we can fit into a
13849 * SAVEt_CLEARPADRANGE in pp_padrange.
13850 * (The sizeof() stuff will be constant-folded, and is
13851 * intended to avoid getting "comparison is always false"
13852 * compiler warnings. See the comments above
13853 * MEM_WRAP_CHECK for more explanation on why we do this
13854 * in a weird way to avoid compiler warnings.)
13857 && (8*sizeof(base) >
13858 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
13860 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13862 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
13866 /* Success! We've got another valid pad op to optimise away */
13868 followop = p->op_next;
13871 if (count < 1 || (count == 1 && !defav))
13874 /* pp_padrange in specifically compile-time void context
13875 * skips pushing a mark and lexicals; in all other contexts
13876 * (including unknown till runtime) it pushes a mark and the
13877 * lexicals. We must be very careful then, that the ops we
13878 * optimise away would have exactly the same effect as the
13880 * In particular in void context, we can only optimise to
13881 * a padrange if we see the complete sequence
13882 * pushmark, pad*v, ...., list
13883 * which has the net effect of leaving the markstack as it
13884 * was. Not pushing onto the stack (whereas padsv does touch
13885 * the stack) makes no difference in void context.
13889 if (followop->op_type == OP_LIST
13890 && OP_GIMME(followop,0) == G_VOID
13893 followop = followop->op_next; /* skip OP_LIST */
13895 /* consolidate two successive my(...);'s */
13898 && oldoldop->op_type == OP_PADRANGE
13899 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
13900 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
13901 && !(oldoldop->op_flags & OPf_SPECIAL)
13904 assert(oldoldop->op_next == oldop);
13905 assert( oldop->op_type == OP_NEXTSTATE
13906 || oldop->op_type == OP_DBSTATE);
13907 assert(oldop->op_next == o);
13910 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
13912 /* Do not assume pad offsets for $c and $d are con-
13917 if ( oldoldop->op_targ + old_count == base
13918 && old_count < OPpPADRANGE_COUNTMASK - count) {
13919 base = oldoldop->op_targ;
13920 count += old_count;
13925 /* if there's any immediately following singleton
13926 * my var's; then swallow them and the associated
13928 * my ($a,$b); my $c; my $d;
13930 * my ($a,$b,$c,$d);
13933 while ( ((p = followop->op_next))
13934 && ( p->op_type == OP_PADSV
13935 || p->op_type == OP_PADAV
13936 || p->op_type == OP_PADHV)
13937 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
13938 && (p->op_private & OPpLVAL_INTRO) == intro
13939 && !(p->op_private & ~OPpLVAL_INTRO)
13941 && ( p->op_next->op_type == OP_NEXTSTATE
13942 || p->op_next->op_type == OP_DBSTATE)
13943 && count < OPpPADRANGE_COUNTMASK
13944 && base + count == p->op_targ
13947 followop = p->op_next;
13955 assert(oldoldop->op_type == OP_PADRANGE);
13956 oldoldop->op_next = followop;
13957 oldoldop->op_private = (intro | count);
13963 /* Convert the pushmark into a padrange.
13964 * To make Deparse easier, we guarantee that a padrange was
13965 * *always* formerly a pushmark */
13966 assert(o->op_type == OP_PUSHMARK);
13967 o->op_next = followop;
13968 OpTYPE_set(o, OP_PADRANGE);
13970 /* bit 7: INTRO; bit 6..0: count */
13971 o->op_private = (intro | count);
13972 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
13973 | gvoid * OPf_WANT_VOID
13974 | (defav ? OPf_SPECIAL : 0));
13982 /* Skip over state($x) in void context. */
13983 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
13984 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
13986 oldop->op_next = o->op_next;
13987 goto redo_nextstate;
13989 if (o->op_type != OP_PADAV)
13993 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
13994 OP* const pop = (o->op_type == OP_PADAV) ?
13995 o->op_next : o->op_next->op_next;
13997 if (pop && pop->op_type == OP_CONST &&
13998 ((PL_op = pop->op_next)) &&
13999 pop->op_next->op_type == OP_AELEM &&
14000 !(pop->op_next->op_private &
14001 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
14002 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
14005 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
14006 no_bareword_allowed(pop);
14007 if (o->op_type == OP_GV)
14008 op_null(o->op_next);
14009 op_null(pop->op_next);
14011 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
14012 o->op_next = pop->op_next->op_next;
14013 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
14014 o->op_private = (U8)i;
14015 if (o->op_type == OP_GV) {
14018 o->op_type = OP_AELEMFAST;
14021 o->op_type = OP_AELEMFAST_LEX;
14023 if (o->op_type != OP_GV)
14027 /* Remove $foo from the op_next chain in void context. */
14029 && ( o->op_next->op_type == OP_RV2SV
14030 || o->op_next->op_type == OP_RV2AV
14031 || o->op_next->op_type == OP_RV2HV )
14032 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14033 && !(o->op_next->op_private & OPpLVAL_INTRO))
14035 oldop->op_next = o->op_next->op_next;
14036 /* Reprocess the previous op if it is a nextstate, to
14037 allow double-nextstate optimisation. */
14039 if (oldop->op_type == OP_NEXTSTATE) {
14046 o = oldop->op_next;
14049 else if (o->op_next->op_type == OP_RV2SV) {
14050 if (!(o->op_next->op_private & OPpDEREF)) {
14051 op_null(o->op_next);
14052 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
14054 o->op_next = o->op_next->op_next;
14055 OpTYPE_set(o, OP_GVSV);
14058 else if (o->op_next->op_type == OP_READLINE
14059 && o->op_next->op_next->op_type == OP_CONCAT
14060 && (o->op_next->op_next->op_flags & OPf_STACKED))
14062 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
14063 OpTYPE_set(o, OP_RCATLINE);
14064 o->op_flags |= OPf_STACKED;
14065 op_null(o->op_next->op_next);
14066 op_null(o->op_next);
14071 #define HV_OR_SCALARHV(op) \
14072 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
14074 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
14075 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
14076 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
14077 ? cUNOPx(op)->op_first \
14081 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
14082 fop->op_private |= OPpTRUEBOOL;
14088 fop = cLOGOP->op_first;
14089 sop = OpSIBLING(fop);
14090 while (cLOGOP->op_other->op_type == OP_NULL)
14091 cLOGOP->op_other = cLOGOP->op_other->op_next;
14092 while (o->op_next && ( o->op_type == o->op_next->op_type
14093 || o->op_next->op_type == OP_NULL))
14094 o->op_next = o->op_next->op_next;
14096 /* If we're an OR and our next is an AND in void context, we'll
14097 follow its op_other on short circuit, same for reverse.
14098 We can't do this with OP_DOR since if it's true, its return
14099 value is the underlying value which must be evaluated
14103 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
14104 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
14106 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
14108 o->op_next = ((LOGOP*)o->op_next)->op_other;
14110 DEFER(cLOGOP->op_other);
14113 fop = HV_OR_SCALARHV(fop);
14114 if (sop) sop = HV_OR_SCALARHV(sop);
14119 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
14120 while (nop && nop->op_next) {
14121 switch (nop->op_next->op_type) {
14126 lop = nop = nop->op_next;
14129 nop = nop->op_next;
14138 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14139 || o->op_type == OP_AND )
14140 fop->op_private |= OPpTRUEBOOL;
14141 else if (!(lop->op_flags & OPf_WANT))
14142 fop->op_private |= OPpMAYBE_TRUEBOOL;
14144 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
14146 sop->op_private |= OPpTRUEBOOL;
14153 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
14154 fop->op_private |= OPpTRUEBOOL;
14155 #undef HV_OR_SCALARHV
14156 /* GERONIMO! */ /* FALLTHROUGH */
14165 while (cLOGOP->op_other->op_type == OP_NULL)
14166 cLOGOP->op_other = cLOGOP->op_other->op_next;
14167 DEFER(cLOGOP->op_other);
14172 while (cLOOP->op_redoop->op_type == OP_NULL)
14173 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
14174 while (cLOOP->op_nextop->op_type == OP_NULL)
14175 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
14176 while (cLOOP->op_lastop->op_type == OP_NULL)
14177 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
14178 /* a while(1) loop doesn't have an op_next that escapes the
14179 * loop, so we have to explicitly follow the op_lastop to
14180 * process the rest of the code */
14181 DEFER(cLOOP->op_lastop);
14185 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
14186 DEFER(cLOGOPo->op_other);
14190 assert(!(cPMOP->op_pmflags & PMf_ONCE));
14191 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
14192 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
14193 cPMOP->op_pmstashstartu.op_pmreplstart
14194 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
14195 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
14201 if (o->op_flags & OPf_SPECIAL) {
14202 /* first arg is a code block */
14203 OP * const nullop = OpSIBLING(cLISTOP->op_first);
14204 OP * kid = cUNOPx(nullop)->op_first;
14206 assert(nullop->op_type == OP_NULL);
14207 assert(kid->op_type == OP_SCOPE
14208 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
14209 /* since OP_SORT doesn't have a handy op_other-style
14210 * field that can point directly to the start of the code
14211 * block, store it in the otherwise-unused op_next field
14212 * of the top-level OP_NULL. This will be quicker at
14213 * run-time, and it will also allow us to remove leading
14214 * OP_NULLs by just messing with op_nexts without
14215 * altering the basic op_first/op_sibling layout. */
14216 kid = kLISTOP->op_first;
14218 (kid->op_type == OP_NULL
14219 && ( kid->op_targ == OP_NEXTSTATE
14220 || kid->op_targ == OP_DBSTATE ))
14221 || kid->op_type == OP_STUB
14222 || kid->op_type == OP_ENTER);
14223 nullop->op_next = kLISTOP->op_next;
14224 DEFER(nullop->op_next);
14227 /* check that RHS of sort is a single plain array */
14228 oright = cUNOPo->op_first;
14229 if (!oright || oright->op_type != OP_PUSHMARK)
14232 if (o->op_private & OPpSORT_INPLACE)
14235 /* reverse sort ... can be optimised. */
14236 if (!OpHAS_SIBLING(cUNOPo)) {
14237 /* Nothing follows us on the list. */
14238 OP * const reverse = o->op_next;
14240 if (reverse->op_type == OP_REVERSE &&
14241 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
14242 OP * const pushmark = cUNOPx(reverse)->op_first;
14243 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
14244 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
14245 /* reverse -> pushmark -> sort */
14246 o->op_private |= OPpSORT_REVERSE;
14248 pushmark->op_next = oright->op_next;
14258 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
14260 LISTOP *enter, *exlist;
14262 if (o->op_private & OPpSORT_INPLACE)
14265 enter = (LISTOP *) o->op_next;
14268 if (enter->op_type == OP_NULL) {
14269 enter = (LISTOP *) enter->op_next;
14273 /* for $a (...) will have OP_GV then OP_RV2GV here.
14274 for (...) just has an OP_GV. */
14275 if (enter->op_type == OP_GV) {
14276 gvop = (OP *) enter;
14277 enter = (LISTOP *) enter->op_next;
14280 if (enter->op_type == OP_RV2GV) {
14281 enter = (LISTOP *) enter->op_next;
14287 if (enter->op_type != OP_ENTERITER)
14290 iter = enter->op_next;
14291 if (!iter || iter->op_type != OP_ITER)
14294 expushmark = enter->op_first;
14295 if (!expushmark || expushmark->op_type != OP_NULL
14296 || expushmark->op_targ != OP_PUSHMARK)
14299 exlist = (LISTOP *) OpSIBLING(expushmark);
14300 if (!exlist || exlist->op_type != OP_NULL
14301 || exlist->op_targ != OP_LIST)
14304 if (exlist->op_last != o) {
14305 /* Mmm. Was expecting to point back to this op. */
14308 theirmark = exlist->op_first;
14309 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
14312 if (OpSIBLING(theirmark) != o) {
14313 /* There's something between the mark and the reverse, eg
14314 for (1, reverse (...))
14319 ourmark = ((LISTOP *)o)->op_first;
14320 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
14323 ourlast = ((LISTOP *)o)->op_last;
14324 if (!ourlast || ourlast->op_next != o)
14327 rv2av = OpSIBLING(ourmark);
14328 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
14329 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
14330 /* We're just reversing a single array. */
14331 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
14332 enter->op_flags |= OPf_STACKED;
14335 /* We don't have control over who points to theirmark, so sacrifice
14337 theirmark->op_next = ourmark->op_next;
14338 theirmark->op_flags = ourmark->op_flags;
14339 ourlast->op_next = gvop ? gvop : (OP *) enter;
14342 enter->op_private |= OPpITER_REVERSED;
14343 iter->op_private |= OPpITER_REVERSED;
14347 o = oldop->op_next;
14355 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
14356 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
14361 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
14362 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
14365 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
14367 sv = newRV((SV *)PL_compcv);
14371 OpTYPE_set(o, OP_CONST);
14372 o->op_flags |= OPf_SPECIAL;
14373 cSVOPo->op_sv = sv;
14378 if (OP_GIMME(o,0) == G_VOID
14379 || ( o->op_next->op_type == OP_LINESEQ
14380 && ( o->op_next->op_next->op_type == OP_LEAVESUB
14381 || ( o->op_next->op_next->op_type == OP_RETURN
14382 && !CvLVALUE(PL_compcv)))))
14384 OP *right = cBINOP->op_first;
14403 OP *left = OpSIBLING(right);
14404 if (left->op_type == OP_SUBSTR
14405 && (left->op_private & 7) < 4) {
14407 /* cut out right */
14408 op_sibling_splice(o, NULL, 1, NULL);
14409 /* and insert it as second child of OP_SUBSTR */
14410 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
14412 left->op_private |= OPpSUBSTR_REPL_FIRST;
14414 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
14421 int l, r, lr, lscalars, rscalars;
14423 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
14424 Note that we do this now rather than in newASSIGNOP(),
14425 since only by now are aliased lexicals flagged as such
14427 See the essay "Common vars in list assignment" above for
14428 the full details of the rationale behind all the conditions
14431 PL_generation sorcery:
14432 To detect whether there are common vars, the global var
14433 PL_generation is incremented for each assign op we scan.
14434 Then we run through all the lexical variables on the LHS,
14435 of the assignment, setting a spare slot in each of them to
14436 PL_generation. Then we scan the RHS, and if any lexicals
14437 already have that value, we know we've got commonality.
14438 Also, if the generation number is already set to
14439 PERL_INT_MAX, then the variable is involved in aliasing, so
14440 we also have potential commonality in that case.
14446 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
14449 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
14453 /* After looking for things which are *always* safe, this main
14454 * if/else chain selects primarily based on the type of the
14455 * LHS, gradually working its way down from the more dangerous
14456 * to the more restrictive and thus safer cases */
14458 if ( !l /* () = ....; */
14459 || !r /* .... = (); */
14460 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
14461 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
14462 || (lscalars < 2) /* ($x, undef) = ... */
14464 NOOP; /* always safe */
14466 else if (l & AAS_DANGEROUS) {
14467 /* always dangerous */
14468 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14469 o->op_private |= OPpASSIGN_COMMON_AGG;
14471 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
14472 /* package vars are always dangerous - too many
14473 * aliasing possibilities */
14474 if (l & AAS_PKG_SCALAR)
14475 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14476 if (l & AAS_PKG_AGG)
14477 o->op_private |= OPpASSIGN_COMMON_AGG;
14479 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
14480 |AAS_LEX_SCALAR|AAS_LEX_AGG))
14482 /* LHS contains only lexicals and safe ops */
14484 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
14485 o->op_private |= OPpASSIGN_COMMON_AGG;
14487 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
14488 if (lr & AAS_LEX_SCALAR_COMM)
14489 o->op_private |= OPpASSIGN_COMMON_SCALAR;
14490 else if ( !(l & AAS_LEX_SCALAR)
14491 && (r & AAS_DEFAV))
14495 * as scalar-safe for performance reasons.
14496 * (it will still have been marked _AGG if necessary */
14499 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
14500 o->op_private |= OPpASSIGN_COMMON_RC1;
14505 * may have to handle aggregate on LHS, but we can't
14506 * have common scalars. */
14509 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
14515 Perl_cpeep_t cpeep =
14516 XopENTRYCUSTOM(o, xop_peep);
14518 cpeep(aTHX_ o, oldop);
14523 /* did we just null the current op? If so, re-process it to handle
14524 * eliding "empty" ops from the chain */
14525 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
14538 Perl_peep(pTHX_ OP *o)
14544 =head1 Custom Operators
14546 =for apidoc Ao||custom_op_xop
14547 Return the XOP structure for a given custom op. This macro should be
14548 considered internal to C<OP_NAME> and the other access macros: use them instead.
14549 This macro does call a function. Prior
14550 to 5.19.6, this was implemented as a
14557 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
14563 static const XOP xop_null = { 0, 0, 0, 0, 0 };
14565 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
14566 assert(o->op_type == OP_CUSTOM);
14568 /* This is wrong. It assumes a function pointer can be cast to IV,
14569 * which isn't guaranteed, but this is what the old custom OP code
14570 * did. In principle it should be safer to Copy the bytes of the
14571 * pointer into a PV: since the new interface is hidden behind
14572 * functions, this can be changed later if necessary. */
14573 /* Change custom_op_xop if this ever happens */
14574 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
14577 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
14579 /* assume noone will have just registered a desc */
14580 if (!he && PL_custom_op_names &&
14581 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
14586 /* XXX does all this need to be shared mem? */
14587 Newxz(xop, 1, XOP);
14588 pv = SvPV(HeVAL(he), l);
14589 XopENTRY_set(xop, xop_name, savepvn(pv, l));
14590 if (PL_custom_op_descs &&
14591 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
14593 pv = SvPV(HeVAL(he), l);
14594 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
14596 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
14600 xop = (XOP *)&xop_null;
14602 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
14606 if(field == XOPe_xop_ptr) {
14609 const U32 flags = XopFLAGS(xop);
14610 if(flags & field) {
14612 case XOPe_xop_name:
14613 any.xop_name = xop->xop_name;
14615 case XOPe_xop_desc:
14616 any.xop_desc = xop->xop_desc;
14618 case XOPe_xop_class:
14619 any.xop_class = xop->xop_class;
14621 case XOPe_xop_peep:
14622 any.xop_peep = xop->xop_peep;
14625 NOT_REACHED; /* NOTREACHED */
14630 case XOPe_xop_name:
14631 any.xop_name = XOPd_xop_name;
14633 case XOPe_xop_desc:
14634 any.xop_desc = XOPd_xop_desc;
14636 case XOPe_xop_class:
14637 any.xop_class = XOPd_xop_class;
14639 case XOPe_xop_peep:
14640 any.xop_peep = XOPd_xop_peep;
14643 NOT_REACHED; /* NOTREACHED */
14648 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
14649 * op.c: In function 'Perl_custom_op_get_field':
14650 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
14651 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
14652 * expands to assert(0), which expands to ((0) ? (void)0 :
14653 * __assert(...)), and gcc doesn't know that __assert can never return. */
14659 =for apidoc Ao||custom_op_register
14660 Register a custom op. See L<perlguts/"Custom Operators">.
14666 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
14670 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
14672 /* see the comment in custom_op_xop */
14673 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
14675 if (!PL_custom_ops)
14676 PL_custom_ops = newHV();
14678 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
14679 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
14684 =for apidoc core_prototype
14686 This function assigns the prototype of the named core function to C<sv>, or
14687 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
14688 C<NULL> if the core function has no prototype. C<code> is a code as returned
14689 by C<keyword()>. It must not be equal to 0.
14695 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
14698 int i = 0, n = 0, seen_question = 0, defgv = 0;
14700 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
14701 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
14702 bool nullret = FALSE;
14704 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
14708 if (!sv) sv = sv_newmortal();
14710 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
14712 switch (code < 0 ? -code : code) {
14713 case KEY_and : case KEY_chop: case KEY_chomp:
14714 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
14715 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
14716 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
14717 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
14718 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
14719 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
14720 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
14721 case KEY_x : case KEY_xor :
14722 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
14723 case KEY_glob: retsetpvs("_;", OP_GLOB);
14724 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
14725 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
14726 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
14727 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
14728 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
14730 case KEY_evalbytes:
14731 name = "entereval"; break;
14739 while (i < MAXO) { /* The slow way. */
14740 if (strEQ(name, PL_op_name[i])
14741 || strEQ(name, PL_op_desc[i]))
14743 if (nullret) { assert(opnum); *opnum = i; return NULL; }
14750 defgv = PL_opargs[i] & OA_DEFGV;
14751 oa = PL_opargs[i] >> OASHIFT;
14753 if (oa & OA_OPTIONAL && !seen_question && (
14754 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
14759 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
14760 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
14761 /* But globs are already references (kinda) */
14762 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
14766 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
14767 && !scalar_mod_type(NULL, i)) {
14772 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
14776 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
14777 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
14778 str[n-1] = '_'; defgv = 0;
14782 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
14784 sv_setpvn(sv, str, n - 1);
14785 if (opnum) *opnum = i;
14790 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
14793 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
14796 PERL_ARGS_ASSERT_CORESUB_OP;
14800 return op_append_elem(OP_LINESEQ,
14803 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
14810 o = newUNOP(OP_AVHVSWITCH,0,argop);
14811 o->op_private = opnum-OP_EACH;
14813 case OP_SELECT: /* which represents OP_SSELECT as well */
14818 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
14819 newSVOP(OP_CONST, 0, newSVuv(1))
14821 coresub_op(newSVuv((UV)OP_SSELECT), 0,
14823 coresub_op(coreargssv, 0, OP_SELECT)
14827 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14829 return op_append_elem(
14832 opnum == OP_WANTARRAY || opnum == OP_RUNCV
14833 ? OPpOFFBYONE << 8 : 0)
14835 case OA_BASEOP_OR_UNOP:
14836 if (opnum == OP_ENTEREVAL) {
14837 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
14838 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
14840 else o = newUNOP(opnum,0,argop);
14841 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
14844 if (is_handle_constructor(o, 1))
14845 argop->op_private |= OPpCOREARGS_DEREF1;
14846 if (scalar_mod_type(NULL, opnum))
14847 argop->op_private |= OPpCOREARGS_SCALARMOD;
14851 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
14852 if (is_handle_constructor(o, 2))
14853 argop->op_private |= OPpCOREARGS_DEREF2;
14854 if (opnum == OP_SUBSTR) {
14855 o->op_private |= OPpMAYBE_LVSUB;
14864 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
14865 SV * const *new_const_svp)
14867 const char *hvname;
14868 bool is_const = !!CvCONST(old_cv);
14869 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
14871 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
14873 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
14875 /* They are 2 constant subroutines generated from
14876 the same constant. This probably means that
14877 they are really the "same" proxy subroutine
14878 instantiated in 2 places. Most likely this is
14879 when a constant is exported twice. Don't warn.
14882 (ckWARN(WARN_REDEFINE)
14884 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
14885 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
14886 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
14887 strEQ(hvname, "autouse"))
14891 && ckWARN_d(WARN_REDEFINE)
14892 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
14895 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
14897 ? "Constant subroutine %"SVf" redefined"
14898 : "Subroutine %"SVf" redefined",
14903 =head1 Hook manipulation
14905 These functions provide convenient and thread-safe means of manipulating
14912 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
14914 Puts a C function into the chain of check functions for a specified op
14915 type. This is the preferred way to manipulate the L</PL_check> array.
14916 C<opcode> specifies which type of op is to be affected. C<new_checker>
14917 is a pointer to the C function that is to be added to that opcode's
14918 check chain, and C<old_checker_p> points to the storage location where a
14919 pointer to the next function in the chain will be stored. The value of
14920 C<new_pointer> is written into the L</PL_check> array, while the value
14921 previously stored there is written to C<*old_checker_p>.
14923 The function should be defined like this:
14925 static OP *new_checker(pTHX_ OP *op) { ... }
14927 It is intended to be called in this manner:
14929 new_checker(aTHX_ op)
14931 C<old_checker_p> should be defined like this:
14933 static Perl_check_t old_checker_p;
14935 L</PL_check> is global to an entire process, and a module wishing to
14936 hook op checking may find itself invoked more than once per process,
14937 typically in different threads. To handle that situation, this function
14938 is idempotent. The location C<*old_checker_p> must initially (once
14939 per process) contain a null pointer. A C variable of static duration
14940 (declared at file scope, typically also marked C<static> to give
14941 it internal linkage) will be implicitly initialised appropriately,
14942 if it does not have an explicit initialiser. This function will only
14943 actually modify the check chain if it finds C<*old_checker_p> to be null.
14944 This function is also thread safe on the small scale. It uses appropriate
14945 locking to avoid race conditions in accessing L</PL_check>.
14947 When this function is called, the function referenced by C<new_checker>
14948 must be ready to be called, except for C<*old_checker_p> being unfilled.
14949 In a threading situation, C<new_checker> may be called immediately,
14950 even before this function has returned. C<*old_checker_p> will always
14951 be appropriately set before C<new_checker> is called. If C<new_checker>
14952 decides not to do anything special with an op that it is given (which
14953 is the usual case for most uses of op check hooking), it must chain the
14954 check function referenced by C<*old_checker_p>.
14956 If you want to influence compilation of calls to a specific subroutine,
14957 then use L</cv_set_call_checker> rather than hooking checking of all
14964 Perl_wrap_op_checker(pTHX_ Optype opcode,
14965 Perl_check_t new_checker, Perl_check_t *old_checker_p)
14969 PERL_UNUSED_CONTEXT;
14970 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
14971 if (*old_checker_p) return;
14972 OP_CHECK_MUTEX_LOCK;
14973 if (!*old_checker_p) {
14974 *old_checker_p = PL_check[opcode];
14975 PL_check[opcode] = new_checker;
14977 OP_CHECK_MUTEX_UNLOCK;
14982 /* Efficient sub that returns a constant scalar value. */
14984 const_sv_xsub(pTHX_ CV* cv)
14987 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
14988 PERL_UNUSED_ARG(items);
14998 const_av_xsub(pTHX_ CV* cv)
15001 AV * const av = MUTABLE_AV(XSANY.any_ptr);
15009 if (SvRMAGICAL(av))
15010 Perl_croak(aTHX_ "Magical list constants are not supported");
15011 if (GIMME_V != G_ARRAY) {
15013 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15016 EXTEND(SP, AvFILLp(av)+1);
15017 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15018 XSRETURN(AvFILLp(av)+1);
15022 * ex: set ts=8 sts=4 sw=4 et: