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"
167 #include "invlist_inline.h"
169 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
170 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
171 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
173 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
175 /* remove any leading "empty" ops from the op_next chain whose first
176 * node's address is stored in op_p. Store the updated address of the
177 * first node in op_p.
181 S_prune_chain_head(OP** op_p)
184 && ( (*op_p)->op_type == OP_NULL
185 || (*op_p)->op_type == OP_SCOPE
186 || (*op_p)->op_type == OP_SCALAR
187 || (*op_p)->op_type == OP_LINESEQ)
189 *op_p = (*op_p)->op_next;
193 /* See the explanatory comments above struct opslab in op.h. */
195 #ifdef PERL_DEBUG_READONLY_OPS
196 # define PERL_SLAB_SIZE 128
197 # define PERL_MAX_SLAB_SIZE 4096
198 # include <sys/mman.h>
201 #ifndef PERL_SLAB_SIZE
202 # define PERL_SLAB_SIZE 64
204 #ifndef PERL_MAX_SLAB_SIZE
205 # define PERL_MAX_SLAB_SIZE 2048
208 /* rounds up to nearest pointer */
209 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
210 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
212 /* requires double parens and aTHX_ */
213 #define DEBUG_S_warn(args) \
215 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
219 /* malloc a new op slab (suitable for attaching to PL_compcv).
220 * sz is in units of pointers */
223 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
227 /* opslot_offset is only U16 */
228 assert(sz < U16_MAX);
230 #ifdef PERL_DEBUG_READONLY_OPS
231 slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
232 PROT_READ|PROT_WRITE,
233 MAP_ANON|MAP_PRIVATE, -1, 0);
234 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
235 (unsigned long) sz, slab));
236 if (slab == MAP_FAILED) {
237 perror("mmap failed");
241 slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
243 slab->opslab_size = (U16)sz;
246 /* The context is unused in non-Windows */
249 slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
250 slab->opslab_head = head ? head : slab;
251 DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
252 (unsigned int)slab->opslab_size, (void*)slab,
253 (void*)(slab->opslab_head)));
258 /* Returns a sz-sized block of memory (suitable for holding an op) from
259 * a free slot in the chain of op slabs attached to PL_compcv.
260 * Allocates a new slab if necessary.
261 * if PL_compcv isn't compiling, malloc() instead.
265 Perl_Slab_Alloc(pTHX_ size_t sz)
267 OPSLAB *head_slab; /* first slab in the chain */
273 /* We only allocate ops from the slab during subroutine compilation.
274 We find the slab via PL_compcv, hence that must be non-NULL. It could
275 also be pointing to a subroutine which is now fully set up (CvROOT()
276 pointing to the top of the optree for that sub), or a subroutine
277 which isn't using the slab allocator. If our sanity checks aren't met,
278 don't use a slab, but allocate the OP directly from the heap. */
279 if (!PL_compcv || CvROOT(PL_compcv)
280 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
282 o = (OP*)PerlMemShared_calloc(1, sz);
286 /* While the subroutine is under construction, the slabs are accessed via
287 CvSTART(), to avoid needing to expand PVCV by one pointer for something
288 unneeded at runtime. Once a subroutine is constructed, the slabs are
289 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
290 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
292 if (!CvSTART(PL_compcv)) {
294 (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
295 CvSLABBED_on(PL_compcv);
296 head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
298 else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
300 opsz = SIZE_TO_PSIZE(sz);
301 sz = opsz + OPSLOT_HEADER_P;
303 /* The slabs maintain a free list of OPs. In particular, constant folding
304 will free up OPs, so it makes sense to re-use them where possible. A
305 freed up slot is used in preference to a new allocation. */
306 if (head_slab->opslab_freed) {
307 OP **too = &head_slab->opslab_freed;
309 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p, head slab %p",
311 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
314 while (o && OpSLOT(o)->opslot_size < sz) {
315 DEBUG_S_warn((aTHX_ "Alas! too small"));
316 o = *(too = &o->op_next);
317 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
320 DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
322 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
325 Zero(o, opsz, I32 *);
331 #define INIT_OPSLOT(s) \
332 slot->opslot_offset = DIFF(slab2, slot) ; \
333 slot->opslot_size = s; \
334 slab2->opslab_free_space -= s; \
335 o = &slot->opslot_op; \
338 /* The partially-filled slab is next in the chain. */
339 slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
340 if (slab2->opslab_free_space < sz) {
341 /* Remaining space is too small. */
342 /* If we can fit a BASEOP, add it to the free chain, so as not
344 if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
345 slot = &slab2->opslab_slots;
346 INIT_OPSLOT(slab2->opslab_free_space);
347 o->op_type = OP_FREED;
348 o->op_next = head_slab->opslab_freed;
349 head_slab->opslab_freed = o;
352 /* Create a new slab. Make this one twice as big. */
353 slab2 = S_new_slab(aTHX_ head_slab,
354 slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
356 : slab2->opslab_size * 2);
357 slab2->opslab_next = head_slab->opslab_next;
358 head_slab->opslab_next = slab2;
360 assert(slab2->opslab_size >= sz);
362 /* Create a new op slot */
364 ((I32 **)&slab2->opslab_slots
365 + slab2->opslab_free_space - sz);
366 assert(slot >= &slab2->opslab_slots);
368 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
369 (void*)o, (void*)slab2, (void*)head_slab));
372 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
373 assert(!o->op_moresib);
374 assert(!o->op_sibparent);
381 #ifdef PERL_DEBUG_READONLY_OPS
383 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
385 PERL_ARGS_ASSERT_SLAB_TO_RO;
387 if (slab->opslab_readonly) return;
388 slab->opslab_readonly = 1;
389 for (; slab; slab = slab->opslab_next) {
390 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
391 (unsigned long) slab->opslab_size, slab));*/
392 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
393 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
394 (unsigned long)slab->opslab_size, errno);
399 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
403 PERL_ARGS_ASSERT_SLAB_TO_RW;
405 if (!slab->opslab_readonly) return;
407 for (; slab2; slab2 = slab2->opslab_next) {
408 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
409 (unsigned long) size, slab2));*/
410 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
411 PROT_READ|PROT_WRITE)) {
412 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
413 (unsigned long)slab2->opslab_size, errno);
416 slab->opslab_readonly = 0;
420 # define Slab_to_rw(op) NOOP
423 /* This cannot possibly be right, but it was copied from the old slab
424 allocator, to which it was originally added, without explanation, in
427 # define PerlMemShared PerlMem
430 /* make freed ops die if they're inadvertently executed */
435 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
440 /* Return the block of memory used by an op to the free list of
441 * the OP slab associated with that op.
445 Perl_Slab_Free(pTHX_ void *op)
447 OP * const o = (OP *)op;
450 PERL_ARGS_ASSERT_SLAB_FREE;
453 o->op_ppaddr = S_pp_freed;
456 if (!o->op_slabbed) {
458 PerlMemShared_free(op);
463 /* If this op is already freed, our refcount will get screwy. */
464 assert(o->op_type != OP_FREED);
465 o->op_type = OP_FREED;
466 o->op_next = slab->opslab_freed;
467 slab->opslab_freed = o;
468 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
470 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
472 OpslabREFCNT_dec_padok(slab);
476 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
478 const bool havepad = !!PL_comppad;
479 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
482 PAD_SAVE_SETNULLPAD();
488 /* Free a chain of OP slabs. Should only be called after all ops contained
489 * in it have been freed. At this point, its reference count should be 1,
490 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
491 * and just directly calls opslab_free().
492 * (Note that the reference count which PL_compcv held on the slab should
493 * have been removed once compilation of the sub was complete).
499 Perl_opslab_free(pTHX_ OPSLAB *slab)
502 PERL_ARGS_ASSERT_OPSLAB_FREE;
504 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
505 assert(slab->opslab_refcnt == 1);
507 slab2 = slab->opslab_next;
509 slab->opslab_refcnt = ~(size_t)0;
511 #ifdef PERL_DEBUG_READONLY_OPS
512 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
514 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
515 perror("munmap failed");
519 PerlMemShared_free(slab);
525 /* like opslab_free(), but first calls op_free() on any ops in the slab
526 * not marked as OP_FREED
530 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
534 size_t savestack_count = 0;
536 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
539 OPSLOT *slot = (OPSLOT*)
540 ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
541 OPSLOT *end = (OPSLOT*)
542 ((I32**)slab2 + slab2->opslab_size);
544 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
546 if (slot->opslot_op.op_type != OP_FREED
547 && !(slot->opslot_op.op_savefree
553 assert(slot->opslot_op.op_slabbed);
554 op_free(&slot->opslot_op);
555 if (slab->opslab_refcnt == 1) goto free;
558 } while ((slab2 = slab2->opslab_next));
559 /* > 1 because the CV still holds a reference count. */
560 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
562 assert(savestack_count == slab->opslab_refcnt-1);
564 /* Remove the CV’s reference count. */
565 slab->opslab_refcnt--;
572 #ifdef PERL_DEBUG_READONLY_OPS
574 Perl_op_refcnt_inc(pTHX_ OP *o)
577 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
578 if (slab && slab->opslab_readonly) {
591 Perl_op_refcnt_dec(pTHX_ OP *o)
594 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
596 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
598 if (slab && slab->opslab_readonly) {
600 result = --o->op_targ;
603 result = --o->op_targ;
609 * In the following definition, the ", (OP*)0" is just to make the compiler
610 * think the expression is of the right type: croak actually does a Siglongjmp.
612 #define CHECKOP(type,o) \
613 ((PL_op_mask && PL_op_mask[type]) \
614 ? ( op_free((OP*)o), \
615 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
617 : PL_check[type](aTHX_ (OP*)o))
619 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
621 #define OpTYPE_set(o,type) \
623 o->op_type = (OPCODE)type; \
624 o->op_ppaddr = PL_ppaddr[type]; \
628 S_no_fh_allowed(pTHX_ OP *o)
630 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
632 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
638 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
640 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
641 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
646 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
648 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
650 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
655 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
657 PERL_ARGS_ASSERT_BAD_TYPE_PV;
659 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
660 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
663 /* remove flags var, its unused in all callers, move to to right end since gv
664 and kid are always the same */
666 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
668 SV * const namesv = cv_name((CV *)gv, NULL, 0);
669 PERL_ARGS_ASSERT_BAD_TYPE_GV;
671 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
672 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
676 S_no_bareword_allowed(pTHX_ OP *o)
678 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
680 qerror(Perl_mess(aTHX_
681 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
683 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
686 /* "register" allocation */
689 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
692 const bool is_our = (PL_parser->in_my == KEY_our);
694 PERL_ARGS_ASSERT_ALLOCMY;
696 if (flags & ~SVf_UTF8)
697 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
700 /* complain about "my $<special_var>" etc etc */
704 || ( (flags & SVf_UTF8)
705 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
706 || (name[1] == '_' && len > 2)))
708 const char * const type =
709 PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
710 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
712 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
714 && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
715 /* diag_listed_as: Can't use global %s in %s */
716 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
717 name[0], toCTRL(name[1]),
718 (int)(len - 2), name + 2,
721 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
723 type), flags & SVf_UTF8);
727 /* allocate a spare slot and store the name in that slot */
729 off = pad_add_name_pvn(name, len,
730 (is_our ? padadd_OUR :
731 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
732 PL_parser->in_my_stash,
734 /* $_ is always in main::, even with our */
735 ? (PL_curstash && !memEQs(name,len,"$_")
741 /* anon sub prototypes contains state vars should always be cloned,
742 * otherwise the state var would be shared between anon subs */
744 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
745 CvCLONE_on(PL_compcv);
751 =head1 Optree Manipulation Functions
753 =for apidoc alloccopstash
755 Available only under threaded builds, this function allocates an entry in
756 C<PL_stashpad> for the stash passed to it.
763 Perl_alloccopstash(pTHX_ HV *hv)
765 PADOFFSET off = 0, o = 1;
766 bool found_slot = FALSE;
768 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
770 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
772 for (; o < PL_stashpadmax; ++o) {
773 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
774 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
775 found_slot = TRUE, off = o;
778 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
779 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
780 off = PL_stashpadmax;
781 PL_stashpadmax += 10;
784 PL_stashpad[PL_stashpadix = off] = hv;
789 /* free the body of an op without examining its contents.
790 * Always use this rather than FreeOp directly */
793 S_op_destroy(pTHX_ OP *o)
803 Free an op and its children. Only use this when an op is no longer linked
810 Perl_op_free(pTHX_ OP *o)
816 bool went_up = FALSE; /* whether we reached the current node by
817 following the parent pointer from a child, and
818 so have already seen this node */
820 if (!o || o->op_type == OP_FREED)
823 if (o->op_private & OPpREFCOUNTED) {
824 /* if base of tree is refcounted, just decrement */
825 switch (o->op_type) {
835 refcnt = OpREFCNT_dec(o);
838 /* Need to find and remove any pattern match ops from
839 * the list we maintain for reset(). */
840 find_and_forget_pmops(o);
853 /* free child ops before ourself, (then free ourself "on the
856 if (!went_up && o->op_flags & OPf_KIDS) {
857 next_op = cUNOPo->op_first;
861 /* find the next node to visit, *then* free the current node
862 * (can't rely on o->op_* fields being valid after o has been
865 /* The next node to visit will be either the sibling, or the
866 * parent if no siblings left, or NULL if we've worked our way
867 * back up to the top node in the tree */
868 next_op = (o == top_op) ? NULL : o->op_sibparent;
869 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
871 /* Now process the current node */
873 /* Though ops may be freed twice, freeing the op after its slab is a
875 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
876 /* During the forced freeing of ops after compilation failure, kidops
877 may be freed before their parents. */
878 if (!o || o->op_type == OP_FREED)
883 /* an op should only ever acquire op_private flags that we know about.
884 * If this fails, you may need to fix something in regen/op_private.
885 * Don't bother testing if:
886 * * the op_ppaddr doesn't match the op; someone may have
887 * overridden the op and be doing strange things with it;
888 * * we've errored, as op flags are often left in an
889 * inconsistent state then. Note that an error when
890 * compiling the main program leaves PL_parser NULL, so
891 * we can't spot faults in the main code, only
892 * evaled/required code */
894 if ( o->op_ppaddr == PL_ppaddr[type]
896 && !PL_parser->error_count)
898 assert(!(o->op_private & ~PL_op_private_valid[type]));
903 /* Call the op_free hook if it has been set. Do it now so that it's called
904 * at the right time for refcounted ops, but still before all of the kids
909 type = (OPCODE)o->op_targ;
912 Slab_to_rw(OpSLAB(o));
914 /* COP* is not cleared by op_clear() so that we may track line
915 * numbers etc even after null() */
916 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
928 /* S_op_clear_gv(): free a GV attached to an OP */
932 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
934 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
938 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
939 || o->op_type == OP_MULTIDEREF)
942 ? ((GV*)PAD_SVl(*ixp)) : NULL;
944 ? (GV*)(*svp) : NULL;
946 /* It's possible during global destruction that the GV is freed
947 before the optree. Whilst the SvREFCNT_inc is happy to bump from
948 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
949 will trigger an assertion failure, because the entry to sv_clear
950 checks that the scalar is not already freed. A check of for
951 !SvIS_FREED(gv) turns out to be invalid, because during global
952 destruction the reference count can be forced down to zero
953 (with SVf_BREAK set). In which case raising to 1 and then
954 dropping to 0 triggers cleanup before it should happen. I
955 *think* that this might actually be a general, systematic,
956 weakness of the whole idea of SVf_BREAK, in that code *is*
957 allowed to raise and lower references during global destruction,
958 so any *valid* code that happens to do this during global
959 destruction might well trigger premature cleanup. */
960 bool still_valid = gv && SvREFCNT(gv);
963 SvREFCNT_inc_simple_void(gv);
966 pad_swipe(*ixp, TRUE);
974 int try_downgrade = SvREFCNT(gv) == 2;
977 gv_try_downgrade(gv);
983 Perl_op_clear(pTHX_ OP *o)
988 PERL_ARGS_ASSERT_OP_CLEAR;
990 switch (o->op_type) {
991 case OP_NULL: /* Was holding old type, if any. */
994 case OP_ENTEREVAL: /* Was holding hints. */
995 case OP_ARGDEFELEM: /* Was holding signature index. */
999 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1006 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1008 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1011 case OP_METHOD_REDIR:
1012 case OP_METHOD_REDIR_SUPER:
1014 if (cMETHOPx(o)->op_rclass_targ) {
1015 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1016 cMETHOPx(o)->op_rclass_targ = 0;
1019 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1020 cMETHOPx(o)->op_rclass_sv = NULL;
1023 case OP_METHOD_NAMED:
1024 case OP_METHOD_SUPER:
1025 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1026 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1029 pad_swipe(o->op_targ, 1);
1036 SvREFCNT_dec(cSVOPo->op_sv);
1037 cSVOPo->op_sv = NULL;
1040 Even if op_clear does a pad_free for the target of the op,
1041 pad_free doesn't actually remove the sv that exists in the pad;
1042 instead it lives on. This results in that it could be reused as
1043 a target later on when the pad was reallocated.
1046 pad_swipe(o->op_targ,1);
1056 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1061 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1062 && (o->op_private & OPpTRANS_USE_SVOP))
1065 if (cPADOPo->op_padix > 0) {
1066 pad_swipe(cPADOPo->op_padix, TRUE);
1067 cPADOPo->op_padix = 0;
1070 SvREFCNT_dec(cSVOPo->op_sv);
1071 cSVOPo->op_sv = NULL;
1075 PerlMemShared_free(cPVOPo->op_pv);
1076 cPVOPo->op_pv = NULL;
1080 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1084 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1085 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1087 if (o->op_private & OPpSPLIT_LEX)
1088 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1091 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1093 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1100 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1101 op_free(cPMOPo->op_code_list);
1102 cPMOPo->op_code_list = NULL;
1103 forget_pmop(cPMOPo);
1104 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1105 /* we use the same protection as the "SAFE" version of the PM_ macros
1106 * here since sv_clean_all might release some PMOPs
1107 * after PL_regex_padav has been cleared
1108 * and the clearing of PL_regex_padav needs to
1109 * happen before sv_clean_all
1112 if(PL_regex_pad) { /* We could be in destruction */
1113 const IV offset = (cPMOPo)->op_pmoffset;
1114 ReREFCNT_dec(PM_GETRE(cPMOPo));
1115 PL_regex_pad[offset] = &PL_sv_undef;
1116 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1120 ReREFCNT_dec(PM_GETRE(cPMOPo));
1121 PM_SETRE(cPMOPo, NULL);
1127 PerlMemShared_free(cUNOP_AUXo->op_aux);
1130 case OP_MULTICONCAT:
1132 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1133 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1134 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1135 * utf8 shared strings */
1136 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1137 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1139 PerlMemShared_free(p1);
1141 PerlMemShared_free(p2);
1142 PerlMemShared_free(aux);
1148 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1149 UV actions = items->uv;
1151 bool is_hash = FALSE;
1154 switch (actions & MDEREF_ACTION_MASK) {
1157 actions = (++items)->uv;
1160 case MDEREF_HV_padhv_helem:
1163 case MDEREF_AV_padav_aelem:
1164 pad_free((++items)->pad_offset);
1167 case MDEREF_HV_gvhv_helem:
1170 case MDEREF_AV_gvav_aelem:
1172 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1174 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1178 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1181 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1183 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1185 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1187 goto do_vivify_rv2xv_elem;
1189 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1192 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1193 pad_free((++items)->pad_offset);
1194 goto do_vivify_rv2xv_elem;
1196 case MDEREF_HV_pop_rv2hv_helem:
1197 case MDEREF_HV_vivify_rv2hv_helem:
1200 do_vivify_rv2xv_elem:
1201 case MDEREF_AV_pop_rv2av_aelem:
1202 case MDEREF_AV_vivify_rv2av_aelem:
1204 switch (actions & MDEREF_INDEX_MASK) {
1205 case MDEREF_INDEX_none:
1208 case MDEREF_INDEX_const:
1212 pad_swipe((++items)->pad_offset, 1);
1214 SvREFCNT_dec((++items)->sv);
1220 case MDEREF_INDEX_padsv:
1221 pad_free((++items)->pad_offset);
1223 case MDEREF_INDEX_gvsv:
1225 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1227 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1232 if (actions & MDEREF_FLAG_last)
1245 actions >>= MDEREF_SHIFT;
1248 /* start of malloc is at op_aux[-1], where the length is
1250 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1255 if (o->op_targ > 0) {
1256 pad_free(o->op_targ);
1262 S_cop_free(pTHX_ COP* cop)
1264 PERL_ARGS_ASSERT_COP_FREE;
1267 if (! specialWARN(cop->cop_warnings))
1268 PerlMemShared_free(cop->cop_warnings);
1269 cophh_free(CopHINTHASH_get(cop));
1270 if (PL_curcop == cop)
1275 S_forget_pmop(pTHX_ PMOP *const o)
1277 HV * const pmstash = PmopSTASH(o);
1279 PERL_ARGS_ASSERT_FORGET_PMOP;
1281 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1282 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1284 PMOP **const array = (PMOP**) mg->mg_ptr;
1285 U32 count = mg->mg_len / sizeof(PMOP**);
1289 if (array[i] == o) {
1290 /* Found it. Move the entry at the end to overwrite it. */
1291 array[i] = array[--count];
1292 mg->mg_len = count * sizeof(PMOP**);
1293 /* Could realloc smaller at this point always, but probably
1294 not worth it. Probably worth free()ing if we're the
1297 Safefree(mg->mg_ptr);
1311 S_find_and_forget_pmops(pTHX_ OP *o)
1315 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1318 switch (o->op_type) {
1323 forget_pmop((PMOP*)o);
1326 if (o->op_flags & OPf_KIDS) {
1327 o = cUNOPo->op_first;
1333 return; /* at top; no parents/siblings to try */
1334 if (OpHAS_SIBLING(o)) {
1335 o = o->op_sibparent; /* process next sibling */
1338 o = o->op_sibparent; /*try parent's next sibling */
1347 Neutralizes an op when it is no longer needed, but is still linked to from
1354 Perl_op_null(pTHX_ OP *o)
1358 PERL_ARGS_ASSERT_OP_NULL;
1360 if (o->op_type == OP_NULL)
1363 o->op_targ = o->op_type;
1364 OpTYPE_set(o, OP_NULL);
1368 Perl_op_refcnt_lock(pTHX)
1369 PERL_TSA_ACQUIRE(PL_op_mutex)
1374 PERL_UNUSED_CONTEXT;
1379 Perl_op_refcnt_unlock(pTHX)
1380 PERL_TSA_RELEASE(PL_op_mutex)
1385 PERL_UNUSED_CONTEXT;
1391 =for apidoc op_sibling_splice
1393 A general function for editing the structure of an existing chain of
1394 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1395 you to delete zero or more sequential nodes, replacing them with zero or
1396 more different nodes. Performs the necessary op_first/op_last
1397 housekeeping on the parent node and op_sibling manipulation on the
1398 children. The last deleted node will be marked as as the last node by
1399 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1401 Note that op_next is not manipulated, and nodes are not freed; that is the
1402 responsibility of the caller. It also won't create a new list op for an
1403 empty list etc; use higher-level functions like op_append_elem() for that.
1405 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1406 the splicing doesn't affect the first or last op in the chain.
1408 C<start> is the node preceding the first node to be spliced. Node(s)
1409 following it will be deleted, and ops will be inserted after it. If it is
1410 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1413 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1414 If -1 or greater than or equal to the number of remaining kids, all
1415 remaining kids are deleted.
1417 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1418 If C<NULL>, no nodes are inserted.
1420 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1425 action before after returns
1426 ------ ----- ----- -------
1429 splice(P, A, 2, X-Y-Z) | | B-C
1433 splice(P, NULL, 1, X-Y) | | A
1437 splice(P, NULL, 3, NULL) | | A-B-C
1441 splice(P, B, 0, X-Y) | | NULL
1445 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1446 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1452 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1456 OP *last_del = NULL;
1457 OP *last_ins = NULL;
1460 first = OpSIBLING(start);
1464 first = cLISTOPx(parent)->op_first;
1466 assert(del_count >= -1);
1468 if (del_count && first) {
1470 while (--del_count && OpHAS_SIBLING(last_del))
1471 last_del = OpSIBLING(last_del);
1472 rest = OpSIBLING(last_del);
1473 OpLASTSIB_set(last_del, NULL);
1480 while (OpHAS_SIBLING(last_ins))
1481 last_ins = OpSIBLING(last_ins);
1482 OpMAYBESIB_set(last_ins, rest, NULL);
1488 OpMAYBESIB_set(start, insert, NULL);
1492 cLISTOPx(parent)->op_first = insert;
1494 parent->op_flags |= OPf_KIDS;
1496 parent->op_flags &= ~OPf_KIDS;
1500 /* update op_last etc */
1507 /* ought to use OP_CLASS(parent) here, but that can't handle
1508 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1510 type = parent->op_type;
1511 if (type == OP_CUSTOM) {
1513 type = XopENTRYCUSTOM(parent, xop_class);
1516 if (type == OP_NULL)
1517 type = parent->op_targ;
1518 type = PL_opargs[type] & OA_CLASS_MASK;
1521 lastop = last_ins ? last_ins : start ? start : NULL;
1522 if ( type == OA_BINOP
1523 || type == OA_LISTOP
1527 cLISTOPx(parent)->op_last = lastop;
1530 OpLASTSIB_set(lastop, parent);
1532 return last_del ? first : NULL;
1535 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1539 =for apidoc op_parent
1541 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1547 Perl_op_parent(OP *o)
1549 PERL_ARGS_ASSERT_OP_PARENT;
1550 while (OpHAS_SIBLING(o))
1552 return o->op_sibparent;
1555 /* replace the sibling following start with a new UNOP, which becomes
1556 * the parent of the original sibling; e.g.
1558 * op_sibling_newUNOP(P, A, unop-args...)
1566 * where U is the new UNOP.
1568 * parent and start args are the same as for op_sibling_splice();
1569 * type and flags args are as newUNOP().
1571 * Returns the new UNOP.
1575 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1579 kid = op_sibling_splice(parent, start, 1, NULL);
1580 newop = newUNOP(type, flags, kid);
1581 op_sibling_splice(parent, start, 0, newop);
1586 /* lowest-level newLOGOP-style function - just allocates and populates
1587 * the struct. Higher-level stuff should be done by S_new_logop() /
1588 * newLOGOP(). This function exists mainly to avoid op_first assignment
1589 * being spread throughout this file.
1593 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1598 NewOp(1101, logop, 1, LOGOP);
1599 OpTYPE_set(logop, type);
1600 logop->op_first = first;
1601 logop->op_other = other;
1603 logop->op_flags = OPf_KIDS;
1604 while (kid && OpHAS_SIBLING(kid))
1605 kid = OpSIBLING(kid);
1607 OpLASTSIB_set(kid, (OP*)logop);
1612 /* Contextualizers */
1615 =for apidoc op_contextualize
1617 Applies a syntactic context to an op tree representing an expression.
1618 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1619 or C<G_VOID> to specify the context to apply. The modified op tree
1626 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1628 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1630 case G_SCALAR: return scalar(o);
1631 case G_ARRAY: return list(o);
1632 case G_VOID: return scalarvoid(o);
1634 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1641 =for apidoc op_linklist
1642 This function is the implementation of the L</LINKLIST> macro. It should
1643 not be called directly.
1650 Perl_op_linklist(pTHX_ OP *o)
1657 PERL_ARGS_ASSERT_OP_LINKLIST;
1660 /* Descend down the tree looking for any unprocessed subtrees to
1663 if (o->op_flags & OPf_KIDS) {
1664 o = cUNOPo->op_first;
1667 o->op_next = o; /* leaf node; link to self initially */
1670 /* if we're at the top level, there either weren't any children
1671 * to process, or we've worked our way back to the top. */
1675 /* o is now processed. Next, process any sibling subtrees */
1677 if (OpHAS_SIBLING(o)) {
1682 /* Done all the subtrees at this level. Go back up a level and
1683 * link the parent in with all its (processed) children.
1686 o = o->op_sibparent;
1687 assert(!o->op_next);
1688 prevp = &(o->op_next);
1689 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1691 *prevp = kid->op_next;
1692 prevp = &(kid->op_next);
1693 kid = OpSIBLING(kid);
1701 S_scalarkids(pTHX_ OP *o)
1703 if (o && o->op_flags & OPf_KIDS) {
1705 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1712 S_scalarboolean(pTHX_ OP *o)
1714 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1716 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1717 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1718 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1719 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1720 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1721 if (ckWARN(WARN_SYNTAX)) {
1722 const line_t oldline = CopLINE(PL_curcop);
1724 if (PL_parser && PL_parser->copline != NOLINE) {
1725 /* This ensures that warnings are reported at the first line
1726 of the conditional, not the last. */
1727 CopLINE_set(PL_curcop, PL_parser->copline);
1729 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1730 CopLINE_set(PL_curcop, oldline);
1737 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1740 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1741 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1743 const char funny = o->op_type == OP_PADAV
1744 || o->op_type == OP_RV2AV ? '@' : '%';
1745 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1747 if (cUNOPo->op_first->op_type != OP_GV
1748 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1750 return varname(gv, funny, 0, NULL, 0, subscript_type);
1753 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1758 S_op_varname(pTHX_ const OP *o)
1760 return S_op_varname_subscript(aTHX_ o, 1);
1764 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1765 { /* or not so pretty :-) */
1766 if (o->op_type == OP_CONST) {
1768 if (SvPOK(*retsv)) {
1770 *retsv = sv_newmortal();
1771 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1772 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1774 else if (!SvOK(*retsv))
1777 else *retpv = "...";
1781 S_scalar_slice_warning(pTHX_ const OP *o)
1784 const bool h = o->op_type == OP_HSLICE
1785 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1791 SV *keysv = NULL; /* just to silence compiler warnings */
1792 const char *key = NULL;
1794 if (!(o->op_private & OPpSLICEWARNING))
1796 if (PL_parser && PL_parser->error_count)
1797 /* This warning can be nonsensical when there is a syntax error. */
1800 kid = cLISTOPo->op_first;
1801 kid = OpSIBLING(kid); /* get past pushmark */
1802 /* weed out false positives: any ops that can return lists */
1803 switch (kid->op_type) {
1829 /* Don't warn if we have a nulled list either. */
1830 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1833 assert(OpSIBLING(kid));
1834 name = S_op_varname(aTHX_ OpSIBLING(kid));
1835 if (!name) /* XS module fiddling with the op tree */
1837 S_op_pretty(aTHX_ kid, &keysv, &key);
1838 assert(SvPOK(name));
1839 sv_chop(name,SvPVX(name)+1);
1841 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1843 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1845 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1846 lbrack, key, rbrack);
1848 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1849 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1850 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1852 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1853 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1858 /* apply scalar context to the o subtree */
1861 Perl_scalar(pTHX_ OP *o)
1866 OP *next_kid = NULL; /* what op (if any) to process next */
1869 /* assumes no premature commitment */
1870 if (!o || (PL_parser && PL_parser->error_count)
1871 || (o->op_flags & OPf_WANT)
1872 || o->op_type == OP_RETURN)
1877 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1879 switch (o->op_type) {
1881 scalar(cBINOPo->op_first);
1882 /* convert what initially looked like a list repeat into a
1883 * scalar repeat, e.g. $s = (1) x $n
1885 if (o->op_private & OPpREPEAT_DOLIST) {
1886 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1887 assert(kid->op_type == OP_PUSHMARK);
1888 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1889 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1890 o->op_private &=~ OPpREPEAT_DOLIST;
1898 /* impose scalar context on everything except the condition */
1899 next_kid = OpSIBLING(cUNOPo->op_first);
1903 if (o->op_flags & OPf_KIDS)
1904 next_kid = cUNOPo->op_first; /* do all kids */
1907 /* the children of these ops are usually a list of statements,
1908 * except the leaves, whose first child is a corresponding enter
1913 kid = cLISTOPo->op_first;
1917 kid = cLISTOPo->op_first;
1919 kid = OpSIBLING(kid);
1922 OP *sib = OpSIBLING(kid);
1923 /* Apply void context to all kids except the last, which
1924 * is scalar (ignoring a trailing ex-nextstate in determining
1925 * if it's the last kid). E.g.
1926 * $scalar = do { void; void; scalar }
1927 * Except that 'when's are always scalar, e.g.
1928 * $scalar = do { given(..) {
1929 * when (..) { scalar }
1930 * when (..) { scalar }
1935 || ( !OpHAS_SIBLING(sib)
1936 && sib->op_type == OP_NULL
1937 && ( sib->op_targ == OP_NEXTSTATE
1938 || sib->op_targ == OP_DBSTATE )
1942 /* tail call optimise calling scalar() on the last kid */
1946 else if (kid->op_type == OP_LEAVEWHEN)
1952 NOT_REACHED; /* NOTREACHED */
1956 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1962 /* Warn about scalar context */
1963 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1964 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1967 const char *key = NULL;
1969 /* This warning can be nonsensical when there is a syntax error. */
1970 if (PL_parser && PL_parser->error_count)
1973 if (!ckWARN(WARN_SYNTAX)) break;
1975 kid = cLISTOPo->op_first;
1976 kid = OpSIBLING(kid); /* get past pushmark */
1977 assert(OpSIBLING(kid));
1978 name = S_op_varname(aTHX_ OpSIBLING(kid));
1979 if (!name) /* XS module fiddling with the op tree */
1981 S_op_pretty(aTHX_ kid, &keysv, &key);
1982 assert(SvPOK(name));
1983 sv_chop(name,SvPVX(name)+1);
1985 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1986 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1987 "%%%" SVf "%c%s%c in scalar context better written "
1988 "as $%" SVf "%c%s%c",
1989 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1990 lbrack, key, rbrack);
1992 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1993 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1994 "%%%" SVf "%c%" SVf "%c in scalar context better "
1995 "written as $%" SVf "%c%" SVf "%c",
1996 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1997 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2001 /* If next_kid is set, someone in the code above wanted us to process
2002 * that kid and all its remaining siblings. Otherwise, work our way
2003 * back up the tree */
2007 return top_op; /* at top; no parents/siblings to try */
2008 if (OpHAS_SIBLING(o))
2009 next_kid = o->op_sibparent;
2011 o = o->op_sibparent; /*try parent's next sibling */
2012 switch (o->op_type) {
2018 /* should really restore PL_curcop to its old value, but
2019 * setting it to PL_compiling is better than do nothing */
2020 PL_curcop = &PL_compiling;
2029 /* apply void context to the optree arg */
2032 Perl_scalarvoid(pTHX_ OP *arg)
2039 PERL_ARGS_ASSERT_SCALARVOID;
2043 SV *useless_sv = NULL;
2044 const char* useless = NULL;
2045 OP * next_kid = NULL;
2047 if (o->op_type == OP_NEXTSTATE
2048 || o->op_type == OP_DBSTATE
2049 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2050 || o->op_targ == OP_DBSTATE)))
2051 PL_curcop = (COP*)o; /* for warning below */
2053 /* assumes no premature commitment */
2054 want = o->op_flags & OPf_WANT;
2055 if ((want && want != OPf_WANT_SCALAR)
2056 || (PL_parser && PL_parser->error_count)
2057 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2062 if ((o->op_private & OPpTARGET_MY)
2063 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2065 /* newASSIGNOP has already applied scalar context, which we
2066 leave, as if this op is inside SASSIGN. */
2070 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2072 switch (o->op_type) {
2074 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2078 if (o->op_flags & OPf_STACKED)
2080 if (o->op_type == OP_REPEAT)
2081 scalar(cBINOPo->op_first);
2084 if ((o->op_flags & OPf_STACKED) &&
2085 !(o->op_private & OPpCONCAT_NESTED))
2089 if (o->op_private == 4)
2124 case OP_GETSOCKNAME:
2125 case OP_GETPEERNAME:
2130 case OP_GETPRIORITY:
2155 useless = OP_DESC(o);
2165 case OP_AELEMFAST_LEX:
2169 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2170 /* Otherwise it's "Useless use of grep iterator" */
2171 useless = OP_DESC(o);
2175 if (!(o->op_private & OPpSPLIT_ASSIGN))
2176 useless = OP_DESC(o);
2180 kid = cUNOPo->op_first;
2181 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2182 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2185 useless = "negative pattern binding (!~)";
2189 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2190 useless = "non-destructive substitution (s///r)";
2194 useless = "non-destructive transliteration (tr///r)";
2201 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2202 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2203 useless = "a variable";
2208 if (cSVOPo->op_private & OPpCONST_STRICT)
2209 no_bareword_allowed(o);
2211 if (ckWARN(WARN_VOID)) {
2213 /* don't warn on optimised away booleans, eg
2214 * use constant Foo, 5; Foo || print; */
2215 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2217 /* the constants 0 and 1 are permitted as they are
2218 conventionally used as dummies in constructs like
2219 1 while some_condition_with_side_effects; */
2220 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2222 else if (SvPOK(sv)) {
2223 SV * const dsv = newSVpvs("");
2225 = Perl_newSVpvf(aTHX_
2227 pv_pretty(dsv, SvPVX_const(sv),
2228 SvCUR(sv), 32, NULL, NULL,
2230 | PERL_PV_ESCAPE_NOCLEAR
2231 | PERL_PV_ESCAPE_UNI_DETECT));
2232 SvREFCNT_dec_NN(dsv);
2234 else if (SvOK(sv)) {
2235 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2238 useless = "a constant (undef)";
2241 op_null(o); /* don't execute or even remember it */
2245 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2249 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2253 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2257 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2262 UNOP *refgen, *rv2cv;
2265 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2268 rv2gv = ((BINOP *)o)->op_last;
2269 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2272 refgen = (UNOP *)((BINOP *)o)->op_first;
2274 if (!refgen || (refgen->op_type != OP_REFGEN
2275 && refgen->op_type != OP_SREFGEN))
2278 exlist = (LISTOP *)refgen->op_first;
2279 if (!exlist || exlist->op_type != OP_NULL
2280 || exlist->op_targ != OP_LIST)
2283 if (exlist->op_first->op_type != OP_PUSHMARK
2284 && exlist->op_first != exlist->op_last)
2287 rv2cv = (UNOP*)exlist->op_last;
2289 if (rv2cv->op_type != OP_RV2CV)
2292 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2293 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2294 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2296 o->op_private |= OPpASSIGN_CV_TO_GV;
2297 rv2gv->op_private |= OPpDONT_INIT_GV;
2298 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2310 kid = cLOGOPo->op_first;
2311 if (kid->op_type == OP_NOT
2312 && (kid->op_flags & OPf_KIDS)) {
2313 if (o->op_type == OP_AND) {
2314 OpTYPE_set(o, OP_OR);
2316 OpTYPE_set(o, OP_AND);
2326 next_kid = OpSIBLING(cUNOPo->op_first);
2330 if (o->op_flags & OPf_STACKED)
2337 if (!(o->op_flags & OPf_KIDS))
2348 next_kid = cLISTOPo->op_first;
2351 /* If the first kid after pushmark is something that the padrange
2352 optimisation would reject, then null the list and the pushmark.
2354 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2355 && ( !(kid = OpSIBLING(kid))
2356 || ( kid->op_type != OP_PADSV
2357 && kid->op_type != OP_PADAV
2358 && kid->op_type != OP_PADHV)
2359 || kid->op_private & ~OPpLVAL_INTRO
2360 || !(kid = OpSIBLING(kid))
2361 || ( kid->op_type != OP_PADSV
2362 && kid->op_type != OP_PADAV
2363 && kid->op_type != OP_PADHV)
2364 || kid->op_private & ~OPpLVAL_INTRO)
2366 op_null(cUNOPo->op_first); /* NULL the pushmark */
2367 op_null(o); /* NULL the list */
2379 /* mortalise it, in case warnings are fatal. */
2380 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2381 "Useless use of %" SVf " in void context",
2382 SVfARG(sv_2mortal(useless_sv)));
2385 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2386 "Useless use of %s in void context",
2391 /* if a kid hasn't been nominated to process, continue with the
2392 * next sibling, or if no siblings left, go back to the parent's
2393 * siblings and so on
2397 return arg; /* at top; no parents/siblings to try */
2398 if (OpHAS_SIBLING(o))
2399 next_kid = o->op_sibparent;
2401 o = o->op_sibparent; /*try parent's next sibling */
2411 S_listkids(pTHX_ OP *o)
2413 if (o && o->op_flags & OPf_KIDS) {
2415 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2422 /* apply list context to the o subtree */
2425 Perl_list(pTHX_ OP *o)
2430 OP *next_kid = NULL; /* what op (if any) to process next */
2434 /* assumes no premature commitment */
2435 if (!o || (o->op_flags & OPf_WANT)
2436 || (PL_parser && PL_parser->error_count)
2437 || o->op_type == OP_RETURN)
2442 if ((o->op_private & OPpTARGET_MY)
2443 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2445 goto do_next; /* As if inside SASSIGN */
2448 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2450 switch (o->op_type) {
2452 if (o->op_private & OPpREPEAT_DOLIST
2453 && !(o->op_flags & OPf_STACKED))
2455 list(cBINOPo->op_first);
2456 kid = cBINOPo->op_last;
2457 /* optimise away (.....) x 1 */
2458 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2459 && SvIVX(kSVOP_sv) == 1)
2461 op_null(o); /* repeat */
2462 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2464 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2472 /* impose list context on everything except the condition */
2473 next_kid = OpSIBLING(cUNOPo->op_first);
2477 if (!(o->op_flags & OPf_KIDS))
2479 /* possibly flatten 1..10 into a constant array */
2480 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2481 list(cBINOPo->op_first);
2482 gen_constant_list(o);
2485 next_kid = cUNOPo->op_first; /* do all kids */
2489 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2490 op_null(cUNOPo->op_first); /* NULL the pushmark */
2491 op_null(o); /* NULL the list */
2493 if (o->op_flags & OPf_KIDS)
2494 next_kid = cUNOPo->op_first; /* do all kids */
2497 /* the children of these ops are usually a list of statements,
2498 * except the leaves, whose first child is a corresponding enter
2502 kid = cLISTOPo->op_first;
2506 kid = cLISTOPo->op_first;
2508 kid = OpSIBLING(kid);
2511 OP *sib = OpSIBLING(kid);
2512 /* Apply void context to all kids except the last, which
2514 * @a = do { void; void; list }
2515 * Except that 'when's are always list context, e.g.
2516 * @a = do { given(..) {
2517 * when (..) { list }
2518 * when (..) { list }
2523 /* tail call optimise calling list() on the last kid */
2527 else if (kid->op_type == OP_LEAVEWHEN)
2533 NOT_REACHED; /* NOTREACHED */
2538 /* If next_kid is set, someone in the code above wanted us to process
2539 * that kid and all its remaining siblings. Otherwise, work our way
2540 * back up the tree */
2544 return top_op; /* at top; no parents/siblings to try */
2545 if (OpHAS_SIBLING(o))
2546 next_kid = o->op_sibparent;
2548 o = o->op_sibparent; /*try parent's next sibling */
2549 switch (o->op_type) {
2555 /* should really restore PL_curcop to its old value, but
2556 * setting it to PL_compiling is better than do nothing */
2557 PL_curcop = &PL_compiling;
2569 S_scalarseq(pTHX_ OP *o)
2572 const OPCODE type = o->op_type;
2574 if (type == OP_LINESEQ || type == OP_SCOPE ||
2575 type == OP_LEAVE || type == OP_LEAVETRY)
2578 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2579 if ((sib = OpSIBLING(kid))
2580 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2581 || ( sib->op_targ != OP_NEXTSTATE
2582 && sib->op_targ != OP_DBSTATE )))
2587 PL_curcop = &PL_compiling;
2589 o->op_flags &= ~OPf_PARENS;
2590 if (PL_hints & HINT_BLOCK_SCOPE)
2591 o->op_flags |= OPf_PARENS;
2594 o = newOP(OP_STUB, 0);
2599 S_modkids(pTHX_ OP *o, I32 type)
2601 if (o && o->op_flags & OPf_KIDS) {
2603 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2604 op_lvalue(kid, type);
2610 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2611 * const fields. Also, convert CONST keys to HEK-in-SVs.
2612 * rop is the op that retrieves the hash;
2613 * key_op is the first key
2614 * real if false, only check (and possibly croak); don't update op
2618 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2624 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2626 if (rop->op_first->op_type == OP_PADSV)
2627 /* @$hash{qw(keys here)} */
2628 rop = (UNOP*)rop->op_first;
2630 /* @{$hash}{qw(keys here)} */
2631 if (rop->op_first->op_type == OP_SCOPE
2632 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2634 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2641 lexname = NULL; /* just to silence compiler warnings */
2642 fields = NULL; /* just to silence compiler warnings */
2646 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2647 SvPAD_TYPED(lexname))
2648 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2649 && isGV(*fields) && GvHV(*fields);
2651 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2653 if (key_op->op_type != OP_CONST)
2655 svp = cSVOPx_svp(key_op);
2657 /* make sure it's not a bareword under strict subs */
2658 if (key_op->op_private & OPpCONST_BARE &&
2659 key_op->op_private & OPpCONST_STRICT)
2661 no_bareword_allowed((OP*)key_op);
2664 /* Make the CONST have a shared SV */
2665 if ( !SvIsCOW_shared_hash(sv = *svp)
2666 && SvTYPE(sv) < SVt_PVMG
2672 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2673 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2674 SvREFCNT_dec_NN(sv);
2679 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2681 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2682 "in variable %" PNf " of type %" HEKf,
2683 SVfARG(*svp), PNfARG(lexname),
2684 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2689 /* info returned by S_sprintf_is_multiconcatable() */
2691 struct sprintf_ismc_info {
2692 SSize_t nargs; /* num of args to sprintf (not including the format) */
2693 char *start; /* start of raw format string */
2694 char *end; /* bytes after end of raw format string */
2695 STRLEN total_len; /* total length (in bytes) of format string, not
2696 including '%s' and half of '%%' */
2697 STRLEN variant; /* number of bytes by which total_len_p would grow
2698 if upgraded to utf8 */
2699 bool utf8; /* whether the format is utf8 */
2703 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2704 * i.e. its format argument is a const string with only '%s' and '%%'
2705 * formats, and the number of args is known, e.g.
2706 * sprintf "a=%s f=%s", $a[0], scalar(f());
2708 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2710 * If successful, the sprintf_ismc_info struct pointed to by info will be
2715 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2717 OP *pm, *constop, *kid;
2720 SSize_t nargs, nformats;
2721 STRLEN cur, total_len, variant;
2724 /* if sprintf's behaviour changes, die here so that someone
2725 * can decide whether to enhance this function or skip optimising
2726 * under those new circumstances */
2727 assert(!(o->op_flags & OPf_STACKED));
2728 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2729 assert(!(o->op_private & ~OPpARG4_MASK));
2731 pm = cUNOPo->op_first;
2732 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2734 constop = OpSIBLING(pm);
2735 if (!constop || constop->op_type != OP_CONST)
2737 sv = cSVOPx_sv(constop);
2738 if (SvMAGICAL(sv) || !SvPOK(sv))
2744 /* Scan format for %% and %s and work out how many %s there are.
2745 * Abandon if other format types are found.
2752 for (p = s; p < e; p++) {
2755 if (!UTF8_IS_INVARIANT(*p))
2761 return FALSE; /* lone % at end gives "Invalid conversion" */
2770 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2773 utf8 = cBOOL(SvUTF8(sv));
2777 /* scan args; they must all be in scalar cxt */
2780 kid = OpSIBLING(constop);
2783 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2786 kid = OpSIBLING(kid);
2789 if (nargs != nformats)
2790 return FALSE; /* e.g. sprintf("%s%s", $a); */
2793 info->nargs = nargs;
2796 info->total_len = total_len;
2797 info->variant = variant;
2805 /* S_maybe_multiconcat():
2807 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2808 * convert it (and its children) into an OP_MULTICONCAT. See the code
2809 * comments just before pp_multiconcat() for the full details of what
2810 * OP_MULTICONCAT supports.
2812 * Basically we're looking for an optree with a chain of OP_CONCATS down
2813 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2814 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2822 * STRINGIFY -- PADSV[$x]
2825 * ex-PUSHMARK -- CONCAT/S
2827 * CONCAT/S -- PADSV[$d]
2829 * CONCAT -- CONST["-"]
2831 * PADSV[$a] -- PADSV[$b]
2833 * Note that at this stage the OP_SASSIGN may have already been optimised
2834 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2838 S_maybe_multiconcat(pTHX_ OP *o)
2841 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2842 OP *topop; /* the top-most op in the concat tree (often equals o,
2843 unless there are assign/stringify ops above it */
2844 OP *parentop; /* the parent op of topop (or itself if no parent) */
2845 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2846 OP *targetop; /* the op corresponding to target=... or target.=... */
2847 OP *stringop; /* the OP_STRINGIFY op, if any */
2848 OP *nextop; /* used for recreating the op_next chain without consts */
2849 OP *kid; /* general-purpose op pointer */
2851 UNOP_AUX_item *lenp;
2852 char *const_str, *p;
2853 struct sprintf_ismc_info sprintf_info;
2855 /* store info about each arg in args[];
2856 * toparg is the highest used slot; argp is a general
2857 * pointer to args[] slots */
2859 void *p; /* initially points to const sv (or null for op);
2860 later, set to SvPV(constsv), with ... */
2861 STRLEN len; /* ... len set to SvPV(..., len) */
2862 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2866 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2869 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2870 the last-processed arg will the LHS of one,
2871 as args are processed in reverse order */
2872 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2873 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2874 U8 flags = 0; /* what will become the op_flags and ... */
2875 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2876 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2877 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2878 bool prev_was_const = FALSE; /* previous arg was a const */
2880 /* -----------------------------------------------------------------
2883 * Examine the optree non-destructively to determine whether it's
2884 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2885 * information about the optree in args[].
2895 assert( o->op_type == OP_SASSIGN
2896 || o->op_type == OP_CONCAT
2897 || o->op_type == OP_SPRINTF
2898 || o->op_type == OP_STRINGIFY);
2900 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2902 /* first see if, at the top of the tree, there is an assign,
2903 * append and/or stringify */
2905 if (topop->op_type == OP_SASSIGN) {
2907 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2909 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2911 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2914 topop = cBINOPo->op_first;
2915 targetop = OpSIBLING(topop);
2916 if (!targetop) /* probably some sort of syntax error */
2919 else if ( topop->op_type == OP_CONCAT
2920 && (topop->op_flags & OPf_STACKED)
2921 && (!(topop->op_private & OPpCONCAT_NESTED))
2926 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2927 * decide what to do about it */
2928 assert(!(o->op_private & OPpTARGET_MY));
2930 /* barf on unknown flags */
2931 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2932 private_flags |= OPpMULTICONCAT_APPEND;
2933 targetop = cBINOPo->op_first;
2935 topop = OpSIBLING(targetop);
2937 /* $x .= <FOO> gets optimised to rcatline instead */
2938 if (topop->op_type == OP_READLINE)
2943 /* Can targetop (the LHS) if it's a padsv, be be optimised
2944 * away and use OPpTARGET_MY instead?
2946 if ( (targetop->op_type == OP_PADSV)
2947 && !(targetop->op_private & OPpDEREF)
2948 && !(targetop->op_private & OPpPAD_STATE)
2949 /* we don't support 'my $x .= ...' */
2950 && ( o->op_type == OP_SASSIGN
2951 || !(targetop->op_private & OPpLVAL_INTRO))
2956 if (topop->op_type == OP_STRINGIFY) {
2957 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2961 /* barf on unknown flags */
2962 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2964 if ((topop->op_private & OPpTARGET_MY)) {
2965 if (o->op_type == OP_SASSIGN)
2966 return; /* can't have two assigns */
2970 private_flags |= OPpMULTICONCAT_STRINGIFY;
2972 topop = cBINOPx(topop)->op_first;
2973 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2974 topop = OpSIBLING(topop);
2977 if (topop->op_type == OP_SPRINTF) {
2978 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2980 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2981 nargs = sprintf_info.nargs;
2982 total_len = sprintf_info.total_len;
2983 variant = sprintf_info.variant;
2984 utf8 = sprintf_info.utf8;
2986 private_flags |= OPpMULTICONCAT_FAKE;
2988 /* we have an sprintf op rather than a concat optree.
2989 * Skip most of the code below which is associated with
2990 * processing that optree. We also skip phase 2, determining
2991 * whether its cost effective to optimise, since for sprintf,
2992 * multiconcat is *always* faster */
2995 /* note that even if the sprintf itself isn't multiconcatable,
2996 * the expression as a whole may be, e.g. in
2997 * $x .= sprintf("%d",...)
2998 * the sprintf op will be left as-is, but the concat/S op may
2999 * be upgraded to multiconcat
3002 else if (topop->op_type == OP_CONCAT) {
3003 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3006 if ((topop->op_private & OPpTARGET_MY)) {
3007 if (o->op_type == OP_SASSIGN || targmyop)
3008 return; /* can't have two assigns */
3013 /* Is it safe to convert a sassign/stringify/concat op into
3015 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3016 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3017 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3018 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3019 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3020 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3021 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3022 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3024 /* Now scan the down the tree looking for a series of
3025 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3026 * stacked). For example this tree:
3031 * CONCAT/STACKED -- EXPR5
3033 * CONCAT/STACKED -- EXPR4
3039 * corresponds to an expression like
3041 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3043 * Record info about each EXPR in args[]: in particular, whether it is
3044 * a stringifiable OP_CONST and if so what the const sv is.
3046 * The reason why the last concat can't be STACKED is the difference
3049 * ((($a .= $a) .= $a) .= $a) .= $a
3052 * $a . $a . $a . $a . $a
3054 * The main difference between the optrees for those two constructs
3055 * is the presence of the last STACKED. As well as modifying $a,
3056 * the former sees the changed $a between each concat, so if $s is
3057 * initially 'a', the first returns 'a' x 16, while the latter returns
3058 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3068 if ( kid->op_type == OP_CONCAT
3072 k1 = cUNOPx(kid)->op_first;
3074 /* shouldn't happen except maybe after compile err? */
3078 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3079 if (kid->op_private & OPpTARGET_MY)
3082 stacked_last = (kid->op_flags & OPf_STACKED);
3094 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3095 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3097 /* At least two spare slots are needed to decompose both
3098 * concat args. If there are no slots left, continue to
3099 * examine the rest of the optree, but don't push new values
3100 * on args[]. If the optree as a whole is legal for conversion
3101 * (in particular that the last concat isn't STACKED), then
3102 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3103 * can be converted into an OP_MULTICONCAT now, with the first
3104 * child of that op being the remainder of the optree -
3105 * which may itself later be converted to a multiconcat op
3109 /* the last arg is the rest of the optree */
3114 else if ( argop->op_type == OP_CONST
3115 && ((sv = cSVOPx_sv(argop)))
3116 /* defer stringification until runtime of 'constant'
3117 * things that might stringify variantly, e.g. the radix
3118 * point of NVs, or overloaded RVs */
3119 && (SvPOK(sv) || SvIOK(sv))
3120 && (!SvGMAGICAL(sv))
3122 if (argop->op_private & OPpCONST_STRICT)
3123 no_bareword_allowed(argop);
3125 utf8 |= cBOOL(SvUTF8(sv));
3128 /* this const may be demoted back to a plain arg later;
3129 * make sure we have enough arg slots left */
3131 prev_was_const = !prev_was_const;
3136 prev_was_const = FALSE;
3146 return; /* we don't support ((A.=B).=C)...) */
3148 /* look for two adjacent consts and don't fold them together:
3151 * $o->concat("a")->concat("b")
3154 * (but $o .= "a" . "b" should still fold)
3157 bool seen_nonconst = FALSE;
3158 for (argp = toparg; argp >= args; argp--) {
3159 if (argp->p == NULL) {
3160 seen_nonconst = TRUE;
3166 /* both previous and current arg were constants;
3167 * leave the current OP_CONST as-is */
3175 /* -----------------------------------------------------------------
3178 * At this point we have determined that the optree *can* be converted
3179 * into a multiconcat. Having gathered all the evidence, we now decide
3180 * whether it *should*.
3184 /* we need at least one concat action, e.g.:
3190 * otherwise we could be doing something like $x = "foo", which
3191 * if treated as as a concat, would fail to COW.
3193 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3196 /* Benchmarking seems to indicate that we gain if:
3197 * * we optimise at least two actions into a single multiconcat
3198 * (e.g concat+concat, sassign+concat);
3199 * * or if we can eliminate at least 1 OP_CONST;
3200 * * or if we can eliminate a padsv via OPpTARGET_MY
3204 /* eliminated at least one OP_CONST */
3206 /* eliminated an OP_SASSIGN */
3207 || o->op_type == OP_SASSIGN
3208 /* eliminated an OP_PADSV */
3209 || (!targmyop && is_targable)
3211 /* definitely a net gain to optimise */
3214 /* ... if not, what else? */
3216 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3217 * multiconcat is faster (due to not creating a temporary copy of
3218 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3224 && topop->op_type == OP_CONCAT
3226 PADOFFSET t = targmyop->op_targ;
3227 OP *k1 = cBINOPx(topop)->op_first;
3228 OP *k2 = cBINOPx(topop)->op_last;
3229 if ( k2->op_type == OP_PADSV
3231 && ( k1->op_type != OP_PADSV
3232 || k1->op_targ != t)
3237 /* need at least two concats */
3238 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3243 /* -----------------------------------------------------------------
3246 * At this point the optree has been verified as ok to be optimised
3247 * into an OP_MULTICONCAT. Now start changing things.
3252 /* stringify all const args and determine utf8ness */
3255 for (argp = args; argp <= toparg; argp++) {
3256 SV *sv = (SV*)argp->p;
3258 continue; /* not a const op */
3259 if (utf8 && !SvUTF8(sv))
3260 sv_utf8_upgrade_nomg(sv);
3261 argp->p = SvPV_nomg(sv, argp->len);
3262 total_len += argp->len;
3264 /* see if any strings would grow if converted to utf8 */
3266 variant += variant_under_utf8_count((U8 *) argp->p,
3267 (U8 *) argp->p + argp->len);
3271 /* create and populate aux struct */
3275 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3276 sizeof(UNOP_AUX_item)
3278 PERL_MULTICONCAT_HEADER_SIZE
3279 + ((nargs + 1) * (variant ? 2 : 1))
3282 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3284 /* Extract all the non-const expressions from the concat tree then
3285 * dispose of the old tree, e.g. convert the tree from this:
3289 * STRINGIFY -- TARGET
3291 * ex-PUSHMARK -- CONCAT
3306 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3308 * except that if EXPRi is an OP_CONST, it's discarded.
3310 * During the conversion process, EXPR ops are stripped from the tree
3311 * and unshifted onto o. Finally, any of o's remaining original
3312 * childen are discarded and o is converted into an OP_MULTICONCAT.
3314 * In this middle of this, o may contain both: unshifted args on the
3315 * left, and some remaining original args on the right. lastkidop
3316 * is set to point to the right-most unshifted arg to delineate
3317 * between the two sets.
3322 /* create a copy of the format with the %'s removed, and record
3323 * the sizes of the const string segments in the aux struct */
3325 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3327 p = sprintf_info.start;
3330 for (; p < sprintf_info.end; p++) {
3334 (lenp++)->ssize = q - oldq;
3341 lenp->ssize = q - oldq;
3342 assert((STRLEN)(q - const_str) == total_len);
3344 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3345 * may or may not be topop) The pushmark and const ops need to be
3346 * kept in case they're an op_next entry point.
3348 lastkidop = cLISTOPx(topop)->op_last;
3349 kid = cUNOPx(topop)->op_first; /* pushmark */
3351 op_null(OpSIBLING(kid)); /* const */
3353 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3354 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3355 lastkidop->op_next = o;
3360 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3364 /* Concatenate all const strings into const_str.
3365 * Note that args[] contains the RHS args in reverse order, so
3366 * we scan args[] from top to bottom to get constant strings
3369 for (argp = toparg; argp >= args; argp--) {
3371 /* not a const op */
3372 (++lenp)->ssize = -1;
3374 STRLEN l = argp->len;
3375 Copy(argp->p, p, l, char);
3377 if (lenp->ssize == -1)
3388 for (argp = args; argp <= toparg; argp++) {
3389 /* only keep non-const args, except keep the first-in-next-chain
3390 * arg no matter what it is (but nulled if OP_CONST), because it
3391 * may be the entry point to this subtree from the previous
3394 bool last = (argp == toparg);
3397 /* set prev to the sibling *before* the arg to be cut out,
3398 * e.g. when cutting EXPR:
3403 * prev= CONCAT -- EXPR
3406 if (argp == args && kid->op_type != OP_CONCAT) {
3407 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3408 * so the expression to be cut isn't kid->op_last but
3411 /* find the op before kid */
3413 o2 = cUNOPx(parentop)->op_first;
3414 while (o2 && o2 != kid) {
3422 else if (kid == o && lastkidop)
3423 prev = last ? lastkidop : OpSIBLING(lastkidop);
3425 prev = last ? NULL : cUNOPx(kid)->op_first;
3427 if (!argp->p || last) {
3429 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3430 /* and unshift to front of o */
3431 op_sibling_splice(o, NULL, 0, aop);
3432 /* record the right-most op added to o: later we will
3433 * free anything to the right of it */
3436 aop->op_next = nextop;
3439 /* null the const at start of op_next chain */
3443 nextop = prev->op_next;
3446 /* the last two arguments are both attached to the same concat op */
3447 if (argp < toparg - 1)
3452 /* Populate the aux struct */
3454 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3455 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3456 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3457 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3458 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3460 /* if variant > 0, calculate a variant const string and lengths where
3461 * the utf8 version of the string will take 'variant' more bytes than
3465 char *p = const_str;
3466 STRLEN ulen = total_len + variant;
3467 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3468 UNOP_AUX_item *ulens = lens + (nargs + 1);
3469 char *up = (char*)PerlMemShared_malloc(ulen);
3472 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3473 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3475 for (n = 0; n < (nargs + 1); n++) {
3477 char * orig_up = up;
3478 for (i = (lens++)->ssize; i > 0; i--) {
3480 append_utf8_from_native_byte(c, (U8**)&up);
3482 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3487 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3488 * that op's first child - an ex-PUSHMARK - because the op_next of
3489 * the previous op may point to it (i.e. it's the entry point for
3494 ? op_sibling_splice(o, lastkidop, 1, NULL)
3495 : op_sibling_splice(stringop, NULL, 1, NULL);
3496 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3497 op_sibling_splice(o, NULL, 0, pmop);
3504 * target .= A.B.C...
3510 if (o->op_type == OP_SASSIGN) {
3511 /* Move the target subtree from being the last of o's children
3512 * to being the last of o's preserved children.
3513 * Note the difference between 'target = ...' and 'target .= ...':
3514 * for the former, target is executed last; for the latter,
3517 kid = OpSIBLING(lastkidop);
3518 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3519 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3520 lastkidop->op_next = kid->op_next;
3521 lastkidop = targetop;
3524 /* Move the target subtree from being the first of o's
3525 * original children to being the first of *all* o's children.
3528 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3529 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3532 /* if the RHS of .= doesn't contain a concat (e.g.
3533 * $x .= "foo"), it gets missed by the "strip ops from the
3534 * tree and add to o" loop earlier */
3535 assert(topop->op_type != OP_CONCAT);
3537 /* in e.g. $x .= "$y", move the $y expression
3538 * from being a child of OP_STRINGIFY to being the
3539 * second child of the OP_CONCAT
3541 assert(cUNOPx(stringop)->op_first == topop);
3542 op_sibling_splice(stringop, NULL, 1, NULL);
3543 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3545 assert(topop == OpSIBLING(cBINOPo->op_first));
3554 * my $lex = A.B.C...
3557 * The original padsv op is kept but nulled in case it's the
3558 * entry point for the optree (which it will be for
3561 private_flags |= OPpTARGET_MY;
3562 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3563 o->op_targ = targetop->op_targ;
3564 targetop->op_targ = 0;
3568 flags |= OPf_STACKED;
3570 else if (targmyop) {
3571 private_flags |= OPpTARGET_MY;
3572 if (o != targmyop) {
3573 o->op_targ = targmyop->op_targ;
3574 targmyop->op_targ = 0;
3578 /* detach the emaciated husk of the sprintf/concat optree and free it */
3580 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3586 /* and convert o into a multiconcat */
3588 o->op_flags = (flags|OPf_KIDS|stacked_last
3589 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3590 o->op_private = private_flags;
3591 o->op_type = OP_MULTICONCAT;
3592 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3593 cUNOP_AUXo->op_aux = aux;
3597 /* do all the final processing on an optree (e.g. running the peephole
3598 * optimiser on it), then attach it to cv (if cv is non-null)
3602 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3606 /* XXX for some reason, evals, require and main optrees are
3607 * never attached to their CV; instead they just hang off
3608 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3609 * and get manually freed when appropriate */
3611 startp = &CvSTART(cv);
3613 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3616 optree->op_private |= OPpREFCOUNTED;
3617 OpREFCNT_set(optree, 1);
3618 optimize_optree(optree);
3620 finalize_optree(optree);
3621 S_prune_chain_head(startp);
3624 /* now that optimizer has done its work, adjust pad values */
3625 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3626 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3632 =for apidoc optimize_optree
3634 This function applies some optimisations to the optree in top-down order.
3635 It is called before the peephole optimizer, which processes ops in
3636 execution order. Note that finalize_optree() also does a top-down scan,
3637 but is called *after* the peephole optimizer.
3643 Perl_optimize_optree(pTHX_ OP* o)
3645 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3648 SAVEVPTR(PL_curcop);
3656 /* helper for optimize_optree() which optimises one op then recurses
3657 * to optimise any children.
3661 S_optimize_op(pTHX_ OP* o)
3665 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3668 OP * next_kid = NULL;
3670 assert(o->op_type != OP_FREED);
3672 switch (o->op_type) {
3675 PL_curcop = ((COP*)o); /* for warnings */
3683 S_maybe_multiconcat(aTHX_ o);
3687 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3688 /* we can't assume that op_pmreplroot->op_sibparent == o
3689 * and that it is thus possible to walk back up the tree
3690 * past op_pmreplroot. So, although we try to avoid
3691 * recursing through op trees, do it here. After all,
3692 * there are unlikely to be many nested s///e's within
3693 * the replacement part of a s///e.
3695 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3703 if (o->op_flags & OPf_KIDS)
3704 next_kid = cUNOPo->op_first;
3706 /* if a kid hasn't been nominated to process, continue with the
3707 * next sibling, or if no siblings left, go back to the parent's
3708 * siblings and so on
3712 return; /* at top; no parents/siblings to try */
3713 if (OpHAS_SIBLING(o))
3714 next_kid = o->op_sibparent;
3716 o = o->op_sibparent; /*try parent's next sibling */
3719 /* this label not yet used. Goto here if any code above sets
3729 =for apidoc finalize_optree
3731 This function finalizes the optree. Should be called directly after
3732 the complete optree is built. It does some additional
3733 checking which can't be done in the normal C<ck_>xxx functions and makes
3734 the tree thread-safe.
3739 Perl_finalize_optree(pTHX_ OP* o)
3741 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3744 SAVEVPTR(PL_curcop);
3752 /* Relocate sv to the pad for thread safety.
3753 * Despite being a "constant", the SV is written to,
3754 * for reference counts, sv_upgrade() etc. */
3755 PERL_STATIC_INLINE void
3756 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3759 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3761 ix = pad_alloc(OP_CONST, SVf_READONLY);
3762 SvREFCNT_dec(PAD_SVl(ix));
3763 PAD_SETSV(ix, *svp);
3764 /* XXX I don't know how this isn't readonly already. */
3765 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3772 =for apidoc traverse_op_tree
3774 Return the next op in a depth-first traversal of the op tree,
3775 returning NULL when the traversal is complete.
3777 The initial call must supply the root of the tree as both top and o.
3779 For now it's static, but it may be exposed to the API in the future.
3785 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3788 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3790 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3791 return cUNOPo->op_first;
3793 else if ((sib = OpSIBLING(o))) {
3797 OP *parent = o->op_sibparent;
3798 assert(!(o->op_moresib));
3799 while (parent && parent != top) {
3800 OP *sib = OpSIBLING(parent);
3803 parent = parent->op_sibparent;
3811 S_finalize_op(pTHX_ OP* o)
3814 PERL_ARGS_ASSERT_FINALIZE_OP;
3817 assert(o->op_type != OP_FREED);
3819 switch (o->op_type) {
3822 PL_curcop = ((COP*)o); /* for warnings */
3825 if (OpHAS_SIBLING(o)) {
3826 OP *sib = OpSIBLING(o);
3827 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3828 && ckWARN(WARN_EXEC)
3829 && OpHAS_SIBLING(sib))
3831 const OPCODE type = OpSIBLING(sib)->op_type;
3832 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3833 const line_t oldline = CopLINE(PL_curcop);
3834 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3835 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3836 "Statement unlikely to be reached");
3837 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3838 "\t(Maybe you meant system() when you said exec()?)\n");
3839 CopLINE_set(PL_curcop, oldline);
3846 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3847 GV * const gv = cGVOPo_gv;
3848 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3849 /* XXX could check prototype here instead of just carping */
3850 SV * const sv = sv_newmortal();
3851 gv_efullname3(sv, gv, NULL);
3852 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3853 "%" SVf "() called too early to check prototype",
3860 if (cSVOPo->op_private & OPpCONST_STRICT)
3861 no_bareword_allowed(o);
3865 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3870 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3871 case OP_METHOD_NAMED:
3872 case OP_METHOD_SUPER:
3873 case OP_METHOD_REDIR:
3874 case OP_METHOD_REDIR_SUPER:
3875 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3884 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3887 rop = (UNOP*)((BINOP*)o)->op_first;
3892 S_scalar_slice_warning(aTHX_ o);
3896 kid = OpSIBLING(cLISTOPo->op_first);
3897 if (/* I bet there's always a pushmark... */
3898 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3899 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3904 key_op = (SVOP*)(kid->op_type == OP_CONST
3906 : OpSIBLING(kLISTOP->op_first));
3908 rop = (UNOP*)((LISTOP*)o)->op_last;
3911 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3913 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3917 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3921 S_scalar_slice_warning(aTHX_ o);
3925 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3926 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3934 if (o->op_flags & OPf_KIDS) {
3937 /* check that op_last points to the last sibling, and that
3938 * the last op_sibling/op_sibparent field points back to the
3939 * parent, and that the only ops with KIDS are those which are
3940 * entitled to them */
3941 U32 type = o->op_type;
3945 if (type == OP_NULL) {
3947 /* ck_glob creates a null UNOP with ex-type GLOB
3948 * (which is a list op. So pretend it wasn't a listop */
3949 if (type == OP_GLOB)
3952 family = PL_opargs[type] & OA_CLASS_MASK;
3954 has_last = ( family == OA_BINOP
3955 || family == OA_LISTOP
3956 || family == OA_PMOP
3957 || family == OA_LOOP
3959 assert( has_last /* has op_first and op_last, or ...
3960 ... has (or may have) op_first: */
3961 || family == OA_UNOP
3962 || family == OA_UNOP_AUX
3963 || family == OA_LOGOP
3964 || family == OA_BASEOP_OR_UNOP
3965 || family == OA_FILESTATOP
3966 || family == OA_LOOPEXOP
3967 || family == OA_METHOP
3968 || type == OP_CUSTOM
3969 || type == OP_NULL /* new_logop does this */
3972 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3973 if (!OpHAS_SIBLING(kid)) {
3975 assert(kid == cLISTOPo->op_last);
3976 assert(kid->op_sibparent == o);
3981 } while (( o = traverse_op_tree(top, o)) != NULL);
3985 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3988 PadnameLVALUE_on(pn);
3989 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3991 /* RT #127786: cv can be NULL due to an eval within the DB package
3992 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3993 * unless they contain an eval, but calling eval within DB
3994 * pretends the eval was done in the caller's scope.
3998 assert(CvPADLIST(cv));
4000 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4001 assert(PadnameLEN(pn));
4002 PadnameLVALUE_on(pn);
4007 S_vivifies(const OPCODE type)
4010 case OP_RV2AV: case OP_ASLICE:
4011 case OP_RV2HV: case OP_KVASLICE:
4012 case OP_RV2SV: case OP_HSLICE:
4013 case OP_AELEMFAST: case OP_KVHSLICE:
4022 /* apply lvalue reference (aliasing) context to the optree o.
4025 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4026 * It may descend and apply this to children too, for example in
4027 * \( $cond ? $x, $y) = (...)
4031 S_lvref(pTHX_ OP *o, I32 type)
4038 switch (o->op_type) {
4040 o = OpSIBLING(cUNOPo->op_first);
4047 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4048 o->op_flags |= OPf_STACKED;
4049 if (o->op_flags & OPf_PARENS) {
4050 if (o->op_private & OPpLVAL_INTRO) {
4051 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4052 "localized parenthesized array in list assignment"));
4056 OpTYPE_set(o, OP_LVAVREF);
4057 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4058 o->op_flags |= OPf_MOD|OPf_REF;
4061 o->op_private |= OPpLVREF_AV;
4065 kid = cUNOPo->op_first;
4066 if (kid->op_type == OP_NULL)
4067 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4069 o->op_private = OPpLVREF_CV;
4070 if (kid->op_type == OP_GV)
4071 o->op_flags |= OPf_STACKED;
4072 else if (kid->op_type == OP_PADCV) {
4073 o->op_targ = kid->op_targ;
4075 op_free(cUNOPo->op_first);
4076 cUNOPo->op_first = NULL;
4077 o->op_flags &=~ OPf_KIDS;
4083 if (o->op_flags & OPf_PARENS) {
4085 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4086 "parenthesized hash in list assignment"));
4089 o->op_private |= OPpLVREF_HV;
4093 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4094 o->op_flags |= OPf_STACKED;
4098 if (o->op_flags & OPf_PARENS) goto parenhash;
4099 o->op_private |= OPpLVREF_HV;
4102 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4106 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4107 if (o->op_flags & OPf_PARENS) goto slurpy;
4108 o->op_private |= OPpLVREF_AV;
4113 o->op_private |= OPpLVREF_ELEM;
4114 o->op_flags |= OPf_STACKED;
4119 OpTYPE_set(o, OP_LVREFSLICE);
4120 o->op_private &= OPpLVAL_INTRO;
4124 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4126 else if (!(o->op_flags & OPf_KIDS))
4129 /* the code formerly only recursed into the first child of
4130 * a non ex-list OP_NULL. if we ever encounter such a null op with
4131 * more than one child, need to decide whether its ok to process
4132 * *all* its kids or not */
4133 assert(o->op_targ == OP_LIST
4134 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4137 o = cLISTOPo->op_first;
4141 if (o->op_flags & OPf_PARENS)
4146 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4147 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4148 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4155 OpTYPE_set(o, OP_LVREF);
4157 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4158 if (type == OP_ENTERLOOP)
4159 o->op_private |= OPpLVREF_ITER;
4164 return; /* at top; no parents/siblings to try */
4165 if (OpHAS_SIBLING(o)) {
4166 o = o->op_sibparent;
4169 o = o->op_sibparent; /*try parent's next sibling */
4175 PERL_STATIC_INLINE bool
4176 S_potential_mod_type(I32 type)
4178 /* Types that only potentially result in modification. */
4179 return type == OP_GREPSTART || type == OP_ENTERSUB
4180 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4185 =for apidoc op_lvalue
4187 Propagate lvalue ("modifiable") context to an op and its children.
4188 C<type> represents the context type, roughly based on the type of op that
4189 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4190 because it has no op type of its own (it is signalled by a flag on
4193 This function detects things that can't be modified, such as C<$x+1>, and
4194 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4195 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4197 It also flags things that need to behave specially in an lvalue context,
4198 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4202 Perl_op_lvalue_flags() is a non-API lower-level interface to
4203 op_lvalue(). The flags param has these bits:
4204 OP_LVALUE_NO_CROAK: return rather than croaking on error
4209 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4214 if (!o || (PL_parser && PL_parser->error_count))
4219 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4221 OP *next_kid = NULL;
4223 if ((o->op_private & OPpTARGET_MY)
4224 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4229 /* elements of a list might be in void context because the list is
4230 in scalar context or because they are attribute sub calls */
4231 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4234 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4236 switch (o->op_type) {
4242 if ((o->op_flags & OPf_PARENS))
4247 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4248 !(o->op_flags & OPf_STACKED)) {
4249 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4250 assert(cUNOPo->op_first->op_type == OP_NULL);
4251 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4254 else { /* lvalue subroutine call */
4255 o->op_private |= OPpLVAL_INTRO;
4256 PL_modcount = RETURN_UNLIMITED_NUMBER;
4257 if (S_potential_mod_type(type)) {
4258 o->op_private |= OPpENTERSUB_INARGS;
4261 else { /* Compile-time error message: */
4262 OP *kid = cUNOPo->op_first;
4267 if (kid->op_type != OP_PUSHMARK) {
4268 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4270 "panic: unexpected lvalue entersub "
4271 "args: type/targ %ld:%" UVuf,
4272 (long)kid->op_type, (UV)kid->op_targ);
4273 kid = kLISTOP->op_first;
4275 while (OpHAS_SIBLING(kid))
4276 kid = OpSIBLING(kid);
4277 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4278 break; /* Postpone until runtime */
4281 kid = kUNOP->op_first;
4282 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4283 kid = kUNOP->op_first;
4284 if (kid->op_type == OP_NULL)
4286 "Unexpected constant lvalue entersub "
4287 "entry via type/targ %ld:%" UVuf,
4288 (long)kid->op_type, (UV)kid->op_targ);
4289 if (kid->op_type != OP_GV) {
4296 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4297 ? MUTABLE_CV(SvRV(gv))
4303 if (flags & OP_LVALUE_NO_CROAK)
4306 namesv = cv_name(cv, NULL, 0);
4307 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4308 "subroutine call of &%" SVf " in %s",
4309 SVfARG(namesv), PL_op_desc[type]),
4317 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4318 /* grep, foreach, subcalls, refgen */
4319 if (S_potential_mod_type(type))
4321 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4322 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4325 type ? PL_op_desc[type] : "local"));
4338 case OP_RIGHT_SHIFT:
4347 if (!(o->op_flags & OPf_STACKED))
4353 if (o->op_flags & OPf_STACKED) {
4357 if (!(o->op_private & OPpREPEAT_DOLIST))
4360 const I32 mods = PL_modcount;
4361 /* we recurse rather than iterate here because we need to
4362 * calculate and use the delta applied to PL_modcount by the
4363 * first child. So in something like
4364 * ($x, ($y) x 3) = split;
4365 * split knows that 4 elements are wanted
4367 modkids(cBINOPo->op_first, type);
4368 if (type != OP_AASSIGN)
4370 kid = cBINOPo->op_last;
4371 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4372 const IV iv = SvIV(kSVOP_sv);
4373 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4375 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4378 PL_modcount = RETURN_UNLIMITED_NUMBER;
4384 next_kid = OpSIBLING(cUNOPo->op_first);
4389 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4390 PL_modcount = RETURN_UNLIMITED_NUMBER;
4391 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4392 fiable since some contexts need to know. */
4393 o->op_flags |= OPf_MOD;
4398 if (scalar_mod_type(o, type))
4400 ref(cUNOPo->op_first, o->op_type);
4407 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4408 if (type == OP_LEAVESUBLV && (
4409 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4410 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4412 o->op_private |= OPpMAYBE_LVSUB;
4416 PL_modcount = RETURN_UNLIMITED_NUMBER;
4422 if (type == OP_LEAVESUBLV)
4423 o->op_private |= OPpMAYBE_LVSUB;
4427 if (type == OP_LEAVESUBLV
4428 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4429 o->op_private |= OPpMAYBE_LVSUB;
4433 PL_hints |= HINT_BLOCK_SCOPE;
4434 if (type == OP_LEAVESUBLV)
4435 o->op_private |= OPpMAYBE_LVSUB;
4440 ref(cUNOPo->op_first, o->op_type);
4444 PL_hints |= HINT_BLOCK_SCOPE;
4454 case OP_AELEMFAST_LEX:
4461 PL_modcount = RETURN_UNLIMITED_NUMBER;
4462 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4464 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4465 fiable since some contexts need to know. */
4466 o->op_flags |= OPf_MOD;
4469 if (scalar_mod_type(o, type))
4471 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4472 && type == OP_LEAVESUBLV)
4473 o->op_private |= OPpMAYBE_LVSUB;
4477 if (!type) /* local() */
4478 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4479 PNfARG(PAD_COMPNAME(o->op_targ)));
4480 if (!(o->op_private & OPpLVAL_INTRO)
4481 || ( type != OP_SASSIGN && type != OP_AASSIGN
4482 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4483 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4491 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4495 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4501 if (type == OP_LEAVESUBLV)
4502 o->op_private |= OPpMAYBE_LVSUB;
4503 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4504 /* we recurse rather than iterate here because the child
4505 * needs to be processed with a different 'type' parameter */
4507 /* substr and vec */
4508 /* If this op is in merely potential (non-fatal) modifiable
4509 context, then apply OP_ENTERSUB context to
4510 the kid op (to avoid croaking). Other-
4511 wise pass this op’s own type so the correct op is mentioned
4512 in error messages. */
4513 op_lvalue(OpSIBLING(cBINOPo->op_first),
4514 S_potential_mod_type(type)
4522 ref(cBINOPo->op_first, o->op_type);
4523 if (type == OP_ENTERSUB &&
4524 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4525 o->op_private |= OPpLVAL_DEFER;
4526 if (type == OP_LEAVESUBLV)
4527 o->op_private |= OPpMAYBE_LVSUB;
4534 o->op_private |= OPpLVALUE;
4540 if (o->op_flags & OPf_KIDS)
4541 next_kid = cLISTOPo->op_last;
4546 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4548 else if (!(o->op_flags & OPf_KIDS))
4551 if (o->op_targ != OP_LIST) {
4552 OP *sib = OpSIBLING(cLISTOPo->op_first);
4553 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4560 * compared with things like OP_MATCH which have the argument
4566 * so handle specially to correctly get "Can't modify" croaks etc
4569 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4571 /* this should trigger a "Can't modify transliteration" err */
4572 op_lvalue(sib, type);
4574 next_kid = cBINOPo->op_first;
4575 /* we assume OP_NULLs which aren't ex-list have no more than 2
4576 * children. If this assumption is wrong, increase the scan
4578 assert( !OpHAS_SIBLING(next_kid)
4579 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4585 next_kid = cLISTOPo->op_first;
4593 if (type == OP_LEAVESUBLV
4594 || !S_vivifies(cLOGOPo->op_first->op_type))
4595 next_kid = cLOGOPo->op_first;
4596 else if (type == OP_LEAVESUBLV
4597 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4598 next_kid = OpSIBLING(cLOGOPo->op_first);
4602 if (type == OP_NULL) { /* local */
4604 if (!FEATURE_MYREF_IS_ENABLED)
4605 Perl_croak(aTHX_ "The experimental declared_refs "
4606 "feature is not enabled");
4607 Perl_ck_warner_d(aTHX_
4608 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4609 "Declaring references is experimental");
4610 next_kid = cUNOPo->op_first;
4613 if (type != OP_AASSIGN && type != OP_SASSIGN
4614 && type != OP_ENTERLOOP)
4616 /* Don’t bother applying lvalue context to the ex-list. */
4617 kid = cUNOPx(cUNOPo->op_first)->op_first;
4618 assert (!OpHAS_SIBLING(kid));
4621 if (type == OP_NULL) /* local */
4623 if (type != OP_AASSIGN) goto nomod;
4624 kid = cUNOPo->op_first;
4627 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4628 S_lvref(aTHX_ kid, type);
4629 if (!PL_parser || PL_parser->error_count == ec) {
4630 if (!FEATURE_REFALIASING_IS_ENABLED)
4632 "Experimental aliasing via reference not enabled");
4633 Perl_ck_warner_d(aTHX_
4634 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4635 "Aliasing via reference is experimental");
4638 if (o->op_type == OP_REFGEN)
4639 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4644 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4645 /* This is actually @array = split. */
4646 PL_modcount = RETURN_UNLIMITED_NUMBER;
4652 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4656 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4657 their argument is a filehandle; thus \stat(".") should not set
4659 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4662 if (type != OP_LEAVESUBLV)
4663 o->op_flags |= OPf_MOD;
4665 if (type == OP_AASSIGN || type == OP_SASSIGN)
4666 o->op_flags |= OPf_SPECIAL
4667 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4668 else if (!type) { /* local() */
4671 o->op_private |= OPpLVAL_INTRO;
4672 o->op_flags &= ~OPf_SPECIAL;
4673 PL_hints |= HINT_BLOCK_SCOPE;
4678 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4679 "Useless localization of %s", OP_DESC(o));
4682 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4683 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4684 o->op_flags |= OPf_REF;
4689 return top_op; /* at top; no parents/siblings to try */
4690 if (OpHAS_SIBLING(o)) {
4691 next_kid = o->op_sibparent;
4692 if (!OpHAS_SIBLING(next_kid)) {
4693 /* a few node types don't recurse into their second child */
4694 OP *parent = next_kid->op_sibparent;
4695 I32 ptype = parent->op_type;
4696 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4697 || ( (ptype == OP_AND || ptype == OP_OR)
4698 && (type != OP_LEAVESUBLV
4699 && S_vivifies(next_kid->op_type))
4702 /*try parent's next sibling */
4709 o = o->op_sibparent; /*try parent's next sibling */
4720 S_scalar_mod_type(const OP *o, I32 type)
4725 if (o && o->op_type == OP_RV2GV)
4749 case OP_RIGHT_SHIFT:
4778 S_is_handle_constructor(const OP *o, I32 numargs)
4780 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4782 switch (o->op_type) {
4790 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4803 S_refkids(pTHX_ OP *o, I32 type)
4805 if (o && o->op_flags & OPf_KIDS) {
4807 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4814 /* Apply reference (autovivification) context to the subtree at o.
4816 * push @{expression}, ....;
4817 * o will be the head of 'expression' and type will be OP_RV2AV.
4818 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4820 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4821 * set_op_ref is true.
4823 * Also calls scalar(o).
4827 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4832 PERL_ARGS_ASSERT_DOREF;
4834 if (PL_parser && PL_parser->error_count)
4838 switch (o->op_type) {
4840 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4841 !(o->op_flags & OPf_STACKED)) {
4842 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4843 assert(cUNOPo->op_first->op_type == OP_NULL);
4844 /* disable pushmark */
4845 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4846 o->op_flags |= OPf_SPECIAL;
4848 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4849 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4850 : type == OP_RV2HV ? OPpDEREF_HV
4852 o->op_flags |= OPf_MOD;
4858 o = OpSIBLING(cUNOPo->op_first);
4862 if (type == OP_DEFINED)
4863 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4866 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4867 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4868 : type == OP_RV2HV ? OPpDEREF_HV
4870 o->op_flags |= OPf_MOD;
4872 if (o->op_flags & OPf_KIDS) {
4874 o = cUNOPo->op_first;
4882 o->op_flags |= OPf_REF;
4885 if (type == OP_DEFINED)
4886 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4888 o = cUNOPo->op_first;
4894 o->op_flags |= OPf_REF;
4899 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4901 o = cBINOPo->op_first;
4906 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4907 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4908 : type == OP_RV2HV ? OPpDEREF_HV
4910 o->op_flags |= OPf_MOD;
4913 o = cBINOPo->op_first;
4922 if (!(o->op_flags & OPf_KIDS))
4924 o = cLISTOPo->op_last;
4933 return scalar(top_op); /* at top; no parents/siblings to try */
4934 if (OpHAS_SIBLING(o)) {
4935 o = o->op_sibparent;
4936 /* Normally skip all siblings and go straight to the parent;
4937 * the only op that requires two children to be processed
4938 * is OP_COND_EXPR */
4939 if (!OpHAS_SIBLING(o)
4940 && o->op_sibparent->op_type == OP_COND_EXPR)
4944 o = o->op_sibparent; /*try parent's next sibling */
4951 S_dup_attrlist(pTHX_ OP *o)
4955 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4957 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4958 * where the first kid is OP_PUSHMARK and the remaining ones
4959 * are OP_CONST. We need to push the OP_CONST values.
4961 if (o->op_type == OP_CONST)
4962 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4964 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4966 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4967 if (o->op_type == OP_CONST)
4968 rop = op_append_elem(OP_LIST, rop,
4969 newSVOP(OP_CONST, o->op_flags,
4970 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4977 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4979 PERL_ARGS_ASSERT_APPLY_ATTRS;
4981 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4983 /* fake up C<use attributes $pkg,$rv,@attrs> */
4985 #define ATTRSMODULE "attributes"
4986 #define ATTRSMODULE_PM "attributes.pm"
4989 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4990 newSVpvs(ATTRSMODULE),
4992 op_prepend_elem(OP_LIST,
4993 newSVOP(OP_CONST, 0, stashsv),
4994 op_prepend_elem(OP_LIST,
4995 newSVOP(OP_CONST, 0,
4997 dup_attrlist(attrs))));
5002 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5004 OP *pack, *imop, *arg;
5005 SV *meth, *stashsv, **svp;
5007 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5012 assert(target->op_type == OP_PADSV ||
5013 target->op_type == OP_PADHV ||
5014 target->op_type == OP_PADAV);
5016 /* Ensure that attributes.pm is loaded. */
5017 /* Don't force the C<use> if we don't need it. */
5018 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5019 if (svp && *svp != &PL_sv_undef)
5020 NOOP; /* already in %INC */
5022 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5023 newSVpvs(ATTRSMODULE), NULL);
5025 /* Need package name for method call. */
5026 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5028 /* Build up the real arg-list. */
5029 stashsv = newSVhek(HvNAME_HEK(stash));
5031 arg = newOP(OP_PADSV, 0);
5032 arg->op_targ = target->op_targ;
5033 arg = op_prepend_elem(OP_LIST,
5034 newSVOP(OP_CONST, 0, stashsv),
5035 op_prepend_elem(OP_LIST,
5036 newUNOP(OP_REFGEN, 0,
5038 dup_attrlist(attrs)));
5040 /* Fake up a method call to import */
5041 meth = newSVpvs_share("import");
5042 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5043 op_append_elem(OP_LIST,
5044 op_prepend_elem(OP_LIST, pack, arg),
5045 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5047 /* Combine the ops. */
5048 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5052 =notfor apidoc apply_attrs_string
5054 Attempts to apply a list of attributes specified by the C<attrstr> and
5055 C<len> arguments to the subroutine identified by the C<cv> argument which
5056 is expected to be associated with the package identified by the C<stashpv>
5057 argument (see L<attributes>). It gets this wrong, though, in that it
5058 does not correctly identify the boundaries of the individual attribute
5059 specifications within C<attrstr>. This is not really intended for the
5060 public API, but has to be listed here for systems such as AIX which
5061 need an explicit export list for symbols. (It's called from XS code
5062 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5063 to respect attribute syntax properly would be welcome.
5069 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5070 const char *attrstr, STRLEN len)
5074 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5077 len = strlen(attrstr);
5081 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5083 const char * const sstr = attrstr;
5084 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5085 attrs = op_append_elem(OP_LIST, attrs,
5086 newSVOP(OP_CONST, 0,
5087 newSVpvn(sstr, attrstr-sstr)));
5091 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5092 newSVpvs(ATTRSMODULE),
5093 NULL, op_prepend_elem(OP_LIST,
5094 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5095 op_prepend_elem(OP_LIST,
5096 newSVOP(OP_CONST, 0,
5097 newRV(MUTABLE_SV(cv))),
5102 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5105 OP *new_proto = NULL;
5110 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5116 if (o->op_type == OP_CONST) {
5117 pv = SvPV(cSVOPo_sv, pvlen);
5118 if (memBEGINs(pv, pvlen, "prototype(")) {
5119 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5120 SV ** const tmpo = cSVOPx_svp(o);
5121 SvREFCNT_dec(cSVOPo_sv);
5126 } else if (o->op_type == OP_LIST) {
5128 assert(o->op_flags & OPf_KIDS);
5129 lasto = cLISTOPo->op_first;
5130 assert(lasto->op_type == OP_PUSHMARK);
5131 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5132 if (o->op_type == OP_CONST) {
5133 pv = SvPV(cSVOPo_sv, pvlen);
5134 if (memBEGINs(pv, pvlen, "prototype(")) {
5135 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5136 SV ** const tmpo = cSVOPx_svp(o);
5137 SvREFCNT_dec(cSVOPo_sv);
5139 if (new_proto && ckWARN(WARN_MISC)) {
5141 const char * newp = SvPV(cSVOPo_sv, new_len);
5142 Perl_warner(aTHX_ packWARN(WARN_MISC),
5143 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5144 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5150 /* excise new_proto from the list */
5151 op_sibling_splice(*attrs, lasto, 1, NULL);
5158 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5159 would get pulled in with no real need */
5160 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5169 svname = sv_newmortal();
5170 gv_efullname3(svname, name, NULL);
5172 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5173 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5175 svname = (SV *)name;
5176 if (ckWARN(WARN_ILLEGALPROTO))
5177 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5179 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5180 STRLEN old_len, new_len;
5181 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5182 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5184 if (curstash && svname == (SV *)name
5185 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5186 svname = sv_2mortal(newSVsv(PL_curstname));
5187 sv_catpvs(svname, "::");
5188 sv_catsv(svname, (SV *)name);
5191 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5192 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5194 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5195 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5205 S_cant_declare(pTHX_ OP *o)
5207 if (o->op_type == OP_NULL
5208 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5209 o = cUNOPo->op_first;
5210 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5211 o->op_type == OP_NULL
5212 && o->op_flags & OPf_SPECIAL
5215 PL_parser->in_my == KEY_our ? "our" :
5216 PL_parser->in_my == KEY_state ? "state" :
5221 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5224 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5226 PERL_ARGS_ASSERT_MY_KID;
5228 if (!o || (PL_parser && PL_parser->error_count))
5233 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5235 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5236 my_kid(kid, attrs, imopsp);
5238 } else if (type == OP_UNDEF || type == OP_STUB) {
5240 } else if (type == OP_RV2SV || /* "our" declaration */
5243 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5244 S_cant_declare(aTHX_ o);
5246 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5248 PL_parser->in_my = FALSE;
5249 PL_parser->in_my_stash = NULL;
5250 apply_attrs(GvSTASH(gv),
5251 (type == OP_RV2SV ? GvSVn(gv) :
5252 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5253 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5256 o->op_private |= OPpOUR_INTRO;
5259 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5260 if (!FEATURE_MYREF_IS_ENABLED)
5261 Perl_croak(aTHX_ "The experimental declared_refs "
5262 "feature is not enabled");
5263 Perl_ck_warner_d(aTHX_
5264 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5265 "Declaring references is experimental");
5266 /* Kid is a nulled OP_LIST, handled above. */
5267 my_kid(cUNOPo->op_first, attrs, imopsp);
5270 else if (type != OP_PADSV &&
5273 type != OP_PUSHMARK)
5275 S_cant_declare(aTHX_ o);
5278 else if (attrs && type != OP_PUSHMARK) {
5282 PL_parser->in_my = FALSE;
5283 PL_parser->in_my_stash = NULL;
5285 /* check for C<my Dog $spot> when deciding package */
5286 stash = PAD_COMPNAME_TYPE(o->op_targ);
5288 stash = PL_curstash;
5289 apply_attrs_my(stash, o, attrs, imopsp);
5291 o->op_flags |= OPf_MOD;
5292 o->op_private |= OPpLVAL_INTRO;
5294 o->op_private |= OPpPAD_STATE;
5299 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5302 int maybe_scalar = 0;
5304 PERL_ARGS_ASSERT_MY_ATTRS;
5306 /* [perl #17376]: this appears to be premature, and results in code such as
5307 C< our(%x); > executing in list mode rather than void mode */
5309 if (o->op_flags & OPf_PARENS)
5319 o = my_kid(o, attrs, &rops);
5321 if (maybe_scalar && o->op_type == OP_PADSV) {
5322 o = scalar(op_append_list(OP_LIST, rops, o));
5323 o->op_private |= OPpLVAL_INTRO;
5326 /* The listop in rops might have a pushmark at the beginning,
5327 which will mess up list assignment. */
5328 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5329 if (rops->op_type == OP_LIST &&
5330 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5332 OP * const pushmark = lrops->op_first;
5333 /* excise pushmark */
5334 op_sibling_splice(rops, NULL, 1, NULL);
5337 o = op_append_list(OP_LIST, o, rops);
5340 PL_parser->in_my = FALSE;
5341 PL_parser->in_my_stash = NULL;
5346 Perl_sawparens(pTHX_ OP *o)
5348 PERL_UNUSED_CONTEXT;
5350 o->op_flags |= OPf_PARENS;
5355 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5359 const OPCODE ltype = left->op_type;
5360 const OPCODE rtype = right->op_type;
5362 PERL_ARGS_ASSERT_BIND_MATCH;
5364 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5365 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5367 const char * const desc
5369 rtype == OP_SUBST || rtype == OP_TRANS
5370 || rtype == OP_TRANSR
5372 ? (int)rtype : OP_MATCH];
5373 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5375 S_op_varname(aTHX_ left);
5377 Perl_warner(aTHX_ packWARN(WARN_MISC),
5378 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5379 desc, SVfARG(name), SVfARG(name));
5381 const char * const sample = (isary
5382 ? "@array" : "%hash");
5383 Perl_warner(aTHX_ packWARN(WARN_MISC),
5384 "Applying %s to %s will act on scalar(%s)",
5385 desc, sample, sample);
5389 if (rtype == OP_CONST &&
5390 cSVOPx(right)->op_private & OPpCONST_BARE &&
5391 cSVOPx(right)->op_private & OPpCONST_STRICT)
5393 no_bareword_allowed(right);
5396 /* !~ doesn't make sense with /r, so error on it for now */
5397 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5399 /* diag_listed_as: Using !~ with %s doesn't make sense */
5400 yyerror("Using !~ with s///r doesn't make sense");
5401 if (rtype == OP_TRANSR && type == OP_NOT)
5402 /* diag_listed_as: Using !~ with %s doesn't make sense */
5403 yyerror("Using !~ with tr///r doesn't make sense");
5405 ismatchop = (rtype == OP_MATCH ||
5406 rtype == OP_SUBST ||
5407 rtype == OP_TRANS || rtype == OP_TRANSR)
5408 && !(right->op_flags & OPf_SPECIAL);
5409 if (ismatchop && right->op_private & OPpTARGET_MY) {
5411 right->op_private &= ~OPpTARGET_MY;
5413 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5414 if (left->op_type == OP_PADSV
5415 && !(left->op_private & OPpLVAL_INTRO))
5417 right->op_targ = left->op_targ;
5422 right->op_flags |= OPf_STACKED;
5423 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5424 ! (rtype == OP_TRANS &&
5425 right->op_private & OPpTRANS_IDENTICAL) &&
5426 ! (rtype == OP_SUBST &&
5427 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5428 left = op_lvalue(left, rtype);
5429 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5430 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5432 o = op_prepend_elem(rtype, scalar(left), right);
5435 return newUNOP(OP_NOT, 0, scalar(o));
5439 return bind_match(type, left,
5440 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5444 Perl_invert(pTHX_ OP *o)
5448 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5452 =for apidoc op_scope
5454 Wraps up an op tree with some additional ops so that at runtime a dynamic
5455 scope will be created. The original ops run in the new dynamic scope,
5456 and then, provided that they exit normally, the scope will be unwound.
5457 The additional ops used to create and unwind the dynamic scope will
5458 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5459 instead if the ops are simple enough to not need the full dynamic scope
5466 Perl_op_scope(pTHX_ OP *o)
5470 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5471 o = op_prepend_elem(OP_LINESEQ,
5472 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5473 OpTYPE_set(o, OP_LEAVE);
5475 else if (o->op_type == OP_LINESEQ) {
5477 OpTYPE_set(o, OP_SCOPE);
5478 kid = ((LISTOP*)o)->op_first;
5479 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5482 /* The following deals with things like 'do {1 for 1}' */
5483 kid = OpSIBLING(kid);
5485 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5490 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5496 Perl_op_unscope(pTHX_ OP *o)
5498 if (o && o->op_type == OP_LINESEQ) {
5499 OP *kid = cLISTOPo->op_first;
5500 for(; kid; kid = OpSIBLING(kid))
5501 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5508 =for apidoc block_start
5510 Handles compile-time scope entry.
5511 Arranges for hints to be restored on block
5512 exit and also handles pad sequence numbers to make lexical variables scope
5513 right. Returns a savestack index for use with C<block_end>.
5519 Perl_block_start(pTHX_ int full)
5521 const int retval = PL_savestack_ix;
5523 PL_compiling.cop_seq = PL_cop_seqmax;
5525 pad_block_start(full);
5527 PL_hints &= ~HINT_BLOCK_SCOPE;
5528 SAVECOMPILEWARNINGS();
5529 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5530 SAVEI32(PL_compiling.cop_seq);
5531 PL_compiling.cop_seq = 0;
5533 CALL_BLOCK_HOOKS(bhk_start, full);
5539 =for apidoc block_end
5541 Handles compile-time scope exit. C<floor>
5542 is the savestack index returned by
5543 C<block_start>, and C<seq> is the body of the block. Returns the block,
5550 Perl_block_end(pTHX_ I32 floor, OP *seq)
5552 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5553 OP* retval = scalarseq(seq);
5556 /* XXX Is the null PL_parser check necessary here? */
5557 assert(PL_parser); /* Let’s find out under debugging builds. */
5558 if (PL_parser && PL_parser->parsed_sub) {
5559 o = newSTATEOP(0, NULL, NULL);
5561 retval = op_append_elem(OP_LINESEQ, retval, o);
5564 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5568 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5572 /* pad_leavemy has created a sequence of introcv ops for all my
5573 subs declared in the block. We have to replicate that list with
5574 clonecv ops, to deal with this situation:
5579 sub s1 { state sub foo { \&s2 } }
5582 Originally, I was going to have introcv clone the CV and turn
5583 off the stale flag. Since &s1 is declared before &s2, the
5584 introcv op for &s1 is executed (on sub entry) before the one for
5585 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5586 cloned, since it is a state sub) closes over &s2 and expects
5587 to see it in its outer CV’s pad. If the introcv op clones &s1,
5588 then &s2 is still marked stale. Since &s1 is not active, and
5589 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5590 ble will not stay shared’ warning. Because it is the same stub
5591 that will be used when the introcv op for &s2 is executed, clos-
5592 ing over it is safe. Hence, we have to turn off the stale flag
5593 on all lexical subs in the block before we clone any of them.
5594 Hence, having introcv clone the sub cannot work. So we create a
5595 list of ops like this:
5619 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5620 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5621 for (;; kid = OpSIBLING(kid)) {
5622 OP *newkid = newOP(OP_CLONECV, 0);
5623 newkid->op_targ = kid->op_targ;
5624 o = op_append_elem(OP_LINESEQ, o, newkid);
5625 if (kid == last) break;
5627 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5630 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5636 =head1 Compile-time scope hooks
5638 =for apidoc blockhook_register
5640 Register a set of hooks to be called when the Perl lexical scope changes
5641 at compile time. See L<perlguts/"Compile-time scope hooks">.
5647 Perl_blockhook_register(pTHX_ BHK *hk)
5649 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5651 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5655 Perl_newPROG(pTHX_ OP *o)
5659 PERL_ARGS_ASSERT_NEWPROG;
5666 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5667 ((PL_in_eval & EVAL_KEEPERR)
5668 ? OPf_SPECIAL : 0), o);
5671 assert(CxTYPE(cx) == CXt_EVAL);
5673 if ((cx->blk_gimme & G_WANT) == G_VOID)
5674 scalarvoid(PL_eval_root);
5675 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5678 scalar(PL_eval_root);
5680 start = op_linklist(PL_eval_root);
5681 PL_eval_root->op_next = 0;
5682 i = PL_savestack_ix;
5685 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5687 PL_savestack_ix = i;
5690 if (o->op_type == OP_STUB) {
5691 /* This block is entered if nothing is compiled for the main
5692 program. This will be the case for an genuinely empty main
5693 program, or one which only has BEGIN blocks etc, so already
5696 Historically (5.000) the guard above was !o. However, commit
5697 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5698 c71fccf11fde0068, changed perly.y so that newPROG() is now
5699 called with the output of block_end(), which returns a new
5700 OP_STUB for the case of an empty optree. ByteLoader (and
5701 maybe other things) also take this path, because they set up
5702 PL_main_start and PL_main_root directly, without generating an
5705 If the parsing the main program aborts (due to parse errors,
5706 or due to BEGIN or similar calling exit), then newPROG()
5707 isn't even called, and hence this code path and its cleanups
5708 are skipped. This shouldn't make a make a difference:
5709 * a non-zero return from perl_parse is a failure, and
5710 perl_destruct() should be called immediately.
5711 * however, if exit(0) is called during the parse, then
5712 perl_parse() returns 0, and perl_run() is called. As
5713 PL_main_start will be NULL, perl_run() will return
5714 promptly, and the exit code will remain 0.
5717 PL_comppad_name = 0;
5719 S_op_destroy(aTHX_ o);
5722 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5723 PL_curcop = &PL_compiling;
5724 start = LINKLIST(PL_main_root);
5725 PL_main_root->op_next = 0;
5726 S_process_optree(aTHX_ NULL, PL_main_root, start);
5727 if (!PL_parser->error_count)
5728 /* on error, leave CV slabbed so that ops left lying around
5729 * will eb cleaned up. Else unslab */
5730 cv_forget_slab(PL_compcv);
5733 /* Register with debugger */
5735 CV * const cv = get_cvs("DB::postponed", 0);
5739 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5741 call_sv(MUTABLE_SV(cv), G_DISCARD);
5748 Perl_localize(pTHX_ OP *o, I32 lex)
5750 PERL_ARGS_ASSERT_LOCALIZE;
5752 if (o->op_flags & OPf_PARENS)
5753 /* [perl #17376]: this appears to be premature, and results in code such as
5754 C< our(%x); > executing in list mode rather than void mode */
5761 if ( PL_parser->bufptr > PL_parser->oldbufptr
5762 && PL_parser->bufptr[-1] == ','
5763 && ckWARN(WARN_PARENTHESIS))
5765 char *s = PL_parser->bufptr;
5768 /* some heuristics to detect a potential error */
5769 while (*s && (memCHRs(", \t\n", *s)))
5773 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
5775 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5778 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5780 while (*s && (memCHRs(", \t\n", *s)))
5786 if (sigil && (*s == ';' || *s == '=')) {
5787 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5788 "Parentheses missing around \"%s\" list",
5790 ? (PL_parser->in_my == KEY_our
5792 : PL_parser->in_my == KEY_state
5802 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5803 PL_parser->in_my = FALSE;
5804 PL_parser->in_my_stash = NULL;
5809 Perl_jmaybe(pTHX_ OP *o)
5811 PERL_ARGS_ASSERT_JMAYBE;
5813 if (o->op_type == OP_LIST) {
5815 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5816 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5821 PERL_STATIC_INLINE OP *
5822 S_op_std_init(pTHX_ OP *o)
5824 I32 type = o->op_type;
5826 PERL_ARGS_ASSERT_OP_STD_INIT;
5828 if (PL_opargs[type] & OA_RETSCALAR)
5830 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5831 o->op_targ = pad_alloc(type, SVs_PADTMP);
5836 PERL_STATIC_INLINE OP *
5837 S_op_integerize(pTHX_ OP *o)
5839 I32 type = o->op_type;
5841 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5843 /* integerize op. */
5844 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5847 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5850 if (type == OP_NEGATE)
5851 /* XXX might want a ck_negate() for this */
5852 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5857 /* This function exists solely to provide a scope to limit
5858 setjmp/longjmp() messing with auto variables.
5860 PERL_STATIC_INLINE int
5861 S_fold_constants_eval(pTHX) {
5877 S_fold_constants(pTHX_ OP *const o)
5882 I32 type = o->op_type;
5887 SV * const oldwarnhook = PL_warnhook;
5888 SV * const olddiehook = PL_diehook;
5890 U8 oldwarn = PL_dowarn;
5893 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5895 if (!(PL_opargs[type] & OA_FOLDCONST))
5904 #ifdef USE_LOCALE_CTYPE
5905 if (IN_LC_COMPILETIME(LC_CTYPE))
5914 #ifdef USE_LOCALE_COLLATE
5915 if (IN_LC_COMPILETIME(LC_COLLATE))
5920 /* XXX what about the numeric ops? */
5921 #ifdef USE_LOCALE_NUMERIC
5922 if (IN_LC_COMPILETIME(LC_NUMERIC))
5927 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5928 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5931 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5932 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5934 const char *s = SvPVX_const(sv);
5935 while (s < SvEND(sv)) {
5936 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5943 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5946 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5947 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5951 if (PL_parser && PL_parser->error_count)
5952 goto nope; /* Don't try to run w/ errors */
5954 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5955 switch (curop->op_type) {
5957 if ( (curop->op_private & OPpCONST_BARE)
5958 && (curop->op_private & OPpCONST_STRICT)) {
5959 no_bareword_allowed(curop);
5967 /* Foldable; move to next op in list */
5971 /* No other op types are considered foldable */
5976 curop = LINKLIST(o);
5977 old_next = o->op_next;
5981 old_cxix = cxstack_ix;
5982 create_eval_scope(NULL, G_FAKINGEVAL);
5984 /* Verify that we don't need to save it: */
5985 assert(PL_curcop == &PL_compiling);
5986 StructCopy(&PL_compiling, ¬_compiling, COP);
5987 PL_curcop = ¬_compiling;
5988 /* The above ensures that we run with all the correct hints of the
5989 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5990 assert(IN_PERL_RUNTIME);
5991 PL_warnhook = PERL_WARNHOOK_FATAL;
5994 /* Effective $^W=1. */
5995 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5996 PL_dowarn |= G_WARN_ON;
5998 ret = S_fold_constants_eval(aTHX);
6002 sv = *(PL_stack_sp--);
6003 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6004 pad_swipe(o->op_targ, FALSE);
6006 else if (SvTEMP(sv)) { /* grab mortal temp? */
6007 SvREFCNT_inc_simple_void(sv);
6010 else { assert(SvIMMORTAL(sv)); }
6013 /* Something tried to die. Abandon constant folding. */
6014 /* Pretend the error never happened. */
6016 o->op_next = old_next;
6019 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6020 PL_warnhook = oldwarnhook;
6021 PL_diehook = olddiehook;
6022 /* XXX note that this croak may fail as we've already blown away
6023 * the stack - eg any nested evals */
6024 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6026 PL_dowarn = oldwarn;
6027 PL_warnhook = oldwarnhook;
6028 PL_diehook = olddiehook;
6029 PL_curcop = &PL_compiling;
6031 /* if we croaked, depending on how we croaked the eval scope
6032 * may or may not have already been popped */
6033 if (cxstack_ix > old_cxix) {
6034 assert(cxstack_ix == old_cxix + 1);
6035 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6036 delete_eval_scope();
6041 /* OP_STRINGIFY and constant folding are used to implement qq.
6042 Here the constant folding is an implementation detail that we
6043 want to hide. If the stringify op is itself already marked
6044 folded, however, then it is actually a folded join. */
6045 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6050 else if (!SvIMMORTAL(sv)) {
6054 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6055 if (!is_stringify) newop->op_folded = 1;
6062 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6063 * the constant value being an AV holding the flattened range.
6067 S_gen_constant_list(pTHX_ OP *o)
6070 OP *curop, *old_next;
6071 SV * const oldwarnhook = PL_warnhook;
6072 SV * const olddiehook = PL_diehook;
6074 U8 oldwarn = PL_dowarn;
6084 if (PL_parser && PL_parser->error_count)
6085 return; /* Don't attempt to run with errors */
6087 curop = LINKLIST(o);
6088 old_next = o->op_next;
6090 op_was_null = o->op_type == OP_NULL;
6091 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6092 o->op_type = OP_CUSTOM;
6095 o->op_type = OP_NULL;
6096 S_prune_chain_head(&curop);
6099 old_cxix = cxstack_ix;
6100 create_eval_scope(NULL, G_FAKINGEVAL);
6102 old_curcop = PL_curcop;
6103 StructCopy(old_curcop, ¬_compiling, COP);
6104 PL_curcop = ¬_compiling;
6105 /* The above ensures that we run with all the correct hints of the
6106 current COP, but that IN_PERL_RUNTIME is true. */
6107 assert(IN_PERL_RUNTIME);
6108 PL_warnhook = PERL_WARNHOOK_FATAL;
6112 /* Effective $^W=1. */
6113 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6114 PL_dowarn |= G_WARN_ON;
6118 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6119 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6121 Perl_pp_pushmark(aTHX);
6124 assert (!(curop->op_flags & OPf_SPECIAL));
6125 assert(curop->op_type == OP_RANGE);
6126 Perl_pp_anonlist(aTHX);
6130 o->op_next = old_next;
6134 PL_warnhook = oldwarnhook;
6135 PL_diehook = olddiehook;
6136 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6141 PL_dowarn = oldwarn;
6142 PL_warnhook = oldwarnhook;
6143 PL_diehook = olddiehook;
6144 PL_curcop = old_curcop;
6146 if (cxstack_ix > old_cxix) {
6147 assert(cxstack_ix == old_cxix + 1);
6148 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6149 delete_eval_scope();
6154 OpTYPE_set(o, OP_RV2AV);
6155 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6156 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6157 o->op_opt = 0; /* needs to be revisited in rpeep() */
6158 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6160 /* replace subtree with an OP_CONST */
6161 curop = ((UNOP*)o)->op_first;
6162 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6165 if (AvFILLp(av) != -1)
6166 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6169 SvREADONLY_on(*svp);
6177 =head1 Optree Manipulation Functions
6180 /* List constructors */
6183 =for apidoc op_append_elem
6185 Append an item to the list of ops contained directly within a list-type
6186 op, returning the lengthened list. C<first> is the list-type op,
6187 and C<last> is the op to append to the list. C<optype> specifies the
6188 intended opcode for the list. If C<first> is not already a list of the
6189 right type, it will be upgraded into one. If either C<first> or C<last>
6190 is null, the other is returned unchanged.
6196 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6204 if (first->op_type != (unsigned)type
6205 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6207 return newLISTOP(type, 0, first, last);
6210 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6211 first->op_flags |= OPf_KIDS;
6216 =for apidoc op_append_list
6218 Concatenate the lists of ops contained directly within two list-type ops,
6219 returning the combined list. C<first> and C<last> are the list-type ops
6220 to concatenate. C<optype> specifies the intended opcode for the list.
6221 If either C<first> or C<last> is not already a list of the right type,
6222 it will be upgraded into one. If either C<first> or C<last> is null,
6223 the other is returned unchanged.
6229 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6237 if (first->op_type != (unsigned)type)
6238 return op_prepend_elem(type, first, last);
6240 if (last->op_type != (unsigned)type)
6241 return op_append_elem(type, first, last);
6243 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6244 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6245 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6246 first->op_flags |= (last->op_flags & OPf_KIDS);
6248 S_op_destroy(aTHX_ last);
6254 =for apidoc op_prepend_elem
6256 Prepend an item to the list of ops contained directly within a list-type
6257 op, returning the lengthened list. C<first> is the op to prepend to the
6258 list, and C<last> is the list-type op. C<optype> specifies the intended
6259 opcode for the list. If C<last> is not already a list of the right type,
6260 it will be upgraded into one. If either C<first> or C<last> is null,
6261 the other is returned unchanged.
6267 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6275 if (last->op_type == (unsigned)type) {
6276 if (type == OP_LIST) { /* already a PUSHMARK there */
6277 /* insert 'first' after pushmark */
6278 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6279 if (!(first->op_flags & OPf_PARENS))
6280 last->op_flags &= ~OPf_PARENS;
6283 op_sibling_splice(last, NULL, 0, first);
6284 last->op_flags |= OPf_KIDS;
6288 return newLISTOP(type, 0, first, last);
6292 =for apidoc op_convert_list
6294 Converts C<o> into a list op if it is not one already, and then converts it
6295 into the specified C<type>, calling its check function, allocating a target if
6296 it needs one, and folding constants.
6298 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6299 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6300 C<op_convert_list> to make it the right type.
6306 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6309 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6310 if (!o || o->op_type != OP_LIST)
6311 o = force_list(o, 0);
6314 o->op_flags &= ~OPf_WANT;
6315 o->op_private &= ~OPpLVAL_INTRO;
6318 if (!(PL_opargs[type] & OA_MARK))
6319 op_null(cLISTOPo->op_first);
6321 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6322 if (kid2 && kid2->op_type == OP_COREARGS) {
6323 op_null(cLISTOPo->op_first);
6324 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6328 if (type != OP_SPLIT)
6329 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6330 * ck_split() create a real PMOP and leave the op's type as listop
6331 * for now. Otherwise op_free() etc will crash.
6333 OpTYPE_set(o, type);
6335 o->op_flags |= flags;
6336 if (flags & OPf_FOLDED)
6339 o = CHECKOP(type, o);
6340 if (o->op_type != (unsigned)type)
6343 return fold_constants(op_integerize(op_std_init(o)));
6350 =head1 Optree construction
6352 =for apidoc newNULLLIST
6354 Constructs, checks, and returns a new C<stub> op, which represents an
6355 empty list expression.
6361 Perl_newNULLLIST(pTHX)
6363 return newOP(OP_STUB, 0);
6366 /* promote o and any siblings to be a list if its not already; i.e.
6374 * pushmark - o - A - B
6376 * If nullit it true, the list op is nulled.
6380 S_force_list(pTHX_ OP *o, bool nullit)
6382 if (!o || o->op_type != OP_LIST) {
6385 /* manually detach any siblings then add them back later */
6386 rest = OpSIBLING(o);
6387 OpLASTSIB_set(o, NULL);
6389 o = newLISTOP(OP_LIST, 0, o, NULL);
6391 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6399 =for apidoc newLISTOP
6401 Constructs, checks, and returns an op of any list type. C<type> is
6402 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6403 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6404 supply up to two ops to be direct children of the list op; they are
6405 consumed by this function and become part of the constructed op tree.
6407 For most list operators, the check function expects all the kid ops to be
6408 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6409 appropriate. What you want to do in that case is create an op of type
6410 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6411 See L</op_convert_list> for more information.
6418 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6422 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6423 * pushmark is banned. So do it now while existing ops are in a
6424 * consistent state, in case they suddenly get freed */
6425 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6427 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6428 || type == OP_CUSTOM);
6430 NewOp(1101, listop, 1, LISTOP);
6431 OpTYPE_set(listop, type);
6434 listop->op_flags = (U8)flags;
6438 else if (!first && last)
6441 OpMORESIB_set(first, last);
6442 listop->op_first = first;
6443 listop->op_last = last;
6446 OpMORESIB_set(pushop, first);
6447 listop->op_first = pushop;
6448 listop->op_flags |= OPf_KIDS;
6450 listop->op_last = pushop;
6452 if (listop->op_last)
6453 OpLASTSIB_set(listop->op_last, (OP*)listop);
6455 return CHECKOP(type, listop);
6461 Constructs, checks, and returns an op of any base type (any type that
6462 has no extra fields). C<type> is the opcode. C<flags> gives the
6463 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6470 Perl_newOP(pTHX_ I32 type, I32 flags)
6475 if (type == -OP_ENTEREVAL) {
6476 type = OP_ENTEREVAL;
6477 flags |= OPpEVAL_BYTES<<8;
6480 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6481 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6482 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6483 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6485 NewOp(1101, o, 1, OP);
6486 OpTYPE_set(o, type);
6487 o->op_flags = (U8)flags;
6490 o->op_private = (U8)(0 | (flags >> 8));
6491 if (PL_opargs[type] & OA_RETSCALAR)
6493 if (PL_opargs[type] & OA_TARGET)
6494 o->op_targ = pad_alloc(type, SVs_PADTMP);
6495 return CHECKOP(type, o);
6501 Constructs, checks, and returns an op of any unary type. C<type> is
6502 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6503 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6504 bits, the eight bits of C<op_private>, except that the bit with value 1
6505 is automatically set. C<first> supplies an optional op to be the direct
6506 child of the unary op; it is consumed by this function and become part
6507 of the constructed op tree.
6509 =for apidoc Amnh||OPf_KIDS
6515 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6520 if (type == -OP_ENTEREVAL) {
6521 type = OP_ENTEREVAL;
6522 flags |= OPpEVAL_BYTES<<8;
6525 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6526 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6527 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6528 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6529 || type == OP_SASSIGN
6530 || type == OP_ENTERTRY
6531 || type == OP_CUSTOM
6532 || type == OP_NULL );
6535 first = newOP(OP_STUB, 0);
6536 if (PL_opargs[type] & OA_MARK)
6537 first = force_list(first, 1);
6539 NewOp(1101, unop, 1, UNOP);
6540 OpTYPE_set(unop, type);
6541 unop->op_first = first;
6542 unop->op_flags = (U8)(flags | OPf_KIDS);
6543 unop->op_private = (U8)(1 | (flags >> 8));
6545 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6546 OpLASTSIB_set(first, (OP*)unop);
6548 unop = (UNOP*) CHECKOP(type, unop);
6552 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6556 =for apidoc newUNOP_AUX
6558 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6559 initialised to C<aux>
6565 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6570 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6571 || type == OP_CUSTOM);
6573 NewOp(1101, unop, 1, UNOP_AUX);
6574 unop->op_type = (OPCODE)type;
6575 unop->op_ppaddr = PL_ppaddr[type];
6576 unop->op_first = first;
6577 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6578 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6581 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6582 OpLASTSIB_set(first, (OP*)unop);
6584 unop = (UNOP_AUX*) CHECKOP(type, unop);
6586 return op_std_init((OP *) unop);
6590 =for apidoc newMETHOP
6592 Constructs, checks, and returns an op of method type with a method name
6593 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6594 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6595 and, shifted up eight bits, the eight bits of C<op_private>, except that
6596 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6597 op which evaluates method name; it is consumed by this function and
6598 become part of the constructed op tree.
6599 Supported optypes: C<OP_METHOD>.
6605 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6609 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6610 || type == OP_CUSTOM);
6612 NewOp(1101, methop, 1, METHOP);
6614 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6615 methop->op_flags = (U8)(flags | OPf_KIDS);
6616 methop->op_u.op_first = dynamic_meth;
6617 methop->op_private = (U8)(1 | (flags >> 8));
6619 if (!OpHAS_SIBLING(dynamic_meth))
6620 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6624 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6625 methop->op_u.op_meth_sv = const_meth;
6626 methop->op_private = (U8)(0 | (flags >> 8));
6627 methop->op_next = (OP*)methop;
6631 methop->op_rclass_targ = 0;
6633 methop->op_rclass_sv = NULL;
6636 OpTYPE_set(methop, type);
6637 return CHECKOP(type, methop);
6641 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6642 PERL_ARGS_ASSERT_NEWMETHOP;
6643 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6647 =for apidoc newMETHOP_named
6649 Constructs, checks, and returns an op of method type with a constant
6650 method name. C<type> is the opcode. C<flags> gives the eight bits of
6651 C<op_flags>, and, shifted up eight bits, the eight bits of
6652 C<op_private>. C<const_meth> supplies a constant method name;
6653 it must be a shared COW string.
6654 Supported optypes: C<OP_METHOD_NAMED>.
6660 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6661 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6662 return newMETHOP_internal(type, flags, NULL, const_meth);
6666 =for apidoc newBINOP
6668 Constructs, checks, and returns an op of any binary type. C<type>
6669 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6670 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6671 the eight bits of C<op_private>, except that the bit with value 1 or
6672 2 is automatically set as required. C<first> and C<last> supply up to
6673 two ops to be the direct children of the binary op; they are consumed
6674 by this function and become part of the constructed op tree.
6680 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6685 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6686 || type == OP_NULL || type == OP_CUSTOM);
6688 NewOp(1101, binop, 1, BINOP);
6691 first = newOP(OP_NULL, 0);
6693 OpTYPE_set(binop, type);
6694 binop->op_first = first;
6695 binop->op_flags = (U8)(flags | OPf_KIDS);
6698 binop->op_private = (U8)(1 | (flags >> 8));
6701 binop->op_private = (U8)(2 | (flags >> 8));
6702 OpMORESIB_set(first, last);
6705 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6706 OpLASTSIB_set(last, (OP*)binop);
6708 binop->op_last = OpSIBLING(binop->op_first);
6710 OpLASTSIB_set(binop->op_last, (OP*)binop);
6712 binop = (BINOP*)CHECKOP(type, binop);
6713 if (binop->op_next || binop->op_type != (OPCODE)type)
6716 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6720 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6722 const char indent[] = " ";
6724 UV len = _invlist_len(invlist);
6725 UV * array = invlist_array(invlist);
6728 PERL_ARGS_ASSERT_INVMAP_DUMP;
6730 for (i = 0; i < len; i++) {
6731 UV start = array[i];
6732 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6734 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6735 if (end == IV_MAX) {
6736 PerlIO_printf(Perl_debug_log, " .. INFTY");
6738 else if (end != start) {
6739 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6742 PerlIO_printf(Perl_debug_log, " ");
6745 PerlIO_printf(Perl_debug_log, "\t");
6747 if (map[i] == TR_UNLISTED) {
6748 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6750 else if (map[i] == TR_SPECIAL_HANDLING) {
6751 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6754 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6759 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6760 * containing the search and replacement strings, assemble into
6761 * a translation table attached as o->op_pv.
6762 * Free expr and repl.
6763 * It expects the toker to have already set the
6764 * OPpTRANS_COMPLEMENT
6767 * flags as appropriate; this function may add
6769 * OPpTRANS_CAN_FORCE_UTF8
6770 * OPpTRANS_IDENTICAL
6776 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6778 /* This function compiles a tr///, from data gathered from toke.c, into a
6779 * form suitable for use by do_trans() in doop.c at runtime.
6781 * It first normalizes the data, while discarding extraneous inputs; then
6782 * writes out the compiled data. The normalization allows for complete
6783 * analysis, and avoids some false negatives and positives earlier versions
6786 * The normalization form is an inversion map (described below in detail).
6787 * This is essentially the compiled form for tr///'s that require UTF-8,
6788 * and its easy to use it to write the 257-byte table for tr///'s that
6789 * don't need UTF-8. That table is identical to what's been in use for
6790 * many perl versions, except that it doesn't handle some edge cases that
6791 * it used to, involving code points above 255. The UTF-8 form now handles
6792 * these. (This could be changed with extra coding should it shown to be
6795 * If the complement (/c) option is specified, the lhs string (tstr) is
6796 * parsed into an inversion list. Complementing these is trivial. Then a
6797 * complemented tstr is built from that, and used thenceforth. This hides
6798 * the fact that it was complemented from almost all successive code.
6800 * One of the important characteristics to know about the input is whether
6801 * the transliteration may be done in place, or does a temporary need to be
6802 * allocated, then copied. If the replacement for every character in every
6803 * possible string takes up no more bytes than the the character it
6804 * replaces, then it can be edited in place. Otherwise the replacement
6805 * could "grow", depending on the strings being processed. Some inputs
6806 * won't grow, and might even shrink under /d, but some inputs could grow,
6807 * so we have to assume any given one might grow. On very long inputs, the
6808 * temporary could eat up a lot of memory, so we want to avoid it if
6809 * possible. For non-UTF-8 inputs, everything is single-byte, so can be
6810 * edited in place, unless there is something in the pattern that could
6811 * force it into UTF-8. The inversion map makes it feasible to determine
6812 * this. Previous versions of this code pretty much punted on determining
6813 * if UTF-8 could be edited in place. Now, this code is rigorous in making
6814 * that determination.
6816 * Another characteristic we need to know is whether the lhs and rhs are
6817 * identical. If so, and no other flags are present, the only effect of
6818 * the tr/// is to count the characters present in the input that are
6819 * mentioned in the lhs string. The implementation of that is easier and
6820 * runs faster than the more general case. Normalizing here allows for
6821 * accurate determination of this. Previously there were false negatives
6824 * Instead of 'transliterated', the comments here use 'unmapped' for the
6825 * characters that are left unchanged by the operation; otherwise they are
6828 * The lhs of the tr/// is here referred to as the t side.
6829 * The rhs of the tr/// is here referred to as the r side.
6832 SV * const tstr = ((SVOP*)expr)->op_sv;
6833 SV * const rstr = ((SVOP*)repl)->op_sv;
6836 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
6837 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
6840 UV t_count = 0, r_count = 0; /* Number of characters in search and
6841 replacement lists */
6843 /* khw thinks some of the private flags for this op are quaintly named.
6844 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
6845 * character when represented in UTF-8 is longer than the original
6846 * character's UTF-8 representation */
6847 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6848 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6849 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6851 /* Set to true if there is some character < 256 in the lhs that maps to >
6852 * 255. If so, a non-UTF-8 match string can be forced into requiring to be
6853 * in UTF-8 by a tr/// operation. */
6854 bool can_force_utf8 = FALSE;
6856 /* What is the maximum expansion factor in UTF-8 transliterations. If a
6857 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
6858 * expansion factor is 1.5. This number is used at runtime to calculate
6859 * how much space to allocate for non-inplace transliterations. Without
6860 * this number, the worst case is 14, which is extremely unlikely to happen
6861 * in real life, and would require significant memory overhead. */
6862 NV max_expansion = 1.;
6864 UV t_range_count, r_range_count, min_range_count;
6869 UV t_cp_end = (UV) -1;
6873 UV final_map = TR_UNLISTED; /* The final character in the replacement
6874 list, updated as we go along. Initialize
6875 to something illegal */
6877 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
6878 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
6880 const U8* tend = t + tlen;
6881 const U8* rend = r + rlen;
6883 SV * inverted_tstr = NULL;
6888 /* This routine implements detection of a transliteration having a longer
6889 * UTF-8 representation than its source, by partitioning all the possible
6890 * code points of the platform into equivalence classes of the same UTF-8
6891 * byte length in the first pass. As it constructs the mappings, it carves
6892 * these up into smaller chunks, but doesn't merge any together. This
6893 * makes it easy to find the instances it's looking for. A second pass is
6894 * done after this has been determined which merges things together to
6895 * shrink the table for runtime. For ASCII platforms, the table is
6896 * trivial, given below, and uses the fundamental characteristics of UTF-8
6897 * to construct the values. For EBCDIC, it isn't so, and we rely on a
6898 * table constructed by the perl script that generates these kinds of
6901 UV PL_partition_by_byte_length[] = {
6904 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))),
6905 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))),
6906 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))),
6907 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))),
6908 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT)))
6912 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT)))
6919 PERL_ARGS_ASSERT_PMTRANS;
6921 PL_hints |= HINT_BLOCK_SCOPE;
6923 /* If /c, the search list is sorted and complemented. This is now done by
6924 * creating an inversion list from it, and then trivially inverting that.
6925 * The previous implementation used qsort, but creating the list
6926 * automatically keeps it sorted as we go along */
6929 SV * inverted_tlist = _new_invlist(tlen);
6932 DEBUG_y(PerlIO_printf(Perl_debug_log,
6933 "%s: %d: tstr before inversion=\n%s\n",
6934 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6938 /* Non-utf8 strings don't have ranges, so each character is listed
6941 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
6944 else { /* But UTF-8 strings have been parsed in toke.c to have
6945 * ranges if appropriate. */
6949 /* Get the first character */
6950 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
6953 /* If the next byte indicates that this wasn't the first
6954 * element of a range, the range is just this one */
6955 if (t >= tend || *t != RANGE_INDICATOR) {
6956 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
6958 else { /* Otherwise, ignore the indicator byte, and get the
6959 final element, and add the whole range */
6961 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
6964 inverted_tlist = _add_range_to_invlist(inverted_tlist,
6968 } /* End of parse through tstr */
6970 /* The inversion list is done; now invert it */
6971 _invlist_invert(inverted_tlist);
6973 /* Now go through the inverted list and create a new tstr for the rest
6974 * of the routine to use. Since the UTF-8 version can have ranges, and
6975 * can be much more compact than the non-UTF-8 version, we create the
6976 * string in UTF-8 even if not necessary. (This is just an intermediate
6977 * value that gets thrown away anyway.) */
6978 invlist_iterinit(inverted_tlist);
6979 inverted_tstr = newSVpvs("");
6980 while (invlist_iternext(inverted_tlist, &start, &end)) {
6981 U8 temp[UTF8_MAXBYTES];
6984 /* IV_MAX keeps things from going out of bounds */
6985 start = MIN(IV_MAX, start);
6986 end = MIN(IV_MAX, end);
6988 temp_end_pos = uvchr_to_utf8(temp, start);
6989 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6992 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
6993 temp_end_pos = uvchr_to_utf8(temp, end);
6994 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6998 /* Set up so the remainder of the routine uses this complement, instead
6999 * of the actual input */
7000 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7001 tend = t0 + temp_len;
7004 SvREFCNT_dec_NN(inverted_tlist);
7007 /* For non-/d, an empty rhs means to use the lhs */
7008 if (rlen == 0 && ! del) {
7011 rstr_utf8 = tstr_utf8;
7014 t_invlist = _new_invlist(1);
7016 /* Parse the (potentially adjusted) input, creating the inversion map.
7017 * This is done in two passes. The first pass is to determine if the
7018 * transliteration can be done in place. The inversion map it creates
7019 * could be used, but generally would be larger and slower to run than the
7020 * output of the second pass, which starts with a more compact table and
7021 * allows more ranges to be merged */
7022 for (pass2 = 0; pass2 < 2; pass2++) {
7024 /* Initialize to a single range */
7025 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7027 /* In the second pass, we just have the single range */
7031 t_array = invlist_array(t_invlist);
7035 /* But in the first pass, the lhs is partitioned such that the
7036 * number of UTF-8 bytes required to represent a code point in each
7037 * partition is the same as the number for any other code point in
7038 * that partion. We copy the pre-compiled partion. */
7039 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7040 invlist_extend(t_invlist, len);
7041 t_array = invlist_array(t_invlist);
7042 Copy(PL_partition_by_byte_length, t_array, len, UV);
7043 invlist_set_len(t_invlist,
7045 *(get_invlist_offset_addr(t_invlist)));
7046 Newx(r_map, len + 1, UV);
7049 /* And the mapping of each of the ranges is initialized. Initially,
7050 * everything is TR_UNLISTED. */
7051 for (i = 0; i < len; i++) {
7052 r_map[i] = TR_UNLISTED;
7059 t_range_count = r_range_count = 0;
7061 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7062 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7063 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7064 _byte_dump_string(r, rend - r, 0)));
7065 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7066 complement, squash, del));
7067 DEBUG_y(invmap_dump(t_invlist, r_map));
7069 /* Now go through the search list constructing an inversion map. The
7070 * input is not necessarily in any particular order. Making it an
7071 * inversion map orders it, potentially simplifying, and makes it easy
7072 * to deal with at run time. This is the only place in core that
7073 * generates an inversion map; if others were introduced, it might be
7074 * better to create general purpose routines to handle them.
7075 * (Inversion maps are created in perl in other places.)
7077 * An inversion map consists of two parallel arrays. One is
7078 * essentially an inversion list: an ordered list of code points such
7079 * that each element gives the first code point of a range of
7080 * consecutive code points that map to the element in the other array
7081 * that has the same index as this one (in other words, the
7082 * corresponding element). Thus the range extends up to (but not
7083 * including) the code point given by the next higher element. In a
7084 * true inversion map, the corresponding element in the other array
7085 * gives the mapping of the first code point in the range, with the
7086 * understanding that the next higher code point in the inversion
7087 * list's range will map to the next higher code point in the map.
7089 * So if at element [i], let's say we have:
7094 * This means that A => a, B => b, C => c.... Let's say that the
7095 * situation is such that:
7099 * This means the sequence that started at [i] stops at K => k. This
7100 * illustrates that you need to look at the next element to find where
7101 * a sequence stops. Except, the highest element in the inversion list
7102 * begins a range that is understood to extend to the platform's
7105 * This routine modifies traditional inversion maps to reserve two
7108 * TR_UNLISTED (or -1) indicates that the no code point in the range
7109 * is listed in the tr/// searchlist. At runtime, these are
7110 * always passed through unchanged. In the inversion map, all
7111 * points in the range are mapped to -1, instead of increasing,
7112 * like the 'L' in the example above.
7114 * We start the parse with every code point mapped to this, and as
7115 * we parse and find ones that are listed in the search list, we
7116 * carve out ranges as we go along that override that.
7118 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7119 * range needs special handling. Again, all code points in the
7120 * range are mapped to -2, instead of increasing.
7122 * Under /d this value means the code point should be deleted from
7123 * the transliteration when encountered.
7125 * Otherwise, it marks that every code point in the range is to
7126 * map to the final character in the replacement list. This
7127 * happens only when the replacement list is shorter than the
7128 * search one, so there are things in the search list that have no
7129 * correspondence in the replacement list. For example, in
7130 * tr/a-z/A/, 'A' is the final value, and the inversion map
7131 * generated for this would be like this:
7136 * 'A' appears once, then the remainder of the range maps to -2.
7137 * The use of -2 isn't strictly necessary, as an inversion map is
7138 * capable of representing this situation, but not nearly so
7139 * compactly, and this is actually quite commonly encountered.
7140 * Indeed, the original design of this code used a full inversion
7141 * map for this. But things like
7143 * generated huge data structures, slowly, and the execution was
7144 * also slow. So the current scheme was implemented.
7146 * So, if the next element in our example is:
7150 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
7154 * [i+4] S TR_UNLISTED
7156 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
7157 * the final element in the arrays, every code point from S to infinity
7158 * maps to TR_UNLISTED.
7161 /* Finish up range started in what otherwise would
7162 * have been the final iteration */
7163 while (t < tend || t_range_count > 0) {
7164 bool adjacent_to_range_above = FALSE;
7165 bool adjacent_to_range_below = FALSE;
7167 bool merge_with_range_above = FALSE;
7168 bool merge_with_range_below = FALSE;
7170 UV span, invmap_range_length_remaining;
7174 /* If we are in the middle of processing a range in the 'target'
7175 * side, the previous iteration has set us up. Otherwise, look at
7176 * the next character in the search list */
7177 if (t_range_count <= 0) {
7180 /* Here, not in the middle of a range, and not UTF-8. The
7181 * next code point is the single byte where we're at */
7189 /* Here, not in the middle of a range, and is UTF-8. The
7190 * next code point is the next UTF-8 char in the input. We
7191 * know the input is valid, because the toker constructed
7193 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7196 /* UTF-8 strings (only) have been parsed in toke.c to have
7197 * ranges. See if the next byte indicates that this was
7198 * the first element of a range. If so, get the final
7199 * element and calculate the range size. If not, the range
7201 if (t < tend && *t == RANGE_INDICATOR) {
7203 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7212 /* Count the total number of listed code points * */
7213 t_count += t_range_count;
7216 /* Similarly, get the next character in the replacement list */
7217 if (r_range_count <= 0) {
7220 /* But if we've exhausted the rhs, there is nothing to map
7221 * to, except the special handling one, and we make the
7222 * range the same size as the lhs one. */
7223 r_cp = TR_SPECIAL_HANDLING;
7224 r_range_count = t_range_count;
7227 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7228 "final_map =%" UVXf "\n", final_map));
7240 r_cp = valid_utf8_to_uvchr(r, &r_char_len);
7242 if (r < rend && *r == RANGE_INDICATOR) {
7244 r_range_count = valid_utf8_to_uvchr(r,
7245 &r_char_len) - r_cp + 1;
7253 if (r_cp == TR_SPECIAL_HANDLING) {
7254 r_range_count = t_range_count;
7257 /* This is the final character so far */
7258 final_map = r_cp + r_range_count - 1;
7260 r_count += r_range_count;
7264 /* Here, we have the next things ready in both sides. They are
7265 * potentially ranges. We try to process as big a chunk as
7266 * possible at once, but the lhs and rhs must be synchronized, so
7267 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7269 min_range_count = MIN(t_range_count, r_range_count);
7271 /* Search the inversion list for the entry that contains the input
7272 * code point <cp>. The inversion map was initialized to cover the
7273 * entire range of possible inputs, so this should not fail. So
7274 * the return value is the index into the list's array of the range
7275 * that contains <cp>, that is, 'i' such that array[i] <= cp <
7277 j = _invlist_search(t_invlist, t_cp);
7281 /* Here, the data structure might look like:
7284 * [i-1] J j # J-L => j-l
7285 * [i] M -1 # M => default; as do N, O, P, Q
7286 * [i+1] R x # R => x, S => x+1, T => x+2
7287 * [i+2] U y # U => y, V => y+1, ...
7289 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7291 * where 'x' and 'y' above are not to be taken literally.
7293 * The maximum chunk we can handle in this loop iteration, is the
7294 * smallest of the three components: the lhs 't_', the rhs 'r_',
7295 * and the remainder of the range in element [i]. (In pass 1, that
7296 * range will have everything in it be of the same class; we can't
7297 * cross into another class.) 'min_range_count' already contains
7298 * the smallest of the first two values. The final one is
7299 * irrelevant if the map is to the special indicator */
7301 invmap_range_length_remaining = (i + 1 < len)
7302 ? t_array[i+1] - t_cp
7304 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7306 /* The end point of this chunk is where we are, plus the span, but
7307 * never larger than the platform's infinity */
7308 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7310 if (r_cp == TR_SPECIAL_HANDLING) {
7311 r_cp_end = TR_SPECIAL_HANDLING;
7314 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7316 /* If something on the lhs is below 256, and something on the
7317 * rhs is above, there is a potential mapping here across that
7318 * boundary. Indeed the only way there isn't is if both sides
7319 * start at the same point. That means they both cross at the
7320 * same time. But otherwise one crosses before the other */
7321 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7322 can_force_utf8 = TRUE;
7326 /* If a character appears in the search list more than once, the
7327 * 2nd and succeeding occurrences are ignored, so only do this
7328 * range if haven't already processed this character. (The range
7329 * has been set up so that all members in it will be of the same
7331 if (r_map[i] == TR_UNLISTED) {
7332 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7333 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7334 t_cp, t_cp_end, r_cp, r_cp_end));
7336 /* This is the first definition for this chunk, hence is valid
7337 * and needs to be processed. Here and in the comments below,
7338 * we use the above sample data. The t_cp chunk must be any
7339 * contiguous subset of M, N, O, P, and/or Q.
7341 * In the first pass, the t_invlist has been partitioned so
7342 * that all elements in any single range have the same number
7343 * of bytes in their UTF-8 representations. And the r space is
7344 * either a single byte, or a range of strictly monotonically
7345 * increasing code points. So the final element in the range
7346 * will be represented by no fewer bytes than the initial one.
7347 * That means that if the final code point in the t range has
7348 * at least as many bytes as the final code point in the r,
7349 * then all code points in the t range have at least as many
7350 * bytes as their corresponding r range element. But if that's
7351 * not true, the transliteration of at least the final code
7352 * point grows in length. As an example, suppose we had
7353 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7354 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7355 * platforms. We have deliberately set up the data structure
7356 * so that any range in the lhs gets split into chunks for
7357 * processing, such that every code point in a chunk has the
7358 * same number of UTF-8 bytes. We only have to check the final
7359 * code point in the rhs against any code point in the lhs. */
7361 && r_cp_end != TR_SPECIAL_HANDLING
7362 && UVCHR_SKIP(t_cp_end) < UVCHR_SKIP(r_cp_end))
7364 /* Consider tr/\xCB/\X{E000}/. The maximum expansion
7365 * factor is 1 byte going to 3 if the lhs is not UTF-8, but
7366 * 2 bytes going to 3 if it is in UTF-8. We could pass two
7367 * different values so doop could choose based on the
7368 * UTF-8ness of the target. But khw thinks (perhaps
7369 * wrongly) that is overkill. It is used only to make sure
7370 * we malloc enough space. If no target string can force
7371 * the result to be UTF-8, then we don't have to worry
7373 NV t_size = (can_force_utf8 && t_cp < 256)
7375 : UVCHR_SKIP(t_cp_end);
7376 NV ratio = UVCHR_SKIP(r_cp_end) / t_size;
7378 o->op_private |= OPpTRANS_GROWS;
7380 /* Now that we know it grows, we can keep track of the
7382 if (ratio > max_expansion) {
7383 max_expansion = ratio;
7384 DEBUG_y(PerlIO_printf(Perl_debug_log,
7385 "New expansion factor: %" NVgf "\n",
7390 /* The very first range is marked as adjacent to the
7391 * non-existent range below it, as it causes things to "just
7394 * If the lowest code point in this chunk is M, it adjoins the
7396 if (t_cp == t_array[i]) {
7397 adjacent_to_range_below = TRUE;
7399 /* And if the map has the same offset from the beginning of
7400 * the range as does this new code point (or both are for
7401 * TR_SPECIAL_HANDLING), this chunk can be completely
7402 * merged with the range below. EXCEPT, in the first pass,
7403 * we don't merge ranges whose UTF-8 byte representations
7404 * have different lengths, so that we can more easily
7405 * detect if a replacement is longer than the source, that
7406 * is if it 'grows'. But in the 2nd pass, there's no
7407 * reason to not merge */
7408 if ( (i > 0 && ( pass2
7409 || UVCHR_SKIP(t_array[i-1])
7410 == UVCHR_SKIP(t_cp)))
7411 && ( ( r_cp == TR_SPECIAL_HANDLING
7412 && r_map[i-1] == TR_SPECIAL_HANDLING)
7413 || ( r_cp != TR_SPECIAL_HANDLING
7414 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7416 merge_with_range_below = TRUE;
7420 /* Similarly, if the highest code point in this chunk is 'Q',
7421 * it adjoins the range above, and if the map is suitable, can
7422 * be merged with it */
7423 if ( t_cp_end >= IV_MAX - 1
7425 && t_cp_end + 1 == t_array[i+1]))
7427 adjacent_to_range_above = TRUE;
7430 || UVCHR_SKIP(t_cp) == UVCHR_SKIP(t_array[i+1]))
7431 && ( ( r_cp == TR_SPECIAL_HANDLING
7432 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7433 || ( r_cp != TR_SPECIAL_HANDLING
7434 && r_cp_end == r_map[i+1] - 1)))
7436 merge_with_range_above = TRUE;
7440 if (merge_with_range_below && merge_with_range_above) {
7442 /* Here the new chunk looks like M => m, ... Q => q; and
7443 * the range above is like R => r, .... Thus, the [i-1]
7444 * and [i+1] ranges should be seamlessly melded so the
7447 * [i-1] J j # J-T => j-t
7448 * [i] U y # U => y, V => y+1, ...
7450 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7452 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7453 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
7455 invlist_set_len(t_invlist,
7457 *(get_invlist_offset_addr(t_invlist)));
7459 else if (merge_with_range_below) {
7461 /* Here the new chunk looks like M => m, .... But either
7462 * (or both) it doesn't extend all the way up through Q; or
7463 * the range above doesn't start with R => r. */
7464 if (! adjacent_to_range_above) {
7466 /* In the first case, let's say the new chunk extends
7467 * through O. We then want:
7469 * [i-1] J j # J-O => j-o
7470 * [i] P -1 # P => -1, Q => -1
7471 * [i+1] R x # R => x, S => x+1, T => x+2
7472 * [i+2] U y # U => y, V => y+1, ...
7474 * [-1] Z -1 # Z => default; as do Z+1, ...
7477 t_array[i] = t_cp_end + 1;
7478 r_map[i] = TR_UNLISTED;
7480 else { /* Adjoins the range above, but can't merge with it
7481 (because 'x' is not the next map after q) */
7483 * [i-1] J j # J-Q => j-q
7484 * [i] R x # R => x, S => x+1, T => x+2
7485 * [i+1] U y # U => y, V => y+1, ...
7487 * [-1] Z -1 # Z => default; as do Z+1, ...
7491 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7492 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7494 invlist_set_len(t_invlist, len,
7495 *(get_invlist_offset_addr(t_invlist)));
7498 else if (merge_with_range_above) {
7500 /* Here the new chunk ends with Q => q, and the range above
7501 * must start with R => r, so the two can be merged. But
7502 * either (or both) the new chunk doesn't extend all the
7503 * way down to M; or the mapping of the final code point
7504 * range below isn't m */
7505 if (! adjacent_to_range_below) {
7507 /* In the first case, let's assume the new chunk starts
7508 * with P => p. Then, because it's merge-able with the
7509 * range above, that range must be R => r. We want:
7511 * [i-1] J j # J-L => j-l
7512 * [i] M -1 # M => -1, N => -1
7513 * [i+1] P p # P-T => p-t
7514 * [i+2] U y # U => y, V => y+1, ...
7516 * [-1] Z -1 # Z => default; as do Z+1, ...
7519 t_array[i+1] = t_cp;
7522 else { /* Adjoins the range below, but can't merge with it
7525 * [i-1] J j # J-L => j-l
7526 * [i] M x # M-T => x-5 .. x+2
7527 * [i+1] U y # U => y, V => y+1, ...
7529 * [-1] Z -1 # Z => default; as do Z+1, ...
7532 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7533 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7537 invlist_set_len(t_invlist, len,
7538 *(get_invlist_offset_addr(t_invlist)));
7541 else if (adjacent_to_range_below && adjacent_to_range_above) {
7542 /* The new chunk completely fills the gap between the
7543 * ranges on either side, but can't merge with either of
7546 * [i-1] J j # J-L => j-l
7547 * [i] M z # M => z, N => z+1 ... Q => z+4
7548 * [i+1] R x # R => x, S => x+1, T => x+2
7549 * [i+2] U y # U => y, V => y+1, ...
7551 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7555 else if (adjacent_to_range_below) {
7556 /* The new chunk adjoins the range below, but not the range
7557 * above, and can't merge. Let's assume the chunk ends at
7560 * [i-1] J j # J-L => j-l
7561 * [i] M z # M => z, N => z+1, O => z+2
7562 * [i+1] P -1 # P => -1, Q => -1
7563 * [i+2] R x # R => x, S => x+1, T => x+2
7564 * [i+3] U y # U => y, V => y+1, ...
7566 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
7568 invlist_extend(t_invlist, len + 1);
7569 t_array = invlist_array(t_invlist);
7570 Renew(r_map, len + 1, UV);
7572 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7573 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7575 t_array[i+1] = t_cp_end + 1;
7576 r_map[i+1] = TR_UNLISTED;
7578 invlist_set_len(t_invlist, len,
7579 *(get_invlist_offset_addr(t_invlist)));
7581 else if (adjacent_to_range_above) {
7582 /* The new chunk adjoins the range above, but not the range
7583 * below, and can't merge. Let's assume the new chunk
7586 * [i-1] J j # J-L => j-l
7587 * [i] M -1 # M => default, N => default
7588 * [i+1] O z # O => z, P => z+1, Q => z+2
7589 * [i+2] R x # R => x, S => x+1, T => x+2
7590 * [i+3] U y # U => y, V => y+1, ...
7592 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7594 invlist_extend(t_invlist, len + 1);
7595 t_array = invlist_array(t_invlist);
7596 Renew(r_map, len + 1, UV);
7598 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7599 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7600 t_array[i+1] = t_cp;
7603 invlist_set_len(t_invlist, len,
7604 *(get_invlist_offset_addr(t_invlist)));
7607 /* The new chunk adjoins neither the range above, nor the
7608 * range below. Lets assume it is N..P => n..p
7610 * [i-1] J j # J-L => j-l
7611 * [i] M -1 # M => default
7612 * [i+1] N n # N..P => n..p
7613 * [i+2] Q -1 # Q => default
7614 * [i+3] R x # R => x, S => x+1, T => x+2
7615 * [i+4] U y # U => y, V => y+1, ...
7617 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7620 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7621 "Before fixing up: len=%d, i=%d\n",
7622 (int) len, (int) i));
7623 DEBUG_yv(invmap_dump(t_invlist, r_map));
7625 invlist_extend(t_invlist, len + 2);
7626 t_array = invlist_array(t_invlist);
7627 Renew(r_map, len + 2, UV);
7629 Move(t_array + i + 1,
7630 t_array + i + 2 + 1, len - i - (2 - 1), UV);
7632 r_map + i + 2 + 1, len - i - (2 - 1), UV);
7635 invlist_set_len(t_invlist, len,
7636 *(get_invlist_offset_addr(t_invlist)));
7638 t_array[i+1] = t_cp;
7641 t_array[i+2] = t_cp_end + 1;
7642 r_map[i+2] = TR_UNLISTED;
7644 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7645 "After iteration: span=%" UVuf ", t_range_count=%"
7646 UVuf " r_range_count=%" UVuf "\n",
7647 span, t_range_count, r_range_count));
7648 DEBUG_yv(invmap_dump(t_invlist, r_map));
7649 } /* End of this chunk needs to be processed */
7651 /* Done with this chunk. */
7653 if (t_cp >= IV_MAX) {
7656 t_range_count -= span;
7657 if (r_cp != TR_SPECIAL_HANDLING) {
7659 r_range_count -= span;
7665 } /* End of loop through the search list */
7667 /* We don't need an exact count, but we do need to know if there is
7668 * anything left over in the replacement list. So, just assume it's
7669 * one byte per character */
7673 } /* End of passes */
7675 SvREFCNT_dec(inverted_tstr);
7677 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7678 DEBUG_y(invmap_dump(t_invlist, r_map));
7680 /* We now have normalized the input into an inversion map.
7682 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7683 * except for the count, and streamlined runtime code can be used */
7684 if (!del && !squash) {
7686 /* They are identical if they point to same address, or if everything
7687 * maps to UNLISTED or to itself. This catches things that not looking
7688 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7689 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7691 for (i = 0; i < len; i++) {
7692 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7693 goto done_identical_check;
7698 /* Here have gone through entire list, and didn't find any
7699 * non-identical mappings */
7700 o->op_private |= OPpTRANS_IDENTICAL;
7702 done_identical_check: ;
7705 t_array = invlist_array(t_invlist);
7707 /* If has components above 255, we generally need to use the inversion map
7711 && t_array[len-1] > 255
7712 /* If the final range is 0x100-INFINITY and is a special
7713 * mapping, the table implementation can handle it */
7714 && ! ( t_array[len-1] == 256
7715 && ( r_map[len-1] == TR_UNLISTED
7716 || r_map[len-1] == TR_SPECIAL_HANDLING))))
7720 /* A UTF-8 op is generated, indicated by this flag. This op is an
7722 o->op_private |= OPpTRANS_USE_SVOP;
7724 if (can_force_utf8) {
7725 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7728 /* The inversion map is pushed; first the list. */
7729 invmap = MUTABLE_AV(newAV());
7730 av_push(invmap, t_invlist);
7732 /* 2nd is the mapping */
7733 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7734 av_push(invmap, r_map_sv);
7736 /* 3rd is the max possible expansion factor */
7737 av_push(invmap, newSVnv(max_expansion));
7739 /* Characters that are in the search list, but not in the replacement
7740 * list are mapped to the final character in the replacement list */
7741 if (! del && r_count < t_count) {
7742 av_push(invmap, newSVuv(final_map));
7746 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7747 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7748 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7749 SvPADTMP_on(invmap);
7750 SvREADONLY_on(invmap);
7752 cSVOPo->op_sv = (SV *) invmap;
7760 /* The OPtrans_map struct already contains one slot; hence the -1. */
7761 SSize_t struct_size = sizeof(OPtrans_map)
7762 + (256 - 1 + 1)*sizeof(short);
7764 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7765 * table. Entries with the value TR_UNMAPPED indicate chars not to be
7766 * translated, while TR_DELETE indicates a search char without a
7767 * corresponding replacement char under /d.
7769 * In addition, an extra slot at the end is used to store the final
7770 * repeating char, or TR_R_EMPTY under an empty replacement list, or
7771 * TR_DELETE under /d; which makes the runtime code easier.
7774 /* Indicate this is an op_pv */
7775 o->op_private &= ~OPpTRANS_USE_SVOP;
7777 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7779 cPVOPo->op_pv = (char*)tbl;
7781 for (i = 0; i < len; i++) {
7782 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7783 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7784 short to = (short) r_map[i];
7786 bool do_increment = TRUE;
7788 /* Any code points above our limit should be irrelevant */
7789 if (t_array[i] >= tbl->size) break;
7791 /* Set up the map */
7792 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7793 to = (short) final_map;
7794 do_increment = FALSE;
7797 do_increment = FALSE;
7800 /* Create a map for everything in this range. The value increases
7801 * except for the special cases */
7802 for (j = (short) t_array[i]; j < upper; j++) {
7804 if (do_increment) to++;
7808 tbl->map[tbl->size] = del
7812 : (short) TR_R_EMPTY;
7813 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
7814 for (i = 0; i < tbl->size; i++) {
7815 if (tbl->map[i] < 0) {
7816 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
7817 (unsigned) i, tbl->map[i]));
7820 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
7821 (unsigned) i, tbl->map[i]));
7823 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
7824 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
7827 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
7828 (unsigned) tbl->size, tbl->map[tbl->size]));
7830 SvREFCNT_dec(t_invlist);
7832 #if 0 /* code that added excess above-255 chars at the end of the table, in
7833 case we ever want to not use the inversion map implementation for
7840 /* More replacement chars than search chars:
7841 * store excess replacement chars at end of main table.
7844 struct_size += excess;
7845 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
7846 struct_size + excess * sizeof(short));
7847 tbl->size += excess;
7848 cPVOPo->op_pv = (char*)tbl;
7850 for (i = 0; i < excess; i++)
7851 tbl->map[i + 256] = r[j+i];
7854 /* no more replacement chars than search chars */
7859 DEBUG_y(PerlIO_printf(Perl_debug_log,
7860 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
7861 " use_svop=%d, can_force_utf8=%d,\nexpansion=%g\n",
7862 del, squash, complement,
7863 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
7864 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
7865 cBOOL(o->op_private & OPpTRANS_GROWS),
7866 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
7871 if(del && rlen != 0 && r_count == t_count) {
7872 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7873 } else if(r_count > t_count) {
7874 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7887 Constructs, checks, and returns an op of any pattern matching type.
7888 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
7889 and, shifted up eight bits, the eight bits of C<op_private>.
7895 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7900 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7901 || type == OP_CUSTOM);
7903 NewOp(1101, pmop, 1, PMOP);
7904 OpTYPE_set(pmop, type);
7905 pmop->op_flags = (U8)flags;
7906 pmop->op_private = (U8)(0 | (flags >> 8));
7907 if (PL_opargs[type] & OA_RETSCALAR)
7910 if (PL_hints & HINT_RE_TAINT)
7911 pmop->op_pmflags |= PMf_RETAINT;
7912 #ifdef USE_LOCALE_CTYPE
7913 if (IN_LC_COMPILETIME(LC_CTYPE)) {
7914 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7919 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7921 if (PL_hints & HINT_RE_FLAGS) {
7922 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7923 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7925 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7926 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7927 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7929 if (reflags && SvOK(reflags)) {
7930 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7936 assert(SvPOK(PL_regex_pad[0]));
7937 if (SvCUR(PL_regex_pad[0])) {
7938 /* Pop off the "packed" IV from the end. */
7939 SV *const repointer_list = PL_regex_pad[0];
7940 const char *p = SvEND(repointer_list) - sizeof(IV);
7941 const IV offset = *((IV*)p);
7943 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7945 SvEND_set(repointer_list, p);
7947 pmop->op_pmoffset = offset;
7948 /* This slot should be free, so assert this: */
7949 assert(PL_regex_pad[offset] == &PL_sv_undef);
7951 SV * const repointer = &PL_sv_undef;
7952 av_push(PL_regex_padav, repointer);
7953 pmop->op_pmoffset = av_tindex(PL_regex_padav);
7954 PL_regex_pad = AvARRAY(PL_regex_padav);
7958 return CHECKOP(type, pmop);
7966 /* Any pad names in scope are potentially lvalues. */
7967 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7968 PADNAME *pn = PAD_COMPNAME_SV(i);
7969 if (!pn || !PadnameLEN(pn))
7971 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7972 S_mark_padname_lvalue(aTHX_ pn);
7976 /* Given some sort of match op o, and an expression expr containing a
7977 * pattern, either compile expr into a regex and attach it to o (if it's
7978 * constant), or convert expr into a runtime regcomp op sequence (if it's
7981 * Flags currently has 2 bits of meaning:
7982 * 1: isreg indicates that the pattern is part of a regex construct, eg
7983 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7984 * split "pattern", which aren't. In the former case, expr will be a list
7985 * if the pattern contains more than one term (eg /a$b/).
7986 * 2: The pattern is for a split.
7988 * When the pattern has been compiled within a new anon CV (for
7989 * qr/(?{...})/ ), then floor indicates the savestack level just before
7990 * the new sub was created
7992 * tr/// is also handled.
7996 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8000 I32 repl_has_vars = 0;
8001 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8002 bool is_compiletime;
8004 bool isreg = cBOOL(flags & 1);
8005 bool is_split = cBOOL(flags & 2);
8007 PERL_ARGS_ASSERT_PMRUNTIME;
8010 return pmtrans(o, expr, repl);
8013 /* find whether we have any runtime or code elements;
8014 * at the same time, temporarily set the op_next of each DO block;
8015 * then when we LINKLIST, this will cause the DO blocks to be excluded
8016 * from the op_next chain (and from having LINKLIST recursively
8017 * applied to them). We fix up the DOs specially later */
8021 if (expr->op_type == OP_LIST) {
8023 for (this_o = cLISTOPx(expr)->op_first; this_o; this_o = OpSIBLING(this_o)) {
8024 if (this_o->op_type == OP_NULL && (this_o->op_flags & OPf_SPECIAL)) {
8026 assert(!this_o->op_next);
8027 if (UNLIKELY(!OpHAS_SIBLING(this_o))) {
8028 assert(PL_parser && PL_parser->error_count);
8029 /* This can happen with qr/ (?{(^{})/. Just fake up
8030 the op we were expecting to see, to avoid crashing
8032 op_sibling_splice(expr, this_o, 0,
8033 newSVOP(OP_CONST, 0, &PL_sv_no));
8035 this_o->op_next = OpSIBLING(this_o);
8037 else if (this_o->op_type != OP_CONST && this_o->op_type != OP_PUSHMARK)
8041 else if (expr->op_type != OP_CONST)
8046 /* fix up DO blocks; treat each one as a separate little sub;
8047 * also, mark any arrays as LIST/REF */
8049 if (expr->op_type == OP_LIST) {
8051 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
8053 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
8054 assert( !(o->op_flags & OPf_WANT));
8055 /* push the array rather than its contents. The regex
8056 * engine will retrieve and join the elements later */
8057 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
8061 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
8063 o->op_next = NULL; /* undo temporary hack from above */
8066 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
8067 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
8069 assert(leaveop->op_first->op_type == OP_ENTER);
8070 assert(OpHAS_SIBLING(leaveop->op_first));
8071 o->op_next = OpSIBLING(leaveop->op_first);
8073 assert(leaveop->op_flags & OPf_KIDS);
8074 assert(leaveop->op_last->op_next == (OP*)leaveop);
8075 leaveop->op_next = NULL; /* stop on last op */
8076 op_null((OP*)leaveop);
8080 OP *scope = cLISTOPo->op_first;
8081 assert(scope->op_type == OP_SCOPE);
8082 assert(scope->op_flags & OPf_KIDS);
8083 scope->op_next = NULL; /* stop on last op */
8087 /* XXX optimize_optree() must be called on o before
8088 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8089 * currently cope with a peephole-optimised optree.
8090 * Calling optimize_optree() here ensures that condition
8091 * is met, but may mean optimize_optree() is applied
8092 * to the same optree later (where hopefully it won't do any
8093 * harm as it can't convert an op to multiconcat if it's
8094 * already been converted */
8097 /* have to peep the DOs individually as we've removed it from
8098 * the op_next chain */
8100 S_prune_chain_head(&(o->op_next));
8102 /* runtime finalizes as part of finalizing whole tree */
8106 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8107 assert( !(expr->op_flags & OPf_WANT));
8108 /* push the array rather than its contents. The regex
8109 * engine will retrieve and join the elements later */
8110 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8113 PL_hints |= HINT_BLOCK_SCOPE;
8115 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8117 if (is_compiletime) {
8118 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8119 regexp_engine const *eng = current_re_engine();
8122 /* make engine handle split ' ' specially */
8123 pm->op_pmflags |= PMf_SPLIT;
8124 rx_flags |= RXf_SPLIT;
8127 if (!has_code || !eng->op_comp) {
8128 /* compile-time simple constant pattern */
8130 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8131 /* whoops! we guessed that a qr// had a code block, but we
8132 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8133 * that isn't required now. Note that we have to be pretty
8134 * confident that nothing used that CV's pad while the
8135 * regex was parsed, except maybe op targets for \Q etc.
8136 * If there were any op targets, though, they should have
8137 * been stolen by constant folding.
8141 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8142 while (++i <= AvFILLp(PL_comppad)) {
8143 # ifdef USE_PAD_RESET
8144 /* under USE_PAD_RESET, pad swipe replaces a swiped
8145 * folded constant with a fresh padtmp */
8146 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8148 assert(!PL_curpad[i]);
8152 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8153 * outer CV (the one whose slab holds the pm op). The
8154 * inner CV (which holds expr) will be freed later, once
8155 * all the entries on the parse stack have been popped on
8156 * return from this function. Which is why its safe to
8157 * call op_free(expr) below.
8160 pm->op_pmflags &= ~PMf_HAS_CV;
8163 /* Skip compiling if parser found an error for this pattern */
8164 if (pm->op_pmflags & PMf_HAS_ERROR) {
8170 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8171 rx_flags, pm->op_pmflags)
8172 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8173 rx_flags, pm->op_pmflags)
8178 /* compile-time pattern that includes literal code blocks */
8182 /* Skip compiling if parser found an error for this pattern */
8183 if (pm->op_pmflags & PMf_HAS_ERROR) {
8187 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8190 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8193 if (pm->op_pmflags & PMf_HAS_CV) {
8195 /* this QR op (and the anon sub we embed it in) is never
8196 * actually executed. It's just a placeholder where we can
8197 * squirrel away expr in op_code_list without the peephole
8198 * optimiser etc processing it for a second time */
8199 OP *qr = newPMOP(OP_QR, 0);
8200 ((PMOP*)qr)->op_code_list = expr;
8202 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8203 SvREFCNT_inc_simple_void(PL_compcv);
8204 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8205 ReANY(re)->qr_anoncv = cv;
8207 /* attach the anon CV to the pad so that
8208 * pad_fixup_inner_anons() can find it */
8209 (void)pad_add_anon(cv, o->op_type);
8210 SvREFCNT_inc_simple_void(cv);
8213 pm->op_code_list = expr;
8218 /* runtime pattern: build chain of regcomp etc ops */
8220 PADOFFSET cv_targ = 0;
8222 reglist = isreg && expr->op_type == OP_LIST;
8227 pm->op_code_list = expr;
8228 /* don't free op_code_list; its ops are embedded elsewhere too */
8229 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8233 /* make engine handle split ' ' specially */
8234 pm->op_pmflags |= PMf_SPLIT;
8236 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8237 * to allow its op_next to be pointed past the regcomp and
8238 * preceding stacking ops;
8239 * OP_REGCRESET is there to reset taint before executing the
8241 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8242 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8244 if (pm->op_pmflags & PMf_HAS_CV) {
8245 /* we have a runtime qr with literal code. This means
8246 * that the qr// has been wrapped in a new CV, which
8247 * means that runtime consts, vars etc will have been compiled
8248 * against a new pad. So... we need to execute those ops
8249 * within the environment of the new CV. So wrap them in a call
8250 * to a new anon sub. i.e. for
8254 * we build an anon sub that looks like
8256 * sub { "a", $b, '(?{...})' }
8258 * and call it, passing the returned list to regcomp.
8259 * Or to put it another way, the list of ops that get executed
8263 * ------ -------------------
8264 * pushmark (for regcomp)
8265 * pushmark (for entersub)
8269 * regcreset regcreset
8271 * const("a") const("a")
8273 * const("(?{...})") const("(?{...})")
8278 SvREFCNT_inc_simple_void(PL_compcv);
8279 CvLVALUE_on(PL_compcv);
8280 /* these lines are just an unrolled newANONATTRSUB */
8281 expr = newSVOP(OP_ANONCODE, 0,
8282 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8283 cv_targ = expr->op_targ;
8284 expr = newUNOP(OP_REFGEN, 0, expr);
8286 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
8289 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8290 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8291 | (reglist ? OPf_STACKED : 0);
8292 rcop->op_targ = cv_targ;
8294 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
8295 if (PL_hints & HINT_RE_EVAL)
8296 S_set_haseval(aTHX);
8298 /* establish postfix order */
8299 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8301 rcop->op_next = expr;
8302 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8305 rcop->op_next = LINKLIST(expr);
8306 expr->op_next = (OP*)rcop;
8309 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8315 /* If we are looking at s//.../e with a single statement, get past
8316 the implicit do{}. */
8317 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8318 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8319 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8322 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8323 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8324 && !OpHAS_SIBLING(sib))
8327 if (curop->op_type == OP_CONST)
8329 else if (( (curop->op_type == OP_RV2SV ||
8330 curop->op_type == OP_RV2AV ||
8331 curop->op_type == OP_RV2HV ||
8332 curop->op_type == OP_RV2GV)
8333 && cUNOPx(curop)->op_first
8334 && cUNOPx(curop)->op_first->op_type == OP_GV )
8335 || curop->op_type == OP_PADSV
8336 || curop->op_type == OP_PADAV
8337 || curop->op_type == OP_PADHV
8338 || curop->op_type == OP_PADANY) {
8346 || !RX_PRELEN(PM_GETRE(pm))
8347 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8349 pm->op_pmflags |= PMf_CONST; /* const for long enough */
8350 op_prepend_elem(o->op_type, scalar(repl), o);
8353 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8354 rcop->op_private = 1;
8356 /* establish postfix order */
8357 rcop->op_next = LINKLIST(repl);
8358 repl->op_next = (OP*)rcop;
8360 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8361 assert(!(pm->op_pmflags & PMf_ONCE));
8362 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8373 Constructs, checks, and returns an op of any type that involves an
8374 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
8375 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
8376 takes ownership of one reference to it.
8382 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8387 PERL_ARGS_ASSERT_NEWSVOP;
8389 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8390 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8391 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8392 || type == OP_CUSTOM);
8394 NewOp(1101, svop, 1, SVOP);
8395 OpTYPE_set(svop, type);
8397 svop->op_next = (OP*)svop;
8398 svop->op_flags = (U8)flags;
8399 svop->op_private = (U8)(0 | (flags >> 8));
8400 if (PL_opargs[type] & OA_RETSCALAR)
8402 if (PL_opargs[type] & OA_TARGET)
8403 svop->op_targ = pad_alloc(type, SVs_PADTMP);
8404 return CHECKOP(type, svop);
8408 =for apidoc newDEFSVOP
8410 Constructs and returns an op to access C<$_>.
8416 Perl_newDEFSVOP(pTHX)
8418 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8424 =for apidoc newPADOP
8426 Constructs, checks, and returns an op of any type that involves a
8427 reference to a pad element. C<type> is the opcode. C<flags> gives the
8428 eight bits of C<op_flags>. A pad slot is automatically allocated, and
8429 is populated with C<sv>; this function takes ownership of one reference
8432 This function only exists if Perl has been compiled to use ithreads.
8438 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8443 PERL_ARGS_ASSERT_NEWPADOP;
8445 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8446 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8447 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8448 || type == OP_CUSTOM);
8450 NewOp(1101, padop, 1, PADOP);
8451 OpTYPE_set(padop, type);
8453 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8454 SvREFCNT_dec(PAD_SVl(padop->op_padix));
8455 PAD_SETSV(padop->op_padix, sv);
8457 padop->op_next = (OP*)padop;
8458 padop->op_flags = (U8)flags;
8459 if (PL_opargs[type] & OA_RETSCALAR)
8461 if (PL_opargs[type] & OA_TARGET)
8462 padop->op_targ = pad_alloc(type, SVs_PADTMP);
8463 return CHECKOP(type, padop);
8466 #endif /* USE_ITHREADS */
8471 Constructs, checks, and returns an op of any type that involves an
8472 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
8473 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
8474 reference; calling this function does not transfer ownership of any
8481 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8483 PERL_ARGS_ASSERT_NEWGVOP;
8486 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8488 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8495 Constructs, checks, and returns an op of any type that involves an
8496 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
8497 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
8498 Depending on the op type, the memory referenced by C<pv> may be freed
8499 when the op is destroyed. If the op is of a freeing type, C<pv> must
8500 have been allocated using C<PerlMemShared_malloc>.
8506 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8509 const bool utf8 = cBOOL(flags & SVf_UTF8);
8514 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8515 || type == OP_RUNCV || type == OP_CUSTOM
8516 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8518 NewOp(1101, pvop, 1, PVOP);
8519 OpTYPE_set(pvop, type);
8521 pvop->op_next = (OP*)pvop;
8522 pvop->op_flags = (U8)flags;
8523 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8524 if (PL_opargs[type] & OA_RETSCALAR)
8526 if (PL_opargs[type] & OA_TARGET)
8527 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8528 return CHECKOP(type, pvop);
8532 Perl_package(pTHX_ OP *o)
8534 SV *const sv = cSVOPo->op_sv;
8536 PERL_ARGS_ASSERT_PACKAGE;
8538 SAVEGENERICSV(PL_curstash);
8539 save_item(PL_curstname);
8541 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8543 sv_setsv(PL_curstname, sv);
8545 PL_hints |= HINT_BLOCK_SCOPE;
8546 PL_parser->copline = NOLINE;
8552 Perl_package_version( pTHX_ OP *v )
8554 U32 savehints = PL_hints;
8555 PERL_ARGS_ASSERT_PACKAGE_VERSION;
8556 PL_hints &= ~HINT_STRICT_VARS;
8557 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8558 PL_hints = savehints;
8563 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8568 SV *use_version = NULL;
8570 PERL_ARGS_ASSERT_UTILIZE;
8572 if (idop->op_type != OP_CONST)
8573 Perl_croak(aTHX_ "Module name must be constant");
8578 SV * const vesv = ((SVOP*)version)->op_sv;
8580 if (!arg && !SvNIOKp(vesv)) {
8587 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8588 Perl_croak(aTHX_ "Version number must be a constant number");
8590 /* Make copy of idop so we don't free it twice */
8591 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8593 /* Fake up a method call to VERSION */
8594 meth = newSVpvs_share("VERSION");
8595 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8596 op_append_elem(OP_LIST,
8597 op_prepend_elem(OP_LIST, pack, version),
8598 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8602 /* Fake up an import/unimport */
8603 if (arg && arg->op_type == OP_STUB) {
8604 imop = arg; /* no import on explicit () */
8606 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8607 imop = NULL; /* use 5.0; */
8609 use_version = ((SVOP*)idop)->op_sv;
8611 idop->op_private |= OPpCONST_NOVER;
8616 /* Make copy of idop so we don't free it twice */
8617 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8619 /* Fake up a method call to import/unimport */
8621 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8622 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8623 op_append_elem(OP_LIST,
8624 op_prepend_elem(OP_LIST, pack, arg),
8625 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8629 /* Fake up the BEGIN {}, which does its thing immediately. */
8631 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8634 op_append_elem(OP_LINESEQ,
8635 op_append_elem(OP_LINESEQ,
8636 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8637 newSTATEOP(0, NULL, veop)),
8638 newSTATEOP(0, NULL, imop) ));
8642 * feature bundle that corresponds to the required version. */
8643 use_version = sv_2mortal(new_version(use_version));
8644 S_enable_feature_bundle(aTHX_ use_version);
8646 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8647 if (vcmp(use_version,
8648 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
8649 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8650 PL_hints |= HINT_STRICT_REFS;
8651 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8652 PL_hints |= HINT_STRICT_SUBS;
8653 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8654 PL_hints |= HINT_STRICT_VARS;
8656 /* otherwise they are off */
8658 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8659 PL_hints &= ~HINT_STRICT_REFS;
8660 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8661 PL_hints &= ~HINT_STRICT_SUBS;
8662 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8663 PL_hints &= ~HINT_STRICT_VARS;
8667 /* The "did you use incorrect case?" warning used to be here.
8668 * The problem is that on case-insensitive filesystems one
8669 * might get false positives for "use" (and "require"):
8670 * "use Strict" or "require CARP" will work. This causes
8671 * portability problems for the script: in case-strict
8672 * filesystems the script will stop working.
8674 * The "incorrect case" warning checked whether "use Foo"
8675 * imported "Foo" to your namespace, but that is wrong, too:
8676 * there is no requirement nor promise in the language that
8677 * a Foo.pm should or would contain anything in package "Foo".
8679 * There is very little Configure-wise that can be done, either:
8680 * the case-sensitivity of the build filesystem of Perl does not
8681 * help in guessing the case-sensitivity of the runtime environment.
8684 PL_hints |= HINT_BLOCK_SCOPE;
8685 PL_parser->copline = NOLINE;
8686 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8690 =head1 Embedding Functions
8692 =for apidoc load_module
8694 Loads the module whose name is pointed to by the string part of C<name>.
8695 Note that the actual module name, not its filename, should be given.
8696 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8697 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8698 trailing arguments can be used to specify arguments to the module's C<import()>
8699 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8700 on the flags. The flags argument is a bitwise-ORed collection of any of
8701 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8702 (or 0 for no flags).
8704 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8705 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8706 the trailing optional arguments may be omitted entirely. Otherwise, if
8707 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8708 exactly one C<OP*>, containing the op tree that produces the relevant import
8709 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8710 will be used as import arguments; and the list must be terminated with C<(SV*)
8711 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8712 set, the trailing C<NULL> pointer is needed even if no import arguments are
8713 desired. The reference count for each specified C<SV*> argument is
8714 decremented. In addition, the C<name> argument is modified.
8716 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8719 =for apidoc Amnh||PERL_LOADMOD_DENY
8720 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8721 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8726 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8730 PERL_ARGS_ASSERT_LOAD_MODULE;
8732 va_start(args, ver);
8733 vload_module(flags, name, ver, &args);
8737 #ifdef PERL_IMPLICIT_CONTEXT
8739 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8743 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8744 va_start(args, ver);
8745 vload_module(flags, name, ver, &args);
8751 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8757 PERL_ARGS_ASSERT_VLOAD_MODULE;
8759 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8760 * that it has a PL_parser to play with while doing that, and also
8761 * that it doesn't mess with any existing parser, by creating a tmp
8762 * new parser with lex_start(). This won't actually be used for much,
8763 * since pp_require() will create another parser for the real work.
8764 * The ENTER/LEAVE pair protect callers from any side effects of use.
8766 * start_subparse() creates a new PL_compcv. This means that any ops
8767 * allocated below will be allocated from that CV's op slab, and so
8768 * will be automatically freed if the utilise() fails
8772 SAVEVPTR(PL_curcop);
8773 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8774 floor = start_subparse(FALSE, 0);
8776 modname = newSVOP(OP_CONST, 0, name);
8777 modname->op_private |= OPpCONST_BARE;
8779 veop = newSVOP(OP_CONST, 0, ver);
8783 if (flags & PERL_LOADMOD_NOIMPORT) {
8784 imop = sawparens(newNULLLIST());
8786 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8787 imop = va_arg(*args, OP*);
8792 sv = va_arg(*args, SV*);
8794 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8795 sv = va_arg(*args, SV*);
8799 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8803 PERL_STATIC_INLINE OP *
8804 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8806 return newUNOP(OP_ENTERSUB, OPf_STACKED,
8807 newLISTOP(OP_LIST, 0, arg,
8808 newUNOP(OP_RV2CV, 0,
8809 newGVOP(OP_GV, 0, gv))));
8813 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8818 PERL_ARGS_ASSERT_DOFILE;
8820 if (!force_builtin && (gv = gv_override("do", 2))) {
8821 doop = S_new_entersubop(aTHX_ gv, term);
8824 doop = newUNOP(OP_DOFILE, 0, scalar(term));
8830 =head1 Optree construction
8832 =for apidoc newSLICEOP
8834 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
8835 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8836 be set automatically, and, shifted up eight bits, the eight bits of
8837 C<op_private>, except that the bit with value 1 or 2 is automatically
8838 set as required. C<listval> and C<subscript> supply the parameters of
8839 the slice; they are consumed by this function and become part of the
8840 constructed op tree.
8846 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8848 return newBINOP(OP_LSLICE, flags,
8849 list(force_list(subscript, 1)),
8850 list(force_list(listval, 1)) );
8853 #define ASSIGN_SCALAR 0
8854 #define ASSIGN_LIST 1
8855 #define ASSIGN_REF 2
8857 /* given the optree o on the LHS of an assignment, determine whether its:
8858 * ASSIGN_SCALAR $x = ...
8859 * ASSIGN_LIST ($x) = ...
8860 * ASSIGN_REF \$x = ...
8864 S_assignment_type(pTHX_ const OP *o)
8873 if (o->op_type == OP_SREFGEN)
8875 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8876 type = kid->op_type;
8877 flags = o->op_flags | kid->op_flags;
8878 if (!(flags & OPf_PARENS)
8879 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8880 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8884 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8885 o = cUNOPo->op_first;
8886 flags = o->op_flags;
8888 ret = ASSIGN_SCALAR;
8891 if (type == OP_COND_EXPR) {
8892 OP * const sib = OpSIBLING(cLOGOPo->op_first);
8893 const I32 t = assignment_type(sib);
8894 const I32 f = assignment_type(OpSIBLING(sib));
8896 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8898 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8899 yyerror("Assignment to both a list and a scalar");
8900 return ASSIGN_SCALAR;
8903 if (type == OP_LIST &&
8904 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8905 o->op_private & OPpLVAL_INTRO)
8908 if (type == OP_LIST || flags & OPf_PARENS ||
8909 type == OP_RV2AV || type == OP_RV2HV ||
8910 type == OP_ASLICE || type == OP_HSLICE ||
8911 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8914 if (type == OP_PADAV || type == OP_PADHV)
8917 if (type == OP_RV2SV)
8924 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8927 const PADOFFSET target = padop->op_targ;
8928 OP *const other = newOP(OP_PADSV,
8930 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8931 OP *const first = newOP(OP_NULL, 0);
8932 OP *const nullop = newCONDOP(0, first, initop, other);
8933 /* XXX targlex disabled for now; see ticket #124160
8934 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8936 OP *const condop = first->op_next;
8938 OpTYPE_set(condop, OP_ONCE);
8939 other->op_targ = target;
8940 nullop->op_flags |= OPf_WANT_SCALAR;
8942 /* Store the initializedness of state vars in a separate
8945 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8946 /* hijacking PADSTALE for uninitialized state variables */
8947 SvPADSTALE_on(PAD_SVl(condop->op_targ));
8953 =for apidoc newASSIGNOP
8955 Constructs, checks, and returns an assignment op. C<left> and C<right>
8956 supply the parameters of the assignment; they are consumed by this
8957 function and become part of the constructed op tree.
8959 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8960 a suitable conditional optree is constructed. If C<optype> is the opcode
8961 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8962 performs the binary operation and assigns the result to the left argument.
8963 Either way, if C<optype> is non-zero then C<flags> has no effect.
8965 If C<optype> is zero, then a plain scalar or list assignment is
8966 constructed. Which type of assignment it is is automatically determined.
8967 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8968 will be set automatically, and, shifted up eight bits, the eight bits
8969 of C<op_private>, except that the bit with value 1 or 2 is automatically
8976 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8982 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
8983 right = scalar(right);
8984 return newLOGOP(optype, 0,
8985 op_lvalue(scalar(left), optype),
8986 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8989 return newBINOP(optype, OPf_STACKED,
8990 op_lvalue(scalar(left), optype), scalar(right));
8994 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8995 OP *state_var_op = NULL;
8996 static const char no_list_state[] = "Initialization of state variables"
8997 " in list currently forbidden";
9000 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9001 left->op_private &= ~ OPpSLICEWARNING;
9004 left = op_lvalue(left, OP_AASSIGN);
9005 curop = list(force_list(left, 1));
9006 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
9007 o->op_private = (U8)(0 | (flags >> 8));
9009 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9011 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9012 if (!(left->op_flags & OPf_PARENS) &&
9013 lop->op_type == OP_PUSHMARK &&
9014 (vop = OpSIBLING(lop)) &&
9015 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9016 !(vop->op_flags & OPf_PARENS) &&
9017 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9018 (OPpLVAL_INTRO|OPpPAD_STATE) &&
9019 (eop = OpSIBLING(vop)) &&
9020 eop->op_type == OP_ENTERSUB &&
9021 !OpHAS_SIBLING(eop)) {
9025 if ((lop->op_type == OP_PADSV ||
9026 lop->op_type == OP_PADAV ||
9027 lop->op_type == OP_PADHV ||
9028 lop->op_type == OP_PADANY)
9029 && (lop->op_private & OPpPAD_STATE)
9031 yyerror(no_list_state);
9032 lop = OpSIBLING(lop);
9036 else if ( (left->op_private & OPpLVAL_INTRO)
9037 && (left->op_private & OPpPAD_STATE)
9038 && ( left->op_type == OP_PADSV
9039 || left->op_type == OP_PADAV
9040 || left->op_type == OP_PADHV
9041 || left->op_type == OP_PADANY)
9043 /* All single variable list context state assignments, hence
9053 if (left->op_flags & OPf_PARENS)
9054 yyerror(no_list_state);
9056 state_var_op = left;
9059 /* optimise @a = split(...) into:
9060 * @{expr}: split(..., @{expr}) (where @a is not flattened)
9061 * @a, my @a, local @a: split(...) (where @a is attached to
9062 * the split op itself)
9066 && right->op_type == OP_SPLIT
9067 /* don't do twice, e.g. @b = (@a = split) */
9068 && !(right->op_private & OPpSPLIT_ASSIGN))
9072 if ( ( left->op_type == OP_RV2AV
9073 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9074 || left->op_type == OP_PADAV)
9076 /* @pkg or @lex or local @pkg' or 'my @lex' */
9080 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9081 = cPADOPx(gvop)->op_padix;
9082 cPADOPx(gvop)->op_padix = 0; /* steal it */
9084 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9085 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9086 cSVOPx(gvop)->op_sv = NULL; /* steal it */
9088 right->op_private |=
9089 left->op_private & OPpOUR_INTRO;
9092 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9093 left->op_targ = 0; /* steal it */
9094 right->op_private |= OPpSPLIT_LEX;
9096 right->op_private |= left->op_private & OPpLVAL_INTRO;
9099 tmpop = cUNOPo->op_first; /* to list (nulled) */
9100 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9101 assert(OpSIBLING(tmpop) == right);
9102 assert(!OpHAS_SIBLING(right));
9103 /* detach the split subtreee from the o tree,
9104 * then free the residual o tree */
9105 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9106 op_free(o); /* blow off assign */
9107 right->op_private |= OPpSPLIT_ASSIGN;
9108 right->op_flags &= ~OPf_WANT;
9109 /* "I don't know and I don't care." */
9112 else if (left->op_type == OP_RV2AV) {
9115 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9116 assert(OpSIBLING(pushop) == left);
9117 /* Detach the array ... */
9118 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9119 /* ... and attach it to the split. */
9120 op_sibling_splice(right, cLISTOPx(right)->op_last,
9122 right->op_flags |= OPf_STACKED;
9123 /* Detach split and expunge aassign as above. */
9126 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9127 ((LISTOP*)right)->op_last->op_type == OP_CONST)
9129 /* convert split(...,0) to split(..., PL_modcount+1) */
9131 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9132 SV * const sv = *svp;
9133 if (SvIOK(sv) && SvIVX(sv) == 0)
9135 if (right->op_private & OPpSPLIT_IMPLIM) {
9136 /* our own SV, created in ck_split */
9138 sv_setiv(sv, PL_modcount+1);
9141 /* SV may belong to someone else */
9143 *svp = newSViv(PL_modcount+1);
9150 o = S_newONCEOP(aTHX_ o, state_var_op);
9153 if (assign_type == ASSIGN_REF)
9154 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9156 right = newOP(OP_UNDEF, 0);
9157 if (right->op_type == OP_READLINE) {
9158 right->op_flags |= OPf_STACKED;
9159 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9163 o = newBINOP(OP_SASSIGN, flags,
9164 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9170 =for apidoc newSTATEOP
9172 Constructs a state op (COP). The state op is normally a C<nextstate> op,
9173 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9174 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9175 If C<label> is non-null, it supplies the name of a label to attach to
9176 the state op; this function takes ownership of the memory pointed at by
9177 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
9180 If C<o> is null, the state op is returned. Otherwise the state op is
9181 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
9182 is consumed by this function and becomes part of the returned op tree.
9188 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9191 const U32 seq = intro_my();
9192 const U32 utf8 = flags & SVf_UTF8;
9195 PL_parser->parsed_sub = 0;
9199 NewOp(1101, cop, 1, COP);
9200 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9201 OpTYPE_set(cop, OP_DBSTATE);
9204 OpTYPE_set(cop, OP_NEXTSTATE);
9206 cop->op_flags = (U8)flags;
9207 CopHINTS_set(cop, PL_hints);
9209 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9211 cop->op_next = (OP*)cop;
9214 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9215 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9217 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9219 PL_hints |= HINT_BLOCK_SCOPE;
9220 /* It seems that we need to defer freeing this pointer, as other parts
9221 of the grammar end up wanting to copy it after this op has been
9226 if (PL_parser->preambling != NOLINE) {
9227 CopLINE_set(cop, PL_parser->preambling);
9228 PL_parser->copline = NOLINE;
9230 else if (PL_parser->copline == NOLINE)
9231 CopLINE_set(cop, CopLINE(PL_curcop));
9233 CopLINE_set(cop, PL_parser->copline);
9234 PL_parser->copline = NOLINE;
9237 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
9239 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9241 CopSTASH_set(cop, PL_curstash);
9243 if (cop->op_type == OP_DBSTATE) {
9244 /* this line can have a breakpoint - store the cop in IV */
9245 AV *av = CopFILEAVx(PL_curcop);
9247 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9248 if (svp && *svp != &PL_sv_undef ) {
9249 (void)SvIOK_on(*svp);
9250 SvIV_set(*svp, PTR2IV(cop));
9255 if (flags & OPf_SPECIAL)
9257 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9261 =for apidoc newLOGOP
9263 Constructs, checks, and returns a logical (flow control) op. C<type>
9264 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
9265 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9266 the eight bits of C<op_private>, except that the bit with value 1 is
9267 automatically set. C<first> supplies the expression controlling the
9268 flow, and C<other> supplies the side (alternate) chain of ops; they are
9269 consumed by this function and become part of the constructed op tree.
9275 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9277 PERL_ARGS_ASSERT_NEWLOGOP;
9279 return new_logop(type, flags, &first, &other);
9283 /* See if the optree o contains a single OP_CONST (plus possibly
9284 * surrounding enter/nextstate/null etc). If so, return it, else return
9289 S_search_const(pTHX_ OP *o)
9291 PERL_ARGS_ASSERT_SEARCH_CONST;
9294 switch (o->op_type) {
9298 if (o->op_flags & OPf_KIDS) {
9299 o = cUNOPo->op_first;
9308 if (!(o->op_flags & OPf_KIDS))
9310 kid = cLISTOPo->op_first;
9313 switch (kid->op_type) {
9317 kid = OpSIBLING(kid);
9320 if (kid != cLISTOPo->op_last)
9327 kid = cLISTOPo->op_last;
9339 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9347 int prepend_not = 0;
9349 PERL_ARGS_ASSERT_NEW_LOGOP;
9354 /* [perl #59802]: Warn about things like "return $a or $b", which
9355 is parsed as "(return $a) or $b" rather than "return ($a or
9356 $b)". NB: This also applies to xor, which is why we do it
9359 switch (first->op_type) {
9363 /* XXX: Perhaps we should emit a stronger warning for these.
9364 Even with the high-precedence operator they don't seem to do
9367 But until we do, fall through here.
9373 /* XXX: Currently we allow people to "shoot themselves in the
9374 foot" by explicitly writing "(return $a) or $b".
9376 Warn unless we are looking at the result from folding or if
9377 the programmer explicitly grouped the operators like this.
9378 The former can occur with e.g.
9380 use constant FEATURE => ( $] >= ... );
9381 sub { not FEATURE and return or do_stuff(); }
9383 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9384 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9385 "Possible precedence issue with control flow operator");
9386 /* XXX: Should we optimze this to "return $a;" (i.e. remove
9392 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
9393 return newBINOP(type, flags, scalar(first), scalar(other));
9395 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9396 || type == OP_CUSTOM);
9398 scalarboolean(first);
9400 /* search for a constant op that could let us fold the test */
9401 if ((cstop = search_const(first))) {
9402 if (cstop->op_private & OPpCONST_STRICT)
9403 no_bareword_allowed(cstop);
9404 else if ((cstop->op_private & OPpCONST_BARE))
9405 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9406 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
9407 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9408 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9409 /* Elide the (constant) lhs, since it can't affect the outcome */
9411 if (other->op_type == OP_CONST)
9412 other->op_private |= OPpCONST_SHORTCIRCUIT;
9414 if (other->op_type == OP_LEAVE)
9415 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9416 else if (other->op_type == OP_MATCH
9417 || other->op_type == OP_SUBST
9418 || other->op_type == OP_TRANSR
9419 || other->op_type == OP_TRANS)
9420 /* Mark the op as being unbindable with =~ */
9421 other->op_flags |= OPf_SPECIAL;
9423 other->op_folded = 1;
9427 /* Elide the rhs, since the outcome is entirely determined by
9428 * the (constant) lhs */
9430 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9431 const OP *o2 = other;
9432 if ( ! (o2->op_type == OP_LIST
9433 && (( o2 = cUNOPx(o2)->op_first))
9434 && o2->op_type == OP_PUSHMARK
9435 && (( o2 = OpSIBLING(o2))) )
9438 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9439 || o2->op_type == OP_PADHV)
9440 && o2->op_private & OPpLVAL_INTRO
9441 && !(o2->op_private & OPpPAD_STATE))
9443 Perl_croak(aTHX_ "This use of my() in false conditional is "
9444 "no longer allowed");
9448 if (cstop->op_type == OP_CONST)
9449 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9454 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9455 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9457 const OP * const k1 = ((UNOP*)first)->op_first;
9458 const OP * const k2 = OpSIBLING(k1);
9460 switch (first->op_type)
9463 if (k2 && k2->op_type == OP_READLINE
9464 && (k2->op_flags & OPf_STACKED)
9465 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9467 warnop = k2->op_type;
9472 if (k1->op_type == OP_READDIR
9473 || k1->op_type == OP_GLOB
9474 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9475 || k1->op_type == OP_EACH
9476 || k1->op_type == OP_AEACH)
9478 warnop = ((k1->op_type == OP_NULL)
9479 ? (OPCODE)k1->op_targ : k1->op_type);
9484 const line_t oldline = CopLINE(PL_curcop);
9485 /* This ensures that warnings are reported at the first line
9486 of the construction, not the last. */
9487 CopLINE_set(PL_curcop, PL_parser->copline);
9488 Perl_warner(aTHX_ packWARN(WARN_MISC),
9489 "Value of %s%s can be \"0\"; test with defined()",
9491 ((warnop == OP_READLINE || warnop == OP_GLOB)
9492 ? " construct" : "() operator"));
9493 CopLINE_set(PL_curcop, oldline);
9497 /* optimize AND and OR ops that have NOTs as children */
9498 if (first->op_type == OP_NOT
9499 && (first->op_flags & OPf_KIDS)
9500 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9501 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
9503 if (type == OP_AND || type == OP_OR) {
9509 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9511 prepend_not = 1; /* prepend a NOT op later */
9516 logop = alloc_LOGOP(type, first, LINKLIST(other));
9517 logop->op_flags |= (U8)flags;
9518 logop->op_private = (U8)(1 | (flags >> 8));
9520 /* establish postfix order */
9521 logop->op_next = LINKLIST(first);
9522 first->op_next = (OP*)logop;
9523 assert(!OpHAS_SIBLING(first));
9524 op_sibling_splice((OP*)logop, first, 0, other);
9526 CHECKOP(type,logop);
9528 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9529 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9537 =for apidoc newCONDOP
9539 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9540 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9541 will be set automatically, and, shifted up eight bits, the eight bits of
9542 C<op_private>, except that the bit with value 1 is automatically set.
9543 C<first> supplies the expression selecting between the two branches,
9544 and C<trueop> and C<falseop> supply the branches; they are consumed by
9545 this function and become part of the constructed op tree.
9551 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9559 PERL_ARGS_ASSERT_NEWCONDOP;
9562 return newLOGOP(OP_AND, 0, first, trueop);
9564 return newLOGOP(OP_OR, 0, first, falseop);
9566 scalarboolean(first);
9567 if ((cstop = search_const(first))) {
9568 /* Left or right arm of the conditional? */
9569 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9570 OP *live = left ? trueop : falseop;
9571 OP *const dead = left ? falseop : trueop;
9572 if (cstop->op_private & OPpCONST_BARE &&
9573 cstop->op_private & OPpCONST_STRICT) {
9574 no_bareword_allowed(cstop);
9578 if (live->op_type == OP_LEAVE)
9579 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9580 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9581 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9582 /* Mark the op as being unbindable with =~ */
9583 live->op_flags |= OPf_SPECIAL;
9584 live->op_folded = 1;
9587 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9588 logop->op_flags |= (U8)flags;
9589 logop->op_private = (U8)(1 | (flags >> 8));
9590 logop->op_next = LINKLIST(falseop);
9592 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9595 /* establish postfix order */
9596 start = LINKLIST(first);
9597 first->op_next = (OP*)logop;
9599 /* make first, trueop, falseop siblings */
9600 op_sibling_splice((OP*)logop, first, 0, trueop);
9601 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9603 o = newUNOP(OP_NULL, 0, (OP*)logop);
9605 trueop->op_next = falseop->op_next = o;
9612 =for apidoc newRANGE
9614 Constructs and returns a C<range> op, with subordinate C<flip> and
9615 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
9616 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9617 for both the C<flip> and C<range> ops, except that the bit with value
9618 1 is automatically set. C<left> and C<right> supply the expressions
9619 controlling the endpoints of the range; they are consumed by this function
9620 and become part of the constructed op tree.
9626 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9634 PERL_ARGS_ASSERT_NEWRANGE;
9636 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9637 range->op_flags = OPf_KIDS;
9638 leftstart = LINKLIST(left);
9639 range->op_private = (U8)(1 | (flags >> 8));
9641 /* make left and right siblings */
9642 op_sibling_splice((OP*)range, left, 0, right);
9644 range->op_next = (OP*)range;
9645 flip = newUNOP(OP_FLIP, flags, (OP*)range);
9646 flop = newUNOP(OP_FLOP, 0, flip);
9647 o = newUNOP(OP_NULL, 0, flop);
9649 range->op_next = leftstart;
9651 left->op_next = flip;
9652 right->op_next = flop;
9655 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9656 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9658 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9659 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9660 SvPADTMP_on(PAD_SV(flip->op_targ));
9662 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9663 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9665 /* check barewords before they might be optimized aways */
9666 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9667 no_bareword_allowed(left);
9668 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9669 no_bareword_allowed(right);
9672 if (!flip->op_private || !flop->op_private)
9673 LINKLIST(o); /* blow off optimizer unless constant */
9679 =for apidoc newLOOPOP
9681 Constructs, checks, and returns an op tree expressing a loop. This is
9682 only a loop in the control flow through the op tree; it does not have
9683 the heavyweight loop structure that allows exiting the loop by C<last>
9684 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9685 top-level op, except that some bits will be set automatically as required.
9686 C<expr> supplies the expression controlling loop iteration, and C<block>
9687 supplies the body of the loop; they are consumed by this function and
9688 become part of the constructed op tree. C<debuggable> is currently
9689 unused and should always be 1.
9695 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9699 const bool once = block && block->op_flags & OPf_SPECIAL &&
9700 block->op_type == OP_NULL;
9702 PERL_UNUSED_ARG(debuggable);
9706 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
9707 || ( expr->op_type == OP_NOT
9708 && cUNOPx(expr)->op_first->op_type == OP_CONST
9709 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9712 /* Return the block now, so that S_new_logop does not try to
9716 return block; /* do {} while 0 does once */
9719 if (expr->op_type == OP_READLINE
9720 || expr->op_type == OP_READDIR
9721 || expr->op_type == OP_GLOB
9722 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9723 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9724 expr = newUNOP(OP_DEFINED, 0,
9725 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9726 } else if (expr->op_flags & OPf_KIDS) {
9727 const OP * const k1 = ((UNOP*)expr)->op_first;
9728 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9729 switch (expr->op_type) {
9731 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9732 && (k2->op_flags & OPf_STACKED)
9733 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9734 expr = newUNOP(OP_DEFINED, 0, expr);
9738 if (k1 && (k1->op_type == OP_READDIR
9739 || k1->op_type == OP_GLOB
9740 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9741 || k1->op_type == OP_EACH
9742 || k1->op_type == OP_AEACH))
9743 expr = newUNOP(OP_DEFINED, 0, expr);
9749 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9750 * op, in listop. This is wrong. [perl #27024] */
9752 block = newOP(OP_NULL, 0);
9753 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9754 o = new_logop(OP_AND, 0, &expr, &listop);
9761 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9763 if (once && o != listop)
9765 assert(cUNOPo->op_first->op_type == OP_AND
9766 || cUNOPo->op_first->op_type == OP_OR);
9767 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9771 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9773 o->op_flags |= flags;
9775 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9780 =for apidoc newWHILEOP
9782 Constructs, checks, and returns an op tree expressing a C<while> loop.
9783 This is a heavyweight loop, with structure that allows exiting the loop
9784 by C<last> and suchlike.
9786 C<loop> is an optional preconstructed C<enterloop> op to use in the
9787 loop; if it is null then a suitable op will be constructed automatically.
9788 C<expr> supplies the loop's controlling expression. C<block> supplies the
9789 main body of the loop, and C<cont> optionally supplies a C<continue> block
9790 that operates as a second half of the body. All of these optree inputs
9791 are consumed by this function and become part of the constructed op tree.
9793 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9794 op and, shifted up eight bits, the eight bits of C<op_private> for
9795 the C<leaveloop> op, except that (in both cases) some bits will be set
9796 automatically. C<debuggable> is currently unused and should always be 1.
9797 C<has_my> can be supplied as true to force the
9798 loop body to be enclosed in its own scope.
9804 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9805 OP *expr, OP *block, OP *cont, I32 has_my)
9814 PERL_UNUSED_ARG(debuggable);
9817 if (expr->op_type == OP_READLINE
9818 || expr->op_type == OP_READDIR
9819 || expr->op_type == OP_GLOB
9820 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9821 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9822 expr = newUNOP(OP_DEFINED, 0,
9823 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9824 } else if (expr->op_flags & OPf_KIDS) {
9825 const OP * const k1 = ((UNOP*)expr)->op_first;
9826 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9827 switch (expr->op_type) {
9829 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9830 && (k2->op_flags & OPf_STACKED)
9831 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9832 expr = newUNOP(OP_DEFINED, 0, expr);
9836 if (k1 && (k1->op_type == OP_READDIR
9837 || k1->op_type == OP_GLOB
9838 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9839 || k1->op_type == OP_EACH
9840 || k1->op_type == OP_AEACH))
9841 expr = newUNOP(OP_DEFINED, 0, expr);
9848 block = newOP(OP_NULL, 0);
9849 else if (cont || has_my) {
9850 block = op_scope(block);
9854 next = LINKLIST(cont);
9857 OP * const unstack = newOP(OP_UNSTACK, 0);
9860 cont = op_append_elem(OP_LINESEQ, cont, unstack);
9864 listop = op_append_list(OP_LINESEQ, block, cont);
9866 redo = LINKLIST(listop);
9870 o = new_logop(OP_AND, 0, &expr, &listop);
9871 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9873 return expr; /* listop already freed by new_logop */
9876 ((LISTOP*)listop)->op_last->op_next =
9877 (o == listop ? redo : LINKLIST(o));
9883 NewOp(1101,loop,1,LOOP);
9884 OpTYPE_set(loop, OP_ENTERLOOP);
9885 loop->op_private = 0;
9886 loop->op_next = (OP*)loop;
9889 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9891 loop->op_redoop = redo;
9892 loop->op_lastop = o;
9893 o->op_private |= loopflags;
9896 loop->op_nextop = next;
9898 loop->op_nextop = o;
9900 o->op_flags |= flags;
9901 o->op_private |= (flags >> 8);
9906 =for apidoc newFOROP
9908 Constructs, checks, and returns an op tree expressing a C<foreach>
9909 loop (iteration through a list of values). This is a heavyweight loop,
9910 with structure that allows exiting the loop by C<last> and suchlike.
9912 C<sv> optionally supplies the variable that will be aliased to each
9913 item in turn; if null, it defaults to C<$_>.
9914 C<expr> supplies the list of values to iterate over. C<block> supplies
9915 the main body of the loop, and C<cont> optionally supplies a C<continue>
9916 block that operates as a second half of the body. All of these optree
9917 inputs are consumed by this function and become part of the constructed
9920 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9921 op and, shifted up eight bits, the eight bits of C<op_private> for
9922 the C<leaveloop> op, except that (in both cases) some bits will be set
9929 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9934 PADOFFSET padoff = 0;
9938 PERL_ARGS_ASSERT_NEWFOROP;
9941 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
9942 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9943 OpTYPE_set(sv, OP_RV2GV);
9945 /* The op_type check is needed to prevent a possible segfault
9946 * if the loop variable is undeclared and 'strict vars' is in
9947 * effect. This is illegal but is nonetheless parsed, so we
9948 * may reach this point with an OP_CONST where we're expecting
9951 if (cUNOPx(sv)->op_first->op_type == OP_GV
9952 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9953 iterpflags |= OPpITER_DEF;
9955 else if (sv->op_type == OP_PADSV) { /* private variable */
9956 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9957 padoff = sv->op_targ;
9961 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9963 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9966 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9968 PADNAME * const pn = PAD_COMPNAME(padoff);
9969 const char * const name = PadnamePV(pn);
9971 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9972 iterpflags |= OPpITER_DEF;
9976 sv = newGVOP(OP_GV, 0, PL_defgv);
9977 iterpflags |= OPpITER_DEF;
9980 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9981 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
9982 iterflags |= OPf_STACKED;
9984 else if (expr->op_type == OP_NULL &&
9985 (expr->op_flags & OPf_KIDS) &&
9986 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
9988 /* Basically turn for($x..$y) into the same as for($x,$y), but we
9989 * set the STACKED flag to indicate that these values are to be
9990 * treated as min/max values by 'pp_enteriter'.
9992 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
9993 LOGOP* const range = (LOGOP*) flip->op_first;
9994 OP* const left = range->op_first;
9995 OP* const right = OpSIBLING(left);
9998 range->op_flags &= ~OPf_KIDS;
9999 /* detach range's children */
10000 op_sibling_splice((OP*)range, NULL, -1, NULL);
10002 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10003 listop->op_first->op_next = range->op_next;
10004 left->op_next = range->op_other;
10005 right->op_next = (OP*)listop;
10006 listop->op_next = listop->op_first;
10009 expr = (OP*)(listop);
10011 iterflags |= OPf_STACKED;
10014 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
10017 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10018 op_append_elem(OP_LIST, list(expr),
10020 assert(!loop->op_next);
10021 /* for my $x () sets OPpLVAL_INTRO;
10022 * for our $x () sets OPpOUR_INTRO */
10023 loop->op_private = (U8)iterpflags;
10025 /* upgrade loop from a LISTOP to a LOOPOP;
10026 * keep it in-place if there's space */
10027 if (loop->op_slabbed
10028 && OpSLOT(loop)->opslot_size
10029 < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
10031 /* no space; allocate new op */
10033 NewOp(1234,tmp,1,LOOP);
10034 Copy(loop,tmp,1,LISTOP);
10035 assert(loop->op_last->op_sibparent == (OP*)loop);
10036 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10037 S_op_destroy(aTHX_ (OP*)loop);
10040 else if (!loop->op_slabbed)
10042 /* loop was malloc()ed */
10043 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10044 OpLASTSIB_set(loop->op_last, (OP*)loop);
10046 loop->op_targ = padoff;
10047 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
10052 =for apidoc newLOOPEX
10054 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10055 or C<last>). C<type> is the opcode. C<label> supplies the parameter
10056 determining the target of the op; it is consumed by this function and
10057 becomes part of the constructed op tree.
10063 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10067 PERL_ARGS_ASSERT_NEWLOOPEX;
10069 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10070 || type == OP_CUSTOM);
10072 if (type != OP_GOTO) {
10073 /* "last()" means "last" */
10074 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10075 o = newOP(type, OPf_SPECIAL);
10079 /* Check whether it's going to be a goto &function */
10080 if (label->op_type == OP_ENTERSUB
10081 && !(label->op_flags & OPf_STACKED))
10082 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10085 /* Check for a constant argument */
10086 if (label->op_type == OP_CONST) {
10087 SV * const sv = ((SVOP *)label)->op_sv;
10089 const char *s = SvPV_const(sv,l);
10090 if (l == strlen(s)) {
10092 SvUTF8(((SVOP*)label)->op_sv),
10094 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10098 /* If we have already created an op, we do not need the label. */
10101 else o = newUNOP(type, OPf_STACKED, label);
10103 PL_hints |= HINT_BLOCK_SCOPE;
10107 /* if the condition is a literal array or hash
10108 (or @{ ... } etc), make a reference to it.
10111 S_ref_array_or_hash(pTHX_ OP *cond)
10114 && (cond->op_type == OP_RV2AV
10115 || cond->op_type == OP_PADAV
10116 || cond->op_type == OP_RV2HV
10117 || cond->op_type == OP_PADHV))
10119 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10122 && (cond->op_type == OP_ASLICE
10123 || cond->op_type == OP_KVASLICE
10124 || cond->op_type == OP_HSLICE
10125 || cond->op_type == OP_KVHSLICE)) {
10127 /* anonlist now needs a list from this op, was previously used in
10128 * scalar context */
10129 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10130 cond->op_flags |= OPf_WANT_LIST;
10132 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10139 /* These construct the optree fragments representing given()
10142 entergiven and enterwhen are LOGOPs; the op_other pointer
10143 points up to the associated leave op. We need this so we
10144 can put it in the context and make break/continue work.
10145 (Also, of course, pp_enterwhen will jump straight to
10146 op_other if the match fails.)
10150 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10151 I32 enter_opcode, I32 leave_opcode,
10152 PADOFFSET entertarg)
10158 PERL_ARGS_ASSERT_NEWGIVWHENOP;
10159 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10161 enterop = alloc_LOGOP(enter_opcode, block, NULL);
10162 enterop->op_targ = 0;
10163 enterop->op_private = 0;
10165 o = newUNOP(leave_opcode, 0, (OP *) enterop);
10168 /* prepend cond if we have one */
10169 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10171 o->op_next = LINKLIST(cond);
10172 cond->op_next = (OP *) enterop;
10175 /* This is a default {} block */
10176 enterop->op_flags |= OPf_SPECIAL;
10177 o ->op_flags |= OPf_SPECIAL;
10179 o->op_next = (OP *) enterop;
10182 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10183 entergiven and enterwhen both
10186 enterop->op_next = LINKLIST(block);
10187 block->op_next = enterop->op_other = o;
10193 /* For the purposes of 'when(implied_smartmatch)'
10194 * versus 'when(boolean_expression)',
10195 * does this look like a boolean operation? For these purposes
10196 a boolean operation is:
10197 - a subroutine call [*]
10198 - a logical connective
10199 - a comparison operator
10200 - a filetest operator, with the exception of -s -M -A -C
10201 - defined(), exists() or eof()
10202 - /$re/ or $foo =~ /$re/
10204 [*] possibly surprising
10207 S_looks_like_bool(pTHX_ const OP *o)
10209 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10211 switch(o->op_type) {
10214 return looks_like_bool(cLOGOPo->op_first);
10218 OP* sibl = OpSIBLING(cLOGOPo->op_first);
10221 looks_like_bool(cLOGOPo->op_first)
10222 && looks_like_bool(sibl));
10228 o->op_flags & OPf_KIDS
10229 && looks_like_bool(cUNOPo->op_first));
10233 case OP_NOT: case OP_XOR:
10235 case OP_EQ: case OP_NE: case OP_LT:
10236 case OP_GT: case OP_LE: case OP_GE:
10238 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
10239 case OP_I_GT: case OP_I_LE: case OP_I_GE:
10241 case OP_SEQ: case OP_SNE: case OP_SLT:
10242 case OP_SGT: case OP_SLE: case OP_SGE:
10244 case OP_SMARTMATCH:
10246 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
10247 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
10248 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
10249 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
10250 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
10251 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
10252 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
10253 case OP_FTTEXT: case OP_FTBINARY:
10255 case OP_DEFINED: case OP_EXISTS:
10256 case OP_MATCH: case OP_EOF:
10264 /* optimised-away (index() != -1) or similar comparison */
10265 if (o->op_private & OPpTRUEBOOL)
10270 /* Detect comparisons that have been optimized away */
10271 if (cSVOPo->op_sv == &PL_sv_yes
10272 || cSVOPo->op_sv == &PL_sv_no)
10285 =for apidoc newGIVENOP
10287 Constructs, checks, and returns an op tree expressing a C<given> block.
10288 C<cond> supplies the expression to whose value C<$_> will be locally
10289 aliased, and C<block> supplies the body of the C<given> construct; they
10290 are consumed by this function and become part of the constructed op tree.
10291 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10297 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10299 PERL_ARGS_ASSERT_NEWGIVENOP;
10300 PERL_UNUSED_ARG(defsv_off);
10302 assert(!defsv_off);
10303 return newGIVWHENOP(
10304 ref_array_or_hash(cond),
10306 OP_ENTERGIVEN, OP_LEAVEGIVEN,
10311 =for apidoc newWHENOP
10313 Constructs, checks, and returns an op tree expressing a C<when> block.
10314 C<cond> supplies the test expression, and C<block> supplies the block
10315 that will be executed if the test evaluates to true; they are consumed
10316 by this function and become part of the constructed op tree. C<cond>
10317 will be interpreted DWIMically, often as a comparison against C<$_>,
10318 and may be null to generate a C<default> block.
10324 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10326 const bool cond_llb = (!cond || looks_like_bool(cond));
10329 PERL_ARGS_ASSERT_NEWWHENOP;
10334 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10336 scalar(ref_array_or_hash(cond)));
10339 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10342 /* must not conflict with SVf_UTF8 */
10343 #define CV_CKPROTO_CURSTASH 0x1
10346 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10347 const STRLEN len, const U32 flags)
10349 SV *name = NULL, *msg;
10350 const char * cvp = SvROK(cv)
10351 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10352 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10355 STRLEN clen = CvPROTOLEN(cv), plen = len;
10357 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10359 if (p == NULL && cvp == NULL)
10362 if (!ckWARN_d(WARN_PROTOTYPE))
10366 p = S_strip_spaces(aTHX_ p, &plen);
10367 cvp = S_strip_spaces(aTHX_ cvp, &clen);
10368 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10369 if (plen == clen && memEQ(cvp, p, plen))
10372 if (flags & SVf_UTF8) {
10373 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10377 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10383 msg = sv_newmortal();
10388 gv_efullname3(name = sv_newmortal(), gv, NULL);
10389 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10390 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10391 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10392 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10393 sv_catpvs(name, "::");
10395 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10396 assert (CvNAMED(SvRV_const(gv)));
10397 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10399 else sv_catsv(name, (SV *)gv);
10401 else name = (SV *)gv;
10403 sv_setpvs(msg, "Prototype mismatch:");
10405 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10407 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10408 UTF8fARG(SvUTF8(cv),clen,cvp)
10411 sv_catpvs(msg, ": none");
10412 sv_catpvs(msg, " vs ");
10414 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10416 sv_catpvs(msg, "none");
10417 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10420 static void const_sv_xsub(pTHX_ CV* cv);
10421 static void const_av_xsub(pTHX_ CV* cv);
10425 =head1 Optree Manipulation Functions
10427 =for apidoc cv_const_sv
10429 If C<cv> is a constant sub eligible for inlining, returns the constant
10430 value returned by the sub. Otherwise, returns C<NULL>.
10432 Constant subs can be created with C<newCONSTSUB> or as described in
10433 L<perlsub/"Constant Functions">.
10438 Perl_cv_const_sv(const CV *const cv)
10443 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10445 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10446 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10451 Perl_cv_const_sv_or_av(const CV * const cv)
10455 if (SvROK(cv)) return SvRV((SV *)cv);
10456 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10457 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10460 /* op_const_sv: examine an optree to determine whether it's in-lineable.
10461 * Can be called in 2 ways:
10464 * look for a single OP_CONST with attached value: return the value
10466 * allow_lex && !CvCONST(cv);
10468 * examine the clone prototype, and if contains only a single
10469 * OP_CONST, return the value; or if it contains a single PADSV ref-
10470 * erencing an outer lexical, turn on CvCONST to indicate the CV is
10471 * a candidate for "constizing" at clone time, and return NULL.
10475 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10478 bool padsv = FALSE;
10483 for (; o; o = o->op_next) {
10484 const OPCODE type = o->op_type;
10486 if (type == OP_NEXTSTATE || type == OP_LINESEQ
10488 || type == OP_PUSHMARK)
10490 if (type == OP_DBSTATE)
10492 if (type == OP_LEAVESUB)
10496 if (type == OP_CONST && cSVOPo->op_sv)
10497 sv = cSVOPo->op_sv;
10498 else if (type == OP_UNDEF && !o->op_private) {
10502 else if (allow_lex && type == OP_PADSV) {
10503 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
10505 sv = &PL_sv_undef; /* an arbitrary non-null value */
10523 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10524 PADNAME * const name, SV ** const const_svp)
10527 assert (o || name);
10528 assert (const_svp);
10530 if (CvFLAGS(PL_compcv)) {
10531 /* might have had built-in attrs applied */
10532 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10533 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10534 && ckWARN(WARN_MISC))
10536 /* protect against fatal warnings leaking compcv */
10537 SAVEFREESV(PL_compcv);
10538 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10539 SvREFCNT_inc_simple_void_NN(PL_compcv);
10542 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10543 & ~(CVf_LVALUE * pureperl));
10548 /* redundant check for speed: */
10549 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10550 const line_t oldline = CopLINE(PL_curcop);
10553 : sv_2mortal(newSVpvn_utf8(
10554 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
10556 if (PL_parser && PL_parser->copline != NOLINE)
10557 /* This ensures that warnings are reported at the first
10558 line of a redefinition, not the last. */
10559 CopLINE_set(PL_curcop, PL_parser->copline);
10560 /* protect against fatal warnings leaking compcv */
10561 SAVEFREESV(PL_compcv);
10562 report_redefined_cv(namesv, cv, const_svp);
10563 SvREFCNT_inc_simple_void_NN(PL_compcv);
10564 CopLINE_set(PL_curcop, oldline);
10571 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10576 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10579 CV *compcv = PL_compcv;
10582 PADOFFSET pax = o->op_targ;
10583 CV *outcv = CvOUTSIDE(PL_compcv);
10586 bool reusable = FALSE;
10588 #ifdef PERL_DEBUG_READONLY_OPS
10589 OPSLAB *slab = NULL;
10592 PERL_ARGS_ASSERT_NEWMYSUB;
10594 PL_hints |= HINT_BLOCK_SCOPE;
10596 /* Find the pad slot for storing the new sub.
10597 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10598 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10599 ing sub. And then we need to dig deeper if this is a lexical from
10601 my sub foo; sub { sub foo { } }
10604 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10605 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10606 pax = PARENT_PAD_INDEX(name);
10607 outcv = CvOUTSIDE(outcv);
10612 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10613 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10614 spot = (CV **)svspot;
10616 if (!(PL_parser && PL_parser->error_count))
10617 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10620 assert(proto->op_type == OP_CONST);
10621 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10622 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10632 if (PL_parser && PL_parser->error_count) {
10634 SvREFCNT_dec(PL_compcv);
10639 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10641 svspot = (SV **)(spot = &clonee);
10643 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10646 assert (SvTYPE(*spot) == SVt_PVCV);
10647 if (CvNAMED(*spot))
10648 hek = CvNAME_HEK(*spot);
10652 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10653 CvNAME_HEK_set(*spot, hek =
10656 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10660 CvLEXICAL_on(*spot);
10662 cv = PadnamePROTOCV(name);
10663 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10667 /* This makes sub {}; work as expected. */
10668 if (block->op_type == OP_STUB) {
10669 const line_t l = PL_parser->copline;
10671 block = newSTATEOP(0, NULL, 0);
10672 PL_parser->copline = l;
10674 block = CvLVALUE(compcv)
10675 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10676 ? newUNOP(OP_LEAVESUBLV, 0,
10677 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10678 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10679 start = LINKLIST(block);
10680 block->op_next = 0;
10681 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10682 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10690 const bool exists = CvROOT(cv) || CvXSUB(cv);
10692 /* if the subroutine doesn't exist and wasn't pre-declared
10693 * with a prototype, assume it will be AUTOLOADed,
10694 * skipping the prototype check
10696 if (exists || SvPOK(cv))
10697 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10699 /* already defined? */
10701 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10707 /* just a "sub foo;" when &foo is already defined */
10708 SAVEFREESV(compcv);
10712 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10719 SvREFCNT_inc_simple_void_NN(const_sv);
10720 SvFLAGS(const_sv) |= SVs_PADTMP;
10722 assert(!CvROOT(cv) && !CvCONST(cv));
10723 cv_forget_slab(cv);
10726 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10727 CvFILE_set_from_cop(cv, PL_curcop);
10728 CvSTASH_set(cv, PL_curstash);
10731 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10732 CvXSUBANY(cv).any_ptr = const_sv;
10733 CvXSUB(cv) = const_sv_xsub;
10737 CvFLAGS(cv) |= CvMETHOD(compcv);
10739 SvREFCNT_dec(compcv);
10744 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10745 determine whether this sub definition is in the same scope as its
10746 declaration. If this sub definition is inside an inner named pack-
10747 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10748 the package sub. So check PadnameOUTER(name) too.
10750 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10751 assert(!CvWEAKOUTSIDE(compcv));
10752 SvREFCNT_dec(CvOUTSIDE(compcv));
10753 CvWEAKOUTSIDE_on(compcv);
10755 /* XXX else do we have a circular reference? */
10757 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10758 /* transfer PL_compcv to cv */
10760 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10761 cv_flags_t preserved_flags =
10762 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10763 PADLIST *const temp_padl = CvPADLIST(cv);
10764 CV *const temp_cv = CvOUTSIDE(cv);
10765 const cv_flags_t other_flags =
10766 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10767 OP * const cvstart = CvSTART(cv);
10771 CvFLAGS(compcv) | preserved_flags;
10772 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10773 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10774 CvPADLIST_set(cv, CvPADLIST(compcv));
10775 CvOUTSIDE(compcv) = temp_cv;
10776 CvPADLIST_set(compcv, temp_padl);
10777 CvSTART(cv) = CvSTART(compcv);
10778 CvSTART(compcv) = cvstart;
10779 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10780 CvFLAGS(compcv) |= other_flags;
10783 Safefree(CvFILE(cv));
10787 /* inner references to compcv must be fixed up ... */
10788 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10789 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10790 ++PL_sub_generation;
10793 /* Might have had built-in attributes applied -- propagate them. */
10794 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10796 /* ... before we throw it away */
10797 SvREFCNT_dec(compcv);
10798 PL_compcv = compcv = cv;
10807 if (!CvNAME_HEK(cv)) {
10808 if (hek) (void)share_hek_hek(hek);
10812 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10813 hek = share_hek(PadnamePV(name)+1,
10814 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10817 CvNAME_HEK_set(cv, hek);
10823 if (CvFILE(cv) && CvDYNFILE(cv))
10824 Safefree(CvFILE(cv));
10825 CvFILE_set_from_cop(cv, PL_curcop);
10826 CvSTASH_set(cv, PL_curstash);
10829 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10831 SvUTF8_on(MUTABLE_SV(cv));
10835 /* If we assign an optree to a PVCV, then we've defined a
10836 * subroutine that the debugger could be able to set a breakpoint
10837 * in, so signal to pp_entereval that it should not throw away any
10838 * saved lines at scope exit. */
10840 PL_breakable_sub_gen++;
10841 CvROOT(cv) = block;
10842 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10843 itself has a refcount. */
10845 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10846 #ifdef PERL_DEBUG_READONLY_OPS
10847 slab = (OPSLAB *)CvSTART(cv);
10849 S_process_optree(aTHX_ cv, block, start);
10854 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10855 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10859 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10860 SV * const tmpstr = sv_newmortal();
10861 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10862 GV_ADDMULTI, SVt_PVHV);
10864 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10865 CopFILE(PL_curcop),
10867 (long)CopLINE(PL_curcop));
10868 if (HvNAME_HEK(PL_curstash)) {
10869 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10870 sv_catpvs(tmpstr, "::");
10873 sv_setpvs(tmpstr, "__ANON__::");
10875 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10876 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10877 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10878 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10879 hv = GvHVn(db_postponed);
10880 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10881 CV * const pcv = GvCV(db_postponed);
10887 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10895 assert(CvDEPTH(outcv));
10897 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10899 cv_clone_into(clonee, *spot);
10900 else *spot = cv_clone(clonee);
10901 SvREFCNT_dec_NN(clonee);
10905 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10906 PADOFFSET depth = CvDEPTH(outcv);
10909 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10911 *svspot = SvREFCNT_inc_simple_NN(cv);
10912 SvREFCNT_dec(oldcv);
10918 PL_parser->copline = NOLINE;
10919 LEAVE_SCOPE(floor);
10920 #ifdef PERL_DEBUG_READONLY_OPS
10929 =for apidoc newATTRSUB_x
10931 Construct a Perl subroutine, also performing some surrounding jobs.
10933 This function is expected to be called in a Perl compilation context,
10934 and some aspects of the subroutine are taken from global variables
10935 associated with compilation. In particular, C<PL_compcv> represents
10936 the subroutine that is currently being compiled. It must be non-null
10937 when this function is called, and some aspects of the subroutine being
10938 constructed are taken from it. The constructed subroutine may actually
10939 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10941 If C<block> is null then the subroutine will have no body, and for the
10942 time being it will be an error to call it. This represents a forward
10943 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
10944 non-null then it provides the Perl code of the subroutine body, which
10945 will be executed when the subroutine is called. This body includes
10946 any argument unwrapping code resulting from a subroutine signature or
10947 similar. The pad use of the code must correspond to the pad attached
10948 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
10949 C<leavesublv> op; this function will add such an op. C<block> is consumed
10950 by this function and will become part of the constructed subroutine.
10952 C<proto> specifies the subroutine's prototype, unless one is supplied
10953 as an attribute (see below). If C<proto> is null, then the subroutine
10954 will not have a prototype. If C<proto> is non-null, it must point to a
10955 C<const> op whose value is a string, and the subroutine will have that
10956 string as its prototype. If a prototype is supplied as an attribute, the
10957 attribute takes precedence over C<proto>, but in that case C<proto> should
10958 preferably be null. In any case, C<proto> is consumed by this function.
10960 C<attrs> supplies attributes to be applied the subroutine. A handful of
10961 attributes take effect by built-in means, being applied to C<PL_compcv>
10962 immediately when seen. Other attributes are collected up and attached
10963 to the subroutine by this route. C<attrs> may be null to supply no
10964 attributes, or point to a C<const> op for a single attribute, or point
10965 to a C<list> op whose children apart from the C<pushmark> are C<const>
10966 ops for one or more attributes. Each C<const> op must be a string,
10967 giving the attribute name optionally followed by parenthesised arguments,
10968 in the manner in which attributes appear in Perl source. The attributes
10969 will be applied to the sub by this function. C<attrs> is consumed by
10972 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10973 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
10974 must point to a C<const> op, which will be consumed by this function,
10975 and its string value supplies a name for the subroutine. The name may
10976 be qualified or unqualified, and if it is unqualified then a default
10977 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
10978 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10979 by which the subroutine will be named.
10981 If there is already a subroutine of the specified name, then the new
10982 sub will either replace the existing one in the glob or be merged with
10983 the existing one. A warning may be generated about redefinition.
10985 If the subroutine has one of a few special names, such as C<BEGIN> or
10986 C<END>, then it will be claimed by the appropriate queue for automatic
10987 running of phase-related subroutines. In this case the relevant glob will
10988 be left not containing any subroutine, even if it did contain one before.
10989 In the case of C<BEGIN>, the subroutine will be executed and the reference
10990 to it disposed of before this function returns.
10992 The function returns a pointer to the constructed subroutine. If the sub
10993 is anonymous then ownership of one counted reference to the subroutine
10994 is transferred to the caller. If the sub is named then the caller does
10995 not get ownership of a reference. In most such cases, where the sub
10996 has a non-phase name, the sub will be alive at the point it is returned
10997 by virtue of being contained in the glob that names it. A phase-named
10998 subroutine will usually be alive by virtue of the reference owned by the
10999 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11000 been executed, will quite likely have been destroyed already by the
11001 time this function returns, making it erroneous for the caller to make
11002 any use of the returned pointer. It is the caller's responsibility to
11003 ensure that it knows which of these situations applies.
11008 /* _x = extended */
11010 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11011 OP *block, bool o_is_gv)
11015 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11017 CV *cv = NULL; /* the previous CV with this name, if any */
11019 const bool ec = PL_parser && PL_parser->error_count;
11020 /* If the subroutine has no body, no attributes, and no builtin attributes
11021 then it's just a sub declaration, and we may be able to get away with
11022 storing with a placeholder scalar in the symbol table, rather than a
11023 full CV. If anything is present then it will take a full CV to
11025 const I32 gv_fetch_flags
11026 = ec ? GV_NOADD_NOINIT :
11027 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11028 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11030 const char * const name =
11031 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11033 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11034 bool evanescent = FALSE;
11036 #ifdef PERL_DEBUG_READONLY_OPS
11037 OPSLAB *slab = NULL;
11045 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
11046 hek and CvSTASH pointer together can imply the GV. If the name
11047 contains a package name, then GvSTASH(CvGV(cv)) may differ from
11048 CvSTASH, so forego the optimisation if we find any.
11049 Also, we may be called from load_module at run time, so
11050 PL_curstash (which sets CvSTASH) may not point to the stash the
11051 sub is stored in. */
11052 /* XXX This optimization is currently disabled for packages other
11053 than main, since there was too much CPAN breakage. */
11055 ec ? GV_NOADD_NOINIT
11056 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11057 || PL_curstash != PL_defstash
11058 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11060 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11061 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11063 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11064 SV * const sv = sv_newmortal();
11065 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11066 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11067 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11068 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11070 } else if (PL_curstash) {
11071 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11074 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11080 move_proto_attr(&proto, &attrs, gv, 0);
11083 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11088 assert(proto->op_type == OP_CONST);
11089 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11090 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11106 SvREFCNT_dec(PL_compcv);
11111 if (name && block) {
11112 const char *s = (char *) my_memrchr(name, ':', namlen);
11113 s = s ? s+1 : name;
11114 if (strEQ(s, "BEGIN")) {
11115 if (PL_in_eval & EVAL_KEEPERR)
11116 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11118 SV * const errsv = ERRSV;
11119 /* force display of errors found but not reported */
11120 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11121 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11128 if (!block && SvTYPE(gv) != SVt_PVGV) {
11129 /* If we are not defining a new sub and the existing one is not a
11131 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11132 /* We are applying attributes to an existing sub, so we need it
11133 upgraded if it is a constant. */
11134 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11135 gv_init_pvn(gv, PL_curstash, name, namlen,
11136 SVf_UTF8 * name_is_utf8);
11138 else { /* Maybe prototype now, and had at maximum
11139 a prototype or const/sub ref before. */
11140 if (SvTYPE(gv) > SVt_NULL) {
11141 cv_ckproto_len_flags((const CV *)gv,
11142 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11148 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11150 SvUTF8_on(MUTABLE_SV(gv));
11153 sv_setiv(MUTABLE_SV(gv), -1);
11156 SvREFCNT_dec(PL_compcv);
11157 cv = PL_compcv = NULL;
11162 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11166 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11172 /* This makes sub {}; work as expected. */
11173 if (block->op_type == OP_STUB) {
11174 const line_t l = PL_parser->copline;
11176 block = newSTATEOP(0, NULL, 0);
11177 PL_parser->copline = l;
11179 block = CvLVALUE(PL_compcv)
11180 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11181 && (!isGV(gv) || !GvASSUMECV(gv)))
11182 ? newUNOP(OP_LEAVESUBLV, 0,
11183 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
11184 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
11185 start = LINKLIST(block);
11186 block->op_next = 0;
11187 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11189 S_op_const_sv(aTHX_ start, PL_compcv,
11190 cBOOL(CvCLONE(PL_compcv)));
11197 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11198 cv_ckproto_len_flags((const CV *)gv,
11199 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11200 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11202 /* All the other code for sub redefinition warnings expects the
11203 clobbered sub to be a CV. Instead of making all those code
11204 paths more complex, just inline the RV version here. */
11205 const line_t oldline = CopLINE(PL_curcop);
11206 assert(IN_PERL_COMPILETIME);
11207 if (PL_parser && PL_parser->copline != NOLINE)
11208 /* This ensures that warnings are reported at the first
11209 line of a redefinition, not the last. */
11210 CopLINE_set(PL_curcop, PL_parser->copline);
11211 /* protect against fatal warnings leaking compcv */
11212 SAVEFREESV(PL_compcv);
11214 if (ckWARN(WARN_REDEFINE)
11215 || ( ckWARN_d(WARN_REDEFINE)
11216 && ( !const_sv || SvRV(gv) == const_sv
11217 || sv_cmp(SvRV(gv), const_sv) ))) {
11219 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11220 "Constant subroutine %" SVf " redefined",
11221 SVfARG(cSVOPo->op_sv));
11224 SvREFCNT_inc_simple_void_NN(PL_compcv);
11225 CopLINE_set(PL_curcop, oldline);
11226 SvREFCNT_dec(SvRV(gv));
11231 const bool exists = CvROOT(cv) || CvXSUB(cv);
11233 /* if the subroutine doesn't exist and wasn't pre-declared
11234 * with a prototype, assume it will be AUTOLOADed,
11235 * skipping the prototype check
11237 if (exists || SvPOK(cv))
11238 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11239 /* already defined (or promised)? */
11240 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11241 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11247 /* just a "sub foo;" when &foo is already defined */
11248 SAVEFREESV(PL_compcv);
11255 SvREFCNT_inc_simple_void_NN(const_sv);
11256 SvFLAGS(const_sv) |= SVs_PADTMP;
11258 assert(!CvROOT(cv) && !CvCONST(cv));
11259 cv_forget_slab(cv);
11260 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11261 CvXSUBANY(cv).any_ptr = const_sv;
11262 CvXSUB(cv) = const_sv_xsub;
11266 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11269 if (isGV(gv) || CvMETHOD(PL_compcv)) {
11270 if (name && isGV(gv))
11271 GvCV_set(gv, NULL);
11272 cv = newCONSTSUB_flags(
11273 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11277 assert(SvREFCNT((SV*)cv) != 0);
11278 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11282 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11283 prepare_SV_for_RV((SV *)gv);
11284 SvOK_off((SV *)gv);
11287 SvRV_set(gv, const_sv);
11291 SvREFCNT_dec(PL_compcv);
11296 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11297 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11300 if (cv) { /* must reuse cv if autoloaded */
11301 /* transfer PL_compcv to cv */
11303 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11304 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11305 PADLIST *const temp_av = CvPADLIST(cv);
11306 CV *const temp_cv = CvOUTSIDE(cv);
11307 const cv_flags_t other_flags =
11308 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11309 OP * const cvstart = CvSTART(cv);
11313 assert(!CvCVGV_RC(cv));
11314 assert(CvGV(cv) == gv);
11319 PERL_HASH(hash, name, namlen);
11329 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11331 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11332 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11333 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11334 CvOUTSIDE(PL_compcv) = temp_cv;
11335 CvPADLIST_set(PL_compcv, temp_av);
11336 CvSTART(cv) = CvSTART(PL_compcv);
11337 CvSTART(PL_compcv) = cvstart;
11338 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11339 CvFLAGS(PL_compcv) |= other_flags;
11342 Safefree(CvFILE(cv));
11344 CvFILE_set_from_cop(cv, PL_curcop);
11345 CvSTASH_set(cv, PL_curstash);
11347 /* inner references to PL_compcv must be fixed up ... */
11348 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11349 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11350 ++PL_sub_generation;
11353 /* Might have had built-in attributes applied -- propagate them. */
11354 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11356 /* ... before we throw it away */
11357 SvREFCNT_dec(PL_compcv);
11362 if (name && isGV(gv)) {
11365 if (HvENAME_HEK(GvSTASH(gv)))
11366 /* sub Foo::bar { (shift)+1 } */
11367 gv_method_changed(gv);
11371 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11372 prepare_SV_for_RV((SV *)gv);
11373 SvOK_off((SV *)gv);
11376 SvRV_set(gv, (SV *)cv);
11377 if (HvENAME_HEK(PL_curstash))
11378 mro_method_changed_in(PL_curstash);
11382 assert(SvREFCNT((SV*)cv) != 0);
11384 if (!CvHASGV(cv)) {
11390 PERL_HASH(hash, name, namlen);
11391 CvNAME_HEK_set(cv, share_hek(name,
11397 CvFILE_set_from_cop(cv, PL_curcop);
11398 CvSTASH_set(cv, PL_curstash);
11402 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11404 SvUTF8_on(MUTABLE_SV(cv));
11408 /* If we assign an optree to a PVCV, then we've defined a
11409 * subroutine that the debugger could be able to set a breakpoint
11410 * in, so signal to pp_entereval that it should not throw away any
11411 * saved lines at scope exit. */
11413 PL_breakable_sub_gen++;
11414 CvROOT(cv) = block;
11415 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11416 itself has a refcount. */
11418 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11419 #ifdef PERL_DEBUG_READONLY_OPS
11420 slab = (OPSLAB *)CvSTART(cv);
11422 S_process_optree(aTHX_ cv, block, start);
11427 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11428 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11429 ? GvSTASH(CvGV(cv))
11433 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11435 SvREFCNT_inc_simple_void_NN(cv);
11438 if (block && has_name) {
11439 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11440 SV * const tmpstr = cv_name(cv,NULL,0);
11441 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11442 GV_ADDMULTI, SVt_PVHV);
11444 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11445 CopFILE(PL_curcop),
11447 (long)CopLINE(PL_curcop));
11448 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11449 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11450 hv = GvHVn(db_postponed);
11451 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11452 CV * const pcv = GvCV(db_postponed);
11458 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11464 if (PL_parser && PL_parser->error_count)
11465 clear_special_blocks(name, gv, cv);
11468 process_special_blocks(floor, name, gv, cv);
11474 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11476 PL_parser->copline = NOLINE;
11477 LEAVE_SCOPE(floor);
11479 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11481 #ifdef PERL_DEBUG_READONLY_OPS
11485 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11486 pad_add_weakref(cv);
11492 S_clear_special_blocks(pTHX_ const char *const fullname,
11493 GV *const gv, CV *const cv) {
11497 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11499 colon = strrchr(fullname,':');
11500 name = colon ? colon + 1 : fullname;
11502 if ((*name == 'B' && strEQ(name, "BEGIN"))
11503 || (*name == 'E' && strEQ(name, "END"))
11504 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11505 || (*name == 'C' && strEQ(name, "CHECK"))
11506 || (*name == 'I' && strEQ(name, "INIT"))) {
11511 GvCV_set(gv, NULL);
11512 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11516 /* Returns true if the sub has been freed. */
11518 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11522 const char *const colon = strrchr(fullname,':');
11523 const char *const name = colon ? colon + 1 : fullname;
11525 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11527 if (*name == 'B') {
11528 if (strEQ(name, "BEGIN")) {
11529 const I32 oldscope = PL_scopestack_ix;
11532 if (floor) LEAVE_SCOPE(floor);
11535 SAVEVPTR(PL_curcop);
11536 if (PL_curcop == &PL_compiling) {
11537 /* Avoid pushing the "global" &PL_compiling onto the
11538 * context stack. For example, a stack trace inside
11539 * nested use's would show all calls coming from whoever
11540 * most recently updated PL_compiling.cop_file and
11541 * cop_line. So instead, temporarily set PL_curcop to a
11542 * private copy of &PL_compiling. PL_curcop will soon be
11543 * set to point back to &PL_compiling anyway but only
11544 * after the temp value has been pushed onto the context
11545 * stack as blk_oldcop.
11546 * This is slightly hacky, but necessary. Note also
11547 * that in the brief window before PL_curcop is set back
11548 * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
11549 * will give the wrong answer.
11551 Newx(PL_curcop, 1, COP);
11552 StructCopy(&PL_compiling, PL_curcop, COP);
11553 PL_curcop->op_slabbed = 0;
11554 SAVEFREEPV(PL_curcop);
11557 PUSHSTACKi(PERLSI_REQUIRE);
11558 SAVECOPFILE(&PL_compiling);
11559 SAVECOPLINE(&PL_compiling);
11561 DEBUG_x( dump_sub(gv) );
11562 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11563 GvCV_set(gv,0); /* cv has been hijacked */
11564 call_list(oldscope, PL_beginav);
11568 return !PL_savebegin;
11573 if (*name == 'E') {
11574 if (strEQ(name, "END")) {
11575 DEBUG_x( dump_sub(gv) );
11576 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11579 } else if (*name == 'U') {
11580 if (strEQ(name, "UNITCHECK")) {
11581 /* It's never too late to run a unitcheck block */
11582 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11586 } else if (*name == 'C') {
11587 if (strEQ(name, "CHECK")) {
11589 /* diag_listed_as: Too late to run %s block */
11590 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11591 "Too late to run CHECK block");
11592 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11596 } else if (*name == 'I') {
11597 if (strEQ(name, "INIT")) {
11599 /* diag_listed_as: Too late to run %s block */
11600 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11601 "Too late to run INIT block");
11602 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11608 DEBUG_x( dump_sub(gv) );
11610 GvCV_set(gv,0); /* cv has been hijacked */
11616 =for apidoc newCONSTSUB
11618 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11619 rather than of counted length, and no flags are set. (This means that
11620 C<name> is always interpreted as Latin-1.)
11626 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11628 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11632 =for apidoc newCONSTSUB_flags
11634 Construct a constant subroutine, also performing some surrounding
11635 jobs. A scalar constant-valued subroutine is eligible for inlining
11636 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11637 123 }>>. Other kinds of constant subroutine have other treatment.
11639 The subroutine will have an empty prototype and will ignore any arguments
11640 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11641 is null, the subroutine will yield an empty list. If C<sv> points to a
11642 scalar, the subroutine will always yield that scalar. If C<sv> points
11643 to an array, the subroutine will always yield a list of the elements of
11644 that array in list context, or the number of elements in the array in
11645 scalar context. This function takes ownership of one counted reference
11646 to the scalar or array, and will arrange for the object to live as long
11647 as the subroutine does. If C<sv> points to a scalar then the inlining
11648 assumes that the value of the scalar will never change, so the caller
11649 must ensure that the scalar is not subsequently written to. If C<sv>
11650 points to an array then no such assumption is made, so it is ostensibly
11651 safe to mutate the array or its elements, but whether this is really
11652 supported has not been determined.
11654 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11655 Other aspects of the subroutine will be left in their default state.
11656 The caller is free to mutate the subroutine beyond its initial state
11657 after this function has returned.
11659 If C<name> is null then the subroutine will be anonymous, with its
11660 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11661 subroutine will be named accordingly, referenced by the appropriate glob.
11662 C<name> is a string of length C<len> bytes giving a sigilless symbol
11663 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11664 otherwise. The name may be either qualified or unqualified. If the
11665 name is unqualified then it defaults to being in the stash specified by
11666 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11667 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11670 C<flags> should not have bits set other than C<SVf_UTF8>.
11672 If there is already a subroutine of the specified name, then the new sub
11673 will replace the existing one in the glob. A warning may be generated
11674 about the redefinition.
11676 If the subroutine has one of a few special names, such as C<BEGIN> or
11677 C<END>, then it will be claimed by the appropriate queue for automatic
11678 running of phase-related subroutines. In this case the relevant glob will
11679 be left not containing any subroutine, even if it did contain one before.
11680 Execution of the subroutine will likely be a no-op, unless C<sv> was
11681 a tied array or the caller modified the subroutine in some interesting
11682 way before it was executed. In the case of C<BEGIN>, the treatment is
11683 buggy: the sub will be executed when only half built, and may be deleted
11684 prematurely, possibly causing a crash.
11686 The function returns a pointer to the constructed subroutine. If the sub
11687 is anonymous then ownership of one counted reference to the subroutine
11688 is transferred to the caller. If the sub is named then the caller does
11689 not get ownership of a reference. In most such cases, where the sub
11690 has a non-phase name, the sub will be alive at the point it is returned
11691 by virtue of being contained in the glob that names it. A phase-named
11692 subroutine will usually be alive by virtue of the reference owned by
11693 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11694 destroyed already by the time this function returns, but currently bugs
11695 occur in that case before the caller gets control. It is the caller's
11696 responsibility to ensure that it knows which of these situations applies.
11702 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11706 const char *const file = CopFILE(PL_curcop);
11710 if (IN_PERL_RUNTIME) {
11711 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11712 * an op shared between threads. Use a non-shared COP for our
11714 SAVEVPTR(PL_curcop);
11715 SAVECOMPILEWARNINGS();
11716 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11717 PL_curcop = &PL_compiling;
11719 SAVECOPLINE(PL_curcop);
11720 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11723 PL_hints &= ~HINT_BLOCK_SCOPE;
11726 SAVEGENERICSV(PL_curstash);
11727 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11730 /* Protect sv against leakage caused by fatal warnings. */
11731 if (sv) SAVEFREESV(sv);
11733 /* file becomes the CvFILE. For an XS, it's usually static storage,
11734 and so doesn't get free()d. (It's expected to be from the C pre-
11735 processor __FILE__ directive). But we need a dynamically allocated one,
11736 and we need it to get freed. */
11737 cv = newXS_len_flags(name, len,
11738 sv && SvTYPE(sv) == SVt_PVAV
11741 file ? file : "", "",
11742 &sv, XS_DYNAMIC_FILENAME | flags);
11744 assert(SvREFCNT((SV*)cv) != 0);
11745 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11756 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11757 static storage, as it is used directly as CvFILE(), without a copy being made.
11763 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11765 PERL_ARGS_ASSERT_NEWXS;
11766 return newXS_len_flags(
11767 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11772 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11773 const char *const filename, const char *const proto,
11776 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11777 return newXS_len_flags(
11778 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11783 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11785 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11786 return newXS_len_flags(
11787 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11792 =for apidoc newXS_len_flags
11794 Construct an XS subroutine, also performing some surrounding jobs.
11796 The subroutine will have the entry point C<subaddr>. It will have
11797 the prototype specified by the nul-terminated string C<proto>, or
11798 no prototype if C<proto> is null. The prototype string is copied;
11799 the caller can mutate the supplied string afterwards. If C<filename>
11800 is non-null, it must be a nul-terminated filename, and the subroutine
11801 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11802 point directly to the supplied string, which must be static. If C<flags>
11803 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11806 Other aspects of the subroutine will be left in their default state.
11807 If anything else needs to be done to the subroutine for it to function
11808 correctly, it is the caller's responsibility to do that after this
11809 function has constructed it. However, beware of the subroutine
11810 potentially being destroyed before this function returns, as described
11813 If C<name> is null then the subroutine will be anonymous, with its
11814 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11815 subroutine will be named accordingly, referenced by the appropriate glob.
11816 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11817 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11818 The name may be either qualified or unqualified, with the stash defaulting
11819 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11820 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11821 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11822 the stash if necessary, with C<GV_ADDMULTI> semantics.
11824 If there is already a subroutine of the specified name, then the new sub
11825 will replace the existing one in the glob. A warning may be generated
11826 about the redefinition. If the old subroutine was C<CvCONST> then the
11827 decision about whether to warn is influenced by an expectation about
11828 whether the new subroutine will become a constant of similar value.
11829 That expectation is determined by C<const_svp>. (Note that the call to
11830 this function doesn't make the new subroutine C<CvCONST> in any case;
11831 that is left to the caller.) If C<const_svp> is null then it indicates
11832 that the new subroutine will not become a constant. If C<const_svp>
11833 is non-null then it indicates that the new subroutine will become a
11834 constant, and it points to an C<SV*> that provides the constant value
11835 that the subroutine will have.
11837 If the subroutine has one of a few special names, such as C<BEGIN> or
11838 C<END>, then it will be claimed by the appropriate queue for automatic
11839 running of phase-related subroutines. In this case the relevant glob will
11840 be left not containing any subroutine, even if it did contain one before.
11841 In the case of C<BEGIN>, the subroutine will be executed and the reference
11842 to it disposed of before this function returns, and also before its
11843 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
11844 constructed by this function to be ready for execution then the caller
11845 must prevent this happening by giving the subroutine a different name.
11847 The function returns a pointer to the constructed subroutine. If the sub
11848 is anonymous then ownership of one counted reference to the subroutine
11849 is transferred to the caller. If the sub is named then the caller does
11850 not get ownership of a reference. In most such cases, where the sub
11851 has a non-phase name, the sub will be alive at the point it is returned
11852 by virtue of being contained in the glob that names it. A phase-named
11853 subroutine will usually be alive by virtue of the reference owned by the
11854 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11855 been executed, will quite likely have been destroyed already by the
11856 time this function returns, making it erroneous for the caller to make
11857 any use of the returned pointer. It is the caller's responsibility to
11858 ensure that it knows which of these situations applies.
11864 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11865 XSUBADDR_t subaddr, const char *const filename,
11866 const char *const proto, SV **const_svp,
11870 bool interleave = FALSE;
11871 bool evanescent = FALSE;
11873 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11876 GV * const gv = gv_fetchpvn(
11877 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11878 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11879 sizeof("__ANON__::__ANON__") - 1,
11880 GV_ADDMULTI | flags, SVt_PVCV);
11882 if ((cv = (name ? GvCV(gv) : NULL))) {
11884 /* just a cached method */
11888 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11889 /* already defined (or promised) */
11890 /* Redundant check that allows us to avoid creating an SV
11891 most of the time: */
11892 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11893 report_redefined_cv(newSVpvn_flags(
11894 name,len,(flags&SVf_UTF8)|SVs_TEMP
11905 if (cv) /* must reuse cv if autoloaded */
11908 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11912 if (HvENAME_HEK(GvSTASH(gv)))
11913 gv_method_changed(gv); /* newXS */
11917 assert(SvREFCNT((SV*)cv) != 0);
11921 /* XSUBs can't be perl lang/perl5db.pl debugged
11922 if (PERLDB_LINE_OR_SAVESRC)
11923 (void)gv_fetchfile(filename); */
11924 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11925 if (flags & XS_DYNAMIC_FILENAME) {
11927 CvFILE(cv) = savepv(filename);
11929 /* NOTE: not copied, as it is expected to be an external constant string */
11930 CvFILE(cv) = (char *)filename;
11933 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11934 CvFILE(cv) = (char*)PL_xsubfilename;
11937 CvXSUB(cv) = subaddr;
11938 #ifndef PERL_IMPLICIT_CONTEXT
11939 CvHSCXT(cv) = &PL_stack_sp;
11945 evanescent = process_special_blocks(0, name, gv, cv);
11948 } /* <- not a conditional branch */
11951 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11953 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11954 if (interleave) LEAVE;
11955 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11959 /* Add a stub CV to a typeglob.
11960 * This is the implementation of a forward declaration, 'sub foo';'
11964 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11966 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11968 PERL_ARGS_ASSERT_NEWSTUB;
11969 assert(!GvCVu(gv));
11972 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11973 gv_method_changed(gv);
11975 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11979 CvGV_set(cv, cvgv);
11980 CvFILE_set_from_cop(cv, PL_curcop);
11981 CvSTASH_set(cv, PL_curstash);
11987 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11994 if (PL_parser && PL_parser->error_count) {
12000 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12001 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12004 if ((cv = GvFORM(gv))) {
12005 if (ckWARN(WARN_REDEFINE)) {
12006 const line_t oldline = CopLINE(PL_curcop);
12007 if (PL_parser && PL_parser->copline != NOLINE)
12008 CopLINE_set(PL_curcop, PL_parser->copline);
12010 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12011 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12013 /* diag_listed_as: Format %s redefined */
12014 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12015 "Format STDOUT redefined");
12017 CopLINE_set(PL_curcop, oldline);
12022 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12024 CvFILE_set_from_cop(cv, PL_curcop);
12027 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12029 start = LINKLIST(root);
12031 S_process_optree(aTHX_ cv, root, start);
12032 cv_forget_slab(cv);
12037 PL_parser->copline = NOLINE;
12038 LEAVE_SCOPE(floor);
12039 PL_compiling.cop_seq = 0;
12043 Perl_newANONLIST(pTHX_ OP *o)
12045 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12049 Perl_newANONHASH(pTHX_ OP *o)
12051 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12055 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12057 return newANONATTRSUB(floor, proto, NULL, block);
12061 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12063 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12065 newSVOP(OP_ANONCODE, 0,
12067 if (CvANONCONST(cv))
12068 anoncode = newUNOP(OP_ANONCONST, 0,
12069 op_convert_list(OP_ENTERSUB,
12070 OPf_STACKED|OPf_WANT_SCALAR,
12072 return newUNOP(OP_REFGEN, 0, anoncode);
12076 Perl_oopsAV(pTHX_ OP *o)
12080 PERL_ARGS_ASSERT_OOPSAV;
12082 switch (o->op_type) {
12085 OpTYPE_set(o, OP_PADAV);
12086 return ref(o, OP_RV2AV);
12090 OpTYPE_set(o, OP_RV2AV);
12095 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12102 Perl_oopsHV(pTHX_ OP *o)
12106 PERL_ARGS_ASSERT_OOPSHV;
12108 switch (o->op_type) {
12111 OpTYPE_set(o, OP_PADHV);
12112 return ref(o, OP_RV2HV);
12116 OpTYPE_set(o, OP_RV2HV);
12117 /* rv2hv steals the bottom bit for its own uses */
12118 o->op_private &= ~OPpARG1_MASK;
12123 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12130 Perl_newAVREF(pTHX_ OP *o)
12134 PERL_ARGS_ASSERT_NEWAVREF;
12136 if (o->op_type == OP_PADANY) {
12137 OpTYPE_set(o, OP_PADAV);
12140 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12141 Perl_croak(aTHX_ "Can't use an array as a reference");
12143 return newUNOP(OP_RV2AV, 0, scalar(o));
12147 Perl_newGVREF(pTHX_ I32 type, OP *o)
12149 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12150 return newUNOP(OP_NULL, 0, o);
12151 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12155 Perl_newHVREF(pTHX_ OP *o)
12159 PERL_ARGS_ASSERT_NEWHVREF;
12161 if (o->op_type == OP_PADANY) {
12162 OpTYPE_set(o, OP_PADHV);
12165 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12166 Perl_croak(aTHX_ "Can't use a hash as a reference");
12168 return newUNOP(OP_RV2HV, 0, scalar(o));
12172 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12174 if (o->op_type == OP_PADANY) {
12176 OpTYPE_set(o, OP_PADCV);
12178 return newUNOP(OP_RV2CV, flags, scalar(o));
12182 Perl_newSVREF(pTHX_ OP *o)
12186 PERL_ARGS_ASSERT_NEWSVREF;
12188 if (o->op_type == OP_PADANY) {
12189 OpTYPE_set(o, OP_PADSV);
12193 return newUNOP(OP_RV2SV, 0, scalar(o));
12196 /* Check routines. See the comments at the top of this file for details
12197 * on when these are called */
12200 Perl_ck_anoncode(pTHX_ OP *o)
12202 PERL_ARGS_ASSERT_CK_ANONCODE;
12204 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12205 cSVOPo->op_sv = NULL;
12210 S_io_hints(pTHX_ OP *o)
12212 #if O_BINARY != 0 || O_TEXT != 0
12214 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12216 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12219 const char *d = SvPV_const(*svp, len);
12220 const I32 mode = mode_from_discipline(d, len);
12221 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12223 if (mode & O_BINARY)
12224 o->op_private |= OPpOPEN_IN_RAW;
12228 o->op_private |= OPpOPEN_IN_CRLF;
12232 svp = hv_fetchs(table, "open_OUT", FALSE);
12235 const char *d = SvPV_const(*svp, len);
12236 const I32 mode = mode_from_discipline(d, len);
12237 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12239 if (mode & O_BINARY)
12240 o->op_private |= OPpOPEN_OUT_RAW;
12244 o->op_private |= OPpOPEN_OUT_CRLF;
12249 PERL_UNUSED_CONTEXT;
12250 PERL_UNUSED_ARG(o);
12255 Perl_ck_backtick(pTHX_ OP *o)
12260 PERL_ARGS_ASSERT_CK_BACKTICK;
12262 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12263 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12264 && (gv = gv_override("readpipe",8)))
12266 /* detach rest of siblings from o and its first child */
12267 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12268 newop = S_new_entersubop(aTHX_ gv, sibl);
12270 else if (!(o->op_flags & OPf_KIDS))
12271 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12276 S_io_hints(aTHX_ o);
12281 Perl_ck_bitop(pTHX_ OP *o)
12283 PERL_ARGS_ASSERT_CK_BITOP;
12285 o->op_private = (U8)(PL_hints & HINT_INTEGER);
12287 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12288 && OP_IS_INFIX_BIT(o->op_type))
12290 const OP * const left = cBINOPo->op_first;
12291 const OP * const right = OpSIBLING(left);
12292 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12293 (left->op_flags & OPf_PARENS) == 0) ||
12294 (OP_IS_NUMCOMPARE(right->op_type) &&
12295 (right->op_flags & OPf_PARENS) == 0))
12296 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12297 "Possible precedence problem on bitwise %s operator",
12298 o->op_type == OP_BIT_OR
12299 ||o->op_type == OP_NBIT_OR ? "|"
12300 : o->op_type == OP_BIT_AND
12301 ||o->op_type == OP_NBIT_AND ? "&"
12302 : o->op_type == OP_BIT_XOR
12303 ||o->op_type == OP_NBIT_XOR ? "^"
12304 : o->op_type == OP_SBIT_OR ? "|."
12305 : o->op_type == OP_SBIT_AND ? "&." : "^."
12311 PERL_STATIC_INLINE bool
12312 is_dollar_bracket(pTHX_ const OP * const o)
12315 PERL_UNUSED_CONTEXT;
12316 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12317 && (kid = cUNOPx(o)->op_first)
12318 && kid->op_type == OP_GV
12319 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12322 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12325 Perl_ck_cmp(pTHX_ OP *o)
12331 OP *indexop, *constop, *start;
12335 PERL_ARGS_ASSERT_CK_CMP;
12337 is_eq = ( o->op_type == OP_EQ
12338 || o->op_type == OP_NE
12339 || o->op_type == OP_I_EQ
12340 || o->op_type == OP_I_NE);
12342 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12343 const OP *kid = cUNOPo->op_first;
12346 ( is_dollar_bracket(aTHX_ kid)
12347 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12349 || ( kid->op_type == OP_CONST
12350 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12354 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12355 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12358 /* convert (index(...) == -1) and variations into
12359 * (r)index/BOOL(,NEG)
12364 indexop = cUNOPo->op_first;
12365 constop = OpSIBLING(indexop);
12367 if (indexop->op_type == OP_CONST) {
12369 indexop = OpSIBLING(constop);
12374 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12377 /* ($lex = index(....)) == -1 */
12378 if (indexop->op_private & OPpTARGET_MY)
12381 if (constop->op_type != OP_CONST)
12384 sv = cSVOPx_sv(constop);
12385 if (!(sv && SvIOK_notUV(sv)))
12389 if (iv != -1 && iv != 0)
12393 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12394 if (!(iv0 ^ reverse))
12398 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12403 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12404 if (!(iv0 ^ reverse))
12408 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12413 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12419 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12425 indexop->op_flags &= ~OPf_PARENS;
12426 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12427 indexop->op_private |= OPpTRUEBOOL;
12429 indexop->op_private |= OPpINDEX_BOOLNEG;
12430 /* cut out the index op and free the eq,const ops */
12431 (void)op_sibling_splice(o, start, 1, NULL);
12439 Perl_ck_concat(pTHX_ OP *o)
12441 const OP * const kid = cUNOPo->op_first;
12443 PERL_ARGS_ASSERT_CK_CONCAT;
12444 PERL_UNUSED_CONTEXT;
12446 /* reuse the padtmp returned by the concat child */
12447 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12448 !(kUNOP->op_first->op_flags & OPf_MOD))
12450 o->op_flags |= OPf_STACKED;
12451 o->op_private |= OPpCONCAT_NESTED;
12457 Perl_ck_spair(pTHX_ OP *o)
12461 PERL_ARGS_ASSERT_CK_SPAIR;
12463 if (o->op_flags & OPf_KIDS) {
12467 const OPCODE type = o->op_type;
12468 o = modkids(ck_fun(o), type);
12469 kid = cUNOPo->op_first;
12470 kidkid = kUNOP->op_first;
12471 newop = OpSIBLING(kidkid);
12473 const OPCODE type = newop->op_type;
12474 if (OpHAS_SIBLING(newop))
12476 if (o->op_type == OP_REFGEN
12477 && ( type == OP_RV2CV
12478 || ( !(newop->op_flags & OPf_PARENS)
12479 && ( type == OP_RV2AV || type == OP_PADAV
12480 || type == OP_RV2HV || type == OP_PADHV))))
12481 NOOP; /* OK (allow srefgen for \@a and \%h) */
12482 else if (OP_GIMME(newop,0) != G_SCALAR)
12485 /* excise first sibling */
12486 op_sibling_splice(kid, NULL, 1, NULL);
12489 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12490 * and OP_CHOMP into OP_SCHOMP */
12491 o->op_ppaddr = PL_ppaddr[++o->op_type];
12496 Perl_ck_delete(pTHX_ OP *o)
12498 PERL_ARGS_ASSERT_CK_DELETE;
12502 if (o->op_flags & OPf_KIDS) {
12503 OP * const kid = cUNOPo->op_first;
12504 switch (kid->op_type) {
12506 o->op_flags |= OPf_SPECIAL;
12509 o->op_private |= OPpSLICE;
12512 o->op_flags |= OPf_SPECIAL;
12517 o->op_flags |= OPf_SPECIAL;
12520 o->op_private |= OPpKVSLICE;
12523 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12524 "element or slice");
12526 if (kid->op_private & OPpLVAL_INTRO)
12527 o->op_private |= OPpLVAL_INTRO;
12534 Perl_ck_eof(pTHX_ OP *o)
12536 PERL_ARGS_ASSERT_CK_EOF;
12538 if (o->op_flags & OPf_KIDS) {
12540 if (cLISTOPo->op_first->op_type == OP_STUB) {
12542 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12547 kid = cLISTOPo->op_first;
12548 if (kid->op_type == OP_RV2GV)
12549 kid->op_private |= OPpALLOW_FAKE;
12556 Perl_ck_eval(pTHX_ OP *o)
12560 PERL_ARGS_ASSERT_CK_EVAL;
12562 PL_hints |= HINT_BLOCK_SCOPE;
12563 if (o->op_flags & OPf_KIDS) {
12564 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12567 if (o->op_type == OP_ENTERTRY) {
12570 /* cut whole sibling chain free from o */
12571 op_sibling_splice(o, NULL, -1, NULL);
12574 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12576 /* establish postfix order */
12577 enter->op_next = (OP*)enter;
12579 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12580 OpTYPE_set(o, OP_LEAVETRY);
12581 enter->op_other = o;
12586 S_set_haseval(aTHX);
12590 const U8 priv = o->op_private;
12592 /* the newUNOP will recursively call ck_eval(), which will handle
12593 * all the stuff at the end of this function, like adding
12596 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12598 o->op_targ = (PADOFFSET)PL_hints;
12599 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12600 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12601 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12602 /* Store a copy of %^H that pp_entereval can pick up. */
12603 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12605 STOREFEATUREBITSHH(hh);
12606 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12607 /* append hhop to only child */
12608 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12610 o->op_private |= OPpEVAL_HAS_HH;
12612 if (!(o->op_private & OPpEVAL_BYTES)
12613 && FEATURE_UNIEVAL_IS_ENABLED)
12614 o->op_private |= OPpEVAL_UNICODE;
12619 Perl_ck_exec(pTHX_ OP *o)
12621 PERL_ARGS_ASSERT_CK_EXEC;
12623 if (o->op_flags & OPf_STACKED) {
12626 kid = OpSIBLING(cUNOPo->op_first);
12627 if (kid->op_type == OP_RV2GV)
12636 Perl_ck_exists(pTHX_ OP *o)
12638 PERL_ARGS_ASSERT_CK_EXISTS;
12641 if (o->op_flags & OPf_KIDS) {
12642 OP * const kid = cUNOPo->op_first;
12643 if (kid->op_type == OP_ENTERSUB) {
12644 (void) ref(kid, o->op_type);
12645 if (kid->op_type != OP_RV2CV
12646 && !(PL_parser && PL_parser->error_count))
12648 "exists argument is not a subroutine name");
12649 o->op_private |= OPpEXISTS_SUB;
12651 else if (kid->op_type == OP_AELEM)
12652 o->op_flags |= OPf_SPECIAL;
12653 else if (kid->op_type != OP_HELEM)
12654 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12655 "element or a subroutine");
12662 Perl_ck_rvconst(pTHX_ OP *o)
12665 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12667 PERL_ARGS_ASSERT_CK_RVCONST;
12669 if (o->op_type == OP_RV2HV)
12670 /* rv2hv steals the bottom bit for its own uses */
12671 o->op_private &= ~OPpARG1_MASK;
12673 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12675 if (kid->op_type == OP_CONST) {
12678 SV * const kidsv = kid->op_sv;
12680 /* Is it a constant from cv_const_sv()? */
12681 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12684 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12685 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12686 const char *badthing;
12687 switch (o->op_type) {
12689 badthing = "a SCALAR";
12692 badthing = "an ARRAY";
12695 badthing = "a HASH";
12703 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12704 SVfARG(kidsv), badthing);
12707 * This is a little tricky. We only want to add the symbol if we
12708 * didn't add it in the lexer. Otherwise we get duplicate strict
12709 * warnings. But if we didn't add it in the lexer, we must at
12710 * least pretend like we wanted to add it even if it existed before,
12711 * or we get possible typo warnings. OPpCONST_ENTERED says
12712 * whether the lexer already added THIS instance of this symbol.
12714 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12715 gv = gv_fetchsv(kidsv,
12716 o->op_type == OP_RV2CV
12717 && o->op_private & OPpMAY_RETURN_CONSTANT
12719 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12722 : o->op_type == OP_RV2SV
12724 : o->op_type == OP_RV2AV
12726 : o->op_type == OP_RV2HV
12733 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12734 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12735 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12737 OpTYPE_set(kid, OP_GV);
12738 SvREFCNT_dec(kid->op_sv);
12739 #ifdef USE_ITHREADS
12740 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12741 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12742 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12743 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12744 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12746 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12748 kid->op_private = 0;
12749 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12757 Perl_ck_ftst(pTHX_ OP *o)
12760 const I32 type = o->op_type;
12762 PERL_ARGS_ASSERT_CK_FTST;
12764 if (o->op_flags & OPf_REF) {
12767 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12768 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12769 const OPCODE kidtype = kid->op_type;
12771 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12772 && !kid->op_folded) {
12773 OP * const newop = newGVOP(type, OPf_REF,
12774 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12779 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12780 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12782 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12783 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12784 array_passed_to_stat, name);
12787 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12788 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12791 scalar((OP *) kid);
12792 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12793 o->op_private |= OPpFT_ACCESS;
12794 if (OP_IS_FILETEST(type)
12795 && OP_IS_FILETEST(kidtype)
12797 o->op_private |= OPpFT_STACKED;
12798 kid->op_private |= OPpFT_STACKING;
12799 if (kidtype == OP_FTTTY && (
12800 !(kid->op_private & OPpFT_STACKED)
12801 || kid->op_private & OPpFT_AFTER_t
12803 o->op_private |= OPpFT_AFTER_t;
12808 if (type == OP_FTTTY)
12809 o = newGVOP(type, OPf_REF, PL_stdingv);
12811 o = newUNOP(type, 0, newDEFSVOP());
12817 Perl_ck_fun(pTHX_ OP *o)
12819 const int type = o->op_type;
12820 I32 oa = PL_opargs[type] >> OASHIFT;
12822 PERL_ARGS_ASSERT_CK_FUN;
12824 if (o->op_flags & OPf_STACKED) {
12825 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12826 oa &= ~OA_OPTIONAL;
12828 return no_fh_allowed(o);
12831 if (o->op_flags & OPf_KIDS) {
12832 OP *prev_kid = NULL;
12833 OP *kid = cLISTOPo->op_first;
12835 bool seen_optional = FALSE;
12837 if (kid->op_type == OP_PUSHMARK ||
12838 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12841 kid = OpSIBLING(kid);
12843 if (kid && kid->op_type == OP_COREARGS) {
12844 bool optional = FALSE;
12847 if (oa & OA_OPTIONAL) optional = TRUE;
12850 if (optional) o->op_private |= numargs;
12855 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12856 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12857 kid = newDEFSVOP();
12858 /* append kid to chain */
12859 op_sibling_splice(o, prev_kid, 0, kid);
12861 seen_optional = TRUE;
12868 /* list seen where single (scalar) arg expected? */
12869 if (numargs == 1 && !(oa >> 4)
12870 && kid->op_type == OP_LIST && type != OP_SCALAR)
12872 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12874 if (type != OP_DELETE) scalar(kid);
12885 if ((type == OP_PUSH || type == OP_UNSHIFT)
12886 && !OpHAS_SIBLING(kid))
12887 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12888 "Useless use of %s with no values",
12891 if (kid->op_type == OP_CONST
12892 && ( !SvROK(cSVOPx_sv(kid))
12893 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
12895 bad_type_pv(numargs, "array", o, kid);
12896 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12897 || kid->op_type == OP_RV2GV) {
12898 bad_type_pv(1, "array", o, kid);
12900 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12901 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12902 PL_op_desc[type]), 0);
12905 op_lvalue(kid, type);
12909 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12910 bad_type_pv(numargs, "hash", o, kid);
12911 op_lvalue(kid, type);
12915 /* replace kid with newop in chain */
12917 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12918 newop->op_next = newop;
12923 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12924 if (kid->op_type == OP_CONST &&
12925 (kid->op_private & OPpCONST_BARE))
12927 OP * const newop = newGVOP(OP_GV, 0,
12928 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
12929 /* replace kid with newop in chain */
12930 op_sibling_splice(o, prev_kid, 1, newop);
12934 else if (kid->op_type == OP_READLINE) {
12935 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12936 bad_type_pv(numargs, "HANDLE", o, kid);
12939 I32 flags = OPf_SPECIAL;
12941 PADOFFSET targ = 0;
12943 /* is this op a FH constructor? */
12944 if (is_handle_constructor(o,numargs)) {
12945 const char *name = NULL;
12948 bool want_dollar = TRUE;
12951 /* Set a flag to tell rv2gv to vivify
12952 * need to "prove" flag does not mean something
12953 * else already - NI-S 1999/05/07
12956 if (kid->op_type == OP_PADSV) {
12958 = PAD_COMPNAME_SV(kid->op_targ);
12959 name = PadnamePV (pn);
12960 len = PadnameLEN(pn);
12961 name_utf8 = PadnameUTF8(pn);
12963 else if (kid->op_type == OP_RV2SV
12964 && kUNOP->op_first->op_type == OP_GV)
12966 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12968 len = GvNAMELEN(gv);
12969 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12971 else if (kid->op_type == OP_AELEM
12972 || kid->op_type == OP_HELEM)
12975 OP *op = ((BINOP*)kid)->op_first;
12979 const char * const a =
12980 kid->op_type == OP_AELEM ?
12982 if (((op->op_type == OP_RV2AV) ||
12983 (op->op_type == OP_RV2HV)) &&
12984 (firstop = ((UNOP*)op)->op_first) &&
12985 (firstop->op_type == OP_GV)) {
12986 /* packagevar $a[] or $h{} */
12987 GV * const gv = cGVOPx_gv(firstop);
12990 Perl_newSVpvf(aTHX_
12995 else if (op->op_type == OP_PADAV
12996 || op->op_type == OP_PADHV) {
12997 /* lexicalvar $a[] or $h{} */
12998 const char * const padname =
12999 PAD_COMPNAME_PV(op->op_targ);
13002 Perl_newSVpvf(aTHX_
13008 name = SvPV_const(tmpstr, len);
13009 name_utf8 = SvUTF8(tmpstr);
13010 sv_2mortal(tmpstr);
13014 name = "__ANONIO__";
13016 want_dollar = FALSE;
13018 op_lvalue(kid, type);
13022 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13023 namesv = PAD_SVl(targ);
13024 if (want_dollar && *name != '$')
13025 sv_setpvs(namesv, "$");
13028 sv_catpvn(namesv, name, len);
13029 if ( name_utf8 ) SvUTF8_on(namesv);
13033 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13035 kid->op_targ = targ;
13036 kid->op_private |= priv;
13042 if ((type == OP_UNDEF || type == OP_POS)
13043 && numargs == 1 && !(oa >> 4)
13044 && kid->op_type == OP_LIST)
13045 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13046 op_lvalue(scalar(kid), type);
13051 kid = OpSIBLING(kid);
13053 /* FIXME - should the numargs or-ing move after the too many
13054 * arguments check? */
13055 o->op_private |= numargs;
13057 return too_many_arguments_pv(o,OP_DESC(o), 0);
13060 else if (PL_opargs[type] & OA_DEFGV) {
13061 /* Ordering of these two is important to keep f_map.t passing. */
13063 return newUNOP(type, 0, newDEFSVOP());
13067 while (oa & OA_OPTIONAL)
13069 if (oa && oa != OA_LIST)
13070 return too_few_arguments_pv(o,OP_DESC(o), 0);
13076 Perl_ck_glob(pTHX_ OP *o)
13080 PERL_ARGS_ASSERT_CK_GLOB;
13083 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13084 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13086 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13090 * \ null - const(wildcard)
13095 * \ mark - glob - rv2cv
13096 * | \ gv(CORE::GLOBAL::glob)
13098 * \ null - const(wildcard)
13100 o->op_flags |= OPf_SPECIAL;
13101 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13102 o = S_new_entersubop(aTHX_ gv, o);
13103 o = newUNOP(OP_NULL, 0, o);
13104 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13107 else o->op_flags &= ~OPf_SPECIAL;
13108 #if !defined(PERL_EXTERNAL_GLOB)
13109 if (!PL_globhook) {
13111 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13112 newSVpvs("File::Glob"), NULL, NULL, NULL);
13115 #endif /* !PERL_EXTERNAL_GLOB */
13116 gv = (GV *)newSV(0);
13117 gv_init(gv, 0, "", 0, 0);
13119 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13120 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13126 Perl_ck_grep(pTHX_ OP *o)
13130 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13132 PERL_ARGS_ASSERT_CK_GREP;
13134 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13136 if (o->op_flags & OPf_STACKED) {
13137 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13138 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13139 return no_fh_allowed(o);
13140 o->op_flags &= ~OPf_STACKED;
13142 kid = OpSIBLING(cLISTOPo->op_first);
13143 if (type == OP_MAPWHILE)
13148 if (PL_parser && PL_parser->error_count)
13150 kid = OpSIBLING(cLISTOPo->op_first);
13151 if (kid->op_type != OP_NULL)
13152 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13153 kid = kUNOP->op_first;
13155 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13156 kid->op_next = (OP*)gwop;
13157 o->op_private = gwop->op_private = 0;
13158 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13160 kid = OpSIBLING(cLISTOPo->op_first);
13161 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13162 op_lvalue(kid, OP_GREPSTART);
13168 Perl_ck_index(pTHX_ OP *o)
13170 PERL_ARGS_ASSERT_CK_INDEX;
13172 if (o->op_flags & OPf_KIDS) {
13173 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13175 kid = OpSIBLING(kid); /* get past "big" */
13176 if (kid && kid->op_type == OP_CONST) {
13177 const bool save_taint = TAINT_get;
13178 SV *sv = kSVOP->op_sv;
13179 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13180 && SvOK(sv) && !SvROK(sv))
13183 sv_copypv(sv, kSVOP->op_sv);
13184 SvREFCNT_dec_NN(kSVOP->op_sv);
13187 if (SvOK(sv)) fbm_compile(sv, 0);
13188 TAINT_set(save_taint);
13189 #ifdef NO_TAINT_SUPPORT
13190 PERL_UNUSED_VAR(save_taint);
13198 Perl_ck_lfun(pTHX_ OP *o)
13200 const OPCODE type = o->op_type;
13202 PERL_ARGS_ASSERT_CK_LFUN;
13204 return modkids(ck_fun(o), type);
13208 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13210 PERL_ARGS_ASSERT_CK_DEFINED;
13212 if ((o->op_flags & OPf_KIDS)) {
13213 switch (cUNOPo->op_first->op_type) {
13216 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13217 " (Maybe you should just omit the defined()?)");
13218 NOT_REACHED; /* NOTREACHED */
13222 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13223 " (Maybe you should just omit the defined()?)");
13224 NOT_REACHED; /* NOTREACHED */
13235 Perl_ck_readline(pTHX_ OP *o)
13237 PERL_ARGS_ASSERT_CK_READLINE;
13239 if (o->op_flags & OPf_KIDS) {
13240 OP *kid = cLISTOPo->op_first;
13241 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13246 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13254 Perl_ck_rfun(pTHX_ OP *o)
13256 const OPCODE type = o->op_type;
13258 PERL_ARGS_ASSERT_CK_RFUN;
13260 return refkids(ck_fun(o), type);
13264 Perl_ck_listiob(pTHX_ OP *o)
13268 PERL_ARGS_ASSERT_CK_LISTIOB;
13270 kid = cLISTOPo->op_first;
13272 o = force_list(o, 1);
13273 kid = cLISTOPo->op_first;
13275 if (kid->op_type == OP_PUSHMARK)
13276 kid = OpSIBLING(kid);
13277 if (kid && o->op_flags & OPf_STACKED)
13278 kid = OpSIBLING(kid);
13279 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13280 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13281 && !kid->op_folded) {
13282 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13284 /* replace old const op with new OP_RV2GV parent */
13285 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13286 OP_RV2GV, OPf_REF);
13287 kid = OpSIBLING(kid);
13292 op_append_elem(o->op_type, o, newDEFSVOP());
13294 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13295 return listkids(o);
13299 Perl_ck_smartmatch(pTHX_ OP *o)
13302 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13303 if (0 == (o->op_flags & OPf_SPECIAL)) {
13304 OP *first = cBINOPo->op_first;
13305 OP *second = OpSIBLING(first);
13307 /* Implicitly take a reference to an array or hash */
13309 /* remove the original two siblings, then add back the
13310 * (possibly different) first and second sibs.
13312 op_sibling_splice(o, NULL, 1, NULL);
13313 op_sibling_splice(o, NULL, 1, NULL);
13314 first = ref_array_or_hash(first);
13315 second = ref_array_or_hash(second);
13316 op_sibling_splice(o, NULL, 0, second);
13317 op_sibling_splice(o, NULL, 0, first);
13319 /* Implicitly take a reference to a regular expression */
13320 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13321 OpTYPE_set(first, OP_QR);
13323 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13324 OpTYPE_set(second, OP_QR);
13333 S_maybe_targlex(pTHX_ OP *o)
13335 OP * const kid = cLISTOPo->op_first;
13336 /* has a disposable target? */
13337 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13338 && !(kid->op_flags & OPf_STACKED)
13339 /* Cannot steal the second time! */
13340 && !(kid->op_private & OPpTARGET_MY)
13343 OP * const kkid = OpSIBLING(kid);
13345 /* Can just relocate the target. */
13346 if (kkid && kkid->op_type == OP_PADSV
13347 && (!(kkid->op_private & OPpLVAL_INTRO)
13348 || kkid->op_private & OPpPAD_STATE))
13350 kid->op_targ = kkid->op_targ;
13352 /* Now we do not need PADSV and SASSIGN.
13353 * Detach kid and free the rest. */
13354 op_sibling_splice(o, NULL, 1, NULL);
13356 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13364 Perl_ck_sassign(pTHX_ OP *o)
13367 OP * const kid = cBINOPo->op_first;
13369 PERL_ARGS_ASSERT_CK_SASSIGN;
13371 if (OpHAS_SIBLING(kid)) {
13372 OP *kkid = OpSIBLING(kid);
13373 /* For state variable assignment with attributes, kkid is a list op
13374 whose op_last is a padsv. */
13375 if ((kkid->op_type == OP_PADSV ||
13376 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13377 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13380 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13381 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13382 return S_newONCEOP(aTHX_ o, kkid);
13385 return S_maybe_targlex(aTHX_ o);
13390 Perl_ck_match(pTHX_ OP *o)
13392 PERL_UNUSED_CONTEXT;
13393 PERL_ARGS_ASSERT_CK_MATCH;
13399 Perl_ck_method(pTHX_ OP *o)
13401 SV *sv, *methsv, *rclass;
13402 const char* method;
13405 STRLEN len, nsplit = 0, i;
13407 OP * const kid = cUNOPo->op_first;
13409 PERL_ARGS_ASSERT_CK_METHOD;
13410 if (kid->op_type != OP_CONST) return o;
13414 /* replace ' with :: */
13415 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13416 SvEND(sv) - SvPVX(sv) )))
13419 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13422 method = SvPVX_const(sv);
13424 utf8 = SvUTF8(sv) ? -1 : 1;
13426 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13431 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13433 if (!nsplit) { /* $proto->method() */
13435 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13438 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13440 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13443 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13444 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13445 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13446 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13448 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13449 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13451 #ifdef USE_ITHREADS
13452 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13454 cMETHOPx(new_op)->op_rclass_sv = rclass;
13461 Perl_ck_null(pTHX_ OP *o)
13463 PERL_ARGS_ASSERT_CK_NULL;
13464 PERL_UNUSED_CONTEXT;
13469 Perl_ck_open(pTHX_ OP *o)
13471 PERL_ARGS_ASSERT_CK_OPEN;
13473 S_io_hints(aTHX_ o);
13475 /* In case of three-arg dup open remove strictness
13476 * from the last arg if it is a bareword. */
13477 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13478 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13482 if ((last->op_type == OP_CONST) && /* The bareword. */
13483 (last->op_private & OPpCONST_BARE) &&
13484 (last->op_private & OPpCONST_STRICT) &&
13485 (oa = OpSIBLING(first)) && /* The fh. */
13486 (oa = OpSIBLING(oa)) && /* The mode. */
13487 (oa->op_type == OP_CONST) &&
13488 SvPOK(((SVOP*)oa)->op_sv) &&
13489 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13490 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13491 (last == OpSIBLING(oa))) /* The bareword. */
13492 last->op_private &= ~OPpCONST_STRICT;
13498 Perl_ck_prototype(pTHX_ OP *o)
13500 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13501 if (!(o->op_flags & OPf_KIDS)) {
13503 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13509 Perl_ck_refassign(pTHX_ OP *o)
13511 OP * const right = cLISTOPo->op_first;
13512 OP * const left = OpSIBLING(right);
13513 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13516 PERL_ARGS_ASSERT_CK_REFASSIGN;
13518 assert (left->op_type == OP_SREFGEN);
13521 /* we use OPpPAD_STATE in refassign to mean either of those things,
13522 * and the code assumes the two flags occupy the same bit position
13523 * in the various ops below */
13524 assert(OPpPAD_STATE == OPpOUR_INTRO);
13526 switch (varop->op_type) {
13528 o->op_private |= OPpLVREF_AV;
13531 o->op_private |= OPpLVREF_HV;
13535 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13536 o->op_targ = varop->op_targ;
13537 varop->op_targ = 0;
13538 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13542 o->op_private |= OPpLVREF_AV;
13544 NOT_REACHED; /* NOTREACHED */
13546 o->op_private |= OPpLVREF_HV;
13550 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13551 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13553 /* Point varop to its GV kid, detached. */
13554 varop = op_sibling_splice(varop, NULL, -1, NULL);
13558 OP * const kidparent =
13559 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13560 OP * const kid = cUNOPx(kidparent)->op_first;
13561 o->op_private |= OPpLVREF_CV;
13562 if (kid->op_type == OP_GV) {
13563 SV *sv = (SV*)cGVOPx_gv(kid);
13565 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13566 /* a CVREF here confuses pp_refassign, so make sure
13568 CV *const cv = (CV*)SvRV(sv);
13569 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13570 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13571 assert(SvTYPE(sv) == SVt_PVGV);
13573 goto detach_and_stack;
13575 if (kid->op_type != OP_PADCV) goto bad;
13576 o->op_targ = kid->op_targ;
13582 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13583 o->op_private |= OPpLVREF_ELEM;
13586 /* Detach varop. */
13587 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13591 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13592 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13597 if (!FEATURE_REFALIASING_IS_ENABLED)
13599 "Experimental aliasing via reference not enabled");
13600 Perl_ck_warner_d(aTHX_
13601 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13602 "Aliasing via reference is experimental");
13604 o->op_flags |= OPf_STACKED;
13605 op_sibling_splice(o, right, 1, varop);
13608 o->op_flags &=~ OPf_STACKED;
13609 op_sibling_splice(o, right, 1, NULL);
13616 Perl_ck_repeat(pTHX_ OP *o)
13618 PERL_ARGS_ASSERT_CK_REPEAT;
13620 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13622 o->op_private |= OPpREPEAT_DOLIST;
13623 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13624 kids = force_list(kids, 1); /* promote it to a list */
13625 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13633 Perl_ck_require(pTHX_ OP *o)
13637 PERL_ARGS_ASSERT_CK_REQUIRE;
13639 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13640 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13644 if (kid->op_type == OP_CONST) {
13645 SV * const sv = kid->op_sv;
13646 U32 const was_readonly = SvREADONLY(sv);
13647 if (kid->op_private & OPpCONST_BARE) {
13652 if (was_readonly) {
13653 SvREADONLY_off(sv);
13656 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13661 /* treat ::foo::bar as foo::bar */
13662 if (len >= 2 && s[0] == ':' && s[1] == ':')
13663 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13665 DIE(aTHX_ "Bareword in require maps to empty filename");
13667 for (; s < end; s++) {
13668 if (*s == ':' && s[1] == ':') {
13670 Move(s+2, s+1, end - s - 1, char);
13674 SvEND_set(sv, end);
13675 sv_catpvs(sv, ".pm");
13676 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13677 hek = share_hek(SvPVX(sv),
13678 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13680 sv_sethek(sv, hek);
13682 SvFLAGS(sv) |= was_readonly;
13684 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13687 if (SvREFCNT(sv) > 1) {
13688 kid->op_sv = newSVpvn_share(
13689 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13690 SvREFCNT_dec_NN(sv);
13695 if (was_readonly) SvREADONLY_off(sv);
13696 PERL_HASH(hash, s, len);
13698 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13700 sv_sethek(sv, hek);
13702 SvFLAGS(sv) |= was_readonly;
13708 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13709 /* handle override, if any */
13710 && (gv = gv_override("require", 7))) {
13712 if (o->op_flags & OPf_KIDS) {
13713 kid = cUNOPo->op_first;
13714 op_sibling_splice(o, NULL, -1, NULL);
13717 kid = newDEFSVOP();
13720 newop = S_new_entersubop(aTHX_ gv, kid);
13728 Perl_ck_return(pTHX_ OP *o)
13732 PERL_ARGS_ASSERT_CK_RETURN;
13734 kid = OpSIBLING(cLISTOPo->op_first);
13735 if (PL_compcv && CvLVALUE(PL_compcv)) {
13736 for (; kid; kid = OpSIBLING(kid))
13737 op_lvalue(kid, OP_LEAVESUBLV);
13744 Perl_ck_select(pTHX_ OP *o)
13749 PERL_ARGS_ASSERT_CK_SELECT;
13751 if (o->op_flags & OPf_KIDS) {
13752 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13753 if (kid && OpHAS_SIBLING(kid)) {
13754 OpTYPE_set(o, OP_SSELECT);
13756 return fold_constants(op_integerize(op_std_init(o)));
13760 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13761 if (kid && kid->op_type == OP_RV2GV)
13762 kid->op_private &= ~HINT_STRICT_REFS;
13767 Perl_ck_shift(pTHX_ OP *o)
13769 const I32 type = o->op_type;
13771 PERL_ARGS_ASSERT_CK_SHIFT;
13773 if (!(o->op_flags & OPf_KIDS)) {
13776 if (!CvUNIQUE(PL_compcv)) {
13777 o->op_flags |= OPf_SPECIAL;
13781 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13783 return newUNOP(type, 0, scalar(argop));
13785 return scalar(ck_fun(o));
13789 Perl_ck_sort(pTHX_ OP *o)
13793 HV * const hinthv =
13794 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13797 PERL_ARGS_ASSERT_CK_SORT;
13800 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13802 const I32 sorthints = (I32)SvIV(*svp);
13803 if ((sorthints & HINT_SORT_STABLE) != 0)
13804 o->op_private |= OPpSORT_STABLE;
13805 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13806 o->op_private |= OPpSORT_UNSTABLE;
13810 if (o->op_flags & OPf_STACKED)
13812 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13814 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13815 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13817 /* if the first arg is a code block, process it and mark sort as
13819 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13821 if (kid->op_type == OP_LEAVE)
13822 op_null(kid); /* wipe out leave */
13823 /* Prevent execution from escaping out of the sort block. */
13826 /* provide scalar context for comparison function/block */
13827 kid = scalar(firstkid);
13828 kid->op_next = kid;
13829 o->op_flags |= OPf_SPECIAL;
13831 else if (kid->op_type == OP_CONST
13832 && kid->op_private & OPpCONST_BARE) {
13836 const char * const name = SvPV(kSVOP_sv, len);
13838 assert (len < 256);
13839 Copy(name, tmpbuf+1, len, char);
13840 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13841 if (off != NOT_IN_PAD) {
13842 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13844 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13845 sv_catpvs(fq, "::");
13846 sv_catsv(fq, kSVOP_sv);
13847 SvREFCNT_dec_NN(kSVOP_sv);
13851 OP * const padop = newOP(OP_PADCV, 0);
13852 padop->op_targ = off;
13853 /* replace the const op with the pad op */
13854 op_sibling_splice(firstkid, NULL, 1, padop);
13860 firstkid = OpSIBLING(firstkid);
13863 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13864 /* provide list context for arguments */
13867 op_lvalue(kid, OP_GREPSTART);
13873 /* for sort { X } ..., where X is one of
13874 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13875 * elide the second child of the sort (the one containing X),
13876 * and set these flags as appropriate
13880 * Also, check and warn on lexical $a, $b.
13884 S_simplify_sort(pTHX_ OP *o)
13886 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13890 const char *gvname;
13893 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13895 kid = kUNOP->op_first; /* get past null */
13896 if (!(have_scopeop = kid->op_type == OP_SCOPE)
13897 && kid->op_type != OP_LEAVE)
13899 kid = kLISTOP->op_last; /* get past scope */
13900 switch(kid->op_type) {
13904 if (!have_scopeop) goto padkids;
13909 k = kid; /* remember this node*/
13910 if (kBINOP->op_first->op_type != OP_RV2SV
13911 || kBINOP->op_last ->op_type != OP_RV2SV)
13914 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13915 then used in a comparison. This catches most, but not
13916 all cases. For instance, it catches
13917 sort { my($a); $a <=> $b }
13919 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13920 (although why you'd do that is anyone's guess).
13924 if (!ckWARN(WARN_SYNTAX)) return;
13925 kid = kBINOP->op_first;
13927 if (kid->op_type == OP_PADSV) {
13928 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13929 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13930 && ( PadnamePV(name)[1] == 'a'
13931 || PadnamePV(name)[1] == 'b' ))
13932 /* diag_listed_as: "my %s" used in sort comparison */
13933 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13934 "\"%s %s\" used in sort comparison",
13935 PadnameIsSTATE(name)
13940 } while ((kid = OpSIBLING(kid)));
13943 kid = kBINOP->op_first; /* get past cmp */
13944 if (kUNOP->op_first->op_type != OP_GV)
13946 kid = kUNOP->op_first; /* get past rv2sv */
13948 if (GvSTASH(gv) != PL_curstash)
13950 gvname = GvNAME(gv);
13951 if (*gvname == 'a' && gvname[1] == '\0')
13953 else if (*gvname == 'b' && gvname[1] == '\0')
13958 kid = k; /* back to cmp */
13959 /* already checked above that it is rv2sv */
13960 kid = kBINOP->op_last; /* down to 2nd arg */
13961 if (kUNOP->op_first->op_type != OP_GV)
13963 kid = kUNOP->op_first; /* get past rv2sv */
13965 if (GvSTASH(gv) != PL_curstash)
13967 gvname = GvNAME(gv);
13969 ? !(*gvname == 'a' && gvname[1] == '\0')
13970 : !(*gvname == 'b' && gvname[1] == '\0'))
13972 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13974 o->op_private |= OPpSORT_DESCEND;
13975 if (k->op_type == OP_NCMP)
13976 o->op_private |= OPpSORT_NUMERIC;
13977 if (k->op_type == OP_I_NCMP)
13978 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13979 kid = OpSIBLING(cLISTOPo->op_first);
13980 /* cut out and delete old block (second sibling) */
13981 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13986 Perl_ck_split(pTHX_ OP *o)
13992 PERL_ARGS_ASSERT_CK_SPLIT;
13994 assert(o->op_type == OP_LIST);
13996 if (o->op_flags & OPf_STACKED)
13997 return no_fh_allowed(o);
13999 kid = cLISTOPo->op_first;
14000 /* delete leading NULL node, then add a CONST if no other nodes */
14001 assert(kid->op_type == OP_NULL);
14002 op_sibling_splice(o, NULL, 1,
14003 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14005 kid = cLISTOPo->op_first;
14007 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14008 /* remove match expression, and replace with new optree with
14009 * a match op at its head */
14010 op_sibling_splice(o, NULL, 1, NULL);
14011 /* pmruntime will handle split " " behavior with flag==2 */
14012 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14013 op_sibling_splice(o, NULL, 0, kid);
14016 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14018 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14019 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14020 "Use of /g modifier is meaningless in split");
14023 /* eliminate the split op, and move the match op (plus any children)
14024 * into its place, then convert the match op into a split op. i.e.
14026 * SPLIT MATCH SPLIT(ex-MATCH)
14028 * MATCH - A - B - C => R - A - B - C => R - A - B - C
14034 * (R, if it exists, will be a regcomp op)
14037 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14038 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14039 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14040 OpTYPE_set(kid, OP_SPLIT);
14041 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14042 kid->op_private = o->op_private;
14045 kid = sibs; /* kid is now the string arg of the split */
14048 kid = newDEFSVOP();
14049 op_append_elem(OP_SPLIT, o, kid);
14053 kid = OpSIBLING(kid);
14055 kid = newSVOP(OP_CONST, 0, newSViv(0));
14056 op_append_elem(OP_SPLIT, o, kid);
14057 o->op_private |= OPpSPLIT_IMPLIM;
14061 if (OpHAS_SIBLING(kid))
14062 return too_many_arguments_pv(o,OP_DESC(o), 0);
14068 Perl_ck_stringify(pTHX_ OP *o)
14070 OP * const kid = OpSIBLING(cUNOPo->op_first);
14071 PERL_ARGS_ASSERT_CK_STRINGIFY;
14072 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14073 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14074 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14075 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14077 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14085 Perl_ck_join(pTHX_ OP *o)
14087 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14089 PERL_ARGS_ASSERT_CK_JOIN;
14091 if (kid && kid->op_type == OP_MATCH) {
14092 if (ckWARN(WARN_SYNTAX)) {
14093 const REGEXP *re = PM_GETRE(kPMOP);
14095 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14096 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14097 : newSVpvs_flags( "STRING", SVs_TEMP );
14098 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14099 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14100 SVfARG(msg), SVfARG(msg));
14104 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14105 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14106 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14107 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14109 const OP * const bairn = OpSIBLING(kid); /* the list */
14110 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14111 && OP_GIMME(bairn,0) == G_SCALAR)
14113 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14114 op_sibling_splice(o, kid, 1, NULL));
14124 =for apidoc rv2cv_op_cv
14126 Examines an op, which is expected to identify a subroutine at runtime,
14127 and attempts to determine at compile time which subroutine it identifies.
14128 This is normally used during Perl compilation to determine whether
14129 a prototype can be applied to a function call. C<cvop> is the op
14130 being considered, normally an C<rv2cv> op. A pointer to the identified
14131 subroutine is returned, if it could be determined statically, and a null
14132 pointer is returned if it was not possible to determine statically.
14134 Currently, the subroutine can be identified statically if the RV that the
14135 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14136 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14137 suitable if the constant value must be an RV pointing to a CV. Details of
14138 this process may change in future versions of Perl. If the C<rv2cv> op
14139 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14140 the subroutine statically: this flag is used to suppress compile-time
14141 magic on a subroutine call, forcing it to use default runtime behaviour.
14143 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14144 of a GV reference is modified. If a GV was examined and its CV slot was
14145 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14146 If the op is not optimised away, and the CV slot is later populated with
14147 a subroutine having a prototype, that flag eventually triggers the warning
14148 "called too early to check prototype".
14150 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14151 of returning a pointer to the subroutine it returns a pointer to the
14152 GV giving the most appropriate name for the subroutine in this context.
14153 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14154 (C<CvANON>) subroutine that is referenced through a GV it will be the
14155 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14156 A null pointer is returned as usual if there is no statically-determinable
14159 =for apidoc Amnh||OPpEARLY_CV
14160 =for apidoc Amnh||OPpENTERSUB_AMPER
14161 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14162 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14167 /* shared by toke.c:yylex */
14169 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14171 PADNAME *name = PAD_COMPNAME(off);
14172 CV *compcv = PL_compcv;
14173 while (PadnameOUTER(name)) {
14174 assert(PARENT_PAD_INDEX(name));
14175 compcv = CvOUTSIDE(compcv);
14176 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14177 [off = PARENT_PAD_INDEX(name)];
14179 assert(!PadnameIsOUR(name));
14180 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14181 return PadnamePROTOCV(name);
14183 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14187 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14192 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14193 if (flags & ~RV2CVOPCV_FLAG_MASK)
14194 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14195 if (cvop->op_type != OP_RV2CV)
14197 if (cvop->op_private & OPpENTERSUB_AMPER)
14199 if (!(cvop->op_flags & OPf_KIDS))
14201 rvop = cUNOPx(cvop)->op_first;
14202 switch (rvop->op_type) {
14204 gv = cGVOPx_gv(rvop);
14206 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14207 cv = MUTABLE_CV(SvRV(gv));
14211 if (flags & RV2CVOPCV_RETURN_STUB)
14217 if (flags & RV2CVOPCV_MARK_EARLY)
14218 rvop->op_private |= OPpEARLY_CV;
14223 SV *rv = cSVOPx_sv(rvop);
14226 cv = (CV*)SvRV(rv);
14230 cv = find_lexical_cv(rvop->op_targ);
14235 } NOT_REACHED; /* NOTREACHED */
14237 if (SvTYPE((SV*)cv) != SVt_PVCV)
14239 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14240 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14244 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14245 if (CvLEXICAL(cv) || CvNAMED(cv))
14247 if (!CvANON(cv) || !gv)
14257 =for apidoc ck_entersub_args_list
14259 Performs the default fixup of the arguments part of an C<entersub>
14260 op tree. This consists of applying list context to each of the
14261 argument ops. This is the standard treatment used on a call marked
14262 with C<&>, or a method call, or a call through a subroutine reference,
14263 or any other call where the callee can't be identified at compile time,
14264 or a call where the callee has no prototype.
14270 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14274 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14276 aop = cUNOPx(entersubop)->op_first;
14277 if (!OpHAS_SIBLING(aop))
14278 aop = cUNOPx(aop)->op_first;
14279 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14280 /* skip the extra attributes->import() call implicitly added in
14281 * something like foo(my $x : bar)
14283 if ( aop->op_type == OP_ENTERSUB
14284 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14288 op_lvalue(aop, OP_ENTERSUB);
14294 =for apidoc ck_entersub_args_proto
14296 Performs the fixup of the arguments part of an C<entersub> op tree
14297 based on a subroutine prototype. This makes various modifications to
14298 the argument ops, from applying context up to inserting C<refgen> ops,
14299 and checking the number and syntactic types of arguments, as directed by
14300 the prototype. This is the standard treatment used on a subroutine call,
14301 not marked with C<&>, where the callee can be identified at compile time
14302 and has a prototype.
14304 C<protosv> supplies the subroutine prototype to be applied to the call.
14305 It may be a normal defined scalar, of which the string value will be used.
14306 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14307 that has been cast to C<SV*>) which has a prototype. The prototype
14308 supplied, in whichever form, does not need to match the actual callee
14309 referenced by the op tree.
14311 If the argument ops disagree with the prototype, for example by having
14312 an unacceptable number of arguments, a valid op tree is returned anyway.
14313 The error is reflected in the parser state, normally resulting in a single
14314 exception at the top level of parsing which covers all the compilation
14315 errors that occurred. In the error message, the callee is referred to
14316 by the name defined by the C<namegv> parameter.
14322 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14325 const char *proto, *proto_end;
14326 OP *aop, *prev, *cvop, *parent;
14329 I32 contextclass = 0;
14330 const char *e = NULL;
14331 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14332 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14333 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14334 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14335 if (SvTYPE(protosv) == SVt_PVCV)
14336 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14337 else proto = SvPV(protosv, proto_len);
14338 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14339 proto_end = proto + proto_len;
14340 parent = entersubop;
14341 aop = cUNOPx(entersubop)->op_first;
14342 if (!OpHAS_SIBLING(aop)) {
14344 aop = cUNOPx(aop)->op_first;
14347 aop = OpSIBLING(aop);
14348 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14349 while (aop != cvop) {
14352 if (proto >= proto_end)
14354 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14355 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14356 SVfARG(namesv)), SvUTF8(namesv));
14366 /* _ must be at the end */
14367 if (proto[1] && !memCHRs(";@%", proto[1]))
14383 if ( o3->op_type != OP_UNDEF
14384 && (o3->op_type != OP_SREFGEN
14385 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14387 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14389 bad_type_gv(arg, namegv, o3,
14390 arg == 1 ? "block or sub {}" : "sub {}");
14393 /* '*' allows any scalar type, including bareword */
14396 if (o3->op_type == OP_RV2GV)
14397 goto wrapref; /* autoconvert GLOB -> GLOBref */
14398 else if (o3->op_type == OP_CONST)
14399 o3->op_private &= ~OPpCONST_STRICT;
14405 if (o3->op_type == OP_RV2AV ||
14406 o3->op_type == OP_PADAV ||
14407 o3->op_type == OP_RV2HV ||
14408 o3->op_type == OP_PADHV
14414 case '[': case ']':
14421 switch (*proto++) {
14423 if (contextclass++ == 0) {
14424 e = (char *) memchr(proto, ']', proto_end - proto);
14425 if (!e || e == proto)
14433 if (contextclass) {
14434 const char *p = proto;
14435 const char *const end = proto;
14437 while (*--p != '[')
14438 /* \[$] accepts any scalar lvalue */
14440 && Perl_op_lvalue_flags(aTHX_
14442 OP_READ, /* not entersub */
14445 bad_type_gv(arg, namegv, o3,
14446 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14451 if (o3->op_type == OP_RV2GV)
14454 bad_type_gv(arg, namegv, o3, "symbol");
14457 if (o3->op_type == OP_ENTERSUB
14458 && !(o3->op_flags & OPf_STACKED))
14461 bad_type_gv(arg, namegv, o3, "subroutine");
14464 if (o3->op_type == OP_RV2SV ||
14465 o3->op_type == OP_PADSV ||
14466 o3->op_type == OP_HELEM ||
14467 o3->op_type == OP_AELEM)
14469 if (!contextclass) {
14470 /* \$ accepts any scalar lvalue */
14471 if (Perl_op_lvalue_flags(aTHX_
14473 OP_READ, /* not entersub */
14476 bad_type_gv(arg, namegv, o3, "scalar");
14480 if (o3->op_type == OP_RV2AV ||
14481 o3->op_type == OP_PADAV)
14483 o3->op_flags &=~ OPf_PARENS;
14487 bad_type_gv(arg, namegv, o3, "array");
14490 if (o3->op_type == OP_RV2HV ||
14491 o3->op_type == OP_PADHV)
14493 o3->op_flags &=~ OPf_PARENS;
14497 bad_type_gv(arg, namegv, o3, "hash");
14500 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14502 if (contextclass && e) {
14507 default: goto oops;
14517 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14518 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14523 op_lvalue(aop, OP_ENTERSUB);
14525 aop = OpSIBLING(aop);
14527 if (aop == cvop && *proto == '_') {
14528 /* generate an access to $_ */
14529 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14531 if (!optional && proto_end > proto &&
14532 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14534 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14535 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14536 SVfARG(namesv)), SvUTF8(namesv));
14542 =for apidoc ck_entersub_args_proto_or_list
14544 Performs the fixup of the arguments part of an C<entersub> op tree either
14545 based on a subroutine prototype or using default list-context processing.
14546 This is the standard treatment used on a subroutine call, not marked
14547 with C<&>, where the callee can be identified at compile time.
14549 C<protosv> supplies the subroutine prototype to be applied to the call,
14550 or indicates that there is no prototype. It may be a normal scalar,
14551 in which case if it is defined then the string value will be used
14552 as a prototype, and if it is undefined then there is no prototype.
14553 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14554 that has been cast to C<SV*>), of which the prototype will be used if it
14555 has one. The prototype (or lack thereof) supplied, in whichever form,
14556 does not need to match the actual callee referenced by the op tree.
14558 If the argument ops disagree with the prototype, for example by having
14559 an unacceptable number of arguments, a valid op tree is returned anyway.
14560 The error is reflected in the parser state, normally resulting in a single
14561 exception at the top level of parsing which covers all the compilation
14562 errors that occurred. In the error message, the callee is referred to
14563 by the name defined by the C<namegv> parameter.
14569 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14570 GV *namegv, SV *protosv)
14572 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14573 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14574 return ck_entersub_args_proto(entersubop, namegv, protosv);
14576 return ck_entersub_args_list(entersubop);
14580 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14582 IV cvflags = SvIVX(protosv);
14583 int opnum = cvflags & 0xffff;
14584 OP *aop = cUNOPx(entersubop)->op_first;
14586 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14590 if (!OpHAS_SIBLING(aop))
14591 aop = cUNOPx(aop)->op_first;
14592 aop = OpSIBLING(aop);
14593 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14595 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14596 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14597 SVfARG(namesv)), SvUTF8(namesv));
14600 op_free(entersubop);
14601 switch(cvflags >> 16) {
14602 case 'F': return newSVOP(OP_CONST, 0,
14603 newSVpv(CopFILE(PL_curcop),0));
14604 case 'L': return newSVOP(
14606 Perl_newSVpvf(aTHX_
14607 "%" IVdf, (IV)CopLINE(PL_curcop)
14610 case 'P': return newSVOP(OP_CONST, 0,
14612 ? newSVhek(HvNAME_HEK(PL_curstash))
14617 NOT_REACHED; /* NOTREACHED */
14620 OP *prev, *cvop, *first, *parent;
14623 parent = entersubop;
14624 if (!OpHAS_SIBLING(aop)) {
14626 aop = cUNOPx(aop)->op_first;
14629 first = prev = aop;
14630 aop = OpSIBLING(aop);
14631 /* find last sibling */
14633 OpHAS_SIBLING(cvop);
14634 prev = cvop, cvop = OpSIBLING(cvop))
14636 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14637 /* Usually, OPf_SPECIAL on an op with no args means that it had
14638 * parens, but these have their own meaning for that flag: */
14639 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14640 && opnum != OP_DELETE && opnum != OP_EXISTS)
14641 flags |= OPf_SPECIAL;
14642 /* excise cvop from end of sibling chain */
14643 op_sibling_splice(parent, prev, 1, NULL);
14645 if (aop == cvop) aop = NULL;
14647 /* detach remaining siblings from the first sibling, then
14648 * dispose of original optree */
14651 op_sibling_splice(parent, first, -1, NULL);
14652 op_free(entersubop);
14654 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14655 flags |= OPpEVAL_BYTES <<8;
14657 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14659 case OA_BASEOP_OR_UNOP:
14660 case OA_FILESTATOP:
14662 return newOP(opnum,flags); /* zero args */
14664 return newUNOP(opnum,flags,aop); /* one arg */
14665 /* too many args */
14672 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14673 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14674 SVfARG(namesv)), SvUTF8(namesv));
14676 nextop = OpSIBLING(aop);
14682 return opnum == OP_RUNCV
14683 ? newPVOP(OP_RUNCV,0,NULL)
14686 return op_convert_list(opnum,0,aop);
14689 NOT_REACHED; /* NOTREACHED */
14694 =for apidoc cv_get_call_checker_flags
14696 Retrieves the function that will be used to fix up a call to C<cv>.
14697 Specifically, the function is applied to an C<entersub> op tree for a
14698 subroutine call, not marked with C<&>, where the callee can be identified
14699 at compile time as C<cv>.
14701 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14702 for it is returned in C<*ckobj_p>, and control flags are returned in
14703 C<*ckflags_p>. The function is intended to be called in this manner:
14705 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14707 In this call, C<entersubop> is a pointer to the C<entersub> op,
14708 which may be replaced by the check function, and C<namegv> supplies
14709 the name that should be used by the check function to refer
14710 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14711 It is permitted to apply the check function in non-standard situations,
14712 such as to a call to a different subroutine or to a method call.
14714 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14715 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14716 instead, anything that can be used as the first argument to L</cv_name>.
14717 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14718 check function requires C<namegv> to be a genuine GV.
14720 By default, the check function is
14721 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14722 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14723 flag is clear. This implements standard prototype processing. It can
14724 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14726 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14727 indicates that the caller only knows about the genuine GV version of
14728 C<namegv>, and accordingly the corresponding bit will always be set in
14729 C<*ckflags_p>, regardless of the check function's recorded requirements.
14730 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14731 indicates the caller knows about the possibility of passing something
14732 other than a GV as C<namegv>, and accordingly the corresponding bit may
14733 be either set or clear in C<*ckflags_p>, indicating the check function's
14734 recorded requirements.
14736 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14737 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14738 (for which see above). All other bits should be clear.
14740 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14742 =for apidoc cv_get_call_checker
14744 The original form of L</cv_get_call_checker_flags>, which does not return
14745 checker flags. When using a checker function returned by this function,
14746 it is only safe to call it with a genuine GV as its C<namegv> argument.
14752 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14753 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14756 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14757 PERL_UNUSED_CONTEXT;
14758 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14760 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14761 *ckobj_p = callmg->mg_obj;
14762 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14764 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14765 *ckobj_p = (SV*)cv;
14766 *ckflags_p = gflags & MGf_REQUIRE_GV;
14771 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14774 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14775 PERL_UNUSED_CONTEXT;
14776 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14781 =for apidoc cv_set_call_checker_flags
14783 Sets the function that will be used to fix up a call to C<cv>.
14784 Specifically, the function is applied to an C<entersub> op tree for a
14785 subroutine call, not marked with C<&>, where the callee can be identified
14786 at compile time as C<cv>.
14788 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14789 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14790 The function should be defined like this:
14792 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14794 It is intended to be called in this manner:
14796 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14798 In this call, C<entersubop> is a pointer to the C<entersub> op,
14799 which may be replaced by the check function, and C<namegv> supplies
14800 the name that should be used by the check function to refer
14801 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14802 It is permitted to apply the check function in non-standard situations,
14803 such as to a call to a different subroutine or to a method call.
14805 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14806 CV or other SV instead. Whatever is passed can be used as the first
14807 argument to L</cv_name>. You can force perl to pass a GV by including
14808 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14810 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14811 bit currently has a defined meaning (for which see above). All other
14812 bits should be clear.
14814 The current setting for a particular CV can be retrieved by
14815 L</cv_get_call_checker_flags>.
14817 =for apidoc cv_set_call_checker
14819 The original form of L</cv_set_call_checker_flags>, which passes it the
14820 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14821 of that flag setting is that the check function is guaranteed to get a
14822 genuine GV as its C<namegv> argument.
14828 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14830 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14831 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14835 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14836 SV *ckobj, U32 ckflags)
14838 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14839 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14840 if (SvMAGICAL((SV*)cv))
14841 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14844 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14845 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14847 if (callmg->mg_flags & MGf_REFCOUNTED) {
14848 SvREFCNT_dec(callmg->mg_obj);
14849 callmg->mg_flags &= ~MGf_REFCOUNTED;
14851 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14852 callmg->mg_obj = ckobj;
14853 if (ckobj != (SV*)cv) {
14854 SvREFCNT_inc_simple_void_NN(ckobj);
14855 callmg->mg_flags |= MGf_REFCOUNTED;
14857 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14858 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14863 S_entersub_alloc_targ(pTHX_ OP * const o)
14865 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14866 o->op_private |= OPpENTERSUB_HASTARG;
14870 Perl_ck_subr(pTHX_ OP *o)
14875 SV **const_class = NULL;
14877 PERL_ARGS_ASSERT_CK_SUBR;
14879 aop = cUNOPx(o)->op_first;
14880 if (!OpHAS_SIBLING(aop))
14881 aop = cUNOPx(aop)->op_first;
14882 aop = OpSIBLING(aop);
14883 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14884 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14885 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14887 o->op_private &= ~1;
14888 o->op_private |= (PL_hints & HINT_STRICT_REFS);
14889 if (PERLDB_SUB && PL_curstash != PL_debstash)
14890 o->op_private |= OPpENTERSUB_DB;
14891 switch (cvop->op_type) {
14893 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14897 case OP_METHOD_NAMED:
14898 case OP_METHOD_SUPER:
14899 case OP_METHOD_REDIR:
14900 case OP_METHOD_REDIR_SUPER:
14901 o->op_flags |= OPf_REF;
14902 if (aop->op_type == OP_CONST) {
14903 aop->op_private &= ~OPpCONST_STRICT;
14904 const_class = &cSVOPx(aop)->op_sv;
14906 else if (aop->op_type == OP_LIST) {
14907 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
14908 if (sib && sib->op_type == OP_CONST) {
14909 sib->op_private &= ~OPpCONST_STRICT;
14910 const_class = &cSVOPx(sib)->op_sv;
14913 /* make class name a shared cow string to speedup method calls */
14914 /* constant string might be replaced with object, f.e. bigint */
14915 if (const_class && SvPOK(*const_class)) {
14917 const char* str = SvPV(*const_class, len);
14919 SV* const shared = newSVpvn_share(
14920 str, SvUTF8(*const_class)
14921 ? -(SSize_t)len : (SSize_t)len,
14924 if (SvREADONLY(*const_class))
14925 SvREADONLY_on(shared);
14926 SvREFCNT_dec(*const_class);
14927 *const_class = shared;
14934 S_entersub_alloc_targ(aTHX_ o);
14935 return ck_entersub_args_list(o);
14937 Perl_call_checker ckfun;
14940 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14941 if (CvISXSUB(cv) || !CvROOT(cv))
14942 S_entersub_alloc_targ(aTHX_ o);
14944 /* The original call checker API guarantees that a GV will be
14945 be provided with the right name. So, if the old API was
14946 used (or the REQUIRE_GV flag was passed), we have to reify
14947 the CV’s GV, unless this is an anonymous sub. This is not
14948 ideal for lexical subs, as its stringification will include
14949 the package. But it is the best we can do. */
14950 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14951 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14954 else namegv = MUTABLE_GV(cv);
14955 /* After a syntax error in a lexical sub, the cv that
14956 rv2cv_op_cv returns may be a nameless stub. */
14957 if (!namegv) return ck_entersub_args_list(o);
14960 return ckfun(aTHX_ o, namegv, ckobj);
14965 Perl_ck_svconst(pTHX_ OP *o)
14967 SV * const sv = cSVOPo->op_sv;
14968 PERL_ARGS_ASSERT_CK_SVCONST;
14969 PERL_UNUSED_CONTEXT;
14970 #ifdef PERL_COPY_ON_WRITE
14971 /* Since the read-only flag may be used to protect a string buffer, we
14972 cannot do copy-on-write with existing read-only scalars that are not
14973 already copy-on-write scalars. To allow $_ = "hello" to do COW with
14974 that constant, mark the constant as COWable here, if it is not
14975 already read-only. */
14976 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14979 # ifdef PERL_DEBUG_READONLY_COW
14989 Perl_ck_trunc(pTHX_ OP *o)
14991 PERL_ARGS_ASSERT_CK_TRUNC;
14993 if (o->op_flags & OPf_KIDS) {
14994 SVOP *kid = (SVOP*)cUNOPo->op_first;
14996 if (kid->op_type == OP_NULL)
14997 kid = (SVOP*)OpSIBLING(kid);
14998 if (kid && kid->op_type == OP_CONST &&
14999 (kid->op_private & OPpCONST_BARE) &&
15002 o->op_flags |= OPf_SPECIAL;
15003 kid->op_private &= ~OPpCONST_STRICT;
15010 Perl_ck_substr(pTHX_ OP *o)
15012 PERL_ARGS_ASSERT_CK_SUBSTR;
15015 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15016 OP *kid = cLISTOPo->op_first;
15018 if (kid->op_type == OP_NULL)
15019 kid = OpSIBLING(kid);
15021 /* Historically, substr(delete $foo{bar},...) has been allowed
15022 with 4-arg substr. Keep it working by applying entersub
15024 op_lvalue(kid, OP_ENTERSUB);
15031 Perl_ck_tell(pTHX_ OP *o)
15033 PERL_ARGS_ASSERT_CK_TELL;
15035 if (o->op_flags & OPf_KIDS) {
15036 OP *kid = cLISTOPo->op_first;
15037 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15038 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15044 Perl_ck_each(pTHX_ OP *o)
15047 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15048 const unsigned orig_type = o->op_type;
15050 PERL_ARGS_ASSERT_CK_EACH;
15053 switch (kid->op_type) {
15059 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15060 : orig_type == OP_KEYS ? OP_AKEYS
15064 if (kid->op_private == OPpCONST_BARE
15065 || !SvROK(cSVOPx_sv(kid))
15066 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15067 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15072 qerror(Perl_mess(aTHX_
15073 "Experimental %s on scalar is now forbidden",
15074 PL_op_desc[orig_type]));
15076 bad_type_pv(1, "hash or array", o, kid);
15084 Perl_ck_length(pTHX_ OP *o)
15086 PERL_ARGS_ASSERT_CK_LENGTH;
15090 if (ckWARN(WARN_SYNTAX)) {
15091 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15095 const bool hash = kid->op_type == OP_PADHV
15096 || kid->op_type == OP_RV2HV;
15097 switch (kid->op_type) {
15102 name = S_op_varname(aTHX_ kid);
15108 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15109 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15111 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15114 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15115 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15116 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15118 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15119 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15120 "length() used on @array (did you mean \"scalar(@array)\"?)");
15129 Perl_ck_isa(pTHX_ OP *o)
15131 OP *classop = cBINOPo->op_last;
15133 PERL_ARGS_ASSERT_CK_ISA;
15135 /* Convert barename into PV */
15136 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15137 /* TODO: Optionally convert package to raw HV here */
15138 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15146 ---------------------------------------------------------
15148 Common vars in list assignment
15150 There now follows some enums and static functions for detecting
15151 common variables in list assignments. Here is a little essay I wrote
15152 for myself when trying to get my head around this. DAPM.
15156 First some random observations:
15158 * If a lexical var is an alias of something else, e.g.
15159 for my $x ($lex, $pkg, $a[0]) {...}
15160 then the act of aliasing will increase the reference count of the SV
15162 * If a package var is an alias of something else, it may still have a
15163 reference count of 1, depending on how the alias was created, e.g.
15164 in *a = *b, $a may have a refcount of 1 since the GP is shared
15165 with a single GvSV pointer to the SV. So If it's an alias of another
15166 package var, then RC may be 1; if it's an alias of another scalar, e.g.
15167 a lexical var or an array element, then it will have RC > 1.
15169 * There are many ways to create a package alias; ultimately, XS code
15170 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15171 run-time tracing mechanisms are unlikely to be able to catch all cases.
15173 * When the LHS is all my declarations, the same vars can't appear directly
15174 on the RHS, but they can indirectly via closures, aliasing and lvalue
15175 subs. But those techniques all involve an increase in the lexical
15176 scalar's ref count.
15178 * When the LHS is all lexical vars (but not necessarily my declarations),
15179 it is possible for the same lexicals to appear directly on the RHS, and
15180 without an increased ref count, since the stack isn't refcounted.
15181 This case can be detected at compile time by scanning for common lex
15182 vars with PL_generation.
15184 * lvalue subs defeat common var detection, but they do at least
15185 return vars with a temporary ref count increment. Also, you can't
15186 tell at compile time whether a sub call is lvalue.
15191 A: There are a few circumstances where there definitely can't be any
15194 LHS empty: () = (...);
15195 RHS empty: (....) = ();
15196 RHS contains only constants or other 'can't possibly be shared'
15197 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
15198 i.e. they only contain ops not marked as dangerous, whose children
15199 are also not dangerous;
15201 LHS contains a single scalar element: e.g. ($x) = (....); because
15202 after $x has been modified, it won't be used again on the RHS;
15203 RHS contains a single element with no aggregate on LHS: e.g.
15204 ($a,$b,$c) = ($x); again, once $a has been modified, its value
15205 won't be used again.
15207 B: If LHS are all 'my' lexical var declarations (or safe ops, which
15210 my ($a, $b, @c) = ...;
15212 Due to closure and goto tricks, these vars may already have content.
15213 For the same reason, an element on the RHS may be a lexical or package
15214 alias of one of the vars on the left, or share common elements, for
15217 my ($x,$y) = f(); # $x and $y on both sides
15218 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15223 my @a = @$ra; # elements of @a on both sides
15224 sub f { @a = 1..4; \@a }
15227 First, just consider scalar vars on LHS:
15229 RHS is safe only if (A), or in addition,
15230 * contains only lexical *scalar* vars, where neither side's
15231 lexicals have been flagged as aliases
15233 If RHS is not safe, then it's always legal to check LHS vars for
15234 RC==1, since the only RHS aliases will always be associated
15237 Note that in particular, RHS is not safe if:
15239 * it contains package scalar vars; e.g.:
15242 my ($x, $y) = (2, $x_alias);
15243 sub f { $x = 1; *x_alias = \$x; }
15245 * It contains other general elements, such as flattened or
15246 * spliced or single array or hash elements, e.g.
15249 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15253 use feature 'refaliasing';
15254 \($a[0], $a[1]) = \($y,$x);
15257 It doesn't matter if the array/hash is lexical or package.
15259 * it contains a function call that happens to be an lvalue
15260 sub which returns one or more of the above, e.g.
15271 (so a sub call on the RHS should be treated the same
15272 as having a package var on the RHS).
15274 * any other "dangerous" thing, such an op or built-in that
15275 returns one of the above, e.g. pp_preinc
15278 If RHS is not safe, what we can do however is at compile time flag
15279 that the LHS are all my declarations, and at run time check whether
15280 all the LHS have RC == 1, and if so skip the full scan.
15282 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15284 Here the issue is whether there can be elements of @a on the RHS
15285 which will get prematurely freed when @a is cleared prior to
15286 assignment. This is only a problem if the aliasing mechanism
15287 is one which doesn't increase the refcount - only if RC == 1
15288 will the RHS element be prematurely freed.
15290 Because the array/hash is being INTROed, it or its elements
15291 can't directly appear on the RHS:
15293 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15295 but can indirectly, e.g.:
15299 sub f { @a = 1..3; \@a }
15301 So if the RHS isn't safe as defined by (A), we must always
15302 mortalise and bump the ref count of any remaining RHS elements
15303 when assigning to a non-empty LHS aggregate.
15305 Lexical scalars on the RHS aren't safe if they've been involved in
15308 use feature 'refaliasing';
15311 \(my $lex) = \$pkg;
15312 my @a = ($lex,3); # equivalent to ($a[0],3)
15319 Similarly with lexical arrays and hashes on the RHS:
15333 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15334 my $a; ($a, my $b) = (....);
15336 The difference between (B) and (C) is that it is now physically
15337 possible for the LHS vars to appear on the RHS too, where they
15338 are not reference counted; but in this case, the compile-time
15339 PL_generation sweep will detect such common vars.
15341 So the rules for (C) differ from (B) in that if common vars are
15342 detected, the runtime "test RC==1" optimisation can no longer be used,
15343 and a full mark and sweep is required
15345 D: As (C), but in addition the LHS may contain package vars.
15347 Since package vars can be aliased without a corresponding refcount
15348 increase, all bets are off. It's only safe if (A). E.g.
15350 my ($x, $y) = (1,2);
15352 for $x_alias ($x) {
15353 ($x_alias, $y) = (3, $x); # whoops
15356 Ditto for LHS aggregate package vars.
15358 E: Any other dangerous ops on LHS, e.g.
15359 (f(), $a[0], @$r) = (...);
15361 this is similar to (E) in that all bets are off. In addition, it's
15362 impossible to determine at compile time whether the LHS
15363 contains a scalar or an aggregate, e.g.
15365 sub f : lvalue { @a }
15368 * ---------------------------------------------------------
15372 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15373 * that at least one of the things flagged was seen.
15377 AAS_MY_SCALAR = 0x001, /* my $scalar */
15378 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
15379 AAS_LEX_SCALAR = 0x004, /* $lexical */
15380 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
15381 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15382 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
15383 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
15384 AAS_DANGEROUS = 0x080, /* an op (other than the above)
15385 that's flagged OA_DANGEROUS */
15386 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
15387 not in any of the categories above */
15388 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
15393 /* helper function for S_aassign_scan().
15394 * check a PAD-related op for commonality and/or set its generation number.
15395 * Returns a boolean indicating whether its shared */
15398 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15400 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15401 /* lexical used in aliasing */
15405 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15407 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15414 Helper function for OPpASSIGN_COMMON* detection in rpeep().
15415 It scans the left or right hand subtree of the aassign op, and returns a
15416 set of flags indicating what sorts of things it found there.
15417 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15418 set PL_generation on lexical vars; if the latter, we see if
15419 PL_generation matches.
15420 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15421 This fn will increment it by the number seen. It's not intended to
15422 be an accurate count (especially as many ops can push a variable
15423 number of SVs onto the stack); rather it's used as to test whether there
15424 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15428 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15431 OP *effective_top_op = o;
15435 bool top = o == effective_top_op;
15437 OP* next_kid = NULL;
15439 /* first, look for a solitary @_ on the RHS */
15442 && (o->op_flags & OPf_KIDS)
15443 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15445 OP *kid = cUNOPo->op_first;
15446 if ( ( kid->op_type == OP_PUSHMARK
15447 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15448 && ((kid = OpSIBLING(kid)))
15449 && !OpHAS_SIBLING(kid)
15450 && kid->op_type == OP_RV2AV
15451 && !(kid->op_flags & OPf_REF)
15452 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15453 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15454 && ((kid = cUNOPx(kid)->op_first))
15455 && kid->op_type == OP_GV
15456 && cGVOPx_gv(kid) == PL_defgv
15461 switch (o->op_type) {
15464 all_flags |= AAS_PKG_SCALAR;
15470 /* if !top, could be e.g. @a[0,1] */
15471 all_flags |= (top && (o->op_flags & OPf_REF))
15472 ? ((o->op_private & OPpLVAL_INTRO)
15473 ? AAS_MY_AGG : AAS_LEX_AGG)
15479 int comm = S_aassign_padcheck(aTHX_ o, rhs)
15480 ? AAS_LEX_SCALAR_COMM : 0;
15482 all_flags |= (o->op_private & OPpLVAL_INTRO)
15483 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15491 if (cUNOPx(o)->op_first->op_type != OP_GV)
15492 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15494 /* if !top, could be e.g. @a[0,1] */
15495 else if (top && (o->op_flags & OPf_REF))
15496 all_flags |= AAS_PKG_AGG;
15498 all_flags |= AAS_DANGEROUS;
15503 if (cUNOPx(o)->op_first->op_type != OP_GV) {
15505 all_flags |= AAS_DANGEROUS; /* ${expr} */
15508 all_flags |= AAS_PKG_SCALAR; /* $pkg */
15512 if (o->op_private & OPpSPLIT_ASSIGN) {
15513 /* the assign in @a = split() has been optimised away
15514 * and the @a attached directly to the split op
15515 * Treat the array as appearing on the RHS, i.e.
15516 * ... = (@a = split)
15521 if (o->op_flags & OPf_STACKED) {
15522 /* @{expr} = split() - the array expression is tacked
15523 * on as an extra child to split - process kid */
15524 next_kid = cLISTOPo->op_last;
15528 /* ... else array is directly attached to split op */
15530 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15531 ? ((o->op_private & OPpLVAL_INTRO)
15532 ? AAS_MY_AGG : AAS_LEX_AGG)
15537 /* other args of split can't be returned */
15538 all_flags |= AAS_SAFE_SCALAR;
15542 /* undef counts as a scalar on the RHS:
15543 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
15544 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
15548 flags = AAS_SAFE_SCALAR;
15553 /* these are all no-ops; they don't push a potentially common SV
15554 * onto the stack, so they are neither AAS_DANGEROUS nor
15555 * AAS_SAFE_SCALAR */
15558 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15563 /* these do nothing, but may have children */
15567 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15569 flags = AAS_DANGEROUS;
15573 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
15574 && (o->op_private & OPpTARGET_MY))
15577 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15578 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15582 /* if its an unrecognised, non-dangerous op, assume that it
15583 * it the cause of at least one safe scalar */
15585 flags = AAS_SAFE_SCALAR;
15589 all_flags |= flags;
15591 /* by default, process all kids next
15592 * XXX this assumes that all other ops are "transparent" - i.e. that
15593 * they can return some of their children. While this true for e.g.
15594 * sort and grep, it's not true for e.g. map. We really need a
15595 * 'transparent' flag added to regen/opcodes
15597 if (o->op_flags & OPf_KIDS) {
15598 next_kid = cUNOPo->op_first;
15599 /* these ops do nothing but may have children; but their
15600 * children should also be treated as top-level */
15601 if ( o == effective_top_op
15602 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15604 effective_top_op = next_kid;
15608 /* If next_kid is set, someone in the code above wanted us to process
15609 * that kid and all its remaining siblings. Otherwise, work our way
15610 * back up the tree */
15612 while (!next_kid) {
15614 return all_flags; /* at top; no parents/siblings to try */
15615 if (OpHAS_SIBLING(o)) {
15616 next_kid = o->op_sibparent;
15617 if (o == effective_top_op)
15618 effective_top_op = next_kid;
15621 if (o == effective_top_op)
15622 effective_top_op = o->op_sibparent;
15623 o = o->op_sibparent; /* try parent's next sibling */
15632 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15633 and modify the optree to make them work inplace */
15636 S_inplace_aassign(pTHX_ OP *o) {
15638 OP *modop, *modop_pushmark;
15640 OP *oleft, *oleft_pushmark;
15642 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15644 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15646 assert(cUNOPo->op_first->op_type == OP_NULL);
15647 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15648 assert(modop_pushmark->op_type == OP_PUSHMARK);
15649 modop = OpSIBLING(modop_pushmark);
15651 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15654 /* no other operation except sort/reverse */
15655 if (OpHAS_SIBLING(modop))
15658 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15659 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15661 if (modop->op_flags & OPf_STACKED) {
15662 /* skip sort subroutine/block */
15663 assert(oright->op_type == OP_NULL);
15664 oright = OpSIBLING(oright);
15667 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15668 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15669 assert(oleft_pushmark->op_type == OP_PUSHMARK);
15670 oleft = OpSIBLING(oleft_pushmark);
15672 /* Check the lhs is an array */
15674 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15675 || OpHAS_SIBLING(oleft)
15676 || (oleft->op_private & OPpLVAL_INTRO)
15680 /* Only one thing on the rhs */
15681 if (OpHAS_SIBLING(oright))
15684 /* check the array is the same on both sides */
15685 if (oleft->op_type == OP_RV2AV) {
15686 if (oright->op_type != OP_RV2AV
15687 || !cUNOPx(oright)->op_first
15688 || cUNOPx(oright)->op_first->op_type != OP_GV
15689 || cUNOPx(oleft )->op_first->op_type != OP_GV
15690 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15691 cGVOPx_gv(cUNOPx(oright)->op_first)
15695 else if (oright->op_type != OP_PADAV
15696 || oright->op_targ != oleft->op_targ
15700 /* This actually is an inplace assignment */
15702 modop->op_private |= OPpSORT_INPLACE;
15704 /* transfer MODishness etc from LHS arg to RHS arg */
15705 oright->op_flags = oleft->op_flags;
15707 /* remove the aassign op and the lhs */
15709 op_null(oleft_pushmark);
15710 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15711 op_null(cUNOPx(oleft)->op_first);
15717 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15718 * that potentially represent a series of one or more aggregate derefs
15719 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15720 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15721 * additional ops left in too).
15723 * The caller will have already verified that the first few ops in the
15724 * chain following 'start' indicate a multideref candidate, and will have
15725 * set 'orig_o' to the point further on in the chain where the first index
15726 * expression (if any) begins. 'orig_action' specifies what type of
15727 * beginning has already been determined by the ops between start..orig_o
15728 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
15730 * 'hints' contains any hints flags that need adding (currently just
15731 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15735 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15739 UNOP_AUX_item *arg_buf = NULL;
15740 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
15741 int index_skip = -1; /* don't output index arg on this action */
15743 /* similar to regex compiling, do two passes; the first pass
15744 * determines whether the op chain is convertible and calculates the
15745 * buffer size; the second pass populates the buffer and makes any
15746 * changes necessary to ops (such as moving consts to the pad on
15747 * threaded builds).
15749 * NB: for things like Coverity, note that both passes take the same
15750 * path through the logic tree (except for 'if (pass)' bits), since
15751 * both passes are following the same op_next chain; and in
15752 * particular, if it would return early on the second pass, it would
15753 * already have returned early on the first pass.
15755 for (pass = 0; pass < 2; pass++) {
15757 UV action = orig_action;
15758 OP *first_elem_op = NULL; /* first seen aelem/helem */
15759 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
15760 int action_count = 0; /* number of actions seen so far */
15761 int action_ix = 0; /* action_count % (actions per IV) */
15762 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
15763 bool is_last = FALSE; /* no more derefs to follow */
15764 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15765 UNOP_AUX_item *arg = arg_buf;
15766 UNOP_AUX_item *action_ptr = arg_buf;
15769 action_ptr->uv = 0;
15773 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15774 case MDEREF_HV_gvhv_helem:
15775 next_is_hash = TRUE;
15777 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15778 case MDEREF_AV_gvav_aelem:
15780 #ifdef USE_ITHREADS
15781 arg->pad_offset = cPADOPx(start)->op_padix;
15782 /* stop it being swiped when nulled */
15783 cPADOPx(start)->op_padix = 0;
15785 arg->sv = cSVOPx(start)->op_sv;
15786 cSVOPx(start)->op_sv = NULL;
15792 case MDEREF_HV_padhv_helem:
15793 case MDEREF_HV_padsv_vivify_rv2hv_helem:
15794 next_is_hash = TRUE;
15796 case MDEREF_AV_padav_aelem:
15797 case MDEREF_AV_padsv_vivify_rv2av_aelem:
15799 arg->pad_offset = start->op_targ;
15800 /* we skip setting op_targ = 0 for now, since the intact
15801 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15802 reset_start_targ = TRUE;
15807 case MDEREF_HV_pop_rv2hv_helem:
15808 next_is_hash = TRUE;
15810 case MDEREF_AV_pop_rv2av_aelem:
15814 NOT_REACHED; /* NOTREACHED */
15819 /* look for another (rv2av/hv; get index;
15820 * aelem/helem/exists/delele) sequence */
15825 UV index_type = MDEREF_INDEX_none;
15827 if (action_count) {
15828 /* if this is not the first lookup, consume the rv2av/hv */
15830 /* for N levels of aggregate lookup, we normally expect
15831 * that the first N-1 [ah]elem ops will be flagged as
15832 * /DEREF (so they autovivifiy if necessary), and the last
15833 * lookup op not to be.
15834 * For other things (like @{$h{k1}{k2}}) extra scope or
15835 * leave ops can appear, so abandon the effort in that
15837 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
15840 /* rv2av or rv2hv sKR/1 */
15842 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15843 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15844 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15847 /* at this point, we wouldn't expect any of these
15848 * possible private flags:
15849 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
15850 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
15852 ASSUME(!(o->op_private &
15853 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
15855 hints = (o->op_private & OPpHINT_STRICT_REFS);
15857 /* make sure the type of the previous /DEREF matches the
15858 * type of the next lookup */
15859 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
15862 action = next_is_hash
15863 ? MDEREF_HV_vivify_rv2hv_helem
15864 : MDEREF_AV_vivify_rv2av_aelem;
15868 /* if this is the second pass, and we're at the depth where
15869 * previously we encountered a non-simple index expression,
15870 * stop processing the index at this point */
15871 if (action_count != index_skip) {
15873 /* look for one or more simple ops that return an array
15874 * index or hash key */
15876 switch (o->op_type) {
15878 /* it may be a lexical var index */
15879 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
15880 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15881 ASSUME(!(o->op_private &
15882 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15884 if ( OP_GIMME(o,0) == G_SCALAR
15885 && !(o->op_flags & (OPf_REF|OPf_MOD))
15886 && o->op_private == 0)
15889 arg->pad_offset = o->op_targ;
15891 index_type = MDEREF_INDEX_padsv;
15897 if (next_is_hash) {
15898 /* it's a constant hash index */
15899 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
15900 /* "use constant foo => FOO; $h{+foo}" for
15901 * some weird FOO, can leave you with constants
15902 * that aren't simple strings. It's not worth
15903 * the extra hassle for those edge cases */
15908 OP * helem_op = o->op_next;
15910 ASSUME( helem_op->op_type == OP_HELEM
15911 || helem_op->op_type == OP_NULL
15913 if (helem_op->op_type == OP_HELEM) {
15914 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
15915 if ( helem_op->op_private & OPpLVAL_INTRO
15916 || rop->op_type != OP_RV2HV
15920 /* on first pass just check; on second pass
15922 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
15927 #ifdef USE_ITHREADS
15928 /* Relocate sv to the pad for thread safety */
15929 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
15930 arg->pad_offset = o->op_targ;
15933 arg->sv = cSVOPx_sv(o);
15938 /* it's a constant array index */
15940 SV *ix_sv = cSVOPo->op_sv;
15945 if ( action_count == 0
15948 && ( action == MDEREF_AV_padav_aelem
15949 || action == MDEREF_AV_gvav_aelem)
15951 maybe_aelemfast = TRUE;
15955 SvREFCNT_dec_NN(cSVOPo->op_sv);
15959 /* we've taken ownership of the SV */
15960 cSVOPo->op_sv = NULL;
15962 index_type = MDEREF_INDEX_const;
15967 /* it may be a package var index */
15969 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
15970 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
15971 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
15972 || o->op_private != 0
15977 if (kid->op_type != OP_RV2SV)
15980 ASSUME(!(kid->op_flags &
15981 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
15982 |OPf_SPECIAL|OPf_PARENS)));
15983 ASSUME(!(kid->op_private &
15985 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
15986 |OPpDEREF|OPpLVAL_INTRO)));
15987 if( (kid->op_flags &~ OPf_PARENS)
15988 != (OPf_WANT_SCALAR|OPf_KIDS)
15989 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
15994 #ifdef USE_ITHREADS
15995 arg->pad_offset = cPADOPx(o)->op_padix;
15996 /* stop it being swiped when nulled */
15997 cPADOPx(o)->op_padix = 0;
15999 arg->sv = cSVOPx(o)->op_sv;
16000 cSVOPo->op_sv = NULL;
16004 index_type = MDEREF_INDEX_gvsv;
16009 } /* action_count != index_skip */
16011 action |= index_type;
16014 /* at this point we have either:
16015 * * detected what looks like a simple index expression,
16016 * and expect the next op to be an [ah]elem, or
16017 * an nulled [ah]elem followed by a delete or exists;
16018 * * found a more complex expression, so something other
16019 * than the above follows.
16022 /* possibly an optimised away [ah]elem (where op_next is
16023 * exists or delete) */
16024 if (o->op_type == OP_NULL)
16027 /* at this point we're looking for an OP_AELEM, OP_HELEM,
16028 * OP_EXISTS or OP_DELETE */
16030 /* if a custom array/hash access checker is in scope,
16031 * abandon optimisation attempt */
16032 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16033 && PL_check[o->op_type] != Perl_ck_null)
16035 /* similarly for customised exists and delete */
16036 if ( (o->op_type == OP_EXISTS)
16037 && PL_check[o->op_type] != Perl_ck_exists)
16039 if ( (o->op_type == OP_DELETE)
16040 && PL_check[o->op_type] != Perl_ck_delete)
16043 if ( o->op_type != OP_AELEM
16044 || (o->op_private &
16045 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16047 maybe_aelemfast = FALSE;
16049 /* look for aelem/helem/exists/delete. If it's not the last elem
16050 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16051 * flags; if it's the last, then it mustn't have
16052 * OPpDEREF_AV/HV, but may have lots of other flags, like
16053 * OPpLVAL_INTRO etc
16056 if ( index_type == MDEREF_INDEX_none
16057 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
16058 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16062 /* we have aelem/helem/exists/delete with valid simple index */
16064 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16065 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
16066 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16068 /* This doesn't make much sense but is legal:
16069 * @{ local $x[0][0] } = 1
16070 * Since scope exit will undo the autovivification,
16071 * don't bother in the first place. The OP_LEAVE
16072 * assertion is in case there are other cases of both
16073 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16074 * exit that would undo the local - in which case this
16075 * block of code would need rethinking.
16077 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16079 OP *n = o->op_next;
16080 while (n && ( n->op_type == OP_NULL
16081 || n->op_type == OP_LIST
16082 || n->op_type == OP_SCALAR))
16084 assert(n && n->op_type == OP_LEAVE);
16086 o->op_private &= ~OPpDEREF;
16091 ASSUME(!(o->op_flags &
16092 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16093 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16095 ok = (o->op_flags &~ OPf_PARENS)
16096 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16097 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16099 else if (o->op_type == OP_EXISTS) {
16100 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16101 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16102 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16103 ok = !(o->op_private & ~OPpARG1_MASK);
16105 else if (o->op_type == OP_DELETE) {
16106 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16107 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16108 ASSUME(!(o->op_private &
16109 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16110 /* don't handle slices or 'local delete'; the latter
16111 * is fairly rare, and has a complex runtime */
16112 ok = !(o->op_private & ~OPpARG1_MASK);
16113 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16114 /* skip handling run-tome error */
16115 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16118 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16119 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16120 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16121 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16122 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16123 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16128 if (!first_elem_op)
16132 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16137 action |= MDEREF_FLAG_last;
16141 /* at this point we have something that started
16142 * promisingly enough (with rv2av or whatever), but failed
16143 * to find a simple index followed by an
16144 * aelem/helem/exists/delete. If this is the first action,
16145 * give up; but if we've already seen at least one
16146 * aelem/helem, then keep them and add a new action with
16147 * MDEREF_INDEX_none, which causes it to do the vivify
16148 * from the end of the previous lookup, and do the deref,
16149 * but stop at that point. So $a[0][expr] will do one
16150 * av_fetch, vivify and deref, then continue executing at
16155 index_skip = action_count;
16156 action |= MDEREF_FLAG_last;
16157 if (index_type != MDEREF_INDEX_none)
16162 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
16165 /* if there's no space for the next action, create a new slot
16166 * for it *before* we start adding args for that action */
16167 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16174 } /* while !is_last */
16182 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16183 if (index_skip == -1) {
16184 mderef->op_flags = o->op_flags
16185 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16186 if (o->op_type == OP_EXISTS)
16187 mderef->op_private = OPpMULTIDEREF_EXISTS;
16188 else if (o->op_type == OP_DELETE)
16189 mderef->op_private = OPpMULTIDEREF_DELETE;
16191 mderef->op_private = o->op_private
16192 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16194 /* accumulate strictness from every level (although I don't think
16195 * they can actually vary) */
16196 mderef->op_private |= hints;
16198 /* integrate the new multideref op into the optree and the
16201 * In general an op like aelem or helem has two child
16202 * sub-trees: the aggregate expression (a_expr) and the
16203 * index expression (i_expr):
16209 * The a_expr returns an AV or HV, while the i-expr returns an
16210 * index. In general a multideref replaces most or all of a
16211 * multi-level tree, e.g.
16227 * With multideref, all the i_exprs will be simple vars or
16228 * constants, except that i_expr1 may be arbitrary in the case
16229 * of MDEREF_INDEX_none.
16231 * The bottom-most a_expr will be either:
16232 * 1) a simple var (so padXv or gv+rv2Xv);
16233 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
16234 * so a simple var with an extra rv2Xv;
16235 * 3) or an arbitrary expression.
16237 * 'start', the first op in the execution chain, will point to
16238 * 1),2): the padXv or gv op;
16239 * 3): the rv2Xv which forms the last op in the a_expr
16240 * execution chain, and the top-most op in the a_expr
16243 * For all cases, the 'start' node is no longer required,
16244 * but we can't free it since one or more external nodes
16245 * may point to it. E.g. consider
16246 * $h{foo} = $a ? $b : $c
16247 * Here, both the op_next and op_other branches of the
16248 * cond_expr point to the gv[*h] of the hash expression, so
16249 * we can't free the 'start' op.
16251 * For expr->[...], we need to save the subtree containing the
16252 * expression; for the other cases, we just need to save the
16254 * So in all cases, we null the start op and keep it around by
16255 * making it the child of the multideref op; for the expr->
16256 * case, the expr will be a subtree of the start node.
16258 * So in the simple 1,2 case the optree above changes to
16264 * ex-gv (or ex-padxv)
16266 * with the op_next chain being
16268 * -> ex-gv -> multideref -> op-following-ex-exists ->
16270 * In the 3 case, we have
16283 * -> rest-of-a_expr subtree ->
16284 * ex-rv2xv -> multideref -> op-following-ex-exists ->
16287 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16288 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16289 * multideref attached as the child, e.g.
16295 * ex-rv2av - i_expr1
16303 /* if we free this op, don't free the pad entry */
16304 if (reset_start_targ)
16305 start->op_targ = 0;
16308 /* Cut the bit we need to save out of the tree and attach to
16309 * the multideref op, then free the rest of the tree */
16311 /* find parent of node to be detached (for use by splice) */
16313 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
16314 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16316 /* there is an arbitrary expression preceding us, e.g.
16317 * expr->[..]? so we need to save the 'expr' subtree */
16318 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16319 p = cUNOPx(p)->op_first;
16320 ASSUME( start->op_type == OP_RV2AV
16321 || start->op_type == OP_RV2HV);
16324 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16325 * above for exists/delete. */
16326 while ( (p->op_flags & OPf_KIDS)
16327 && cUNOPx(p)->op_first != start
16329 p = cUNOPx(p)->op_first;
16331 ASSUME(cUNOPx(p)->op_first == start);
16333 /* detach from main tree, and re-attach under the multideref */
16334 op_sibling_splice(mderef, NULL, 0,
16335 op_sibling_splice(p, NULL, 1, NULL));
16338 start->op_next = mderef;
16340 mderef->op_next = index_skip == -1 ? o->op_next : o;
16342 /* excise and free the original tree, and replace with
16343 * the multideref op */
16344 p = op_sibling_splice(top_op, NULL, -1, mderef);
16353 Size_t size = arg - arg_buf;
16355 if (maybe_aelemfast && action_count == 1)
16358 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16359 sizeof(UNOP_AUX_item) * (size + 1));
16360 /* for dumping etc: store the length in a hidden first slot;
16361 * we set the op_aux pointer to the second slot */
16362 arg_buf->uv = size;
16365 } /* for (pass = ...) */
16368 /* See if the ops following o are such that o will always be executed in
16369 * boolean context: that is, the SV which o pushes onto the stack will
16370 * only ever be consumed by later ops via SvTRUE(sv) or similar.
16371 * If so, set a suitable private flag on o. Normally this will be
16372 * bool_flag; but see below why maybe_flag is needed too.
16374 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16375 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16376 * already be taken, so you'll have to give that op two different flags.
16378 * More explanation of 'maybe_flag' and 'safe_and' parameters.
16379 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16380 * those underlying ops) short-circuit, which means that rather than
16381 * necessarily returning a truth value, they may return the LH argument,
16382 * which may not be boolean. For example in $x = (keys %h || -1), keys
16383 * should return a key count rather than a boolean, even though its
16384 * sort-of being used in boolean context.
16386 * So we only consider such logical ops to provide boolean context to
16387 * their LH argument if they themselves are in void or boolean context.
16388 * However, sometimes the context isn't known until run-time. In this
16389 * case the op is marked with the maybe_flag flag it.
16391 * Consider the following.
16393 * sub f { ....; if (%h) { .... } }
16395 * This is actually compiled as
16397 * sub f { ....; %h && do { .... } }
16399 * Here we won't know until runtime whether the final statement (and hence
16400 * the &&) is in void context and so is safe to return a boolean value.
16401 * So mark o with maybe_flag rather than the bool_flag.
16402 * Note that there is cost associated with determining context at runtime
16403 * (e.g. a call to block_gimme()), so it may not be worth setting (at
16404 * compile time) and testing (at runtime) maybe_flag if the scalar verses
16405 * boolean costs savings are marginal.
16407 * However, we can do slightly better with && (compared to || and //):
16408 * this op only returns its LH argument when that argument is false. In
16409 * this case, as long as the op promises to return a false value which is
16410 * valid in both boolean and scalar contexts, we can mark an op consumed
16411 * by && with bool_flag rather than maybe_flag.
16412 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16413 * than &PL_sv_no for a false result in boolean context, then it's safe. An
16414 * op which promises to handle this case is indicated by setting safe_and
16419 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16424 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16426 /* OPpTARGET_MY and boolean context probably don't mix well.
16427 * If someone finds a valid use case, maybe add an extra flag to this
16428 * function which indicates its safe to do so for this op? */
16429 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
16430 && (o->op_private & OPpTARGET_MY)));
16435 switch (lop->op_type) {
16440 /* these two consume the stack argument in the scalar case,
16441 * and treat it as a boolean in the non linenumber case */
16444 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16445 || (lop->op_private & OPpFLIP_LINENUM))
16451 /* these never leave the original value on the stack */
16460 /* OR DOR and AND evaluate their arg as a boolean, but then may
16461 * leave the original scalar value on the stack when following the
16462 * op_next route. If not in void context, we need to ensure
16463 * that whatever follows consumes the arg only in boolean context
16475 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16479 else if (!(lop->op_flags & OPf_WANT)) {
16480 /* unknown context - decide at runtime */
16492 lop = lop->op_next;
16495 o->op_private |= flag;
16500 /* mechanism for deferring recursion in rpeep() */
16502 #define MAX_DEFERRED 4
16506 if (defer_ix == (MAX_DEFERRED-1)) { \
16507 OP **defer = defer_queue[defer_base]; \
16508 CALL_RPEEP(*defer); \
16509 S_prune_chain_head(defer); \
16510 defer_base = (defer_base + 1) % MAX_DEFERRED; \
16513 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16516 #define IS_AND_OP(o) (o->op_type == OP_AND)
16517 #define IS_OR_OP(o) (o->op_type == OP_OR)
16520 /* A peephole optimizer. We visit the ops in the order they're to execute.
16521 * See the comments at the top of this file for more details about when
16522 * peep() is called */
16525 Perl_rpeep(pTHX_ OP *o)
16529 OP* oldoldop = NULL;
16530 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16531 int defer_base = 0;
16534 if (!o || o->op_opt)
16537 assert(o->op_type != OP_FREED);
16541 SAVEVPTR(PL_curcop);
16542 for (;; o = o->op_next) {
16543 if (o && o->op_opt)
16546 while (defer_ix >= 0) {
16548 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16549 CALL_RPEEP(*defer);
16550 S_prune_chain_head(defer);
16557 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16558 assert(!oldoldop || oldoldop->op_next == oldop);
16559 assert(!oldop || oldop->op_next == o);
16561 /* By default, this op has now been optimised. A couple of cases below
16562 clear this again. */
16566 /* look for a series of 1 or more aggregate derefs, e.g.
16567 * $a[1]{foo}[$i]{$k}
16568 * and replace with a single OP_MULTIDEREF op.
16569 * Each index must be either a const, or a simple variable,
16571 * First, look for likely combinations of starting ops,
16572 * corresponding to (global and lexical variants of)
16574 * $r->[...] $r->{...}
16575 * (preceding expression)->[...]
16576 * (preceding expression)->{...}
16577 * and if so, call maybe_multideref() to do a full inspection
16578 * of the op chain and if appropriate, replace with an
16586 switch (o2->op_type) {
16588 /* $pkg[..] : gv[*pkg]
16589 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
16591 /* Fail if there are new op flag combinations that we're
16592 * not aware of, rather than:
16593 * * silently failing to optimise, or
16594 * * silently optimising the flag away.
16595 * If this ASSUME starts failing, examine what new flag
16596 * has been added to the op, and decide whether the
16597 * optimisation should still occur with that flag, then
16598 * update the code accordingly. This applies to all the
16599 * other ASSUMEs in the block of code too.
16601 ASSUME(!(o2->op_flags &
16602 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16603 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16607 if (o2->op_type == OP_RV2AV) {
16608 action = MDEREF_AV_gvav_aelem;
16612 if (o2->op_type == OP_RV2HV) {
16613 action = MDEREF_HV_gvhv_helem;
16617 if (o2->op_type != OP_RV2SV)
16620 /* at this point we've seen gv,rv2sv, so the only valid
16621 * construct left is $pkg->[] or $pkg->{} */
16623 ASSUME(!(o2->op_flags & OPf_STACKED));
16624 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16625 != (OPf_WANT_SCALAR|OPf_MOD))
16628 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16629 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16630 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16632 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
16633 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16637 if (o2->op_type == OP_RV2AV) {
16638 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16641 if (o2->op_type == OP_RV2HV) {
16642 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16648 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16650 ASSUME(!(o2->op_flags &
16651 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16652 if ((o2->op_flags &
16653 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16654 != (OPf_WANT_SCALAR|OPf_MOD))
16657 ASSUME(!(o2->op_private &
16658 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16659 /* skip if state or intro, or not a deref */
16660 if ( o2->op_private != OPpDEREF_AV
16661 && o2->op_private != OPpDEREF_HV)
16665 if (o2->op_type == OP_RV2AV) {
16666 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16669 if (o2->op_type == OP_RV2HV) {
16670 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16677 /* $lex[..]: padav[@lex:1,2] sR *
16678 * or $lex{..}: padhv[%lex:1,2] sR */
16679 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16680 OPf_REF|OPf_SPECIAL)));
16681 if ((o2->op_flags &
16682 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16683 != (OPf_WANT_SCALAR|OPf_REF))
16685 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16687 /* OPf_PARENS isn't currently used in this case;
16688 * if that changes, let us know! */
16689 ASSUME(!(o2->op_flags & OPf_PARENS));
16691 /* at this point, we wouldn't expect any of the remaining
16692 * possible private flags:
16693 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16694 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16696 * OPpSLICEWARNING shouldn't affect runtime
16698 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16700 action = o2->op_type == OP_PADAV
16701 ? MDEREF_AV_padav_aelem
16702 : MDEREF_HV_padhv_helem;
16704 S_maybe_multideref(aTHX_ o, o2, action, 0);
16710 action = o2->op_type == OP_RV2AV
16711 ? MDEREF_AV_pop_rv2av_aelem
16712 : MDEREF_HV_pop_rv2hv_helem;
16715 /* (expr)->[...]: rv2av sKR/1;
16716 * (expr)->{...}: rv2hv sKR/1; */
16718 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16720 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16721 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16722 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16725 /* at this point, we wouldn't expect any of these
16726 * possible private flags:
16727 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16728 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16730 ASSUME(!(o2->op_private &
16731 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16733 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16737 S_maybe_multideref(aTHX_ o, o2, action, hints);
16746 switch (o->op_type) {
16748 PL_curcop = ((COP*)o); /* for warnings */
16751 PL_curcop = ((COP*)o); /* for warnings */
16753 /* Optimise a "return ..." at the end of a sub to just be "...".
16754 * This saves 2 ops. Before:
16755 * 1 <;> nextstate(main 1 -e:1) v ->2
16756 * 4 <@> return K ->5
16757 * 2 <0> pushmark s ->3
16758 * - <1> ex-rv2sv sK/1 ->4
16759 * 3 <#> gvsv[*cat] s ->4
16762 * - <@> return K ->-
16763 * - <0> pushmark s ->2
16764 * - <1> ex-rv2sv sK/1 ->-
16765 * 2 <$> gvsv(*cat) s ->3
16768 OP *next = o->op_next;
16769 OP *sibling = OpSIBLING(o);
16770 if ( OP_TYPE_IS(next, OP_PUSHMARK)
16771 && OP_TYPE_IS(sibling, OP_RETURN)
16772 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16773 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16774 ||OP_TYPE_IS(sibling->op_next->op_next,
16776 && cUNOPx(sibling)->op_first == next
16777 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16780 /* Look through the PUSHMARK's siblings for one that
16781 * points to the RETURN */
16782 OP *top = OpSIBLING(next);
16783 while (top && top->op_next) {
16784 if (top->op_next == sibling) {
16785 top->op_next = sibling->op_next;
16786 o->op_next = next->op_next;
16789 top = OpSIBLING(top);
16794 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16796 * This latter form is then suitable for conversion into padrange
16797 * later on. Convert:
16799 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16803 * nextstate1 -> listop -> nextstate3
16805 * pushmark -> padop1 -> padop2
16807 if (o->op_next && (
16808 o->op_next->op_type == OP_PADSV
16809 || o->op_next->op_type == OP_PADAV
16810 || o->op_next->op_type == OP_PADHV
16812 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
16813 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
16814 && o->op_next->op_next->op_next && (
16815 o->op_next->op_next->op_next->op_type == OP_PADSV
16816 || o->op_next->op_next->op_next->op_type == OP_PADAV
16817 || o->op_next->op_next->op_next->op_type == OP_PADHV
16819 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
16820 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
16821 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
16822 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
16824 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
16827 ns2 = pad1->op_next;
16828 pad2 = ns2->op_next;
16829 ns3 = pad2->op_next;
16831 /* we assume here that the op_next chain is the same as
16832 * the op_sibling chain */
16833 assert(OpSIBLING(o) == pad1);
16834 assert(OpSIBLING(pad1) == ns2);
16835 assert(OpSIBLING(ns2) == pad2);
16836 assert(OpSIBLING(pad2) == ns3);
16838 /* excise and delete ns2 */
16839 op_sibling_splice(NULL, pad1, 1, NULL);
16842 /* excise pad1 and pad2 */
16843 op_sibling_splice(NULL, o, 2, NULL);
16845 /* create new listop, with children consisting of:
16846 * a new pushmark, pad1, pad2. */
16847 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
16848 newop->op_flags |= OPf_PARENS;
16849 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16851 /* insert newop between o and ns3 */
16852 op_sibling_splice(NULL, o, 0, newop);
16854 /*fixup op_next chain */
16855 newpm = cUNOPx(newop)->op_first; /* pushmark */
16856 o ->op_next = newpm;
16857 newpm->op_next = pad1;
16858 pad1 ->op_next = pad2;
16859 pad2 ->op_next = newop; /* listop */
16860 newop->op_next = ns3;
16862 /* Ensure pushmark has this flag if padops do */
16863 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
16864 newpm->op_flags |= OPf_MOD;
16870 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
16871 to carry two labels. For now, take the easier option, and skip
16872 this optimisation if the first NEXTSTATE has a label. */
16873 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
16874 OP *nextop = o->op_next;
16876 switch (nextop->op_type) {
16881 nextop = nextop->op_next;
16887 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
16890 oldop->op_next = nextop;
16892 /* Skip (old)oldop assignment since the current oldop's
16893 op_next already points to the next op. */
16900 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
16901 if (o->op_next->op_private & OPpTARGET_MY) {
16902 if (o->op_flags & OPf_STACKED) /* chained concats */
16903 break; /* ignore_optimization */
16905 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
16906 o->op_targ = o->op_next->op_targ;
16907 o->op_next->op_targ = 0;
16908 o->op_private |= OPpTARGET_MY;
16911 op_null(o->op_next);
16915 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
16916 break; /* Scalar stub must produce undef. List stub is noop */
16920 if (o->op_targ == OP_NEXTSTATE
16921 || o->op_targ == OP_DBSTATE)
16923 PL_curcop = ((COP*)o);
16925 /* XXX: We avoid setting op_seq here to prevent later calls
16926 to rpeep() from mistakenly concluding that optimisation
16927 has already occurred. This doesn't fix the real problem,
16928 though (See 20010220.007 (#5874)). AMS 20010719 */
16929 /* op_seq functionality is now replaced by op_opt */
16937 oldop->op_next = o->op_next;
16951 convert repeat into a stub with no kids.
16953 if (o->op_next->op_type == OP_CONST
16954 || ( o->op_next->op_type == OP_PADSV
16955 && !(o->op_next->op_private & OPpLVAL_INTRO))
16956 || ( o->op_next->op_type == OP_GV
16957 && o->op_next->op_next->op_type == OP_RV2SV
16958 && !(o->op_next->op_next->op_private
16959 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
16961 const OP *kid = o->op_next->op_next;
16962 if (o->op_next->op_type == OP_GV)
16963 kid = kid->op_next;
16964 /* kid is now the ex-list. */
16965 if (kid->op_type == OP_NULL
16966 && (kid = kid->op_next)->op_type == OP_CONST
16967 /* kid is now the repeat count. */
16968 && kid->op_next->op_type == OP_REPEAT
16969 && kid->op_next->op_private & OPpREPEAT_DOLIST
16970 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
16971 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
16974 o = kid->op_next; /* repeat */
16975 oldop->op_next = o;
16976 op_free(cBINOPo->op_first);
16977 op_free(cBINOPo->op_last );
16978 o->op_flags &=~ OPf_KIDS;
16979 /* stub is a baseop; repeat is a binop */
16980 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
16981 OpTYPE_set(o, OP_STUB);
16987 /* Convert a series of PAD ops for my vars plus support into a
16988 * single padrange op. Basically
16990 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
16992 * becomes, depending on circumstances, one of
16994 * padrange ----------------------------------> (list) -> rest
16995 * padrange --------------------------------------------> rest
16997 * where all the pad indexes are sequential and of the same type
16999 * We convert the pushmark into a padrange op, then skip
17000 * any other pad ops, and possibly some trailing ops.
17001 * Note that we don't null() the skipped ops, to make it
17002 * easier for Deparse to undo this optimisation (and none of
17003 * the skipped ops are holding any resourses). It also makes
17004 * it easier for find_uninit_var(), as it can just ignore
17005 * padrange, and examine the original pad ops.
17009 OP *followop = NULL; /* the op that will follow the padrange op */
17012 PADOFFSET base = 0; /* init only to stop compiler whining */
17013 bool gvoid = 0; /* init only to stop compiler whining */
17014 bool defav = 0; /* seen (...) = @_ */
17015 bool reuse = 0; /* reuse an existing padrange op */
17017 /* look for a pushmark -> gv[_] -> rv2av */
17022 if ( p->op_type == OP_GV
17023 && cGVOPx_gv(p) == PL_defgv
17024 && (rv2av = p->op_next)
17025 && rv2av->op_type == OP_RV2AV
17026 && !(rv2av->op_flags & OPf_REF)
17027 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17028 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17030 q = rv2av->op_next;
17031 if (q->op_type == OP_NULL)
17033 if (q->op_type == OP_PUSHMARK) {
17043 /* scan for PAD ops */
17045 for (p = p->op_next; p; p = p->op_next) {
17046 if (p->op_type == OP_NULL)
17049 if (( p->op_type != OP_PADSV
17050 && p->op_type != OP_PADAV
17051 && p->op_type != OP_PADHV
17053 /* any private flag other than INTRO? e.g. STATE */
17054 || (p->op_private & ~OPpLVAL_INTRO)
17058 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17060 if ( p->op_type == OP_PADAV
17062 && p->op_next->op_type == OP_CONST
17063 && p->op_next->op_next
17064 && p->op_next->op_next->op_type == OP_AELEM
17068 /* for 1st padop, note what type it is and the range
17069 * start; for the others, check that it's the same type
17070 * and that the targs are contiguous */
17072 intro = (p->op_private & OPpLVAL_INTRO);
17074 gvoid = OP_GIMME(p,0) == G_VOID;
17077 if ((p->op_private & OPpLVAL_INTRO) != intro)
17079 /* Note that you'd normally expect targs to be
17080 * contiguous in my($a,$b,$c), but that's not the case
17081 * when external modules start doing things, e.g.
17082 * Function::Parameters */
17083 if (p->op_targ != base + count)
17085 assert(p->op_targ == base + count);
17086 /* Either all the padops or none of the padops should
17087 be in void context. Since we only do the optimisa-
17088 tion for av/hv when the aggregate itself is pushed
17089 on to the stack (one item), there is no need to dis-
17090 tinguish list from scalar context. */
17091 if (gvoid != (OP_GIMME(p,0) == G_VOID))
17095 /* for AV, HV, only when we're not flattening */
17096 if ( p->op_type != OP_PADSV
17098 && !(p->op_flags & OPf_REF)
17102 if (count >= OPpPADRANGE_COUNTMASK)
17105 /* there's a biggest base we can fit into a
17106 * SAVEt_CLEARPADRANGE in pp_padrange.
17107 * (The sizeof() stuff will be constant-folded, and is
17108 * intended to avoid getting "comparison is always false"
17109 * compiler warnings. See the comments above
17110 * MEM_WRAP_CHECK for more explanation on why we do this
17111 * in a weird way to avoid compiler warnings.)
17114 && (8*sizeof(base) >
17115 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17117 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17119 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17123 /* Success! We've got another valid pad op to optimise away */
17125 followop = p->op_next;
17128 if (count < 1 || (count == 1 && !defav))
17131 /* pp_padrange in specifically compile-time void context
17132 * skips pushing a mark and lexicals; in all other contexts
17133 * (including unknown till runtime) it pushes a mark and the
17134 * lexicals. We must be very careful then, that the ops we
17135 * optimise away would have exactly the same effect as the
17137 * In particular in void context, we can only optimise to
17138 * a padrange if we see the complete sequence
17139 * pushmark, pad*v, ...., list
17140 * which has the net effect of leaving the markstack as it
17141 * was. Not pushing onto the stack (whereas padsv does touch
17142 * the stack) makes no difference in void context.
17146 if (followop->op_type == OP_LIST
17147 && OP_GIMME(followop,0) == G_VOID
17150 followop = followop->op_next; /* skip OP_LIST */
17152 /* consolidate two successive my(...);'s */
17155 && oldoldop->op_type == OP_PADRANGE
17156 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17157 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17158 && !(oldoldop->op_flags & OPf_SPECIAL)
17161 assert(oldoldop->op_next == oldop);
17162 assert( oldop->op_type == OP_NEXTSTATE
17163 || oldop->op_type == OP_DBSTATE);
17164 assert(oldop->op_next == o);
17167 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17169 /* Do not assume pad offsets for $c and $d are con-
17174 if ( oldoldop->op_targ + old_count == base
17175 && old_count < OPpPADRANGE_COUNTMASK - count) {
17176 base = oldoldop->op_targ;
17177 count += old_count;
17182 /* if there's any immediately following singleton
17183 * my var's; then swallow them and the associated
17185 * my ($a,$b); my $c; my $d;
17187 * my ($a,$b,$c,$d);
17190 while ( ((p = followop->op_next))
17191 && ( p->op_type == OP_PADSV
17192 || p->op_type == OP_PADAV
17193 || p->op_type == OP_PADHV)
17194 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17195 && (p->op_private & OPpLVAL_INTRO) == intro
17196 && !(p->op_private & ~OPpLVAL_INTRO)
17198 && ( p->op_next->op_type == OP_NEXTSTATE
17199 || p->op_next->op_type == OP_DBSTATE)
17200 && count < OPpPADRANGE_COUNTMASK
17201 && base + count == p->op_targ
17204 followop = p->op_next;
17212 assert(oldoldop->op_type == OP_PADRANGE);
17213 oldoldop->op_next = followop;
17214 oldoldop->op_private = (intro | count);
17220 /* Convert the pushmark into a padrange.
17221 * To make Deparse easier, we guarantee that a padrange was
17222 * *always* formerly a pushmark */
17223 assert(o->op_type == OP_PUSHMARK);
17224 o->op_next = followop;
17225 OpTYPE_set(o, OP_PADRANGE);
17227 /* bit 7: INTRO; bit 6..0: count */
17228 o->op_private = (intro | count);
17229 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17230 | gvoid * OPf_WANT_VOID
17231 | (defav ? OPf_SPECIAL : 0));
17237 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17238 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17243 /*'keys %h' in void or scalar context: skip the OP_KEYS
17244 * and perform the functionality directly in the RV2HV/PADHV
17247 if (o->op_flags & OPf_REF) {
17248 OP *k = o->op_next;
17249 U8 want = (k->op_flags & OPf_WANT);
17251 && k->op_type == OP_KEYS
17252 && ( want == OPf_WANT_VOID
17253 || want == OPf_WANT_SCALAR)
17254 && !(k->op_private & OPpMAYBE_LVSUB)
17255 && !(k->op_flags & OPf_MOD)
17257 o->op_next = k->op_next;
17258 o->op_flags &= ~(OPf_REF|OPf_WANT);
17259 o->op_flags |= want;
17260 o->op_private |= (o->op_type == OP_PADHV ?
17261 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17262 /* for keys(%lex), hold onto the OP_KEYS's targ
17263 * since padhv doesn't have its own targ to return
17265 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17270 /* see if %h is used in boolean context */
17271 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17272 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17275 if (o->op_type != OP_PADHV)
17279 if ( o->op_type == OP_PADAV
17280 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17282 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17285 /* Skip over state($x) in void context. */
17286 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17287 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17289 oldop->op_next = o->op_next;
17290 goto redo_nextstate;
17292 if (o->op_type != OP_PADAV)
17296 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17297 OP* const pop = (o->op_type == OP_PADAV) ?
17298 o->op_next : o->op_next->op_next;
17300 if (pop && pop->op_type == OP_CONST &&
17301 ((PL_op = pop->op_next)) &&
17302 pop->op_next->op_type == OP_AELEM &&
17303 !(pop->op_next->op_private &
17304 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17305 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17308 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17309 no_bareword_allowed(pop);
17310 if (o->op_type == OP_GV)
17311 op_null(o->op_next);
17312 op_null(pop->op_next);
17314 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17315 o->op_next = pop->op_next->op_next;
17316 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17317 o->op_private = (U8)i;
17318 if (o->op_type == OP_GV) {
17321 o->op_type = OP_AELEMFAST;
17324 o->op_type = OP_AELEMFAST_LEX;
17326 if (o->op_type != OP_GV)
17330 /* Remove $foo from the op_next chain in void context. */
17332 && ( o->op_next->op_type == OP_RV2SV
17333 || o->op_next->op_type == OP_RV2AV
17334 || o->op_next->op_type == OP_RV2HV )
17335 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17336 && !(o->op_next->op_private & OPpLVAL_INTRO))
17338 oldop->op_next = o->op_next->op_next;
17339 /* Reprocess the previous op if it is a nextstate, to
17340 allow double-nextstate optimisation. */
17342 if (oldop->op_type == OP_NEXTSTATE) {
17349 o = oldop->op_next;
17352 else if (o->op_next->op_type == OP_RV2SV) {
17353 if (!(o->op_next->op_private & OPpDEREF)) {
17354 op_null(o->op_next);
17355 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17357 o->op_next = o->op_next->op_next;
17358 OpTYPE_set(o, OP_GVSV);
17361 else if (o->op_next->op_type == OP_READLINE
17362 && o->op_next->op_next->op_type == OP_CONCAT
17363 && (o->op_next->op_next->op_flags & OPf_STACKED))
17365 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17366 OpTYPE_set(o, OP_RCATLINE);
17367 o->op_flags |= OPf_STACKED;
17368 op_null(o->op_next->op_next);
17369 op_null(o->op_next);
17380 while (cLOGOP->op_other->op_type == OP_NULL)
17381 cLOGOP->op_other = cLOGOP->op_other->op_next;
17382 while (o->op_next && ( o->op_type == o->op_next->op_type
17383 || o->op_next->op_type == OP_NULL))
17384 o->op_next = o->op_next->op_next;
17386 /* If we're an OR and our next is an AND in void context, we'll
17387 follow its op_other on short circuit, same for reverse.
17388 We can't do this with OP_DOR since if it's true, its return
17389 value is the underlying value which must be evaluated
17393 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17394 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17396 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17398 o->op_next = ((LOGOP*)o->op_next)->op_other;
17400 DEFER(cLOGOP->op_other);
17405 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17406 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17415 case OP_ARGDEFELEM:
17416 while (cLOGOP->op_other->op_type == OP_NULL)
17417 cLOGOP->op_other = cLOGOP->op_other->op_next;
17418 DEFER(cLOGOP->op_other);
17423 while (cLOOP->op_redoop->op_type == OP_NULL)
17424 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17425 while (cLOOP->op_nextop->op_type == OP_NULL)
17426 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17427 while (cLOOP->op_lastop->op_type == OP_NULL)
17428 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17429 /* a while(1) loop doesn't have an op_next that escapes the
17430 * loop, so we have to explicitly follow the op_lastop to
17431 * process the rest of the code */
17432 DEFER(cLOOP->op_lastop);
17436 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17437 DEFER(cLOGOPo->op_other);
17441 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17442 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17443 assert(!(cPMOP->op_pmflags & PMf_ONCE));
17444 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17445 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17446 cPMOP->op_pmstashstartu.op_pmreplstart
17447 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17448 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17454 if (o->op_flags & OPf_SPECIAL) {
17455 /* first arg is a code block */
17456 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17457 OP * kid = cUNOPx(nullop)->op_first;
17459 assert(nullop->op_type == OP_NULL);
17460 assert(kid->op_type == OP_SCOPE
17461 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17462 /* since OP_SORT doesn't have a handy op_other-style
17463 * field that can point directly to the start of the code
17464 * block, store it in the otherwise-unused op_next field
17465 * of the top-level OP_NULL. This will be quicker at
17466 * run-time, and it will also allow us to remove leading
17467 * OP_NULLs by just messing with op_nexts without
17468 * altering the basic op_first/op_sibling layout. */
17469 kid = kLISTOP->op_first;
17471 (kid->op_type == OP_NULL
17472 && ( kid->op_targ == OP_NEXTSTATE
17473 || kid->op_targ == OP_DBSTATE ))
17474 || kid->op_type == OP_STUB
17475 || kid->op_type == OP_ENTER
17476 || (PL_parser && PL_parser->error_count));
17477 nullop->op_next = kid->op_next;
17478 DEFER(nullop->op_next);
17481 /* check that RHS of sort is a single plain array */
17482 oright = cUNOPo->op_first;
17483 if (!oright || oright->op_type != OP_PUSHMARK)
17486 if (o->op_private & OPpSORT_INPLACE)
17489 /* reverse sort ... can be optimised. */
17490 if (!OpHAS_SIBLING(cUNOPo)) {
17491 /* Nothing follows us on the list. */
17492 OP * const reverse = o->op_next;
17494 if (reverse->op_type == OP_REVERSE &&
17495 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17496 OP * const pushmark = cUNOPx(reverse)->op_first;
17497 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17498 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17499 /* reverse -> pushmark -> sort */
17500 o->op_private |= OPpSORT_REVERSE;
17502 pushmark->op_next = oright->op_next;
17512 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17514 LISTOP *enter, *exlist;
17516 if (o->op_private & OPpSORT_INPLACE)
17519 enter = (LISTOP *) o->op_next;
17522 if (enter->op_type == OP_NULL) {
17523 enter = (LISTOP *) enter->op_next;
17527 /* for $a (...) will have OP_GV then OP_RV2GV here.
17528 for (...) just has an OP_GV. */
17529 if (enter->op_type == OP_GV) {
17530 gvop = (OP *) enter;
17531 enter = (LISTOP *) enter->op_next;
17534 if (enter->op_type == OP_RV2GV) {
17535 enter = (LISTOP *) enter->op_next;
17541 if (enter->op_type != OP_ENTERITER)
17544 iter = enter->op_next;
17545 if (!iter || iter->op_type != OP_ITER)
17548 expushmark = enter->op_first;
17549 if (!expushmark || expushmark->op_type != OP_NULL
17550 || expushmark->op_targ != OP_PUSHMARK)
17553 exlist = (LISTOP *) OpSIBLING(expushmark);
17554 if (!exlist || exlist->op_type != OP_NULL
17555 || exlist->op_targ != OP_LIST)
17558 if (exlist->op_last != o) {
17559 /* Mmm. Was expecting to point back to this op. */
17562 theirmark = exlist->op_first;
17563 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17566 if (OpSIBLING(theirmark) != o) {
17567 /* There's something between the mark and the reverse, eg
17568 for (1, reverse (...))
17573 ourmark = ((LISTOP *)o)->op_first;
17574 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17577 ourlast = ((LISTOP *)o)->op_last;
17578 if (!ourlast || ourlast->op_next != o)
17581 rv2av = OpSIBLING(ourmark);
17582 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17583 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17584 /* We're just reversing a single array. */
17585 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17586 enter->op_flags |= OPf_STACKED;
17589 /* We don't have control over who points to theirmark, so sacrifice
17591 theirmark->op_next = ourmark->op_next;
17592 theirmark->op_flags = ourmark->op_flags;
17593 ourlast->op_next = gvop ? gvop : (OP *) enter;
17596 enter->op_private |= OPpITER_REVERSED;
17597 iter->op_private |= OPpITER_REVERSED;
17601 o = oldop->op_next;
17603 NOT_REACHED; /* NOTREACHED */
17609 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17610 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17615 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17616 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17619 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17621 sv = newRV((SV *)PL_compcv);
17625 OpTYPE_set(o, OP_CONST);
17626 o->op_flags |= OPf_SPECIAL;
17627 cSVOPo->op_sv = sv;
17632 if (OP_GIMME(o,0) == G_VOID
17633 || ( o->op_next->op_type == OP_LINESEQ
17634 && ( o->op_next->op_next->op_type == OP_LEAVESUB
17635 || ( o->op_next->op_next->op_type == OP_RETURN
17636 && !CvLVALUE(PL_compcv)))))
17638 OP *right = cBINOP->op_first;
17657 OP *left = OpSIBLING(right);
17658 if (left->op_type == OP_SUBSTR
17659 && (left->op_private & 7) < 4) {
17661 /* cut out right */
17662 op_sibling_splice(o, NULL, 1, NULL);
17663 /* and insert it as second child of OP_SUBSTR */
17664 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17666 left->op_private |= OPpSUBSTR_REPL_FIRST;
17668 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17675 int l, r, lr, lscalars, rscalars;
17677 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17678 Note that we do this now rather than in newASSIGNOP(),
17679 since only by now are aliased lexicals flagged as such
17681 See the essay "Common vars in list assignment" above for
17682 the full details of the rationale behind all the conditions
17685 PL_generation sorcery:
17686 To detect whether there are common vars, the global var
17687 PL_generation is incremented for each assign op we scan.
17688 Then we run through all the lexical variables on the LHS,
17689 of the assignment, setting a spare slot in each of them to
17690 PL_generation. Then we scan the RHS, and if any lexicals
17691 already have that value, we know we've got commonality.
17692 Also, if the generation number is already set to
17693 PERL_INT_MAX, then the variable is involved in aliasing, so
17694 we also have potential commonality in that case.
17700 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
17703 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17707 /* After looking for things which are *always* safe, this main
17708 * if/else chain selects primarily based on the type of the
17709 * LHS, gradually working its way down from the more dangerous
17710 * to the more restrictive and thus safer cases */
17712 if ( !l /* () = ....; */
17713 || !r /* .... = (); */
17714 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17715 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17716 || (lscalars < 2) /* ($x, undef) = ... */
17718 NOOP; /* always safe */
17720 else if (l & AAS_DANGEROUS) {
17721 /* always dangerous */
17722 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17723 o->op_private |= OPpASSIGN_COMMON_AGG;
17725 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17726 /* package vars are always dangerous - too many
17727 * aliasing possibilities */
17728 if (l & AAS_PKG_SCALAR)
17729 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17730 if (l & AAS_PKG_AGG)
17731 o->op_private |= OPpASSIGN_COMMON_AGG;
17733 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17734 |AAS_LEX_SCALAR|AAS_LEX_AGG))
17736 /* LHS contains only lexicals and safe ops */
17738 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17739 o->op_private |= OPpASSIGN_COMMON_AGG;
17741 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17742 if (lr & AAS_LEX_SCALAR_COMM)
17743 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17744 else if ( !(l & AAS_LEX_SCALAR)
17745 && (r & AAS_DEFAV))
17749 * as scalar-safe for performance reasons.
17750 * (it will still have been marked _AGG if necessary */
17753 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17754 /* if there are only lexicals on the LHS and no
17755 * common ones on the RHS, then we assume that the
17756 * only way those lexicals could also get
17757 * on the RHS is via some sort of dereffing or
17760 * ($lex, $x) = (1, $$r)
17761 * and in this case we assume the var must have
17762 * a bumped ref count. So if its ref count is 1,
17763 * it must only be on the LHS.
17765 o->op_private |= OPpASSIGN_COMMON_RC1;
17770 * may have to handle aggregate on LHS, but we can't
17771 * have common scalars. */
17774 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17776 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17777 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17782 /* see if ref() is used in boolean context */
17783 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17784 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17788 /* see if the op is used in known boolean context,
17789 * but not if OA_TARGLEX optimisation is enabled */
17790 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17791 && !(o->op_private & OPpTARGET_MY)
17793 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17797 /* see if the op is used in known boolean context */
17798 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17799 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17803 Perl_cpeep_t cpeep =
17804 XopENTRYCUSTOM(o, xop_peep);
17806 cpeep(aTHX_ o, oldop);
17811 /* did we just null the current op? If so, re-process it to handle
17812 * eliding "empty" ops from the chain */
17813 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
17826 Perl_peep(pTHX_ OP *o)
17832 =head1 Custom Operators
17834 =for apidoc Perl_custom_op_xop
17835 Return the XOP structure for a given custom op. This macro should be
17836 considered internal to C<OP_NAME> and the other access macros: use them instead.
17837 This macro does call a function. Prior
17838 to 5.19.6, this was implemented as a
17845 /* use PERL_MAGIC_ext to call a function to free the xop structure when
17846 * freeing PL_custom_ops */
17849 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
17853 PERL_UNUSED_ARG(mg);
17854 xop = INT2PTR(XOP *, SvIV(sv));
17855 Safefree(xop->xop_name);
17856 Safefree(xop->xop_desc);
17862 static const MGVTBL custom_op_register_vtbl = {
17867 custom_op_register_free, /* free */
17877 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
17883 static const XOP xop_null = { 0, 0, 0, 0, 0 };
17885 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
17886 assert(o->op_type == OP_CUSTOM);
17888 /* This is wrong. It assumes a function pointer can be cast to IV,
17889 * which isn't guaranteed, but this is what the old custom OP code
17890 * did. In principle it should be safer to Copy the bytes of the
17891 * pointer into a PV: since the new interface is hidden behind
17892 * functions, this can be changed later if necessary. */
17893 /* Change custom_op_xop if this ever happens */
17894 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
17897 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17899 /* See if the op isn't registered, but its name *is* registered.
17900 * That implies someone is using the pre-5.14 API,where only name and
17901 * description could be registered. If so, fake up a real
17903 * We only check for an existing name, and assume no one will have
17904 * just registered a desc */
17905 if (!he && PL_custom_op_names &&
17906 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
17911 /* XXX does all this need to be shared mem? */
17912 Newxz(xop, 1, XOP);
17913 pv = SvPV(HeVAL(he), l);
17914 XopENTRY_set(xop, xop_name, savepvn(pv, l));
17915 if (PL_custom_op_descs &&
17916 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
17918 pv = SvPV(HeVAL(he), l);
17919 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
17921 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
17922 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17923 /* add magic to the SV so that the xop struct (pointed to by
17924 * SvIV(sv)) is freed. Normally a static xop is registered, but
17925 * for this backcompat hack, we've alloced one */
17926 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
17927 &custom_op_register_vtbl, NULL, 0);
17932 xop = (XOP *)&xop_null;
17934 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
17938 if(field == XOPe_xop_ptr) {
17941 const U32 flags = XopFLAGS(xop);
17942 if(flags & field) {
17944 case XOPe_xop_name:
17945 any.xop_name = xop->xop_name;
17947 case XOPe_xop_desc:
17948 any.xop_desc = xop->xop_desc;
17950 case XOPe_xop_class:
17951 any.xop_class = xop->xop_class;
17953 case XOPe_xop_peep:
17954 any.xop_peep = xop->xop_peep;
17957 NOT_REACHED; /* NOTREACHED */
17962 case XOPe_xop_name:
17963 any.xop_name = XOPd_xop_name;
17965 case XOPe_xop_desc:
17966 any.xop_desc = XOPd_xop_desc;
17968 case XOPe_xop_class:
17969 any.xop_class = XOPd_xop_class;
17971 case XOPe_xop_peep:
17972 any.xop_peep = XOPd_xop_peep;
17975 NOT_REACHED; /* NOTREACHED */
17980 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
17981 * op.c: In function 'Perl_custom_op_get_field':
17982 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
17983 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
17984 * expands to assert(0), which expands to ((0) ? (void)0 :
17985 * __assert(...)), and gcc doesn't know that __assert can never return. */
17991 =for apidoc custom_op_register
17992 Register a custom op. See L<perlguts/"Custom Operators">.
17998 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18002 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18004 /* see the comment in custom_op_xop */
18005 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18007 if (!PL_custom_ops)
18008 PL_custom_ops = newHV();
18010 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18011 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18016 =for apidoc core_prototype
18018 This function assigns the prototype of the named core function to C<sv>, or
18019 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
18020 C<NULL> if the core function has no prototype. C<code> is a code as returned
18021 by C<keyword()>. It must not be equal to 0.
18027 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18030 int i = 0, n = 0, seen_question = 0, defgv = 0;
18032 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18033 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18034 bool nullret = FALSE;
18036 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18040 if (!sv) sv = sv_newmortal();
18042 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18044 switch (code < 0 ? -code : code) {
18045 case KEY_and : case KEY_chop: case KEY_chomp:
18046 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
18047 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
18048 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
18049 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
18050 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
18051 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
18052 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
18053 case KEY_x : case KEY_xor :
18054 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18055 case KEY_glob: retsetpvs("_;", OP_GLOB);
18056 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
18057 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
18058 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
18059 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
18060 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18062 case KEY_evalbytes:
18063 name = "entereval"; break;
18071 while (i < MAXO) { /* The slow way. */
18072 if (strEQ(name, PL_op_name[i])
18073 || strEQ(name, PL_op_desc[i]))
18075 if (nullret) { assert(opnum); *opnum = i; return NULL; }
18082 defgv = PL_opargs[i] & OA_DEFGV;
18083 oa = PL_opargs[i] >> OASHIFT;
18085 if (oa & OA_OPTIONAL && !seen_question && (
18086 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18091 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18092 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18093 /* But globs are already references (kinda) */
18094 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18098 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18099 && !scalar_mod_type(NULL, i)) {
18104 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18108 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18109 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18110 str[n-1] = '_'; defgv = 0;
18114 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18116 sv_setpvn(sv, str, n - 1);
18117 if (opnum) *opnum = i;
18122 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18125 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18126 newSVOP(OP_COREARGS,0,coreargssv);
18129 PERL_ARGS_ASSERT_CORESUB_OP;
18133 return op_append_elem(OP_LINESEQ,
18136 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18143 o = newUNOP(OP_AVHVSWITCH,0,argop);
18144 o->op_private = opnum-OP_EACH;
18146 case OP_SELECT: /* which represents OP_SSELECT as well */
18151 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18152 newSVOP(OP_CONST, 0, newSVuv(1))
18154 coresub_op(newSVuv((UV)OP_SSELECT), 0,
18156 coresub_op(coreargssv, 0, OP_SELECT)
18160 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18162 return op_append_elem(
18165 opnum == OP_WANTARRAY || opnum == OP_RUNCV
18166 ? OPpOFFBYONE << 8 : 0)
18168 case OA_BASEOP_OR_UNOP:
18169 if (opnum == OP_ENTEREVAL) {
18170 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18171 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18173 else o = newUNOP(opnum,0,argop);
18174 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18177 if (is_handle_constructor(o, 1))
18178 argop->op_private |= OPpCOREARGS_DEREF1;
18179 if (scalar_mod_type(NULL, opnum))
18180 argop->op_private |= OPpCOREARGS_SCALARMOD;
18184 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18185 if (is_handle_constructor(o, 2))
18186 argop->op_private |= OPpCOREARGS_DEREF2;
18187 if (opnum == OP_SUBSTR) {
18188 o->op_private |= OPpMAYBE_LVSUB;
18197 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18198 SV * const *new_const_svp)
18200 const char *hvname;
18201 bool is_const = !!CvCONST(old_cv);
18202 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18204 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18206 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18208 /* They are 2 constant subroutines generated from
18209 the same constant. This probably means that
18210 they are really the "same" proxy subroutine
18211 instantiated in 2 places. Most likely this is
18212 when a constant is exported twice. Don't warn.
18215 (ckWARN(WARN_REDEFINE)
18217 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18218 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18219 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18220 strEQ(hvname, "autouse"))
18224 && ckWARN_d(WARN_REDEFINE)
18225 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18228 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18230 ? "Constant subroutine %" SVf " redefined"
18231 : "Subroutine %" SVf " redefined",
18236 =head1 Hook manipulation
18238 These functions provide convenient and thread-safe means of manipulating
18245 =for apidoc wrap_op_checker
18247 Puts a C function into the chain of check functions for a specified op
18248 type. This is the preferred way to manipulate the L</PL_check> array.
18249 C<opcode> specifies which type of op is to be affected. C<new_checker>
18250 is a pointer to the C function that is to be added to that opcode's
18251 check chain, and C<old_checker_p> points to the storage location where a
18252 pointer to the next function in the chain will be stored. The value of
18253 C<new_checker> is written into the L</PL_check> array, while the value
18254 previously stored there is written to C<*old_checker_p>.
18256 L</PL_check> is global to an entire process, and a module wishing to
18257 hook op checking may find itself invoked more than once per process,
18258 typically in different threads. To handle that situation, this function
18259 is idempotent. The location C<*old_checker_p> must initially (once
18260 per process) contain a null pointer. A C variable of static duration
18261 (declared at file scope, typically also marked C<static> to give
18262 it internal linkage) will be implicitly initialised appropriately,
18263 if it does not have an explicit initialiser. This function will only
18264 actually modify the check chain if it finds C<*old_checker_p> to be null.
18265 This function is also thread safe on the small scale. It uses appropriate
18266 locking to avoid race conditions in accessing L</PL_check>.
18268 When this function is called, the function referenced by C<new_checker>
18269 must be ready to be called, except for C<*old_checker_p> being unfilled.
18270 In a threading situation, C<new_checker> may be called immediately,
18271 even before this function has returned. C<*old_checker_p> will always
18272 be appropriately set before C<new_checker> is called. If C<new_checker>
18273 decides not to do anything special with an op that it is given (which
18274 is the usual case for most uses of op check hooking), it must chain the
18275 check function referenced by C<*old_checker_p>.
18277 Taken all together, XS code to hook an op checker should typically look
18278 something like this:
18280 static Perl_check_t nxck_frob;
18281 static OP *myck_frob(pTHX_ OP *op) {
18283 op = nxck_frob(aTHX_ op);
18288 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18290 If you want to influence compilation of calls to a specific subroutine,
18291 then use L</cv_set_call_checker_flags> rather than hooking checking of
18292 all C<entersub> ops.
18298 Perl_wrap_op_checker(pTHX_ Optype opcode,
18299 Perl_check_t new_checker, Perl_check_t *old_checker_p)
18303 PERL_UNUSED_CONTEXT;
18304 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18305 if (*old_checker_p) return;
18306 OP_CHECK_MUTEX_LOCK;
18307 if (!*old_checker_p) {
18308 *old_checker_p = PL_check[opcode];
18309 PL_check[opcode] = new_checker;
18311 OP_CHECK_MUTEX_UNLOCK;
18316 /* Efficient sub that returns a constant scalar value. */
18318 const_sv_xsub(pTHX_ CV* cv)
18321 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18322 PERL_UNUSED_ARG(items);
18332 const_av_xsub(pTHX_ CV* cv)
18335 AV * const av = MUTABLE_AV(XSANY.any_ptr);
18343 if (SvRMAGICAL(av))
18344 Perl_croak(aTHX_ "Magical list constants are not supported");
18345 if (GIMME_V != G_ARRAY) {
18347 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18350 EXTEND(SP, AvFILLp(av)+1);
18351 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18352 XSRETURN(AvFILLp(av)+1);
18355 /* Copy an existing cop->cop_warnings field.
18356 * If it's one of the standard addresses, just re-use the address.
18357 * This is the e implementation for the DUP_WARNINGS() macro
18361 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18364 STRLEN *new_warnings;
18366 if (warnings == NULL || specialWARN(warnings))
18369 size = sizeof(*warnings) + *warnings;
18371 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18372 Copy(warnings, new_warnings, size, char);
18373 return new_warnings;
18377 * ex: set ts=8 sts=4 sw=4 et: