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 /* don't optimise away assign in 'local $foo = ....' */
2920 if ( (targetop->op_private & OPpLVAL_INTRO)
2921 /* these are the common ops which do 'local', but
2923 && ( targetop->op_type == OP_GVSV
2924 || targetop->op_type == OP_RV2SV
2925 || targetop->op_type == OP_AELEM
2926 || targetop->op_type == OP_HELEM
2931 else if ( topop->op_type == OP_CONCAT
2932 && (topop->op_flags & OPf_STACKED)
2933 && (!(topop->op_private & OPpCONCAT_NESTED))
2938 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2939 * decide what to do about it */
2940 assert(!(o->op_private & OPpTARGET_MY));
2942 /* barf on unknown flags */
2943 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2944 private_flags |= OPpMULTICONCAT_APPEND;
2945 targetop = cBINOPo->op_first;
2947 topop = OpSIBLING(targetop);
2949 /* $x .= <FOO> gets optimised to rcatline instead */
2950 if (topop->op_type == OP_READLINE)
2955 /* Can targetop (the LHS) if it's a padsv, be be optimised
2956 * away and use OPpTARGET_MY instead?
2958 if ( (targetop->op_type == OP_PADSV)
2959 && !(targetop->op_private & OPpDEREF)
2960 && !(targetop->op_private & OPpPAD_STATE)
2961 /* we don't support 'my $x .= ...' */
2962 && ( o->op_type == OP_SASSIGN
2963 || !(targetop->op_private & OPpLVAL_INTRO))
2968 if (topop->op_type == OP_STRINGIFY) {
2969 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2973 /* barf on unknown flags */
2974 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2976 if ((topop->op_private & OPpTARGET_MY)) {
2977 if (o->op_type == OP_SASSIGN)
2978 return; /* can't have two assigns */
2982 private_flags |= OPpMULTICONCAT_STRINGIFY;
2984 topop = cBINOPx(topop)->op_first;
2985 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2986 topop = OpSIBLING(topop);
2989 if (topop->op_type == OP_SPRINTF) {
2990 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2992 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2993 nargs = sprintf_info.nargs;
2994 total_len = sprintf_info.total_len;
2995 variant = sprintf_info.variant;
2996 utf8 = sprintf_info.utf8;
2998 private_flags |= OPpMULTICONCAT_FAKE;
3000 /* we have an sprintf op rather than a concat optree.
3001 * Skip most of the code below which is associated with
3002 * processing that optree. We also skip phase 2, determining
3003 * whether its cost effective to optimise, since for sprintf,
3004 * multiconcat is *always* faster */
3007 /* note that even if the sprintf itself isn't multiconcatable,
3008 * the expression as a whole may be, e.g. in
3009 * $x .= sprintf("%d",...)
3010 * the sprintf op will be left as-is, but the concat/S op may
3011 * be upgraded to multiconcat
3014 else if (topop->op_type == OP_CONCAT) {
3015 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3018 if ((topop->op_private & OPpTARGET_MY)) {
3019 if (o->op_type == OP_SASSIGN || targmyop)
3020 return; /* can't have two assigns */
3025 /* Is it safe to convert a sassign/stringify/concat op into
3027 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3028 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3029 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3030 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3031 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3032 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3033 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3034 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3036 /* Now scan the down the tree looking for a series of
3037 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3038 * stacked). For example this tree:
3043 * CONCAT/STACKED -- EXPR5
3045 * CONCAT/STACKED -- EXPR4
3051 * corresponds to an expression like
3053 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3055 * Record info about each EXPR in args[]: in particular, whether it is
3056 * a stringifiable OP_CONST and if so what the const sv is.
3058 * The reason why the last concat can't be STACKED is the difference
3061 * ((($a .= $a) .= $a) .= $a) .= $a
3064 * $a . $a . $a . $a . $a
3066 * The main difference between the optrees for those two constructs
3067 * is the presence of the last STACKED. As well as modifying $a,
3068 * the former sees the changed $a between each concat, so if $s is
3069 * initially 'a', the first returns 'a' x 16, while the latter returns
3070 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3080 if ( kid->op_type == OP_CONCAT
3084 k1 = cUNOPx(kid)->op_first;
3086 /* shouldn't happen except maybe after compile err? */
3090 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3091 if (kid->op_private & OPpTARGET_MY)
3094 stacked_last = (kid->op_flags & OPf_STACKED);
3106 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3107 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3109 /* At least two spare slots are needed to decompose both
3110 * concat args. If there are no slots left, continue to
3111 * examine the rest of the optree, but don't push new values
3112 * on args[]. If the optree as a whole is legal for conversion
3113 * (in particular that the last concat isn't STACKED), then
3114 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3115 * can be converted into an OP_MULTICONCAT now, with the first
3116 * child of that op being the remainder of the optree -
3117 * which may itself later be converted to a multiconcat op
3121 /* the last arg is the rest of the optree */
3126 else if ( argop->op_type == OP_CONST
3127 && ((sv = cSVOPx_sv(argop)))
3128 /* defer stringification until runtime of 'constant'
3129 * things that might stringify variantly, e.g. the radix
3130 * point of NVs, or overloaded RVs */
3131 && (SvPOK(sv) || SvIOK(sv))
3132 && (!SvGMAGICAL(sv))
3134 if (argop->op_private & OPpCONST_STRICT)
3135 no_bareword_allowed(argop);
3137 utf8 |= cBOOL(SvUTF8(sv));
3140 /* this const may be demoted back to a plain arg later;
3141 * make sure we have enough arg slots left */
3143 prev_was_const = !prev_was_const;
3148 prev_was_const = FALSE;
3158 return; /* we don't support ((A.=B).=C)...) */
3160 /* look for two adjacent consts and don't fold them together:
3163 * $o->concat("a")->concat("b")
3166 * (but $o .= "a" . "b" should still fold)
3169 bool seen_nonconst = FALSE;
3170 for (argp = toparg; argp >= args; argp--) {
3171 if (argp->p == NULL) {
3172 seen_nonconst = TRUE;
3178 /* both previous and current arg were constants;
3179 * leave the current OP_CONST as-is */
3187 /* -----------------------------------------------------------------
3190 * At this point we have determined that the optree *can* be converted
3191 * into a multiconcat. Having gathered all the evidence, we now decide
3192 * whether it *should*.
3196 /* we need at least one concat action, e.g.:
3202 * otherwise we could be doing something like $x = "foo", which
3203 * if treated as as a concat, would fail to COW.
3205 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3208 /* Benchmarking seems to indicate that we gain if:
3209 * * we optimise at least two actions into a single multiconcat
3210 * (e.g concat+concat, sassign+concat);
3211 * * or if we can eliminate at least 1 OP_CONST;
3212 * * or if we can eliminate a padsv via OPpTARGET_MY
3216 /* eliminated at least one OP_CONST */
3218 /* eliminated an OP_SASSIGN */
3219 || o->op_type == OP_SASSIGN
3220 /* eliminated an OP_PADSV */
3221 || (!targmyop && is_targable)
3223 /* definitely a net gain to optimise */
3226 /* ... if not, what else? */
3228 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3229 * multiconcat is faster (due to not creating a temporary copy of
3230 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3236 && topop->op_type == OP_CONCAT
3238 PADOFFSET t = targmyop->op_targ;
3239 OP *k1 = cBINOPx(topop)->op_first;
3240 OP *k2 = cBINOPx(topop)->op_last;
3241 if ( k2->op_type == OP_PADSV
3243 && ( k1->op_type != OP_PADSV
3244 || k1->op_targ != t)
3249 /* need at least two concats */
3250 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3255 /* -----------------------------------------------------------------
3258 * At this point the optree has been verified as ok to be optimised
3259 * into an OP_MULTICONCAT. Now start changing things.
3264 /* stringify all const args and determine utf8ness */
3267 for (argp = args; argp <= toparg; argp++) {
3268 SV *sv = (SV*)argp->p;
3270 continue; /* not a const op */
3271 if (utf8 && !SvUTF8(sv))
3272 sv_utf8_upgrade_nomg(sv);
3273 argp->p = SvPV_nomg(sv, argp->len);
3274 total_len += argp->len;
3276 /* see if any strings would grow if converted to utf8 */
3278 variant += variant_under_utf8_count((U8 *) argp->p,
3279 (U8 *) argp->p + argp->len);
3283 /* create and populate aux struct */
3287 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3288 sizeof(UNOP_AUX_item)
3290 PERL_MULTICONCAT_HEADER_SIZE
3291 + ((nargs + 1) * (variant ? 2 : 1))
3294 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3296 /* Extract all the non-const expressions from the concat tree then
3297 * dispose of the old tree, e.g. convert the tree from this:
3301 * STRINGIFY -- TARGET
3303 * ex-PUSHMARK -- CONCAT
3318 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3320 * except that if EXPRi is an OP_CONST, it's discarded.
3322 * During the conversion process, EXPR ops are stripped from the tree
3323 * and unshifted onto o. Finally, any of o's remaining original
3324 * childen are discarded and o is converted into an OP_MULTICONCAT.
3326 * In this middle of this, o may contain both: unshifted args on the
3327 * left, and some remaining original args on the right. lastkidop
3328 * is set to point to the right-most unshifted arg to delineate
3329 * between the two sets.
3334 /* create a copy of the format with the %'s removed, and record
3335 * the sizes of the const string segments in the aux struct */
3337 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3339 p = sprintf_info.start;
3342 for (; p < sprintf_info.end; p++) {
3346 (lenp++)->ssize = q - oldq;
3353 lenp->ssize = q - oldq;
3354 assert((STRLEN)(q - const_str) == total_len);
3356 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3357 * may or may not be topop) The pushmark and const ops need to be
3358 * kept in case they're an op_next entry point.
3360 lastkidop = cLISTOPx(topop)->op_last;
3361 kid = cUNOPx(topop)->op_first; /* pushmark */
3363 op_null(OpSIBLING(kid)); /* const */
3365 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3366 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3367 lastkidop->op_next = o;
3372 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3376 /* Concatenate all const strings into const_str.
3377 * Note that args[] contains the RHS args in reverse order, so
3378 * we scan args[] from top to bottom to get constant strings
3381 for (argp = toparg; argp >= args; argp--) {
3383 /* not a const op */
3384 (++lenp)->ssize = -1;
3386 STRLEN l = argp->len;
3387 Copy(argp->p, p, l, char);
3389 if (lenp->ssize == -1)
3400 for (argp = args; argp <= toparg; argp++) {
3401 /* only keep non-const args, except keep the first-in-next-chain
3402 * arg no matter what it is (but nulled if OP_CONST), because it
3403 * may be the entry point to this subtree from the previous
3406 bool last = (argp == toparg);
3409 /* set prev to the sibling *before* the arg to be cut out,
3410 * e.g. when cutting EXPR:
3415 * prev= CONCAT -- EXPR
3418 if (argp == args && kid->op_type != OP_CONCAT) {
3419 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3420 * so the expression to be cut isn't kid->op_last but
3423 /* find the op before kid */
3425 o2 = cUNOPx(parentop)->op_first;
3426 while (o2 && o2 != kid) {
3434 else if (kid == o && lastkidop)
3435 prev = last ? lastkidop : OpSIBLING(lastkidop);
3437 prev = last ? NULL : cUNOPx(kid)->op_first;
3439 if (!argp->p || last) {
3441 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3442 /* and unshift to front of o */
3443 op_sibling_splice(o, NULL, 0, aop);
3444 /* record the right-most op added to o: later we will
3445 * free anything to the right of it */
3448 aop->op_next = nextop;
3451 /* null the const at start of op_next chain */
3455 nextop = prev->op_next;
3458 /* the last two arguments are both attached to the same concat op */
3459 if (argp < toparg - 1)
3464 /* Populate the aux struct */
3466 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3467 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3468 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3469 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3470 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3472 /* if variant > 0, calculate a variant const string and lengths where
3473 * the utf8 version of the string will take 'variant' more bytes than
3477 char *p = const_str;
3478 STRLEN ulen = total_len + variant;
3479 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3480 UNOP_AUX_item *ulens = lens + (nargs + 1);
3481 char *up = (char*)PerlMemShared_malloc(ulen);
3484 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3485 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3487 for (n = 0; n < (nargs + 1); n++) {
3489 char * orig_up = up;
3490 for (i = (lens++)->ssize; i > 0; i--) {
3492 append_utf8_from_native_byte(c, (U8**)&up);
3494 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3499 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3500 * that op's first child - an ex-PUSHMARK - because the op_next of
3501 * the previous op may point to it (i.e. it's the entry point for
3506 ? op_sibling_splice(o, lastkidop, 1, NULL)
3507 : op_sibling_splice(stringop, NULL, 1, NULL);
3508 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3509 op_sibling_splice(o, NULL, 0, pmop);
3516 * target .= A.B.C...
3522 if (o->op_type == OP_SASSIGN) {
3523 /* Move the target subtree from being the last of o's children
3524 * to being the last of o's preserved children.
3525 * Note the difference between 'target = ...' and 'target .= ...':
3526 * for the former, target is executed last; for the latter,
3529 kid = OpSIBLING(lastkidop);
3530 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3531 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3532 lastkidop->op_next = kid->op_next;
3533 lastkidop = targetop;
3536 /* Move the target subtree from being the first of o's
3537 * original children to being the first of *all* o's children.
3540 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3541 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3544 /* if the RHS of .= doesn't contain a concat (e.g.
3545 * $x .= "foo"), it gets missed by the "strip ops from the
3546 * tree and add to o" loop earlier */
3547 assert(topop->op_type != OP_CONCAT);
3549 /* in e.g. $x .= "$y", move the $y expression
3550 * from being a child of OP_STRINGIFY to being the
3551 * second child of the OP_CONCAT
3553 assert(cUNOPx(stringop)->op_first == topop);
3554 op_sibling_splice(stringop, NULL, 1, NULL);
3555 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3557 assert(topop == OpSIBLING(cBINOPo->op_first));
3566 * my $lex = A.B.C...
3569 * The original padsv op is kept but nulled in case it's the
3570 * entry point for the optree (which it will be for
3573 private_flags |= OPpTARGET_MY;
3574 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3575 o->op_targ = targetop->op_targ;
3576 targetop->op_targ = 0;
3580 flags |= OPf_STACKED;
3582 else if (targmyop) {
3583 private_flags |= OPpTARGET_MY;
3584 if (o != targmyop) {
3585 o->op_targ = targmyop->op_targ;
3586 targmyop->op_targ = 0;
3590 /* detach the emaciated husk of the sprintf/concat optree and free it */
3592 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3598 /* and convert o into a multiconcat */
3600 o->op_flags = (flags|OPf_KIDS|stacked_last
3601 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3602 o->op_private = private_flags;
3603 o->op_type = OP_MULTICONCAT;
3604 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3605 cUNOP_AUXo->op_aux = aux;
3609 /* do all the final processing on an optree (e.g. running the peephole
3610 * optimiser on it), then attach it to cv (if cv is non-null)
3614 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3618 /* XXX for some reason, evals, require and main optrees are
3619 * never attached to their CV; instead they just hang off
3620 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3621 * and get manually freed when appropriate */
3623 startp = &CvSTART(cv);
3625 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3628 optree->op_private |= OPpREFCOUNTED;
3629 OpREFCNT_set(optree, 1);
3630 optimize_optree(optree);
3632 finalize_optree(optree);
3633 S_prune_chain_head(startp);
3636 /* now that optimizer has done its work, adjust pad values */
3637 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3638 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3644 =for apidoc optimize_optree
3646 This function applies some optimisations to the optree in top-down order.
3647 It is called before the peephole optimizer, which processes ops in
3648 execution order. Note that finalize_optree() also does a top-down scan,
3649 but is called *after* the peephole optimizer.
3655 Perl_optimize_optree(pTHX_ OP* o)
3657 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3660 SAVEVPTR(PL_curcop);
3668 /* helper for optimize_optree() which optimises one op then recurses
3669 * to optimise any children.
3673 S_optimize_op(pTHX_ OP* o)
3677 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3680 OP * next_kid = NULL;
3682 assert(o->op_type != OP_FREED);
3684 switch (o->op_type) {
3687 PL_curcop = ((COP*)o); /* for warnings */
3695 S_maybe_multiconcat(aTHX_ o);
3699 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3700 /* we can't assume that op_pmreplroot->op_sibparent == o
3701 * and that it is thus possible to walk back up the tree
3702 * past op_pmreplroot. So, although we try to avoid
3703 * recursing through op trees, do it here. After all,
3704 * there are unlikely to be many nested s///e's within
3705 * the replacement part of a s///e.
3707 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3715 if (o->op_flags & OPf_KIDS)
3716 next_kid = cUNOPo->op_first;
3718 /* if a kid hasn't been nominated to process, continue with the
3719 * next sibling, or if no siblings left, go back to the parent's
3720 * siblings and so on
3724 return; /* at top; no parents/siblings to try */
3725 if (OpHAS_SIBLING(o))
3726 next_kid = o->op_sibparent;
3728 o = o->op_sibparent; /*try parent's next sibling */
3731 /* this label not yet used. Goto here if any code above sets
3741 =for apidoc finalize_optree
3743 This function finalizes the optree. Should be called directly after
3744 the complete optree is built. It does some additional
3745 checking which can't be done in the normal C<ck_>xxx functions and makes
3746 the tree thread-safe.
3751 Perl_finalize_optree(pTHX_ OP* o)
3753 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3756 SAVEVPTR(PL_curcop);
3764 /* Relocate sv to the pad for thread safety.
3765 * Despite being a "constant", the SV is written to,
3766 * for reference counts, sv_upgrade() etc. */
3767 PERL_STATIC_INLINE void
3768 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3771 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3773 ix = pad_alloc(OP_CONST, SVf_READONLY);
3774 SvREFCNT_dec(PAD_SVl(ix));
3775 PAD_SETSV(ix, *svp);
3776 /* XXX I don't know how this isn't readonly already. */
3777 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3784 =for apidoc traverse_op_tree
3786 Return the next op in a depth-first traversal of the op tree,
3787 returning NULL when the traversal is complete.
3789 The initial call must supply the root of the tree as both top and o.
3791 For now it's static, but it may be exposed to the API in the future.
3797 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3800 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3802 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3803 return cUNOPo->op_first;
3805 else if ((sib = OpSIBLING(o))) {
3809 OP *parent = o->op_sibparent;
3810 assert(!(o->op_moresib));
3811 while (parent && parent != top) {
3812 OP *sib = OpSIBLING(parent);
3815 parent = parent->op_sibparent;
3823 S_finalize_op(pTHX_ OP* o)
3826 PERL_ARGS_ASSERT_FINALIZE_OP;
3829 assert(o->op_type != OP_FREED);
3831 switch (o->op_type) {
3834 PL_curcop = ((COP*)o); /* for warnings */
3837 if (OpHAS_SIBLING(o)) {
3838 OP *sib = OpSIBLING(o);
3839 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3840 && ckWARN(WARN_EXEC)
3841 && OpHAS_SIBLING(sib))
3843 const OPCODE type = OpSIBLING(sib)->op_type;
3844 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3845 const line_t oldline = CopLINE(PL_curcop);
3846 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3847 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3848 "Statement unlikely to be reached");
3849 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3850 "\t(Maybe you meant system() when you said exec()?)\n");
3851 CopLINE_set(PL_curcop, oldline);
3858 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3859 GV * const gv = cGVOPo_gv;
3860 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3861 /* XXX could check prototype here instead of just carping */
3862 SV * const sv = sv_newmortal();
3863 gv_efullname3(sv, gv, NULL);
3864 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3865 "%" SVf "() called too early to check prototype",
3872 if (cSVOPo->op_private & OPpCONST_STRICT)
3873 no_bareword_allowed(o);
3877 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3882 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3883 case OP_METHOD_NAMED:
3884 case OP_METHOD_SUPER:
3885 case OP_METHOD_REDIR:
3886 case OP_METHOD_REDIR_SUPER:
3887 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3896 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3899 rop = (UNOP*)((BINOP*)o)->op_first;
3904 S_scalar_slice_warning(aTHX_ o);
3908 kid = OpSIBLING(cLISTOPo->op_first);
3909 if (/* I bet there's always a pushmark... */
3910 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3911 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3916 key_op = (SVOP*)(kid->op_type == OP_CONST
3918 : OpSIBLING(kLISTOP->op_first));
3920 rop = (UNOP*)((LISTOP*)o)->op_last;
3923 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3925 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3929 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3933 S_scalar_slice_warning(aTHX_ o);
3937 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3938 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3946 if (o->op_flags & OPf_KIDS) {
3949 /* check that op_last points to the last sibling, and that
3950 * the last op_sibling/op_sibparent field points back to the
3951 * parent, and that the only ops with KIDS are those which are
3952 * entitled to them */
3953 U32 type = o->op_type;
3957 if (type == OP_NULL) {
3959 /* ck_glob creates a null UNOP with ex-type GLOB
3960 * (which is a list op. So pretend it wasn't a listop */
3961 if (type == OP_GLOB)
3964 family = PL_opargs[type] & OA_CLASS_MASK;
3966 has_last = ( family == OA_BINOP
3967 || family == OA_LISTOP
3968 || family == OA_PMOP
3969 || family == OA_LOOP
3971 assert( has_last /* has op_first and op_last, or ...
3972 ... has (or may have) op_first: */
3973 || family == OA_UNOP
3974 || family == OA_UNOP_AUX
3975 || family == OA_LOGOP
3976 || family == OA_BASEOP_OR_UNOP
3977 || family == OA_FILESTATOP
3978 || family == OA_LOOPEXOP
3979 || family == OA_METHOP
3980 || type == OP_CUSTOM
3981 || type == OP_NULL /* new_logop does this */
3984 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3985 if (!OpHAS_SIBLING(kid)) {
3987 assert(kid == cLISTOPo->op_last);
3988 assert(kid->op_sibparent == o);
3993 } while (( o = traverse_op_tree(top, o)) != NULL);
3997 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
4000 PadnameLVALUE_on(pn);
4001 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
4003 /* RT #127786: cv can be NULL due to an eval within the DB package
4004 * called from an anon sub - anon subs don't have CvOUTSIDE() set
4005 * unless they contain an eval, but calling eval within DB
4006 * pretends the eval was done in the caller's scope.
4010 assert(CvPADLIST(cv));
4012 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
4013 assert(PadnameLEN(pn));
4014 PadnameLVALUE_on(pn);
4019 S_vivifies(const OPCODE type)
4022 case OP_RV2AV: case OP_ASLICE:
4023 case OP_RV2HV: case OP_KVASLICE:
4024 case OP_RV2SV: case OP_HSLICE:
4025 case OP_AELEMFAST: case OP_KVHSLICE:
4034 /* apply lvalue reference (aliasing) context to the optree o.
4037 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4038 * It may descend and apply this to children too, for example in
4039 * \( $cond ? $x, $y) = (...)
4043 S_lvref(pTHX_ OP *o, I32 type)
4050 switch (o->op_type) {
4052 o = OpSIBLING(cUNOPo->op_first);
4059 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4060 o->op_flags |= OPf_STACKED;
4061 if (o->op_flags & OPf_PARENS) {
4062 if (o->op_private & OPpLVAL_INTRO) {
4063 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4064 "localized parenthesized array in list assignment"));
4068 OpTYPE_set(o, OP_LVAVREF);
4069 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4070 o->op_flags |= OPf_MOD|OPf_REF;
4073 o->op_private |= OPpLVREF_AV;
4077 kid = cUNOPo->op_first;
4078 if (kid->op_type == OP_NULL)
4079 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4081 o->op_private = OPpLVREF_CV;
4082 if (kid->op_type == OP_GV)
4083 o->op_flags |= OPf_STACKED;
4084 else if (kid->op_type == OP_PADCV) {
4085 o->op_targ = kid->op_targ;
4087 op_free(cUNOPo->op_first);
4088 cUNOPo->op_first = NULL;
4089 o->op_flags &=~ OPf_KIDS;
4095 if (o->op_flags & OPf_PARENS) {
4097 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4098 "parenthesized hash in list assignment"));
4101 o->op_private |= OPpLVREF_HV;
4105 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4106 o->op_flags |= OPf_STACKED;
4110 if (o->op_flags & OPf_PARENS) goto parenhash;
4111 o->op_private |= OPpLVREF_HV;
4114 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4118 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4119 if (o->op_flags & OPf_PARENS) goto slurpy;
4120 o->op_private |= OPpLVREF_AV;
4125 o->op_private |= OPpLVREF_ELEM;
4126 o->op_flags |= OPf_STACKED;
4131 OpTYPE_set(o, OP_LVREFSLICE);
4132 o->op_private &= OPpLVAL_INTRO;
4136 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4138 else if (!(o->op_flags & OPf_KIDS))
4141 /* the code formerly only recursed into the first child of
4142 * a non ex-list OP_NULL. if we ever encounter such a null op with
4143 * more than one child, need to decide whether its ok to process
4144 * *all* its kids or not */
4145 assert(o->op_targ == OP_LIST
4146 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4149 o = cLISTOPo->op_first;
4153 if (o->op_flags & OPf_PARENS)
4158 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4159 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4160 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4167 OpTYPE_set(o, OP_LVREF);
4169 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4170 if (type == OP_ENTERLOOP)
4171 o->op_private |= OPpLVREF_ITER;
4176 return; /* at top; no parents/siblings to try */
4177 if (OpHAS_SIBLING(o)) {
4178 o = o->op_sibparent;
4181 o = o->op_sibparent; /*try parent's next sibling */
4187 PERL_STATIC_INLINE bool
4188 S_potential_mod_type(I32 type)
4190 /* Types that only potentially result in modification. */
4191 return type == OP_GREPSTART || type == OP_ENTERSUB
4192 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4197 =for apidoc op_lvalue
4199 Propagate lvalue ("modifiable") context to an op and its children.
4200 C<type> represents the context type, roughly based on the type of op that
4201 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4202 because it has no op type of its own (it is signalled by a flag on
4205 This function detects things that can't be modified, such as C<$x+1>, and
4206 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4207 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4209 It also flags things that need to behave specially in an lvalue context,
4210 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4214 Perl_op_lvalue_flags() is a non-API lower-level interface to
4215 op_lvalue(). The flags param has these bits:
4216 OP_LVALUE_NO_CROAK: return rather than croaking on error
4221 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4226 if (!o || (PL_parser && PL_parser->error_count))
4231 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4233 OP *next_kid = NULL;
4235 if ((o->op_private & OPpTARGET_MY)
4236 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4241 /* elements of a list might be in void context because the list is
4242 in scalar context or because they are attribute sub calls */
4243 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4246 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4248 switch (o->op_type) {
4254 if ((o->op_flags & OPf_PARENS))
4259 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4260 !(o->op_flags & OPf_STACKED)) {
4261 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4262 assert(cUNOPo->op_first->op_type == OP_NULL);
4263 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4266 else { /* lvalue subroutine call */
4267 o->op_private |= OPpLVAL_INTRO;
4268 PL_modcount = RETURN_UNLIMITED_NUMBER;
4269 if (S_potential_mod_type(type)) {
4270 o->op_private |= OPpENTERSUB_INARGS;
4273 else { /* Compile-time error message: */
4274 OP *kid = cUNOPo->op_first;
4279 if (kid->op_type != OP_PUSHMARK) {
4280 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4282 "panic: unexpected lvalue entersub "
4283 "args: type/targ %ld:%" UVuf,
4284 (long)kid->op_type, (UV)kid->op_targ);
4285 kid = kLISTOP->op_first;
4287 while (OpHAS_SIBLING(kid))
4288 kid = OpSIBLING(kid);
4289 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4290 break; /* Postpone until runtime */
4293 kid = kUNOP->op_first;
4294 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4295 kid = kUNOP->op_first;
4296 if (kid->op_type == OP_NULL)
4298 "Unexpected constant lvalue entersub "
4299 "entry via type/targ %ld:%" UVuf,
4300 (long)kid->op_type, (UV)kid->op_targ);
4301 if (kid->op_type != OP_GV) {
4308 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4309 ? MUTABLE_CV(SvRV(gv))
4315 if (flags & OP_LVALUE_NO_CROAK)
4318 namesv = cv_name(cv, NULL, 0);
4319 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4320 "subroutine call of &%" SVf " in %s",
4321 SVfARG(namesv), PL_op_desc[type]),
4329 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4330 /* grep, foreach, subcalls, refgen */
4331 if (S_potential_mod_type(type))
4333 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4334 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4337 type ? PL_op_desc[type] : "local"));
4350 case OP_RIGHT_SHIFT:
4359 if (!(o->op_flags & OPf_STACKED))
4365 if (o->op_flags & OPf_STACKED) {
4369 if (!(o->op_private & OPpREPEAT_DOLIST))
4372 const I32 mods = PL_modcount;
4373 /* we recurse rather than iterate here because we need to
4374 * calculate and use the delta applied to PL_modcount by the
4375 * first child. So in something like
4376 * ($x, ($y) x 3) = split;
4377 * split knows that 4 elements are wanted
4379 modkids(cBINOPo->op_first, type);
4380 if (type != OP_AASSIGN)
4382 kid = cBINOPo->op_last;
4383 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4384 const IV iv = SvIV(kSVOP_sv);
4385 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4387 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4390 PL_modcount = RETURN_UNLIMITED_NUMBER;
4396 next_kid = OpSIBLING(cUNOPo->op_first);
4401 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4402 PL_modcount = RETURN_UNLIMITED_NUMBER;
4403 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4404 fiable since some contexts need to know. */
4405 o->op_flags |= OPf_MOD;
4410 if (scalar_mod_type(o, type))
4412 ref(cUNOPo->op_first, o->op_type);
4419 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4420 if (type == OP_LEAVESUBLV && (
4421 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4422 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4424 o->op_private |= OPpMAYBE_LVSUB;
4428 PL_modcount = RETURN_UNLIMITED_NUMBER;
4434 if (type == OP_LEAVESUBLV)
4435 o->op_private |= OPpMAYBE_LVSUB;
4439 if (type == OP_LEAVESUBLV
4440 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4441 o->op_private |= OPpMAYBE_LVSUB;
4445 PL_hints |= HINT_BLOCK_SCOPE;
4446 if (type == OP_LEAVESUBLV)
4447 o->op_private |= OPpMAYBE_LVSUB;
4452 ref(cUNOPo->op_first, o->op_type);
4456 PL_hints |= HINT_BLOCK_SCOPE;
4466 case OP_AELEMFAST_LEX:
4473 PL_modcount = RETURN_UNLIMITED_NUMBER;
4474 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4476 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4477 fiable since some contexts need to know. */
4478 o->op_flags |= OPf_MOD;
4481 if (scalar_mod_type(o, type))
4483 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4484 && type == OP_LEAVESUBLV)
4485 o->op_private |= OPpMAYBE_LVSUB;
4489 if (!type) /* local() */
4490 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4491 PNfARG(PAD_COMPNAME(o->op_targ)));
4492 if (!(o->op_private & OPpLVAL_INTRO)
4493 || ( type != OP_SASSIGN && type != OP_AASSIGN
4494 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4495 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4503 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4507 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4513 if (type == OP_LEAVESUBLV)
4514 o->op_private |= OPpMAYBE_LVSUB;
4515 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4516 /* we recurse rather than iterate here because the child
4517 * needs to be processed with a different 'type' parameter */
4519 /* substr and vec */
4520 /* If this op is in merely potential (non-fatal) modifiable
4521 context, then apply OP_ENTERSUB context to
4522 the kid op (to avoid croaking). Other-
4523 wise pass this op’s own type so the correct op is mentioned
4524 in error messages. */
4525 op_lvalue(OpSIBLING(cBINOPo->op_first),
4526 S_potential_mod_type(type)
4534 ref(cBINOPo->op_first, o->op_type);
4535 if (type == OP_ENTERSUB &&
4536 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4537 o->op_private |= OPpLVAL_DEFER;
4538 if (type == OP_LEAVESUBLV)
4539 o->op_private |= OPpMAYBE_LVSUB;
4546 o->op_private |= OPpLVALUE;
4552 if (o->op_flags & OPf_KIDS)
4553 next_kid = cLISTOPo->op_last;
4558 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4560 else if (!(o->op_flags & OPf_KIDS))
4563 if (o->op_targ != OP_LIST) {
4564 OP *sib = OpSIBLING(cLISTOPo->op_first);
4565 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4572 * compared with things like OP_MATCH which have the argument
4578 * so handle specially to correctly get "Can't modify" croaks etc
4581 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4583 /* this should trigger a "Can't modify transliteration" err */
4584 op_lvalue(sib, type);
4586 next_kid = cBINOPo->op_first;
4587 /* we assume OP_NULLs which aren't ex-list have no more than 2
4588 * children. If this assumption is wrong, increase the scan
4590 assert( !OpHAS_SIBLING(next_kid)
4591 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4597 next_kid = cLISTOPo->op_first;
4605 if (type == OP_LEAVESUBLV
4606 || !S_vivifies(cLOGOPo->op_first->op_type))
4607 next_kid = cLOGOPo->op_first;
4608 else if (type == OP_LEAVESUBLV
4609 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4610 next_kid = OpSIBLING(cLOGOPo->op_first);
4614 if (type == OP_NULL) { /* local */
4616 if (!FEATURE_MYREF_IS_ENABLED)
4617 Perl_croak(aTHX_ "The experimental declared_refs "
4618 "feature is not enabled");
4619 Perl_ck_warner_d(aTHX_
4620 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4621 "Declaring references is experimental");
4622 next_kid = cUNOPo->op_first;
4625 if (type != OP_AASSIGN && type != OP_SASSIGN
4626 && type != OP_ENTERLOOP)
4628 /* Don’t bother applying lvalue context to the ex-list. */
4629 kid = cUNOPx(cUNOPo->op_first)->op_first;
4630 assert (!OpHAS_SIBLING(kid));
4633 if (type == OP_NULL) /* local */
4635 if (type != OP_AASSIGN) goto nomod;
4636 kid = cUNOPo->op_first;
4639 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4640 S_lvref(aTHX_ kid, type);
4641 if (!PL_parser || PL_parser->error_count == ec) {
4642 if (!FEATURE_REFALIASING_IS_ENABLED)
4644 "Experimental aliasing via reference not enabled");
4645 Perl_ck_warner_d(aTHX_
4646 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4647 "Aliasing via reference is experimental");
4650 if (o->op_type == OP_REFGEN)
4651 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4656 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4657 /* This is actually @array = split. */
4658 PL_modcount = RETURN_UNLIMITED_NUMBER;
4664 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4668 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4669 their argument is a filehandle; thus \stat(".") should not set
4671 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4674 if (type != OP_LEAVESUBLV)
4675 o->op_flags |= OPf_MOD;
4677 if (type == OP_AASSIGN || type == OP_SASSIGN)
4678 o->op_flags |= OPf_SPECIAL
4679 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4680 else if (!type) { /* local() */
4683 o->op_private |= OPpLVAL_INTRO;
4684 o->op_flags &= ~OPf_SPECIAL;
4685 PL_hints |= HINT_BLOCK_SCOPE;
4690 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4691 "Useless localization of %s", OP_DESC(o));
4694 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4695 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4696 o->op_flags |= OPf_REF;
4701 return top_op; /* at top; no parents/siblings to try */
4702 if (OpHAS_SIBLING(o)) {
4703 next_kid = o->op_sibparent;
4704 if (!OpHAS_SIBLING(next_kid)) {
4705 /* a few node types don't recurse into their second child */
4706 OP *parent = next_kid->op_sibparent;
4707 I32 ptype = parent->op_type;
4708 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4709 || ( (ptype == OP_AND || ptype == OP_OR)
4710 && (type != OP_LEAVESUBLV
4711 && S_vivifies(next_kid->op_type))
4714 /*try parent's next sibling */
4721 o = o->op_sibparent; /*try parent's next sibling */
4732 S_scalar_mod_type(const OP *o, I32 type)
4737 if (o && o->op_type == OP_RV2GV)
4761 case OP_RIGHT_SHIFT:
4790 S_is_handle_constructor(const OP *o, I32 numargs)
4792 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4794 switch (o->op_type) {
4802 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4815 S_refkids(pTHX_ OP *o, I32 type)
4817 if (o && o->op_flags & OPf_KIDS) {
4819 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4826 /* Apply reference (autovivification) context to the subtree at o.
4828 * push @{expression}, ....;
4829 * o will be the head of 'expression' and type will be OP_RV2AV.
4830 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4832 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4833 * set_op_ref is true.
4835 * Also calls scalar(o).
4839 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4844 PERL_ARGS_ASSERT_DOREF;
4846 if (PL_parser && PL_parser->error_count)
4850 switch (o->op_type) {
4852 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4853 !(o->op_flags & OPf_STACKED)) {
4854 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4855 assert(cUNOPo->op_first->op_type == OP_NULL);
4856 /* disable pushmark */
4857 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4858 o->op_flags |= OPf_SPECIAL;
4860 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4861 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4862 : type == OP_RV2HV ? OPpDEREF_HV
4864 o->op_flags |= OPf_MOD;
4870 o = OpSIBLING(cUNOPo->op_first);
4874 if (type == OP_DEFINED)
4875 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4878 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4879 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4880 : type == OP_RV2HV ? OPpDEREF_HV
4882 o->op_flags |= OPf_MOD;
4884 if (o->op_flags & OPf_KIDS) {
4886 o = cUNOPo->op_first;
4894 o->op_flags |= OPf_REF;
4897 if (type == OP_DEFINED)
4898 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4900 o = cUNOPo->op_first;
4906 o->op_flags |= OPf_REF;
4911 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4913 o = cBINOPo->op_first;
4918 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4919 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4920 : type == OP_RV2HV ? OPpDEREF_HV
4922 o->op_flags |= OPf_MOD;
4925 o = cBINOPo->op_first;
4934 if (!(o->op_flags & OPf_KIDS))
4936 o = cLISTOPo->op_last;
4945 return scalar(top_op); /* at top; no parents/siblings to try */
4946 if (OpHAS_SIBLING(o)) {
4947 o = o->op_sibparent;
4948 /* Normally skip all siblings and go straight to the parent;
4949 * the only op that requires two children to be processed
4950 * is OP_COND_EXPR */
4951 if (!OpHAS_SIBLING(o)
4952 && o->op_sibparent->op_type == OP_COND_EXPR)
4956 o = o->op_sibparent; /*try parent's next sibling */
4963 S_dup_attrlist(pTHX_ OP *o)
4967 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4969 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4970 * where the first kid is OP_PUSHMARK and the remaining ones
4971 * are OP_CONST. We need to push the OP_CONST values.
4973 if (o->op_type == OP_CONST)
4974 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4976 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4978 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4979 if (o->op_type == OP_CONST)
4980 rop = op_append_elem(OP_LIST, rop,
4981 newSVOP(OP_CONST, o->op_flags,
4982 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4989 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4991 PERL_ARGS_ASSERT_APPLY_ATTRS;
4993 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4995 /* fake up C<use attributes $pkg,$rv,@attrs> */
4997 #define ATTRSMODULE "attributes"
4998 #define ATTRSMODULE_PM "attributes.pm"
5001 aTHX_ PERL_LOADMOD_IMPORT_OPS,
5002 newSVpvs(ATTRSMODULE),
5004 op_prepend_elem(OP_LIST,
5005 newSVOP(OP_CONST, 0, stashsv),
5006 op_prepend_elem(OP_LIST,
5007 newSVOP(OP_CONST, 0,
5009 dup_attrlist(attrs))));
5014 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5016 OP *pack, *imop, *arg;
5017 SV *meth, *stashsv, **svp;
5019 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5024 assert(target->op_type == OP_PADSV ||
5025 target->op_type == OP_PADHV ||
5026 target->op_type == OP_PADAV);
5028 /* Ensure that attributes.pm is loaded. */
5029 /* Don't force the C<use> if we don't need it. */
5030 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5031 if (svp && *svp != &PL_sv_undef)
5032 NOOP; /* already in %INC */
5034 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5035 newSVpvs(ATTRSMODULE), NULL);
5037 /* Need package name for method call. */
5038 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5040 /* Build up the real arg-list. */
5041 stashsv = newSVhek(HvNAME_HEK(stash));
5043 arg = newOP(OP_PADSV, 0);
5044 arg->op_targ = target->op_targ;
5045 arg = op_prepend_elem(OP_LIST,
5046 newSVOP(OP_CONST, 0, stashsv),
5047 op_prepend_elem(OP_LIST,
5048 newUNOP(OP_REFGEN, 0,
5050 dup_attrlist(attrs)));
5052 /* Fake up a method call to import */
5053 meth = newSVpvs_share("import");
5054 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5055 op_append_elem(OP_LIST,
5056 op_prepend_elem(OP_LIST, pack, arg),
5057 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5059 /* Combine the ops. */
5060 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5064 =notfor apidoc apply_attrs_string
5066 Attempts to apply a list of attributes specified by the C<attrstr> and
5067 C<len> arguments to the subroutine identified by the C<cv> argument which
5068 is expected to be associated with the package identified by the C<stashpv>
5069 argument (see L<attributes>). It gets this wrong, though, in that it
5070 does not correctly identify the boundaries of the individual attribute
5071 specifications within C<attrstr>. This is not really intended for the
5072 public API, but has to be listed here for systems such as AIX which
5073 need an explicit export list for symbols. (It's called from XS code
5074 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5075 to respect attribute syntax properly would be welcome.
5081 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5082 const char *attrstr, STRLEN len)
5086 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5089 len = strlen(attrstr);
5093 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5095 const char * const sstr = attrstr;
5096 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5097 attrs = op_append_elem(OP_LIST, attrs,
5098 newSVOP(OP_CONST, 0,
5099 newSVpvn(sstr, attrstr-sstr)));
5103 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5104 newSVpvs(ATTRSMODULE),
5105 NULL, op_prepend_elem(OP_LIST,
5106 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5107 op_prepend_elem(OP_LIST,
5108 newSVOP(OP_CONST, 0,
5109 newRV(MUTABLE_SV(cv))),
5114 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5117 OP *new_proto = NULL;
5122 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5128 if (o->op_type == OP_CONST) {
5129 pv = SvPV(cSVOPo_sv, pvlen);
5130 if (memBEGINs(pv, pvlen, "prototype(")) {
5131 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5132 SV ** const tmpo = cSVOPx_svp(o);
5133 SvREFCNT_dec(cSVOPo_sv);
5138 } else if (o->op_type == OP_LIST) {
5140 assert(o->op_flags & OPf_KIDS);
5141 lasto = cLISTOPo->op_first;
5142 assert(lasto->op_type == OP_PUSHMARK);
5143 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5144 if (o->op_type == OP_CONST) {
5145 pv = SvPV(cSVOPo_sv, pvlen);
5146 if (memBEGINs(pv, pvlen, "prototype(")) {
5147 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5148 SV ** const tmpo = cSVOPx_svp(o);
5149 SvREFCNT_dec(cSVOPo_sv);
5151 if (new_proto && ckWARN(WARN_MISC)) {
5153 const char * newp = SvPV(cSVOPo_sv, new_len);
5154 Perl_warner(aTHX_ packWARN(WARN_MISC),
5155 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5156 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5162 /* excise new_proto from the list */
5163 op_sibling_splice(*attrs, lasto, 1, NULL);
5170 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5171 would get pulled in with no real need */
5172 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5181 svname = sv_newmortal();
5182 gv_efullname3(svname, name, NULL);
5184 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5185 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5187 svname = (SV *)name;
5188 if (ckWARN(WARN_ILLEGALPROTO))
5189 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5191 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5192 STRLEN old_len, new_len;
5193 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5194 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5196 if (curstash && svname == (SV *)name
5197 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5198 svname = sv_2mortal(newSVsv(PL_curstname));
5199 sv_catpvs(svname, "::");
5200 sv_catsv(svname, (SV *)name);
5203 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5204 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5206 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5207 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5217 S_cant_declare(pTHX_ OP *o)
5219 if (o->op_type == OP_NULL
5220 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5221 o = cUNOPo->op_first;
5222 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5223 o->op_type == OP_NULL
5224 && o->op_flags & OPf_SPECIAL
5227 PL_parser->in_my == KEY_our ? "our" :
5228 PL_parser->in_my == KEY_state ? "state" :
5233 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5236 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5238 PERL_ARGS_ASSERT_MY_KID;
5240 if (!o || (PL_parser && PL_parser->error_count))
5245 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5247 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5248 my_kid(kid, attrs, imopsp);
5250 } else if (type == OP_UNDEF || type == OP_STUB) {
5252 } else if (type == OP_RV2SV || /* "our" declaration */
5255 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5256 S_cant_declare(aTHX_ o);
5258 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5260 PL_parser->in_my = FALSE;
5261 PL_parser->in_my_stash = NULL;
5262 apply_attrs(GvSTASH(gv),
5263 (type == OP_RV2SV ? GvSVn(gv) :
5264 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5265 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5268 o->op_private |= OPpOUR_INTRO;
5271 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5272 if (!FEATURE_MYREF_IS_ENABLED)
5273 Perl_croak(aTHX_ "The experimental declared_refs "
5274 "feature is not enabled");
5275 Perl_ck_warner_d(aTHX_
5276 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5277 "Declaring references is experimental");
5278 /* Kid is a nulled OP_LIST, handled above. */
5279 my_kid(cUNOPo->op_first, attrs, imopsp);
5282 else if (type != OP_PADSV &&
5285 type != OP_PUSHMARK)
5287 S_cant_declare(aTHX_ o);
5290 else if (attrs && type != OP_PUSHMARK) {
5294 PL_parser->in_my = FALSE;
5295 PL_parser->in_my_stash = NULL;
5297 /* check for C<my Dog $spot> when deciding package */
5298 stash = PAD_COMPNAME_TYPE(o->op_targ);
5300 stash = PL_curstash;
5301 apply_attrs_my(stash, o, attrs, imopsp);
5303 o->op_flags |= OPf_MOD;
5304 o->op_private |= OPpLVAL_INTRO;
5306 o->op_private |= OPpPAD_STATE;
5311 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5314 int maybe_scalar = 0;
5316 PERL_ARGS_ASSERT_MY_ATTRS;
5318 /* [perl #17376]: this appears to be premature, and results in code such as
5319 C< our(%x); > executing in list mode rather than void mode */
5321 if (o->op_flags & OPf_PARENS)
5331 o = my_kid(o, attrs, &rops);
5333 if (maybe_scalar && o->op_type == OP_PADSV) {
5334 o = scalar(op_append_list(OP_LIST, rops, o));
5335 o->op_private |= OPpLVAL_INTRO;
5338 /* The listop in rops might have a pushmark at the beginning,
5339 which will mess up list assignment. */
5340 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5341 if (rops->op_type == OP_LIST &&
5342 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5344 OP * const pushmark = lrops->op_first;
5345 /* excise pushmark */
5346 op_sibling_splice(rops, NULL, 1, NULL);
5349 o = op_append_list(OP_LIST, o, rops);
5352 PL_parser->in_my = FALSE;
5353 PL_parser->in_my_stash = NULL;
5358 Perl_sawparens(pTHX_ OP *o)
5360 PERL_UNUSED_CONTEXT;
5362 o->op_flags |= OPf_PARENS;
5367 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5371 const OPCODE ltype = left->op_type;
5372 const OPCODE rtype = right->op_type;
5374 PERL_ARGS_ASSERT_BIND_MATCH;
5376 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5377 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5379 const char * const desc
5381 rtype == OP_SUBST || rtype == OP_TRANS
5382 || rtype == OP_TRANSR
5384 ? (int)rtype : OP_MATCH];
5385 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5387 S_op_varname(aTHX_ left);
5389 Perl_warner(aTHX_ packWARN(WARN_MISC),
5390 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5391 desc, SVfARG(name), SVfARG(name));
5393 const char * const sample = (isary
5394 ? "@array" : "%hash");
5395 Perl_warner(aTHX_ packWARN(WARN_MISC),
5396 "Applying %s to %s will act on scalar(%s)",
5397 desc, sample, sample);
5401 if (rtype == OP_CONST &&
5402 cSVOPx(right)->op_private & OPpCONST_BARE &&
5403 cSVOPx(right)->op_private & OPpCONST_STRICT)
5405 no_bareword_allowed(right);
5408 /* !~ doesn't make sense with /r, so error on it for now */
5409 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5411 /* diag_listed_as: Using !~ with %s doesn't make sense */
5412 yyerror("Using !~ with s///r doesn't make sense");
5413 if (rtype == OP_TRANSR && type == OP_NOT)
5414 /* diag_listed_as: Using !~ with %s doesn't make sense */
5415 yyerror("Using !~ with tr///r doesn't make sense");
5417 ismatchop = (rtype == OP_MATCH ||
5418 rtype == OP_SUBST ||
5419 rtype == OP_TRANS || rtype == OP_TRANSR)
5420 && !(right->op_flags & OPf_SPECIAL);
5421 if (ismatchop && right->op_private & OPpTARGET_MY) {
5423 right->op_private &= ~OPpTARGET_MY;
5425 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5426 if (left->op_type == OP_PADSV
5427 && !(left->op_private & OPpLVAL_INTRO))
5429 right->op_targ = left->op_targ;
5434 right->op_flags |= OPf_STACKED;
5435 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5436 ! (rtype == OP_TRANS &&
5437 right->op_private & OPpTRANS_IDENTICAL) &&
5438 ! (rtype == OP_SUBST &&
5439 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5440 left = op_lvalue(left, rtype);
5441 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5442 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5444 o = op_prepend_elem(rtype, scalar(left), right);
5447 return newUNOP(OP_NOT, 0, scalar(o));
5451 return bind_match(type, left,
5452 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5456 Perl_invert(pTHX_ OP *o)
5460 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5464 =for apidoc op_scope
5466 Wraps up an op tree with some additional ops so that at runtime a dynamic
5467 scope will be created. The original ops run in the new dynamic scope,
5468 and then, provided that they exit normally, the scope will be unwound.
5469 The additional ops used to create and unwind the dynamic scope will
5470 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5471 instead if the ops are simple enough to not need the full dynamic scope
5478 Perl_op_scope(pTHX_ OP *o)
5482 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5483 o = op_prepend_elem(OP_LINESEQ,
5484 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5485 OpTYPE_set(o, OP_LEAVE);
5487 else if (o->op_type == OP_LINESEQ) {
5489 OpTYPE_set(o, OP_SCOPE);
5490 kid = ((LISTOP*)o)->op_first;
5491 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5494 /* The following deals with things like 'do {1 for 1}' */
5495 kid = OpSIBLING(kid);
5497 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5502 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5508 Perl_op_unscope(pTHX_ OP *o)
5510 if (o && o->op_type == OP_LINESEQ) {
5511 OP *kid = cLISTOPo->op_first;
5512 for(; kid; kid = OpSIBLING(kid))
5513 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5520 =for apidoc block_start
5522 Handles compile-time scope entry.
5523 Arranges for hints to be restored on block
5524 exit and also handles pad sequence numbers to make lexical variables scope
5525 right. Returns a savestack index for use with C<block_end>.
5531 Perl_block_start(pTHX_ int full)
5533 const int retval = PL_savestack_ix;
5535 PL_compiling.cop_seq = PL_cop_seqmax;
5537 pad_block_start(full);
5539 PL_hints &= ~HINT_BLOCK_SCOPE;
5540 SAVECOMPILEWARNINGS();
5541 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5542 SAVEI32(PL_compiling.cop_seq);
5543 PL_compiling.cop_seq = 0;
5545 CALL_BLOCK_HOOKS(bhk_start, full);
5551 =for apidoc block_end
5553 Handles compile-time scope exit. C<floor>
5554 is the savestack index returned by
5555 C<block_start>, and C<seq> is the body of the block. Returns the block,
5562 Perl_block_end(pTHX_ I32 floor, OP *seq)
5564 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5565 OP* retval = scalarseq(seq);
5568 /* XXX Is the null PL_parser check necessary here? */
5569 assert(PL_parser); /* Let’s find out under debugging builds. */
5570 if (PL_parser && PL_parser->parsed_sub) {
5571 o = newSTATEOP(0, NULL, NULL);
5573 retval = op_append_elem(OP_LINESEQ, retval, o);
5576 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5580 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5584 /* pad_leavemy has created a sequence of introcv ops for all my
5585 subs declared in the block. We have to replicate that list with
5586 clonecv ops, to deal with this situation:
5591 sub s1 { state sub foo { \&s2 } }
5594 Originally, I was going to have introcv clone the CV and turn
5595 off the stale flag. Since &s1 is declared before &s2, the
5596 introcv op for &s1 is executed (on sub entry) before the one for
5597 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5598 cloned, since it is a state sub) closes over &s2 and expects
5599 to see it in its outer CV’s pad. If the introcv op clones &s1,
5600 then &s2 is still marked stale. Since &s1 is not active, and
5601 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5602 ble will not stay shared’ warning. Because it is the same stub
5603 that will be used when the introcv op for &s2 is executed, clos-
5604 ing over it is safe. Hence, we have to turn off the stale flag
5605 on all lexical subs in the block before we clone any of them.
5606 Hence, having introcv clone the sub cannot work. So we create a
5607 list of ops like this:
5631 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5632 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5633 for (;; kid = OpSIBLING(kid)) {
5634 OP *newkid = newOP(OP_CLONECV, 0);
5635 newkid->op_targ = kid->op_targ;
5636 o = op_append_elem(OP_LINESEQ, o, newkid);
5637 if (kid == last) break;
5639 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5642 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5648 =head1 Compile-time scope hooks
5650 =for apidoc blockhook_register
5652 Register a set of hooks to be called when the Perl lexical scope changes
5653 at compile time. See L<perlguts/"Compile-time scope hooks">.
5659 Perl_blockhook_register(pTHX_ BHK *hk)
5661 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5663 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5667 Perl_newPROG(pTHX_ OP *o)
5671 PERL_ARGS_ASSERT_NEWPROG;
5678 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5679 ((PL_in_eval & EVAL_KEEPERR)
5680 ? OPf_SPECIAL : 0), o);
5683 assert(CxTYPE(cx) == CXt_EVAL);
5685 if ((cx->blk_gimme & G_WANT) == G_VOID)
5686 scalarvoid(PL_eval_root);
5687 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5690 scalar(PL_eval_root);
5692 start = op_linklist(PL_eval_root);
5693 PL_eval_root->op_next = 0;
5694 i = PL_savestack_ix;
5697 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5699 PL_savestack_ix = i;
5702 if (o->op_type == OP_STUB) {
5703 /* This block is entered if nothing is compiled for the main
5704 program. This will be the case for an genuinely empty main
5705 program, or one which only has BEGIN blocks etc, so already
5708 Historically (5.000) the guard above was !o. However, commit
5709 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5710 c71fccf11fde0068, changed perly.y so that newPROG() is now
5711 called with the output of block_end(), which returns a new
5712 OP_STUB for the case of an empty optree. ByteLoader (and
5713 maybe other things) also take this path, because they set up
5714 PL_main_start and PL_main_root directly, without generating an
5717 If the parsing the main program aborts (due to parse errors,
5718 or due to BEGIN or similar calling exit), then newPROG()
5719 isn't even called, and hence this code path and its cleanups
5720 are skipped. This shouldn't make a make a difference:
5721 * a non-zero return from perl_parse is a failure, and
5722 perl_destruct() should be called immediately.
5723 * however, if exit(0) is called during the parse, then
5724 perl_parse() returns 0, and perl_run() is called. As
5725 PL_main_start will be NULL, perl_run() will return
5726 promptly, and the exit code will remain 0.
5729 PL_comppad_name = 0;
5731 S_op_destroy(aTHX_ o);
5734 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5735 PL_curcop = &PL_compiling;
5736 start = LINKLIST(PL_main_root);
5737 PL_main_root->op_next = 0;
5738 S_process_optree(aTHX_ NULL, PL_main_root, start);
5739 if (!PL_parser->error_count)
5740 /* on error, leave CV slabbed so that ops left lying around
5741 * will eb cleaned up. Else unslab */
5742 cv_forget_slab(PL_compcv);
5745 /* Register with debugger */
5747 CV * const cv = get_cvs("DB::postponed", 0);
5751 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5753 call_sv(MUTABLE_SV(cv), G_DISCARD);
5760 Perl_localize(pTHX_ OP *o, I32 lex)
5762 PERL_ARGS_ASSERT_LOCALIZE;
5764 if (o->op_flags & OPf_PARENS)
5765 /* [perl #17376]: this appears to be premature, and results in code such as
5766 C< our(%x); > executing in list mode rather than void mode */
5773 if ( PL_parser->bufptr > PL_parser->oldbufptr
5774 && PL_parser->bufptr[-1] == ','
5775 && ckWARN(WARN_PARENTHESIS))
5777 char *s = PL_parser->bufptr;
5780 /* some heuristics to detect a potential error */
5781 while (*s && (memCHRs(", \t\n", *s)))
5785 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
5787 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5790 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5792 while (*s && (memCHRs(", \t\n", *s)))
5798 if (sigil && (*s == ';' || *s == '=')) {
5799 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5800 "Parentheses missing around \"%s\" list",
5802 ? (PL_parser->in_my == KEY_our
5804 : PL_parser->in_my == KEY_state
5814 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5815 PL_parser->in_my = FALSE;
5816 PL_parser->in_my_stash = NULL;
5821 Perl_jmaybe(pTHX_ OP *o)
5823 PERL_ARGS_ASSERT_JMAYBE;
5825 if (o->op_type == OP_LIST) {
5827 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5828 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5833 PERL_STATIC_INLINE OP *
5834 S_op_std_init(pTHX_ OP *o)
5836 I32 type = o->op_type;
5838 PERL_ARGS_ASSERT_OP_STD_INIT;
5840 if (PL_opargs[type] & OA_RETSCALAR)
5842 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5843 o->op_targ = pad_alloc(type, SVs_PADTMP);
5848 PERL_STATIC_INLINE OP *
5849 S_op_integerize(pTHX_ OP *o)
5851 I32 type = o->op_type;
5853 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5855 /* integerize op. */
5856 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5859 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5862 if (type == OP_NEGATE)
5863 /* XXX might want a ck_negate() for this */
5864 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5869 /* This function exists solely to provide a scope to limit
5870 setjmp/longjmp() messing with auto variables.
5872 PERL_STATIC_INLINE int
5873 S_fold_constants_eval(pTHX) {
5889 S_fold_constants(pTHX_ OP *const o)
5894 I32 type = o->op_type;
5899 SV * const oldwarnhook = PL_warnhook;
5900 SV * const olddiehook = PL_diehook;
5902 U8 oldwarn = PL_dowarn;
5905 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5907 if (!(PL_opargs[type] & OA_FOLDCONST))
5916 #ifdef USE_LOCALE_CTYPE
5917 if (IN_LC_COMPILETIME(LC_CTYPE))
5926 #ifdef USE_LOCALE_COLLATE
5927 if (IN_LC_COMPILETIME(LC_COLLATE))
5932 /* XXX what about the numeric ops? */
5933 #ifdef USE_LOCALE_NUMERIC
5934 if (IN_LC_COMPILETIME(LC_NUMERIC))
5939 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5940 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5943 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5944 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5946 const char *s = SvPVX_const(sv);
5947 while (s < SvEND(sv)) {
5948 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5955 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5958 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5959 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5963 if (PL_parser && PL_parser->error_count)
5964 goto nope; /* Don't try to run w/ errors */
5966 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5967 switch (curop->op_type) {
5969 if ( (curop->op_private & OPpCONST_BARE)
5970 && (curop->op_private & OPpCONST_STRICT)) {
5971 no_bareword_allowed(curop);
5979 /* Foldable; move to next op in list */
5983 /* No other op types are considered foldable */
5988 curop = LINKLIST(o);
5989 old_next = o->op_next;
5993 old_cxix = cxstack_ix;
5994 create_eval_scope(NULL, G_FAKINGEVAL);
5996 /* Verify that we don't need to save it: */
5997 assert(PL_curcop == &PL_compiling);
5998 StructCopy(&PL_compiling, ¬_compiling, COP);
5999 PL_curcop = ¬_compiling;
6000 /* The above ensures that we run with all the correct hints of the
6001 currently compiling COP, but that IN_PERL_RUNTIME is true. */
6002 assert(IN_PERL_RUNTIME);
6003 PL_warnhook = PERL_WARNHOOK_FATAL;
6006 /* Effective $^W=1. */
6007 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6008 PL_dowarn |= G_WARN_ON;
6010 ret = S_fold_constants_eval(aTHX);
6014 sv = *(PL_stack_sp--);
6015 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6016 pad_swipe(o->op_targ, FALSE);
6018 else if (SvTEMP(sv)) { /* grab mortal temp? */
6019 SvREFCNT_inc_simple_void(sv);
6022 else { assert(SvIMMORTAL(sv)); }
6025 /* Something tried to die. Abandon constant folding. */
6026 /* Pretend the error never happened. */
6028 o->op_next = old_next;
6031 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6032 PL_warnhook = oldwarnhook;
6033 PL_diehook = olddiehook;
6034 /* XXX note that this croak may fail as we've already blown away
6035 * the stack - eg any nested evals */
6036 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6038 PL_dowarn = oldwarn;
6039 PL_warnhook = oldwarnhook;
6040 PL_diehook = olddiehook;
6041 PL_curcop = &PL_compiling;
6043 /* if we croaked, depending on how we croaked the eval scope
6044 * may or may not have already been popped */
6045 if (cxstack_ix > old_cxix) {
6046 assert(cxstack_ix == old_cxix + 1);
6047 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6048 delete_eval_scope();
6053 /* OP_STRINGIFY and constant folding are used to implement qq.
6054 Here the constant folding is an implementation detail that we
6055 want to hide. If the stringify op is itself already marked
6056 folded, however, then it is actually a folded join. */
6057 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6062 else if (!SvIMMORTAL(sv)) {
6066 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6067 if (!is_stringify) newop->op_folded = 1;
6074 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6075 * the constant value being an AV holding the flattened range.
6079 S_gen_constant_list(pTHX_ OP *o)
6082 OP *curop, *old_next;
6083 SV * const oldwarnhook = PL_warnhook;
6084 SV * const olddiehook = PL_diehook;
6086 U8 oldwarn = PL_dowarn;
6096 if (PL_parser && PL_parser->error_count)
6097 return; /* Don't attempt to run with errors */
6099 curop = LINKLIST(o);
6100 old_next = o->op_next;
6102 op_was_null = o->op_type == OP_NULL;
6103 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6104 o->op_type = OP_CUSTOM;
6107 o->op_type = OP_NULL;
6108 S_prune_chain_head(&curop);
6111 old_cxix = cxstack_ix;
6112 create_eval_scope(NULL, G_FAKINGEVAL);
6114 old_curcop = PL_curcop;
6115 StructCopy(old_curcop, ¬_compiling, COP);
6116 PL_curcop = ¬_compiling;
6117 /* The above ensures that we run with all the correct hints of the
6118 current COP, but that IN_PERL_RUNTIME is true. */
6119 assert(IN_PERL_RUNTIME);
6120 PL_warnhook = PERL_WARNHOOK_FATAL;
6124 /* Effective $^W=1. */
6125 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6126 PL_dowarn |= G_WARN_ON;
6130 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6131 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6133 Perl_pp_pushmark(aTHX);
6136 assert (!(curop->op_flags & OPf_SPECIAL));
6137 assert(curop->op_type == OP_RANGE);
6138 Perl_pp_anonlist(aTHX);
6142 o->op_next = old_next;
6146 PL_warnhook = oldwarnhook;
6147 PL_diehook = olddiehook;
6148 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6153 PL_dowarn = oldwarn;
6154 PL_warnhook = oldwarnhook;
6155 PL_diehook = olddiehook;
6156 PL_curcop = old_curcop;
6158 if (cxstack_ix > old_cxix) {
6159 assert(cxstack_ix == old_cxix + 1);
6160 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6161 delete_eval_scope();
6166 OpTYPE_set(o, OP_RV2AV);
6167 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6168 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6169 o->op_opt = 0; /* needs to be revisited in rpeep() */
6170 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6172 /* replace subtree with an OP_CONST */
6173 curop = ((UNOP*)o)->op_first;
6174 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6177 if (AvFILLp(av) != -1)
6178 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6181 SvREADONLY_on(*svp);
6189 =head1 Optree Manipulation Functions
6192 /* List constructors */
6195 =for apidoc op_append_elem
6197 Append an item to the list of ops contained directly within a list-type
6198 op, returning the lengthened list. C<first> is the list-type op,
6199 and C<last> is the op to append to the list. C<optype> specifies the
6200 intended opcode for the list. If C<first> is not already a list of the
6201 right type, it will be upgraded into one. If either C<first> or C<last>
6202 is null, the other is returned unchanged.
6208 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6216 if (first->op_type != (unsigned)type
6217 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6219 return newLISTOP(type, 0, first, last);
6222 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6223 first->op_flags |= OPf_KIDS;
6228 =for apidoc op_append_list
6230 Concatenate the lists of ops contained directly within two list-type ops,
6231 returning the combined list. C<first> and C<last> are the list-type ops
6232 to concatenate. C<optype> specifies the intended opcode for the list.
6233 If either C<first> or C<last> is not already a list of the right type,
6234 it will be upgraded into one. If either C<first> or C<last> is null,
6235 the other is returned unchanged.
6241 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6249 if (first->op_type != (unsigned)type)
6250 return op_prepend_elem(type, first, last);
6252 if (last->op_type != (unsigned)type)
6253 return op_append_elem(type, first, last);
6255 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6256 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6257 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6258 first->op_flags |= (last->op_flags & OPf_KIDS);
6260 S_op_destroy(aTHX_ last);
6266 =for apidoc op_prepend_elem
6268 Prepend an item to the list of ops contained directly within a list-type
6269 op, returning the lengthened list. C<first> is the op to prepend to the
6270 list, and C<last> is the list-type op. C<optype> specifies the intended
6271 opcode for the list. If C<last> is not already a list of the right type,
6272 it will be upgraded into one. If either C<first> or C<last> is null,
6273 the other is returned unchanged.
6279 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6287 if (last->op_type == (unsigned)type) {
6288 if (type == OP_LIST) { /* already a PUSHMARK there */
6289 /* insert 'first' after pushmark */
6290 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6291 if (!(first->op_flags & OPf_PARENS))
6292 last->op_flags &= ~OPf_PARENS;
6295 op_sibling_splice(last, NULL, 0, first);
6296 last->op_flags |= OPf_KIDS;
6300 return newLISTOP(type, 0, first, last);
6304 =for apidoc op_convert_list
6306 Converts C<o> into a list op if it is not one already, and then converts it
6307 into the specified C<type>, calling its check function, allocating a target if
6308 it needs one, and folding constants.
6310 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6311 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6312 C<op_convert_list> to make it the right type.
6318 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6321 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6322 if (!o || o->op_type != OP_LIST)
6323 o = force_list(o, 0);
6326 o->op_flags &= ~OPf_WANT;
6327 o->op_private &= ~OPpLVAL_INTRO;
6330 if (!(PL_opargs[type] & OA_MARK))
6331 op_null(cLISTOPo->op_first);
6333 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6334 if (kid2 && kid2->op_type == OP_COREARGS) {
6335 op_null(cLISTOPo->op_first);
6336 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6340 if (type != OP_SPLIT)
6341 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6342 * ck_split() create a real PMOP and leave the op's type as listop
6343 * for now. Otherwise op_free() etc will crash.
6345 OpTYPE_set(o, type);
6347 o->op_flags |= flags;
6348 if (flags & OPf_FOLDED)
6351 o = CHECKOP(type, o);
6352 if (o->op_type != (unsigned)type)
6355 return fold_constants(op_integerize(op_std_init(o)));
6362 =head1 Optree construction
6364 =for apidoc newNULLLIST
6366 Constructs, checks, and returns a new C<stub> op, which represents an
6367 empty list expression.
6373 Perl_newNULLLIST(pTHX)
6375 return newOP(OP_STUB, 0);
6378 /* promote o and any siblings to be a list if its not already; i.e.
6386 * pushmark - o - A - B
6388 * If nullit it true, the list op is nulled.
6392 S_force_list(pTHX_ OP *o, bool nullit)
6394 if (!o || o->op_type != OP_LIST) {
6397 /* manually detach any siblings then add them back later */
6398 rest = OpSIBLING(o);
6399 OpLASTSIB_set(o, NULL);
6401 o = newLISTOP(OP_LIST, 0, o, NULL);
6403 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6411 =for apidoc newLISTOP
6413 Constructs, checks, and returns an op of any list type. C<type> is
6414 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6415 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6416 supply up to two ops to be direct children of the list op; they are
6417 consumed by this function and become part of the constructed op tree.
6419 For most list operators, the check function expects all the kid ops to be
6420 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6421 appropriate. What you want to do in that case is create an op of type
6422 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6423 See L</op_convert_list> for more information.
6430 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6434 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6435 * pushmark is banned. So do it now while existing ops are in a
6436 * consistent state, in case they suddenly get freed */
6437 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6439 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6440 || type == OP_CUSTOM);
6442 NewOp(1101, listop, 1, LISTOP);
6443 OpTYPE_set(listop, type);
6446 listop->op_flags = (U8)flags;
6450 else if (!first && last)
6453 OpMORESIB_set(first, last);
6454 listop->op_first = first;
6455 listop->op_last = last;
6458 OpMORESIB_set(pushop, first);
6459 listop->op_first = pushop;
6460 listop->op_flags |= OPf_KIDS;
6462 listop->op_last = pushop;
6464 if (listop->op_last)
6465 OpLASTSIB_set(listop->op_last, (OP*)listop);
6467 return CHECKOP(type, listop);
6473 Constructs, checks, and returns an op of any base type (any type that
6474 has no extra fields). C<type> is the opcode. C<flags> gives the
6475 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6482 Perl_newOP(pTHX_ I32 type, I32 flags)
6487 if (type == -OP_ENTEREVAL) {
6488 type = OP_ENTEREVAL;
6489 flags |= OPpEVAL_BYTES<<8;
6492 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6493 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6494 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6495 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6497 NewOp(1101, o, 1, OP);
6498 OpTYPE_set(o, type);
6499 o->op_flags = (U8)flags;
6502 o->op_private = (U8)(0 | (flags >> 8));
6503 if (PL_opargs[type] & OA_RETSCALAR)
6505 if (PL_opargs[type] & OA_TARGET)
6506 o->op_targ = pad_alloc(type, SVs_PADTMP);
6507 return CHECKOP(type, o);
6513 Constructs, checks, and returns an op of any unary type. C<type> is
6514 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6515 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6516 bits, the eight bits of C<op_private>, except that the bit with value 1
6517 is automatically set. C<first> supplies an optional op to be the direct
6518 child of the unary op; it is consumed by this function and become part
6519 of the constructed op tree.
6521 =for apidoc Amnh||OPf_KIDS
6527 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6532 if (type == -OP_ENTEREVAL) {
6533 type = OP_ENTEREVAL;
6534 flags |= OPpEVAL_BYTES<<8;
6537 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6538 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6539 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6540 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6541 || type == OP_SASSIGN
6542 || type == OP_ENTERTRY
6543 || type == OP_CUSTOM
6544 || type == OP_NULL );
6547 first = newOP(OP_STUB, 0);
6548 if (PL_opargs[type] & OA_MARK)
6549 first = force_list(first, 1);
6551 NewOp(1101, unop, 1, UNOP);
6552 OpTYPE_set(unop, type);
6553 unop->op_first = first;
6554 unop->op_flags = (U8)(flags | OPf_KIDS);
6555 unop->op_private = (U8)(1 | (flags >> 8));
6557 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6558 OpLASTSIB_set(first, (OP*)unop);
6560 unop = (UNOP*) CHECKOP(type, unop);
6564 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6568 =for apidoc newUNOP_AUX
6570 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6571 initialised to C<aux>
6577 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6582 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6583 || type == OP_CUSTOM);
6585 NewOp(1101, unop, 1, UNOP_AUX);
6586 unop->op_type = (OPCODE)type;
6587 unop->op_ppaddr = PL_ppaddr[type];
6588 unop->op_first = first;
6589 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6590 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6593 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6594 OpLASTSIB_set(first, (OP*)unop);
6596 unop = (UNOP_AUX*) CHECKOP(type, unop);
6598 return op_std_init((OP *) unop);
6602 =for apidoc newMETHOP
6604 Constructs, checks, and returns an op of method type with a method name
6605 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6606 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6607 and, shifted up eight bits, the eight bits of C<op_private>, except that
6608 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6609 op which evaluates method name; it is consumed by this function and
6610 become part of the constructed op tree.
6611 Supported optypes: C<OP_METHOD>.
6617 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6621 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6622 || type == OP_CUSTOM);
6624 NewOp(1101, methop, 1, METHOP);
6626 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6627 methop->op_flags = (U8)(flags | OPf_KIDS);
6628 methop->op_u.op_first = dynamic_meth;
6629 methop->op_private = (U8)(1 | (flags >> 8));
6631 if (!OpHAS_SIBLING(dynamic_meth))
6632 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6636 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6637 methop->op_u.op_meth_sv = const_meth;
6638 methop->op_private = (U8)(0 | (flags >> 8));
6639 methop->op_next = (OP*)methop;
6643 methop->op_rclass_targ = 0;
6645 methop->op_rclass_sv = NULL;
6648 OpTYPE_set(methop, type);
6649 return CHECKOP(type, methop);
6653 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6654 PERL_ARGS_ASSERT_NEWMETHOP;
6655 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6659 =for apidoc newMETHOP_named
6661 Constructs, checks, and returns an op of method type with a constant
6662 method name. C<type> is the opcode. C<flags> gives the eight bits of
6663 C<op_flags>, and, shifted up eight bits, the eight bits of
6664 C<op_private>. C<const_meth> supplies a constant method name;
6665 it must be a shared COW string.
6666 Supported optypes: C<OP_METHOD_NAMED>.
6672 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6673 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6674 return newMETHOP_internal(type, flags, NULL, const_meth);
6678 =for apidoc newBINOP
6680 Constructs, checks, and returns an op of any binary type. C<type>
6681 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6682 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6683 the eight bits of C<op_private>, except that the bit with value 1 or
6684 2 is automatically set as required. C<first> and C<last> supply up to
6685 two ops to be the direct children of the binary op; they are consumed
6686 by this function and become part of the constructed op tree.
6692 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6697 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6698 || type == OP_NULL || type == OP_CUSTOM);
6700 NewOp(1101, binop, 1, BINOP);
6703 first = newOP(OP_NULL, 0);
6705 OpTYPE_set(binop, type);
6706 binop->op_first = first;
6707 binop->op_flags = (U8)(flags | OPf_KIDS);
6710 binop->op_private = (U8)(1 | (flags >> 8));
6713 binop->op_private = (U8)(2 | (flags >> 8));
6714 OpMORESIB_set(first, last);
6717 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6718 OpLASTSIB_set(last, (OP*)binop);
6720 binop->op_last = OpSIBLING(binop->op_first);
6722 OpLASTSIB_set(binop->op_last, (OP*)binop);
6724 binop = (BINOP*)CHECKOP(type, binop);
6725 if (binop->op_next || binop->op_type != (OPCODE)type)
6728 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6732 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
6734 const char indent[] = " ";
6736 UV len = _invlist_len(invlist);
6737 UV * array = invlist_array(invlist);
6740 PERL_ARGS_ASSERT_INVMAP_DUMP;
6742 for (i = 0; i < len; i++) {
6743 UV start = array[i];
6744 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
6746 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
6747 if (end == IV_MAX) {
6748 PerlIO_printf(Perl_debug_log, " .. INFTY");
6750 else if (end != start) {
6751 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
6754 PerlIO_printf(Perl_debug_log, " ");
6757 PerlIO_printf(Perl_debug_log, "\t");
6759 if (map[i] == TR_UNLISTED) {
6760 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
6762 else if (map[i] == TR_SPECIAL_HANDLING) {
6763 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
6766 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
6771 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6772 * containing the search and replacement strings, assemble into
6773 * a translation table attached as o->op_pv.
6774 * Free expr and repl.
6775 * It expects the toker to have already set the
6776 * OPpTRANS_COMPLEMENT
6779 * flags as appropriate; this function may add
6781 * OPpTRANS_CAN_FORCE_UTF8
6782 * OPpTRANS_IDENTICAL
6788 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6790 /* This function compiles a tr///, from data gathered from toke.c, into a
6791 * form suitable for use by do_trans() in doop.c at runtime.
6793 * It first normalizes the data, while discarding extraneous inputs; then
6794 * writes out the compiled data. The normalization allows for complete
6795 * analysis, and avoids some false negatives and positives earlier versions
6798 * The normalization form is an inversion map (described below in detail).
6799 * This is essentially the compiled form for tr///'s that require UTF-8,
6800 * and its easy to use it to write the 257-byte table for tr///'s that
6801 * don't need UTF-8. That table is identical to what's been in use for
6802 * many perl versions, except that it doesn't handle some edge cases that
6803 * it used to, involving code points above 255. The UTF-8 form now handles
6804 * these. (This could be changed with extra coding should it shown to be
6807 * If the complement (/c) option is specified, the lhs string (tstr) is
6808 * parsed into an inversion list. Complementing these is trivial. Then a
6809 * complemented tstr is built from that, and used thenceforth. This hides
6810 * the fact that it was complemented from almost all successive code.
6812 * One of the important characteristics to know about the input is whether
6813 * the transliteration may be done in place, or does a temporary need to be
6814 * allocated, then copied. If the replacement for every character in every
6815 * possible string takes up no more bytes than the the character it
6816 * replaces, then it can be edited in place. Otherwise the replacement
6817 * could "grow", depending on the strings being processed. Some inputs
6818 * won't grow, and might even shrink under /d, but some inputs could grow,
6819 * so we have to assume any given one might grow. On very long inputs, the
6820 * temporary could eat up a lot of memory, so we want to avoid it if
6821 * possible. For non-UTF-8 inputs, everything is single-byte, so can be
6822 * edited in place, unless there is something in the pattern that could
6823 * force it into UTF-8. The inversion map makes it feasible to determine
6824 * this. Previous versions of this code pretty much punted on determining
6825 * if UTF-8 could be edited in place. Now, this code is rigorous in making
6826 * that determination.
6828 * Another characteristic we need to know is whether the lhs and rhs are
6829 * identical. If so, and no other flags are present, the only effect of
6830 * the tr/// is to count the characters present in the input that are
6831 * mentioned in the lhs string. The implementation of that is easier and
6832 * runs faster than the more general case. Normalizing here allows for
6833 * accurate determination of this. Previously there were false negatives
6836 * Instead of 'transliterated', the comments here use 'unmapped' for the
6837 * characters that are left unchanged by the operation; otherwise they are
6840 * The lhs of the tr/// is here referred to as the t side.
6841 * The rhs of the tr/// is here referred to as the r side.
6844 SV * const tstr = ((SVOP*)expr)->op_sv;
6845 SV * const rstr = ((SVOP*)repl)->op_sv;
6848 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
6849 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
6852 UV t_count = 0, r_count = 0; /* Number of characters in search and
6853 replacement lists */
6855 /* khw thinks some of the private flags for this op are quaintly named.
6856 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
6857 * character when represented in UTF-8 is longer than the original
6858 * character's UTF-8 representation */
6859 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6860 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6861 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6863 /* Set to true if there is some character < 256 in the lhs that maps to >
6864 * 255. If so, a non-UTF-8 match string can be forced into requiring to be
6865 * in UTF-8 by a tr/// operation. */
6866 bool can_force_utf8 = FALSE;
6868 /* What is the maximum expansion factor in UTF-8 transliterations. If a
6869 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
6870 * expansion factor is 1.5. This number is used at runtime to calculate
6871 * how much space to allocate for non-inplace transliterations. Without
6872 * this number, the worst case is 14, which is extremely unlikely to happen
6873 * in real life, and would require significant memory overhead. */
6874 NV max_expansion = 1.;
6876 UV t_range_count, r_range_count, min_range_count;
6881 UV t_cp_end = (UV) -1;
6885 UV final_map = TR_UNLISTED; /* The final character in the replacement
6886 list, updated as we go along. Initialize
6887 to something illegal */
6889 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
6890 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
6892 const U8* tend = t + tlen;
6893 const U8* rend = r + rlen;
6895 SV * inverted_tstr = NULL;
6900 /* This routine implements detection of a transliteration having a longer
6901 * UTF-8 representation than its source, by partitioning all the possible
6902 * code points of the platform into equivalence classes of the same UTF-8
6903 * byte length in the first pass. As it constructs the mappings, it carves
6904 * these up into smaller chunks, but doesn't merge any together. This
6905 * makes it easy to find the instances it's looking for. A second pass is
6906 * done after this has been determined which merges things together to
6907 * shrink the table for runtime. For ASCII platforms, the table is
6908 * trivial, given below, and uses the fundamental characteristics of UTF-8
6909 * to construct the values. For EBCDIC, it isn't so, and we rely on a
6910 * table constructed by the perl script that generates these kinds of
6913 UV PL_partition_by_byte_length[] = {
6916 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))),
6917 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))),
6918 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))),
6919 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))),
6920 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT)))
6924 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT)))
6931 PERL_ARGS_ASSERT_PMTRANS;
6933 PL_hints |= HINT_BLOCK_SCOPE;
6935 /* If /c, the search list is sorted and complemented. This is now done by
6936 * creating an inversion list from it, and then trivially inverting that.
6937 * The previous implementation used qsort, but creating the list
6938 * automatically keeps it sorted as we go along */
6941 SV * inverted_tlist = _new_invlist(tlen);
6944 DEBUG_y(PerlIO_printf(Perl_debug_log,
6945 "%s: %d: tstr before inversion=\n%s\n",
6946 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6950 /* Non-utf8 strings don't have ranges, so each character is listed
6953 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
6956 else { /* But UTF-8 strings have been parsed in toke.c to have
6957 * ranges if appropriate. */
6961 /* Get the first character */
6962 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
6965 /* If the next byte indicates that this wasn't the first
6966 * element of a range, the range is just this one */
6967 if (t >= tend || *t != RANGE_INDICATOR) {
6968 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
6970 else { /* Otherwise, ignore the indicator byte, and get the
6971 final element, and add the whole range */
6973 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
6976 inverted_tlist = _add_range_to_invlist(inverted_tlist,
6980 } /* End of parse through tstr */
6982 /* The inversion list is done; now invert it */
6983 _invlist_invert(inverted_tlist);
6985 /* Now go through the inverted list and create a new tstr for the rest
6986 * of the routine to use. Since the UTF-8 version can have ranges, and
6987 * can be much more compact than the non-UTF-8 version, we create the
6988 * string in UTF-8 even if not necessary. (This is just an intermediate
6989 * value that gets thrown away anyway.) */
6990 invlist_iterinit(inverted_tlist);
6991 inverted_tstr = newSVpvs("");
6992 while (invlist_iternext(inverted_tlist, &start, &end)) {
6993 U8 temp[UTF8_MAXBYTES];
6996 /* IV_MAX keeps things from going out of bounds */
6997 start = MIN(IV_MAX, start);
6998 end = MIN(IV_MAX, end);
7000 temp_end_pos = uvchr_to_utf8(temp, start);
7001 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7004 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
7005 temp_end_pos = uvchr_to_utf8(temp, end);
7006 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
7010 /* Set up so the remainder of the routine uses this complement, instead
7011 * of the actual input */
7012 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
7013 tend = t0 + temp_len;
7016 SvREFCNT_dec_NN(inverted_tlist);
7019 /* For non-/d, an empty rhs means to use the lhs */
7020 if (rlen == 0 && ! del) {
7023 rstr_utf8 = tstr_utf8;
7026 t_invlist = _new_invlist(1);
7028 /* Initialize to a single range */
7029 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7031 /* For the first pass, the lhs is partitioned such that the
7032 * number of UTF-8 bytes required to represent a code point in each
7033 * partition is the same as the number for any other code point in
7034 * that partion. We copy the pre-compiled partion. */
7035 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
7036 invlist_extend(t_invlist, len);
7037 t_array = invlist_array(t_invlist);
7038 Copy(PL_partition_by_byte_length, t_array, len, UV);
7039 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
7040 Newx(r_map, len + 1, UV);
7042 /* Parse the (potentially adjusted) input, creating the inversion map.
7043 * This is done in two passes. The first pass is to determine if the
7044 * transliteration can be done in place. The inversion map it creates
7045 * could be used, but generally would be larger and slower to run than the
7046 * output of the second pass, which starts with a more compact table and
7047 * allows more ranges to be merged */
7048 for (pass2 = 0; pass2 < 2; pass2++) {
7050 /* Initialize to a single range */
7051 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
7053 /* In the second pass, we just have the single range */
7055 t_array = invlist_array(t_invlist);
7058 /* And the mapping of each of the ranges is initialized. Initially,
7059 * everything is TR_UNLISTED. */
7060 for (i = 0; i < len; i++) {
7061 r_map[i] = TR_UNLISTED;
7068 t_range_count = r_range_count = 0;
7070 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
7071 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
7072 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
7073 _byte_dump_string(r, rend - r, 0)));
7074 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
7075 complement, squash, del));
7076 DEBUG_y(invmap_dump(t_invlist, r_map));
7078 /* Now go through the search list constructing an inversion map. The
7079 * input is not necessarily in any particular order. Making it an
7080 * inversion map orders it, potentially simplifying, and makes it easy
7081 * to deal with at run time. This is the only place in core that
7082 * generates an inversion map; if others were introduced, it might be
7083 * better to create general purpose routines to handle them.
7084 * (Inversion maps are created in perl in other places.)
7086 * An inversion map consists of two parallel arrays. One is
7087 * essentially an inversion list: an ordered list of code points such
7088 * that each element gives the first code point of a range of
7089 * consecutive code points that map to the element in the other array
7090 * that has the same index as this one (in other words, the
7091 * corresponding element). Thus the range extends up to (but not
7092 * including) the code point given by the next higher element. In a
7093 * true inversion map, the corresponding element in the other array
7094 * gives the mapping of the first code point in the range, with the
7095 * understanding that the next higher code point in the inversion
7096 * list's range will map to the next higher code point in the map.
7098 * So if at element [i], let's say we have:
7103 * This means that A => a, B => b, C => c.... Let's say that the
7104 * situation is such that:
7108 * This means the sequence that started at [i] stops at K => k. This
7109 * illustrates that you need to look at the next element to find where
7110 * a sequence stops. Except, the highest element in the inversion list
7111 * begins a range that is understood to extend to the platform's
7114 * This routine modifies traditional inversion maps to reserve two
7117 * TR_UNLISTED (or -1) indicates that no code point in the range
7118 * is listed in the tr/// searchlist. At runtime, these are
7119 * always passed through unchanged. In the inversion map, all
7120 * points in the range are mapped to -1, instead of increasing,
7121 * like the 'L' in the example above.
7123 * We start the parse with every code point mapped to this, and as
7124 * we parse and find ones that are listed in the search list, we
7125 * carve out ranges as we go along that override that.
7127 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
7128 * range needs special handling. Again, all code points in the
7129 * range are mapped to -2, instead of increasing.
7131 * Under /d this value means the code point should be deleted from
7132 * the transliteration when encountered.
7134 * Otherwise, it marks that every code point in the range is to
7135 * map to the final character in the replacement list. This
7136 * happens only when the replacement list is shorter than the
7137 * search one, so there are things in the search list that have no
7138 * correspondence in the replacement list. For example, in
7139 * tr/a-z/A/, 'A' is the final value, and the inversion map
7140 * generated for this would be like this:
7145 * 'A' appears once, then the remainder of the range maps to -2.
7146 * The use of -2 isn't strictly necessary, as an inversion map is
7147 * capable of representing this situation, but not nearly so
7148 * compactly, and this is actually quite commonly encountered.
7149 * Indeed, the original design of this code used a full inversion
7150 * map for this. But things like
7152 * generated huge data structures, slowly, and the execution was
7153 * also slow. So the current scheme was implemented.
7155 * So, if the next element in our example is:
7159 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
7163 * [i+4] S TR_UNLISTED
7165 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
7166 * the final element in the arrays, every code point from S to infinity
7167 * maps to TR_UNLISTED.
7170 /* Finish up range started in what otherwise would
7171 * have been the final iteration */
7172 while (t < tend || t_range_count > 0) {
7173 bool adjacent_to_range_above = FALSE;
7174 bool adjacent_to_range_below = FALSE;
7176 bool merge_with_range_above = FALSE;
7177 bool merge_with_range_below = FALSE;
7179 UV span, invmap_range_length_remaining;
7183 /* If we are in the middle of processing a range in the 'target'
7184 * side, the previous iteration has set us up. Otherwise, look at
7185 * the next character in the search list */
7186 if (t_range_count <= 0) {
7189 /* Here, not in the middle of a range, and not UTF-8. The
7190 * next code point is the single byte where we're at */
7198 /* Here, not in the middle of a range, and is UTF-8. The
7199 * next code point is the next UTF-8 char in the input. We
7200 * know the input is valid, because the toker constructed
7202 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
7205 /* UTF-8 strings (only) have been parsed in toke.c to have
7206 * ranges. See if the next byte indicates that this was
7207 * the first element of a range. If so, get the final
7208 * element and calculate the range size. If not, the range
7210 if (t < tend && *t == RANGE_INDICATOR) {
7212 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
7221 /* Count the total number of listed code points * */
7222 t_count += t_range_count;
7225 /* Similarly, get the next character in the replacement list */
7226 if (r_range_count <= 0) {
7229 /* But if we've exhausted the rhs, there is nothing to map
7230 * to, except the special handling one, and we make the
7231 * range the same size as the lhs one. */
7232 r_cp = TR_SPECIAL_HANDLING;
7233 r_range_count = t_range_count;
7236 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7237 "final_map =%" UVXf "\n", final_map));
7249 r_cp = valid_utf8_to_uvchr(r, &r_char_len);
7251 if (r < rend && *r == RANGE_INDICATOR) {
7253 r_range_count = valid_utf8_to_uvchr(r,
7254 &r_char_len) - r_cp + 1;
7262 if (r_cp == TR_SPECIAL_HANDLING) {
7263 r_range_count = t_range_count;
7266 /* This is the final character so far */
7267 final_map = r_cp + r_range_count - 1;
7269 r_count += r_range_count;
7273 /* Here, we have the next things ready in both sides. They are
7274 * potentially ranges. We try to process as big a chunk as
7275 * possible at once, but the lhs and rhs must be synchronized, so
7276 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
7278 min_range_count = MIN(t_range_count, r_range_count);
7280 /* Search the inversion list for the entry that contains the input
7281 * code point <cp>. The inversion map was initialized to cover the
7282 * entire range of possible inputs, so this should not fail. So
7283 * the return value is the index into the list's array of the range
7284 * that contains <cp>, that is, 'i' such that array[i] <= cp <
7286 j = _invlist_search(t_invlist, t_cp);
7290 /* Here, the data structure might look like:
7293 * [i-1] J j # J-L => j-l
7294 * [i] M -1 # M => default; as do N, O, P, Q
7295 * [i+1] R x # R => x, S => x+1, T => x+2
7296 * [i+2] U y # U => y, V => y+1, ...
7298 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7300 * where 'x' and 'y' above are not to be taken literally.
7302 * The maximum chunk we can handle in this loop iteration, is the
7303 * smallest of the three components: the lhs 't_', the rhs 'r_',
7304 * and the remainder of the range in element [i]. (In pass 1, that
7305 * range will have everything in it be of the same class; we can't
7306 * cross into another class.) 'min_range_count' already contains
7307 * the smallest of the first two values. The final one is
7308 * irrelevant if the map is to the special indicator */
7310 invmap_range_length_remaining = (i + 1 < len)
7311 ? t_array[i+1] - t_cp
7313 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
7315 /* The end point of this chunk is where we are, plus the span, but
7316 * never larger than the platform's infinity */
7317 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
7319 if (r_cp == TR_SPECIAL_HANDLING) {
7320 r_cp_end = TR_SPECIAL_HANDLING;
7323 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
7325 /* If something on the lhs is below 256, and something on the
7326 * rhs is above, there is a potential mapping here across that
7327 * boundary. Indeed the only way there isn't is if both sides
7328 * start at the same point. That means they both cross at the
7329 * same time. But otherwise one crosses before the other */
7330 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
7331 can_force_utf8 = TRUE;
7335 /* If a character appears in the search list more than once, the
7336 * 2nd and succeeding occurrences are ignored, so only do this
7337 * range if haven't already processed this character. (The range
7338 * has been set up so that all members in it will be of the same
7340 if (r_map[i] == TR_UNLISTED) {
7341 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7342 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
7343 t_cp, t_cp_end, r_cp, r_cp_end));
7345 /* This is the first definition for this chunk, hence is valid
7346 * and needs to be processed. Here and in the comments below,
7347 * we use the above sample data. The t_cp chunk must be any
7348 * contiguous subset of M, N, O, P, and/or Q.
7350 * In the first pass, the t_invlist has been partitioned so
7351 * that all elements in any single range have the same number
7352 * of bytes in their UTF-8 representations. And the r space is
7353 * either a single byte, or a range of strictly monotonically
7354 * increasing code points. So the final element in the range
7355 * will be represented by no fewer bytes than the initial one.
7356 * That means that if the final code point in the t range has
7357 * at least as many bytes as the final code point in the r,
7358 * then all code points in the t range have at least as many
7359 * bytes as their corresponding r range element. But if that's
7360 * not true, the transliteration of at least the final code
7361 * point grows in length. As an example, suppose we had
7362 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
7363 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
7364 * platforms. We have deliberately set up the data structure
7365 * so that any range in the lhs gets split into chunks for
7366 * processing, such that every code point in a chunk has the
7367 * same number of UTF-8 bytes. We only have to check the final
7368 * code point in the rhs against any code point in the lhs. */
7370 && r_cp_end != TR_SPECIAL_HANDLING
7371 && UVCHR_SKIP(t_cp_end) < UVCHR_SKIP(r_cp_end))
7373 /* Consider tr/\xCB/\X{E000}/. The maximum expansion
7374 * factor is 1 byte going to 3 if the lhs is not UTF-8, but
7375 * 2 bytes going to 3 if it is in UTF-8. We could pass two
7376 * different values so doop could choose based on the
7377 * UTF-8ness of the target. But khw thinks (perhaps
7378 * wrongly) that is overkill. It is used only to make sure
7379 * we malloc enough space. If no target string can force
7380 * the result to be UTF-8, then we don't have to worry
7382 NV t_size = (can_force_utf8 && t_cp < 256)
7384 : UVCHR_SKIP(t_cp_end);
7385 NV ratio = UVCHR_SKIP(r_cp_end) / t_size;
7387 o->op_private |= OPpTRANS_GROWS;
7389 /* Now that we know it grows, we can keep track of the
7391 if (ratio > max_expansion) {
7392 max_expansion = ratio;
7393 DEBUG_y(PerlIO_printf(Perl_debug_log,
7394 "New expansion factor: %" NVgf "\n",
7399 /* The very first range is marked as adjacent to the
7400 * non-existent range below it, as it causes things to "just
7403 * If the lowest code point in this chunk is M, it adjoins the
7405 if (t_cp == t_array[i]) {
7406 adjacent_to_range_below = TRUE;
7408 /* And if the map has the same offset from the beginning of
7409 * the range as does this new code point (or both are for
7410 * TR_SPECIAL_HANDLING), this chunk can be completely
7411 * merged with the range below. EXCEPT, in the first pass,
7412 * we don't merge ranges whose UTF-8 byte representations
7413 * have different lengths, so that we can more easily
7414 * detect if a replacement is longer than the source, that
7415 * is if it 'grows'. But in the 2nd pass, there's no
7416 * reason to not merge */
7417 if ( (i > 0 && ( pass2
7418 || UVCHR_SKIP(t_array[i-1])
7419 == UVCHR_SKIP(t_cp)))
7420 && ( ( r_cp == TR_SPECIAL_HANDLING
7421 && r_map[i-1] == TR_SPECIAL_HANDLING)
7422 || ( r_cp != TR_SPECIAL_HANDLING
7423 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
7425 merge_with_range_below = TRUE;
7429 /* Similarly, if the highest code point in this chunk is 'Q',
7430 * it adjoins the range above, and if the map is suitable, can
7431 * be merged with it */
7432 if ( t_cp_end >= IV_MAX - 1
7434 && t_cp_end + 1 == t_array[i+1]))
7436 adjacent_to_range_above = TRUE;
7439 || UVCHR_SKIP(t_cp) == UVCHR_SKIP(t_array[i+1]))
7440 && ( ( r_cp == TR_SPECIAL_HANDLING
7441 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
7442 || ( r_cp != TR_SPECIAL_HANDLING
7443 && r_cp_end == r_map[i+1] - 1)))
7445 merge_with_range_above = TRUE;
7449 if (merge_with_range_below && merge_with_range_above) {
7451 /* Here the new chunk looks like M => m, ... Q => q; and
7452 * the range above is like R => r, .... Thus, the [i-1]
7453 * and [i+1] ranges should be seamlessly melded so the
7456 * [i-1] J j # J-T => j-t
7457 * [i] U y # U => y, V => y+1, ...
7459 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7461 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
7462 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
7464 invlist_set_len(t_invlist,
7466 *(get_invlist_offset_addr(t_invlist)));
7468 else if (merge_with_range_below) {
7470 /* Here the new chunk looks like M => m, .... But either
7471 * (or both) it doesn't extend all the way up through Q; or
7472 * the range above doesn't start with R => r. */
7473 if (! adjacent_to_range_above) {
7475 /* In the first case, let's say the new chunk extends
7476 * through O. We then want:
7478 * [i-1] J j # J-O => j-o
7479 * [i] P -1 # P => -1, Q => -1
7480 * [i+1] R x # R => x, S => x+1, T => x+2
7481 * [i+2] U y # U => y, V => y+1, ...
7483 * [-1] Z -1 # Z => default; as do Z+1, ...
7486 t_array[i] = t_cp_end + 1;
7487 r_map[i] = TR_UNLISTED;
7489 else { /* Adjoins the range above, but can't merge with it
7490 (because 'x' is not the next map after q) */
7492 * [i-1] J j # J-Q => j-q
7493 * [i] R x # R => x, S => x+1, T => x+2
7494 * [i+1] U y # U => y, V => y+1, ...
7496 * [-1] Z -1 # Z => default; as do Z+1, ...
7500 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7501 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7503 invlist_set_len(t_invlist, len,
7504 *(get_invlist_offset_addr(t_invlist)));
7507 else if (merge_with_range_above) {
7509 /* Here the new chunk ends with Q => q, and the range above
7510 * must start with R => r, so the two can be merged. But
7511 * either (or both) the new chunk doesn't extend all the
7512 * way down to M; or the mapping of the final code point
7513 * range below isn't m */
7514 if (! adjacent_to_range_below) {
7516 /* In the first case, let's assume the new chunk starts
7517 * with P => p. Then, because it's merge-able with the
7518 * range above, that range must be R => r. We want:
7520 * [i-1] J j # J-L => j-l
7521 * [i] M -1 # M => -1, N => -1
7522 * [i+1] P p # P-T => p-t
7523 * [i+2] U y # U => y, V => y+1, ...
7525 * [-1] Z -1 # Z => default; as do Z+1, ...
7528 t_array[i+1] = t_cp;
7531 else { /* Adjoins the range below, but can't merge with it
7534 * [i-1] J j # J-L => j-l
7535 * [i] M x # M-T => x-5 .. x+2
7536 * [i+1] U y # U => y, V => y+1, ...
7538 * [-1] Z -1 # Z => default; as do Z+1, ...
7541 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
7542 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
7546 invlist_set_len(t_invlist, len,
7547 *(get_invlist_offset_addr(t_invlist)));
7550 else if (adjacent_to_range_below && adjacent_to_range_above) {
7551 /* The new chunk completely fills the gap between the
7552 * ranges on either side, but can't merge with either of
7555 * [i-1] J j # J-L => j-l
7556 * [i] M z # M => z, N => z+1 ... Q => z+4
7557 * [i+1] R x # R => x, S => x+1, T => x+2
7558 * [i+2] U y # U => y, V => y+1, ...
7560 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7564 else if (adjacent_to_range_below) {
7565 /* The new chunk adjoins the range below, but not the range
7566 * above, and can't merge. Let's assume the chunk ends at
7569 * [i-1] J j # J-L => j-l
7570 * [i] M z # M => z, N => z+1, O => z+2
7571 * [i+1] P -1 # P => -1, Q => -1
7572 * [i+2] R x # R => x, S => x+1, T => x+2
7573 * [i+3] U y # U => y, V => y+1, ...
7575 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
7577 invlist_extend(t_invlist, len + 1);
7578 t_array = invlist_array(t_invlist);
7579 Renew(r_map, len + 1, UV);
7581 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7582 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7584 t_array[i+1] = t_cp_end + 1;
7585 r_map[i+1] = TR_UNLISTED;
7587 invlist_set_len(t_invlist, len,
7588 *(get_invlist_offset_addr(t_invlist)));
7590 else if (adjacent_to_range_above) {
7591 /* The new chunk adjoins the range above, but not the range
7592 * below, and can't merge. Let's assume the new chunk
7595 * [i-1] J j # J-L => j-l
7596 * [i] M -1 # M => default, N => default
7597 * [i+1] O z # O => z, P => z+1, Q => z+2
7598 * [i+2] R x # R => x, S => x+1, T => x+2
7599 * [i+3] U y # U => y, V => y+1, ...
7601 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7603 invlist_extend(t_invlist, len + 1);
7604 t_array = invlist_array(t_invlist);
7605 Renew(r_map, len + 1, UV);
7607 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
7608 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
7609 t_array[i+1] = t_cp;
7612 invlist_set_len(t_invlist, len,
7613 *(get_invlist_offset_addr(t_invlist)));
7616 /* The new chunk adjoins neither the range above, nor the
7617 * range below. Lets assume it is N..P => n..p
7619 * [i-1] J j # J-L => j-l
7620 * [i] M -1 # M => default
7621 * [i+1] N n # N..P => n..p
7622 * [i+2] Q -1 # Q => default
7623 * [i+3] R x # R => x, S => x+1, T => x+2
7624 * [i+4] U y # U => y, V => y+1, ...
7626 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
7629 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7630 "Before fixing up: len=%d, i=%d\n",
7631 (int) len, (int) i));
7632 DEBUG_yv(invmap_dump(t_invlist, r_map));
7634 invlist_extend(t_invlist, len + 2);
7635 t_array = invlist_array(t_invlist);
7636 Renew(r_map, len + 2, UV);
7638 Move(t_array + i + 1,
7639 t_array + i + 2 + 1, len - i - (2 - 1), UV);
7641 r_map + i + 2 + 1, len - i - (2 - 1), UV);
7644 invlist_set_len(t_invlist, len,
7645 *(get_invlist_offset_addr(t_invlist)));
7647 t_array[i+1] = t_cp;
7650 t_array[i+2] = t_cp_end + 1;
7651 r_map[i+2] = TR_UNLISTED;
7653 DEBUG_yv(PerlIO_printf(Perl_debug_log,
7654 "After iteration: span=%" UVuf ", t_range_count=%"
7655 UVuf " r_range_count=%" UVuf "\n",
7656 span, t_range_count, r_range_count));
7657 DEBUG_yv(invmap_dump(t_invlist, r_map));
7658 } /* End of this chunk needs to be processed */
7660 /* Done with this chunk. */
7662 if (t_cp >= IV_MAX) {
7665 t_range_count -= span;
7666 if (r_cp != TR_SPECIAL_HANDLING) {
7668 r_range_count -= span;
7674 } /* End of loop through the search list */
7676 /* We don't need an exact count, but we do need to know if there is
7677 * anything left over in the replacement list. So, just assume it's
7678 * one byte per character */
7682 } /* End of passes */
7684 SvREFCNT_dec(inverted_tstr);
7686 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
7687 DEBUG_y(invmap_dump(t_invlist, r_map));
7689 /* We now have normalized the input into an inversion map.
7691 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
7692 * except for the count, and streamlined runtime code can be used */
7693 if (!del && !squash) {
7695 /* They are identical if they point to same address, or if everything
7696 * maps to UNLISTED or to itself. This catches things that not looking
7697 * at the normalized inversion map doesn't catch, like tr/aa/ab/ or
7698 * tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
7700 for (i = 0; i < len; i++) {
7701 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
7702 goto done_identical_check;
7707 /* Here have gone through entire list, and didn't find any
7708 * non-identical mappings */
7709 o->op_private |= OPpTRANS_IDENTICAL;
7711 done_identical_check: ;
7714 t_array = invlist_array(t_invlist);
7716 /* If has components above 255, we generally need to use the inversion map
7720 && t_array[len-1] > 255
7721 /* If the final range is 0x100-INFINITY and is a special
7722 * mapping, the table implementation can handle it */
7723 && ! ( t_array[len-1] == 256
7724 && ( r_map[len-1] == TR_UNLISTED
7725 || r_map[len-1] == TR_SPECIAL_HANDLING))))
7729 /* A UTF-8 op is generated, indicated by this flag. This op is an
7731 o->op_private |= OPpTRANS_USE_SVOP;
7733 if (can_force_utf8) {
7734 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
7737 /* The inversion map is pushed; first the list. */
7738 invmap = MUTABLE_AV(newAV());
7739 av_push(invmap, t_invlist);
7741 /* 2nd is the mapping */
7742 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
7743 av_push(invmap, r_map_sv);
7745 /* 3rd is the max possible expansion factor */
7746 av_push(invmap, newSVnv(max_expansion));
7748 /* Characters that are in the search list, but not in the replacement
7749 * list are mapped to the final character in the replacement list */
7750 if (! del && r_count < t_count) {
7751 av_push(invmap, newSVuv(final_map));
7755 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7756 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7757 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
7758 SvPADTMP_on(invmap);
7759 SvREADONLY_on(invmap);
7761 cSVOPo->op_sv = (SV *) invmap;
7769 /* The OPtrans_map struct already contains one slot; hence the -1. */
7770 SSize_t struct_size = sizeof(OPtrans_map)
7771 + (256 - 1 + 1)*sizeof(short);
7773 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7774 * table. Entries with the value TR_UNMAPPED indicate chars not to be
7775 * translated, while TR_DELETE indicates a search char without a
7776 * corresponding replacement char under /d.
7778 * In addition, an extra slot at the end is used to store the final
7779 * repeating char, or TR_R_EMPTY under an empty replacement list, or
7780 * TR_DELETE under /d; which makes the runtime code easier.
7783 /* Indicate this is an op_pv */
7784 o->op_private &= ~OPpTRANS_USE_SVOP;
7786 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7788 cPVOPo->op_pv = (char*)tbl;
7790 for (i = 0; i < len; i++) {
7791 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7792 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7793 short to = (short) r_map[i];
7795 bool do_increment = TRUE;
7797 /* Any code points above our limit should be irrelevant */
7798 if (t_array[i] >= tbl->size) break;
7800 /* Set up the map */
7801 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7802 to = (short) final_map;
7803 do_increment = FALSE;
7806 do_increment = FALSE;
7809 /* Create a map for everything in this range. The value increases
7810 * except for the special cases */
7811 for (j = (short) t_array[i]; j < upper; j++) {
7813 if (do_increment) to++;
7817 tbl->map[tbl->size] = del
7821 : (short) TR_R_EMPTY;
7822 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
7823 for (i = 0; i < tbl->size; i++) {
7824 if (tbl->map[i] < 0) {
7825 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
7826 (unsigned) i, tbl->map[i]));
7829 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
7830 (unsigned) i, tbl->map[i]));
7832 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
7833 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
7836 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
7837 (unsigned) tbl->size, tbl->map[tbl->size]));
7839 SvREFCNT_dec(t_invlist);
7841 #if 0 /* code that added excess above-255 chars at the end of the table, in
7842 case we ever want to not use the inversion map implementation for
7849 /* More replacement chars than search chars:
7850 * store excess replacement chars at end of main table.
7853 struct_size += excess;
7854 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
7855 struct_size + excess * sizeof(short));
7856 tbl->size += excess;
7857 cPVOPo->op_pv = (char*)tbl;
7859 for (i = 0; i < excess; i++)
7860 tbl->map[i + 256] = r[j+i];
7863 /* no more replacement chars than search chars */
7869 DEBUG_y(PerlIO_printf(Perl_debug_log,
7870 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
7871 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
7872 del, squash, complement,
7873 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
7874 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
7875 cBOOL(o->op_private & OPpTRANS_GROWS),
7876 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
7881 if(del && rlen != 0 && r_count == t_count) {
7882 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7883 } else if(r_count > t_count) {
7884 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7897 Constructs, checks, and returns an op of any pattern matching type.
7898 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
7899 and, shifted up eight bits, the eight bits of C<op_private>.
7905 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7910 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7911 || type == OP_CUSTOM);
7913 NewOp(1101, pmop, 1, PMOP);
7914 OpTYPE_set(pmop, type);
7915 pmop->op_flags = (U8)flags;
7916 pmop->op_private = (U8)(0 | (flags >> 8));
7917 if (PL_opargs[type] & OA_RETSCALAR)
7920 if (PL_hints & HINT_RE_TAINT)
7921 pmop->op_pmflags |= PMf_RETAINT;
7922 #ifdef USE_LOCALE_CTYPE
7923 if (IN_LC_COMPILETIME(LC_CTYPE)) {
7924 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7929 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7931 if (PL_hints & HINT_RE_FLAGS) {
7932 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7933 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7935 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7936 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7937 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7939 if (reflags && SvOK(reflags)) {
7940 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7946 assert(SvPOK(PL_regex_pad[0]));
7947 if (SvCUR(PL_regex_pad[0])) {
7948 /* Pop off the "packed" IV from the end. */
7949 SV *const repointer_list = PL_regex_pad[0];
7950 const char *p = SvEND(repointer_list) - sizeof(IV);
7951 const IV offset = *((IV*)p);
7953 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7955 SvEND_set(repointer_list, p);
7957 pmop->op_pmoffset = offset;
7958 /* This slot should be free, so assert this: */
7959 assert(PL_regex_pad[offset] == &PL_sv_undef);
7961 SV * const repointer = &PL_sv_undef;
7962 av_push(PL_regex_padav, repointer);
7963 pmop->op_pmoffset = av_tindex(PL_regex_padav);
7964 PL_regex_pad = AvARRAY(PL_regex_padav);
7968 return CHECKOP(type, pmop);
7976 /* Any pad names in scope are potentially lvalues. */
7977 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7978 PADNAME *pn = PAD_COMPNAME_SV(i);
7979 if (!pn || !PadnameLEN(pn))
7981 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7982 S_mark_padname_lvalue(aTHX_ pn);
7986 /* Given some sort of match op o, and an expression expr containing a
7987 * pattern, either compile expr into a regex and attach it to o (if it's
7988 * constant), or convert expr into a runtime regcomp op sequence (if it's
7991 * Flags currently has 2 bits of meaning:
7992 * 1: isreg indicates that the pattern is part of a regex construct, eg
7993 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7994 * split "pattern", which aren't. In the former case, expr will be a list
7995 * if the pattern contains more than one term (eg /a$b/).
7996 * 2: The pattern is for a split.
7998 * When the pattern has been compiled within a new anon CV (for
7999 * qr/(?{...})/ ), then floor indicates the savestack level just before
8000 * the new sub was created
8002 * tr/// is also handled.
8006 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
8010 I32 repl_has_vars = 0;
8011 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
8012 bool is_compiletime;
8014 bool isreg = cBOOL(flags & 1);
8015 bool is_split = cBOOL(flags & 2);
8017 PERL_ARGS_ASSERT_PMRUNTIME;
8020 return pmtrans(o, expr, repl);
8023 /* find whether we have any runtime or code elements;
8024 * at the same time, temporarily set the op_next of each DO block;
8025 * then when we LINKLIST, this will cause the DO blocks to be excluded
8026 * from the op_next chain (and from having LINKLIST recursively
8027 * applied to them). We fix up the DOs specially later */
8031 if (expr->op_type == OP_LIST) {
8033 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8034 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
8036 assert(!child->op_next);
8037 if (UNLIKELY(!OpHAS_SIBLING(child))) {
8038 assert(PL_parser && PL_parser->error_count);
8039 /* This can happen with qr/ (?{(^{})/. Just fake up
8040 the op we were expecting to see, to avoid crashing
8042 op_sibling_splice(expr, child, 0,
8043 newSVOP(OP_CONST, 0, &PL_sv_no));
8045 child->op_next = OpSIBLING(child);
8047 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
8051 else if (expr->op_type != OP_CONST)
8056 /* fix up DO blocks; treat each one as a separate little sub;
8057 * also, mark any arrays as LIST/REF */
8059 if (expr->op_type == OP_LIST) {
8061 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
8063 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
8064 assert( !(child->op_flags & OPf_WANT));
8065 /* push the array rather than its contents. The regex
8066 * engine will retrieve and join the elements later */
8067 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
8071 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
8073 child->op_next = NULL; /* undo temporary hack from above */
8076 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
8077 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
8079 assert(leaveop->op_first->op_type == OP_ENTER);
8080 assert(OpHAS_SIBLING(leaveop->op_first));
8081 child->op_next = OpSIBLING(leaveop->op_first);
8083 assert(leaveop->op_flags & OPf_KIDS);
8084 assert(leaveop->op_last->op_next == (OP*)leaveop);
8085 leaveop->op_next = NULL; /* stop on last op */
8086 op_null((OP*)leaveop);
8090 OP *scope = cLISTOPx(child)->op_first;
8091 assert(scope->op_type == OP_SCOPE);
8092 assert(scope->op_flags & OPf_KIDS);
8093 scope->op_next = NULL; /* stop on last op */
8097 /* XXX optimize_optree() must be called on o before
8098 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
8099 * currently cope with a peephole-optimised optree.
8100 * Calling optimize_optree() here ensures that condition
8101 * is met, but may mean optimize_optree() is applied
8102 * to the same optree later (where hopefully it won't do any
8103 * harm as it can't convert an op to multiconcat if it's
8104 * already been converted */
8105 optimize_optree(child);
8107 /* have to peep the DOs individually as we've removed it from
8108 * the op_next chain */
8110 S_prune_chain_head(&(child->op_next));
8112 /* runtime finalizes as part of finalizing whole tree */
8113 finalize_optree(child);
8116 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
8117 assert( !(expr->op_flags & OPf_WANT));
8118 /* push the array rather than its contents. The regex
8119 * engine will retrieve and join the elements later */
8120 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
8123 PL_hints |= HINT_BLOCK_SCOPE;
8125 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
8127 if (is_compiletime) {
8128 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
8129 regexp_engine const *eng = current_re_engine();
8132 /* make engine handle split ' ' specially */
8133 pm->op_pmflags |= PMf_SPLIT;
8134 rx_flags |= RXf_SPLIT;
8137 if (!has_code || !eng->op_comp) {
8138 /* compile-time simple constant pattern */
8140 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
8141 /* whoops! we guessed that a qr// had a code block, but we
8142 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
8143 * that isn't required now. Note that we have to be pretty
8144 * confident that nothing used that CV's pad while the
8145 * regex was parsed, except maybe op targets for \Q etc.
8146 * If there were any op targets, though, they should have
8147 * been stolen by constant folding.
8151 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
8152 while (++i <= AvFILLp(PL_comppad)) {
8153 # ifdef USE_PAD_RESET
8154 /* under USE_PAD_RESET, pad swipe replaces a swiped
8155 * folded constant with a fresh padtmp */
8156 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
8158 assert(!PL_curpad[i]);
8162 /* This LEAVE_SCOPE will restore PL_compcv to point to the
8163 * outer CV (the one whose slab holds the pm op). The
8164 * inner CV (which holds expr) will be freed later, once
8165 * all the entries on the parse stack have been popped on
8166 * return from this function. Which is why its safe to
8167 * call op_free(expr) below.
8170 pm->op_pmflags &= ~PMf_HAS_CV;
8173 /* Skip compiling if parser found an error for this pattern */
8174 if (pm->op_pmflags & PMf_HAS_ERROR) {
8180 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8181 rx_flags, pm->op_pmflags)
8182 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8183 rx_flags, pm->op_pmflags)
8188 /* compile-time pattern that includes literal code blocks */
8192 /* Skip compiling if parser found an error for this pattern */
8193 if (pm->op_pmflags & PMf_HAS_ERROR) {
8197 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
8200 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
8203 if (pm->op_pmflags & PMf_HAS_CV) {
8205 /* this QR op (and the anon sub we embed it in) is never
8206 * actually executed. It's just a placeholder where we can
8207 * squirrel away expr in op_code_list without the peephole
8208 * optimiser etc processing it for a second time */
8209 OP *qr = newPMOP(OP_QR, 0);
8210 ((PMOP*)qr)->op_code_list = expr;
8212 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
8213 SvREFCNT_inc_simple_void(PL_compcv);
8214 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
8215 ReANY(re)->qr_anoncv = cv;
8217 /* attach the anon CV to the pad so that
8218 * pad_fixup_inner_anons() can find it */
8219 (void)pad_add_anon(cv, o->op_type);
8220 SvREFCNT_inc_simple_void(cv);
8223 pm->op_code_list = expr;
8228 /* runtime pattern: build chain of regcomp etc ops */
8230 PADOFFSET cv_targ = 0;
8232 reglist = isreg && expr->op_type == OP_LIST;
8237 pm->op_code_list = expr;
8238 /* don't free op_code_list; its ops are embedded elsewhere too */
8239 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
8243 /* make engine handle split ' ' specially */
8244 pm->op_pmflags |= PMf_SPLIT;
8246 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
8247 * to allow its op_next to be pointed past the regcomp and
8248 * preceding stacking ops;
8249 * OP_REGCRESET is there to reset taint before executing the
8251 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
8252 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
8254 if (pm->op_pmflags & PMf_HAS_CV) {
8255 /* we have a runtime qr with literal code. This means
8256 * that the qr// has been wrapped in a new CV, which
8257 * means that runtime consts, vars etc will have been compiled
8258 * against a new pad. So... we need to execute those ops
8259 * within the environment of the new CV. So wrap them in a call
8260 * to a new anon sub. i.e. for
8264 * we build an anon sub that looks like
8266 * sub { "a", $b, '(?{...})' }
8268 * and call it, passing the returned list to regcomp.
8269 * Or to put it another way, the list of ops that get executed
8273 * ------ -------------------
8274 * pushmark (for regcomp)
8275 * pushmark (for entersub)
8279 * regcreset regcreset
8281 * const("a") const("a")
8283 * const("(?{...})") const("(?{...})")
8288 SvREFCNT_inc_simple_void(PL_compcv);
8289 CvLVALUE_on(PL_compcv);
8290 /* these lines are just an unrolled newANONATTRSUB */
8291 expr = newSVOP(OP_ANONCODE, 0,
8292 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
8293 cv_targ = expr->op_targ;
8294 expr = newUNOP(OP_REFGEN, 0, expr);
8296 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
8299 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
8300 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
8301 | (reglist ? OPf_STACKED : 0);
8302 rcop->op_targ = cv_targ;
8304 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
8305 if (PL_hints & HINT_RE_EVAL)
8306 S_set_haseval(aTHX);
8308 /* establish postfix order */
8309 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
8311 rcop->op_next = expr;
8312 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
8315 rcop->op_next = LINKLIST(expr);
8316 expr->op_next = (OP*)rcop;
8319 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
8325 /* If we are looking at s//.../e with a single statement, get past
8326 the implicit do{}. */
8327 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
8328 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
8329 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
8332 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
8333 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
8334 && !OpHAS_SIBLING(sib))
8337 if (curop->op_type == OP_CONST)
8339 else if (( (curop->op_type == OP_RV2SV ||
8340 curop->op_type == OP_RV2AV ||
8341 curop->op_type == OP_RV2HV ||
8342 curop->op_type == OP_RV2GV)
8343 && cUNOPx(curop)->op_first
8344 && cUNOPx(curop)->op_first->op_type == OP_GV )
8345 || curop->op_type == OP_PADSV
8346 || curop->op_type == OP_PADAV
8347 || curop->op_type == OP_PADHV
8348 || curop->op_type == OP_PADANY) {
8356 || !RX_PRELEN(PM_GETRE(pm))
8357 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
8359 pm->op_pmflags |= PMf_CONST; /* const for long enough */
8360 op_prepend_elem(o->op_type, scalar(repl), o);
8363 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
8364 rcop->op_private = 1;
8366 /* establish postfix order */
8367 rcop->op_next = LINKLIST(repl);
8368 repl->op_next = (OP*)rcop;
8370 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
8371 assert(!(pm->op_pmflags & PMf_ONCE));
8372 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
8383 Constructs, checks, and returns an op of any type that involves an
8384 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
8385 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
8386 takes ownership of one reference to it.
8392 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
8397 PERL_ARGS_ASSERT_NEWSVOP;
8399 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8400 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8401 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8402 || type == OP_CUSTOM);
8404 NewOp(1101, svop, 1, SVOP);
8405 OpTYPE_set(svop, type);
8407 svop->op_next = (OP*)svop;
8408 svop->op_flags = (U8)flags;
8409 svop->op_private = (U8)(0 | (flags >> 8));
8410 if (PL_opargs[type] & OA_RETSCALAR)
8412 if (PL_opargs[type] & OA_TARGET)
8413 svop->op_targ = pad_alloc(type, SVs_PADTMP);
8414 return CHECKOP(type, svop);
8418 =for apidoc newDEFSVOP
8420 Constructs and returns an op to access C<$_>.
8426 Perl_newDEFSVOP(pTHX)
8428 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
8434 =for apidoc newPADOP
8436 Constructs, checks, and returns an op of any type that involves a
8437 reference to a pad element. C<type> is the opcode. C<flags> gives the
8438 eight bits of C<op_flags>. A pad slot is automatically allocated, and
8439 is populated with C<sv>; this function takes ownership of one reference
8442 This function only exists if Perl has been compiled to use ithreads.
8448 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
8453 PERL_ARGS_ASSERT_NEWPADOP;
8455 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
8456 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8457 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
8458 || type == OP_CUSTOM);
8460 NewOp(1101, padop, 1, PADOP);
8461 OpTYPE_set(padop, type);
8463 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
8464 SvREFCNT_dec(PAD_SVl(padop->op_padix));
8465 PAD_SETSV(padop->op_padix, sv);
8467 padop->op_next = (OP*)padop;
8468 padop->op_flags = (U8)flags;
8469 if (PL_opargs[type] & OA_RETSCALAR)
8471 if (PL_opargs[type] & OA_TARGET)
8472 padop->op_targ = pad_alloc(type, SVs_PADTMP);
8473 return CHECKOP(type, padop);
8476 #endif /* USE_ITHREADS */
8481 Constructs, checks, and returns an op of any type that involves an
8482 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
8483 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
8484 reference; calling this function does not transfer ownership of any
8491 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
8493 PERL_ARGS_ASSERT_NEWGVOP;
8496 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8498 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
8505 Constructs, checks, and returns an op of any type that involves an
8506 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
8507 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
8508 Depending on the op type, the memory referenced by C<pv> may be freed
8509 when the op is destroyed. If the op is of a freeing type, C<pv> must
8510 have been allocated using C<PerlMemShared_malloc>.
8516 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
8519 const bool utf8 = cBOOL(flags & SVf_UTF8);
8524 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
8525 || type == OP_RUNCV || type == OP_CUSTOM
8526 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
8528 NewOp(1101, pvop, 1, PVOP);
8529 OpTYPE_set(pvop, type);
8531 pvop->op_next = (OP*)pvop;
8532 pvop->op_flags = (U8)flags;
8533 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
8534 if (PL_opargs[type] & OA_RETSCALAR)
8536 if (PL_opargs[type] & OA_TARGET)
8537 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
8538 return CHECKOP(type, pvop);
8542 Perl_package(pTHX_ OP *o)
8544 SV *const sv = cSVOPo->op_sv;
8546 PERL_ARGS_ASSERT_PACKAGE;
8548 SAVEGENERICSV(PL_curstash);
8549 save_item(PL_curstname);
8551 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
8553 sv_setsv(PL_curstname, sv);
8555 PL_hints |= HINT_BLOCK_SCOPE;
8556 PL_parser->copline = NOLINE;
8562 Perl_package_version( pTHX_ OP *v )
8564 U32 savehints = PL_hints;
8565 PERL_ARGS_ASSERT_PACKAGE_VERSION;
8566 PL_hints &= ~HINT_STRICT_VARS;
8567 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
8568 PL_hints = savehints;
8573 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
8578 SV *use_version = NULL;
8580 PERL_ARGS_ASSERT_UTILIZE;
8582 if (idop->op_type != OP_CONST)
8583 Perl_croak(aTHX_ "Module name must be constant");
8588 SV * const vesv = ((SVOP*)version)->op_sv;
8590 if (!arg && !SvNIOKp(vesv)) {
8597 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
8598 Perl_croak(aTHX_ "Version number must be a constant number");
8600 /* Make copy of idop so we don't free it twice */
8601 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8603 /* Fake up a method call to VERSION */
8604 meth = newSVpvs_share("VERSION");
8605 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8606 op_append_elem(OP_LIST,
8607 op_prepend_elem(OP_LIST, pack, version),
8608 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
8612 /* Fake up an import/unimport */
8613 if (arg && arg->op_type == OP_STUB) {
8614 imop = arg; /* no import on explicit () */
8616 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
8617 imop = NULL; /* use 5.0; */
8619 use_version = ((SVOP*)idop)->op_sv;
8621 idop->op_private |= OPpCONST_NOVER;
8626 /* Make copy of idop so we don't free it twice */
8627 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
8629 /* Fake up a method call to import/unimport */
8631 ? newSVpvs_share("import") : newSVpvs_share("unimport");
8632 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
8633 op_append_elem(OP_LIST,
8634 op_prepend_elem(OP_LIST, pack, arg),
8635 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
8639 /* Fake up the BEGIN {}, which does its thing immediately. */
8641 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
8644 op_append_elem(OP_LINESEQ,
8645 op_append_elem(OP_LINESEQ,
8646 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
8647 newSTATEOP(0, NULL, veop)),
8648 newSTATEOP(0, NULL, imop) ));
8652 * feature bundle that corresponds to the required version. */
8653 use_version = sv_2mortal(new_version(use_version));
8654 S_enable_feature_bundle(aTHX_ use_version);
8656 /* If a version >= 5.11.0 is requested, strictures are on by default! */
8657 if (vcmp(use_version,
8658 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
8659 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8660 PL_hints |= HINT_STRICT_REFS;
8661 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8662 PL_hints |= HINT_STRICT_SUBS;
8663 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8664 PL_hints |= HINT_STRICT_VARS;
8666 /* otherwise they are off */
8668 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
8669 PL_hints &= ~HINT_STRICT_REFS;
8670 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
8671 PL_hints &= ~HINT_STRICT_SUBS;
8672 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
8673 PL_hints &= ~HINT_STRICT_VARS;
8677 /* The "did you use incorrect case?" warning used to be here.
8678 * The problem is that on case-insensitive filesystems one
8679 * might get false positives for "use" (and "require"):
8680 * "use Strict" or "require CARP" will work. This causes
8681 * portability problems for the script: in case-strict
8682 * filesystems the script will stop working.
8684 * The "incorrect case" warning checked whether "use Foo"
8685 * imported "Foo" to your namespace, but that is wrong, too:
8686 * there is no requirement nor promise in the language that
8687 * a Foo.pm should or would contain anything in package "Foo".
8689 * There is very little Configure-wise that can be done, either:
8690 * the case-sensitivity of the build filesystem of Perl does not
8691 * help in guessing the case-sensitivity of the runtime environment.
8694 PL_hints |= HINT_BLOCK_SCOPE;
8695 PL_parser->copline = NOLINE;
8696 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
8700 =head1 Embedding Functions
8702 =for apidoc load_module
8704 Loads the module whose name is pointed to by the string part of C<name>.
8705 Note that the actual module name, not its filename, should be given.
8706 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
8707 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
8708 trailing arguments can be used to specify arguments to the module's C<import()>
8709 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
8710 on the flags. The flags argument is a bitwise-ORed collection of any of
8711 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
8712 (or 0 for no flags).
8714 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
8715 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
8716 the trailing optional arguments may be omitted entirely. Otherwise, if
8717 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
8718 exactly one C<OP*>, containing the op tree that produces the relevant import
8719 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
8720 will be used as import arguments; and the list must be terminated with C<(SV*)
8721 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
8722 set, the trailing C<NULL> pointer is needed even if no import arguments are
8723 desired. The reference count for each specified C<SV*> argument is
8724 decremented. In addition, the C<name> argument is modified.
8726 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
8729 =for apidoc Amnh||PERL_LOADMOD_DENY
8730 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
8731 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
8736 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8740 PERL_ARGS_ASSERT_LOAD_MODULE;
8742 va_start(args, ver);
8743 vload_module(flags, name, ver, &args);
8747 #ifdef PERL_IMPLICIT_CONTEXT
8749 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8753 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8754 va_start(args, ver);
8755 vload_module(flags, name, ver, &args);
8761 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8767 PERL_ARGS_ASSERT_VLOAD_MODULE;
8769 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8770 * that it has a PL_parser to play with while doing that, and also
8771 * that it doesn't mess with any existing parser, by creating a tmp
8772 * new parser with lex_start(). This won't actually be used for much,
8773 * since pp_require() will create another parser for the real work.
8774 * The ENTER/LEAVE pair protect callers from any side effects of use.
8776 * start_subparse() creates a new PL_compcv. This means that any ops
8777 * allocated below will be allocated from that CV's op slab, and so
8778 * will be automatically freed if the utilise() fails
8782 SAVEVPTR(PL_curcop);
8783 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8784 floor = start_subparse(FALSE, 0);
8786 modname = newSVOP(OP_CONST, 0, name);
8787 modname->op_private |= OPpCONST_BARE;
8789 veop = newSVOP(OP_CONST, 0, ver);
8793 if (flags & PERL_LOADMOD_NOIMPORT) {
8794 imop = sawparens(newNULLLIST());
8796 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8797 imop = va_arg(*args, OP*);
8802 sv = va_arg(*args, SV*);
8804 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8805 sv = va_arg(*args, SV*);
8809 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8813 PERL_STATIC_INLINE OP *
8814 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8816 return newUNOP(OP_ENTERSUB, OPf_STACKED,
8817 newLISTOP(OP_LIST, 0, arg,
8818 newUNOP(OP_RV2CV, 0,
8819 newGVOP(OP_GV, 0, gv))));
8823 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8828 PERL_ARGS_ASSERT_DOFILE;
8830 if (!force_builtin && (gv = gv_override("do", 2))) {
8831 doop = S_new_entersubop(aTHX_ gv, term);
8834 doop = newUNOP(OP_DOFILE, 0, scalar(term));
8840 =head1 Optree construction
8842 =for apidoc newSLICEOP
8844 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
8845 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8846 be set automatically, and, shifted up eight bits, the eight bits of
8847 C<op_private>, except that the bit with value 1 or 2 is automatically
8848 set as required. C<listval> and C<subscript> supply the parameters of
8849 the slice; they are consumed by this function and become part of the
8850 constructed op tree.
8856 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8858 return newBINOP(OP_LSLICE, flags,
8859 list(force_list(subscript, 1)),
8860 list(force_list(listval, 1)) );
8863 #define ASSIGN_SCALAR 0
8864 #define ASSIGN_LIST 1
8865 #define ASSIGN_REF 2
8867 /* given the optree o on the LHS of an assignment, determine whether its:
8868 * ASSIGN_SCALAR $x = ...
8869 * ASSIGN_LIST ($x) = ...
8870 * ASSIGN_REF \$x = ...
8874 S_assignment_type(pTHX_ const OP *o)
8883 if (o->op_type == OP_SREFGEN)
8885 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8886 type = kid->op_type;
8887 flags = o->op_flags | kid->op_flags;
8888 if (!(flags & OPf_PARENS)
8889 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8890 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8894 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8895 o = cUNOPo->op_first;
8896 flags = o->op_flags;
8898 ret = ASSIGN_SCALAR;
8901 if (type == OP_COND_EXPR) {
8902 OP * const sib = OpSIBLING(cLOGOPo->op_first);
8903 const I32 t = assignment_type(sib);
8904 const I32 f = assignment_type(OpSIBLING(sib));
8906 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8908 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8909 yyerror("Assignment to both a list and a scalar");
8910 return ASSIGN_SCALAR;
8913 if (type == OP_LIST &&
8914 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8915 o->op_private & OPpLVAL_INTRO)
8918 if (type == OP_LIST || flags & OPf_PARENS ||
8919 type == OP_RV2AV || type == OP_RV2HV ||
8920 type == OP_ASLICE || type == OP_HSLICE ||
8921 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8924 if (type == OP_PADAV || type == OP_PADHV)
8927 if (type == OP_RV2SV)
8934 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8937 const PADOFFSET target = padop->op_targ;
8938 OP *const other = newOP(OP_PADSV,
8940 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8941 OP *const first = newOP(OP_NULL, 0);
8942 OP *const nullop = newCONDOP(0, first, initop, other);
8943 /* XXX targlex disabled for now; see ticket #124160
8944 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8946 OP *const condop = first->op_next;
8948 OpTYPE_set(condop, OP_ONCE);
8949 other->op_targ = target;
8950 nullop->op_flags |= OPf_WANT_SCALAR;
8952 /* Store the initializedness of state vars in a separate
8955 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8956 /* hijacking PADSTALE for uninitialized state variables */
8957 SvPADSTALE_on(PAD_SVl(condop->op_targ));
8963 =for apidoc newASSIGNOP
8965 Constructs, checks, and returns an assignment op. C<left> and C<right>
8966 supply the parameters of the assignment; they are consumed by this
8967 function and become part of the constructed op tree.
8969 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8970 a suitable conditional optree is constructed. If C<optype> is the opcode
8971 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8972 performs the binary operation and assigns the result to the left argument.
8973 Either way, if C<optype> is non-zero then C<flags> has no effect.
8975 If C<optype> is zero, then a plain scalar or list assignment is
8976 constructed. Which type of assignment it is is automatically determined.
8977 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8978 will be set automatically, and, shifted up eight bits, the eight bits
8979 of C<op_private>, except that the bit with value 1 or 2 is automatically
8986 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8992 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
8993 right = scalar(right);
8994 return newLOGOP(optype, 0,
8995 op_lvalue(scalar(left), optype),
8996 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8999 return newBINOP(optype, OPf_STACKED,
9000 op_lvalue(scalar(left), optype), scalar(right));
9004 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
9005 OP *state_var_op = NULL;
9006 static const char no_list_state[] = "Initialization of state variables"
9007 " in list currently forbidden";
9010 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
9011 left->op_private &= ~ OPpSLICEWARNING;
9014 left = op_lvalue(left, OP_AASSIGN);
9015 curop = list(force_list(left, 1));
9016 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
9017 o->op_private = (U8)(0 | (flags >> 8));
9019 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
9021 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
9022 if (!(left->op_flags & OPf_PARENS) &&
9023 lop->op_type == OP_PUSHMARK &&
9024 (vop = OpSIBLING(lop)) &&
9025 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
9026 !(vop->op_flags & OPf_PARENS) &&
9027 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
9028 (OPpLVAL_INTRO|OPpPAD_STATE) &&
9029 (eop = OpSIBLING(vop)) &&
9030 eop->op_type == OP_ENTERSUB &&
9031 !OpHAS_SIBLING(eop)) {
9035 if ((lop->op_type == OP_PADSV ||
9036 lop->op_type == OP_PADAV ||
9037 lop->op_type == OP_PADHV ||
9038 lop->op_type == OP_PADANY)
9039 && (lop->op_private & OPpPAD_STATE)
9041 yyerror(no_list_state);
9042 lop = OpSIBLING(lop);
9046 else if ( (left->op_private & OPpLVAL_INTRO)
9047 && (left->op_private & OPpPAD_STATE)
9048 && ( left->op_type == OP_PADSV
9049 || left->op_type == OP_PADAV
9050 || left->op_type == OP_PADHV
9051 || left->op_type == OP_PADANY)
9053 /* All single variable list context state assignments, hence
9063 if (left->op_flags & OPf_PARENS)
9064 yyerror(no_list_state);
9066 state_var_op = left;
9069 /* optimise @a = split(...) into:
9070 * @{expr}: split(..., @{expr}) (where @a is not flattened)
9071 * @a, my @a, local @a: split(...) (where @a is attached to
9072 * the split op itself)
9076 && right->op_type == OP_SPLIT
9077 /* don't do twice, e.g. @b = (@a = split) */
9078 && !(right->op_private & OPpSPLIT_ASSIGN))
9082 if ( ( left->op_type == OP_RV2AV
9083 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
9084 || left->op_type == OP_PADAV)
9086 /* @pkg or @lex or local @pkg' or 'my @lex' */
9090 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
9091 = cPADOPx(gvop)->op_padix;
9092 cPADOPx(gvop)->op_padix = 0; /* steal it */
9094 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
9095 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
9096 cSVOPx(gvop)->op_sv = NULL; /* steal it */
9098 right->op_private |=
9099 left->op_private & OPpOUR_INTRO;
9102 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
9103 left->op_targ = 0; /* steal it */
9104 right->op_private |= OPpSPLIT_LEX;
9106 right->op_private |= left->op_private & OPpLVAL_INTRO;
9109 tmpop = cUNOPo->op_first; /* to list (nulled) */
9110 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
9111 assert(OpSIBLING(tmpop) == right);
9112 assert(!OpHAS_SIBLING(right));
9113 /* detach the split subtreee from the o tree,
9114 * then free the residual o tree */
9115 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
9116 op_free(o); /* blow off assign */
9117 right->op_private |= OPpSPLIT_ASSIGN;
9118 right->op_flags &= ~OPf_WANT;
9119 /* "I don't know and I don't care." */
9122 else if (left->op_type == OP_RV2AV) {
9125 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
9126 assert(OpSIBLING(pushop) == left);
9127 /* Detach the array ... */
9128 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
9129 /* ... and attach it to the split. */
9130 op_sibling_splice(right, cLISTOPx(right)->op_last,
9132 right->op_flags |= OPf_STACKED;
9133 /* Detach split and expunge aassign as above. */
9136 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
9137 ((LISTOP*)right)->op_last->op_type == OP_CONST)
9139 /* convert split(...,0) to split(..., PL_modcount+1) */
9141 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
9142 SV * const sv = *svp;
9143 if (SvIOK(sv) && SvIVX(sv) == 0)
9145 if (right->op_private & OPpSPLIT_IMPLIM) {
9146 /* our own SV, created in ck_split */
9148 sv_setiv(sv, PL_modcount+1);
9151 /* SV may belong to someone else */
9153 *svp = newSViv(PL_modcount+1);
9160 o = S_newONCEOP(aTHX_ o, state_var_op);
9163 if (assign_type == ASSIGN_REF)
9164 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
9166 right = newOP(OP_UNDEF, 0);
9167 if (right->op_type == OP_READLINE) {
9168 right->op_flags |= OPf_STACKED;
9169 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
9173 o = newBINOP(OP_SASSIGN, flags,
9174 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
9180 =for apidoc newSTATEOP
9182 Constructs a state op (COP). The state op is normally a C<nextstate> op,
9183 but will be a C<dbstate> op if debugging is enabled for currently-compiled
9184 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
9185 If C<label> is non-null, it supplies the name of a label to attach to
9186 the state op; this function takes ownership of the memory pointed at by
9187 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
9190 If C<o> is null, the state op is returned. Otherwise the state op is
9191 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
9192 is consumed by this function and becomes part of the returned op tree.
9198 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
9201 const U32 seq = intro_my();
9202 const U32 utf8 = flags & SVf_UTF8;
9205 PL_parser->parsed_sub = 0;
9209 NewOp(1101, cop, 1, COP);
9210 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
9211 OpTYPE_set(cop, OP_DBSTATE);
9214 OpTYPE_set(cop, OP_NEXTSTATE);
9216 cop->op_flags = (U8)flags;
9217 CopHINTS_set(cop, PL_hints);
9219 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
9221 cop->op_next = (OP*)cop;
9224 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
9225 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
9227 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
9229 PL_hints |= HINT_BLOCK_SCOPE;
9230 /* It seems that we need to defer freeing this pointer, as other parts
9231 of the grammar end up wanting to copy it after this op has been
9236 if (PL_parser->preambling != NOLINE) {
9237 CopLINE_set(cop, PL_parser->preambling);
9238 PL_parser->copline = NOLINE;
9240 else if (PL_parser->copline == NOLINE)
9241 CopLINE_set(cop, CopLINE(PL_curcop));
9243 CopLINE_set(cop, PL_parser->copline);
9244 PL_parser->copline = NOLINE;
9247 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
9249 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
9251 CopSTASH_set(cop, PL_curstash);
9253 if (cop->op_type == OP_DBSTATE) {
9254 /* this line can have a breakpoint - store the cop in IV */
9255 AV *av = CopFILEAVx(PL_curcop);
9257 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
9258 if (svp && *svp != &PL_sv_undef ) {
9259 (void)SvIOK_on(*svp);
9260 SvIV_set(*svp, PTR2IV(cop));
9265 if (flags & OPf_SPECIAL)
9267 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
9271 =for apidoc newLOGOP
9273 Constructs, checks, and returns a logical (flow control) op. C<type>
9274 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
9275 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
9276 the eight bits of C<op_private>, except that the bit with value 1 is
9277 automatically set. C<first> supplies the expression controlling the
9278 flow, and C<other> supplies the side (alternate) chain of ops; they are
9279 consumed by this function and become part of the constructed op tree.
9285 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
9287 PERL_ARGS_ASSERT_NEWLOGOP;
9289 return new_logop(type, flags, &first, &other);
9293 /* See if the optree o contains a single OP_CONST (plus possibly
9294 * surrounding enter/nextstate/null etc). If so, return it, else return
9299 S_search_const(pTHX_ OP *o)
9301 PERL_ARGS_ASSERT_SEARCH_CONST;
9304 switch (o->op_type) {
9308 if (o->op_flags & OPf_KIDS) {
9309 o = cUNOPo->op_first;
9318 if (!(o->op_flags & OPf_KIDS))
9320 kid = cLISTOPo->op_first;
9323 switch (kid->op_type) {
9327 kid = OpSIBLING(kid);
9330 if (kid != cLISTOPo->op_last)
9337 kid = cLISTOPo->op_last;
9349 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
9357 int prepend_not = 0;
9359 PERL_ARGS_ASSERT_NEW_LOGOP;
9364 /* [perl #59802]: Warn about things like "return $a or $b", which
9365 is parsed as "(return $a) or $b" rather than "return ($a or
9366 $b)". NB: This also applies to xor, which is why we do it
9369 switch (first->op_type) {
9373 /* XXX: Perhaps we should emit a stronger warning for these.
9374 Even with the high-precedence operator they don't seem to do
9377 But until we do, fall through here.
9383 /* XXX: Currently we allow people to "shoot themselves in the
9384 foot" by explicitly writing "(return $a) or $b".
9386 Warn unless we are looking at the result from folding or if
9387 the programmer explicitly grouped the operators like this.
9388 The former can occur with e.g.
9390 use constant FEATURE => ( $] >= ... );
9391 sub { not FEATURE and return or do_stuff(); }
9393 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
9394 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9395 "Possible precedence issue with control flow operator");
9396 /* XXX: Should we optimze this to "return $a;" (i.e. remove
9402 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
9403 return newBINOP(type, flags, scalar(first), scalar(other));
9405 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
9406 || type == OP_CUSTOM);
9408 scalarboolean(first);
9410 /* search for a constant op that could let us fold the test */
9411 if ((cstop = search_const(first))) {
9412 if (cstop->op_private & OPpCONST_STRICT)
9413 no_bareword_allowed(cstop);
9414 else if ((cstop->op_private & OPpCONST_BARE))
9415 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
9416 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
9417 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
9418 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
9419 /* Elide the (constant) lhs, since it can't affect the outcome */
9421 if (other->op_type == OP_CONST)
9422 other->op_private |= OPpCONST_SHORTCIRCUIT;
9424 if (other->op_type == OP_LEAVE)
9425 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
9426 else if (other->op_type == OP_MATCH
9427 || other->op_type == OP_SUBST
9428 || other->op_type == OP_TRANSR
9429 || other->op_type == OP_TRANS)
9430 /* Mark the op as being unbindable with =~ */
9431 other->op_flags |= OPf_SPECIAL;
9433 other->op_folded = 1;
9437 /* Elide the rhs, since the outcome is entirely determined by
9438 * the (constant) lhs */
9440 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
9441 const OP *o2 = other;
9442 if ( ! (o2->op_type == OP_LIST
9443 && (( o2 = cUNOPx(o2)->op_first))
9444 && o2->op_type == OP_PUSHMARK
9445 && (( o2 = OpSIBLING(o2))) )
9448 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
9449 || o2->op_type == OP_PADHV)
9450 && o2->op_private & OPpLVAL_INTRO
9451 && !(o2->op_private & OPpPAD_STATE))
9453 Perl_croak(aTHX_ "This use of my() in false conditional is "
9454 "no longer allowed");
9458 if (cstop->op_type == OP_CONST)
9459 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
9464 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
9465 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
9467 const OP * const k1 = ((UNOP*)first)->op_first;
9468 const OP * const k2 = OpSIBLING(k1);
9470 switch (first->op_type)
9473 if (k2 && k2->op_type == OP_READLINE
9474 && (k2->op_flags & OPf_STACKED)
9475 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9477 warnop = k2->op_type;
9482 if (k1->op_type == OP_READDIR
9483 || k1->op_type == OP_GLOB
9484 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9485 || k1->op_type == OP_EACH
9486 || k1->op_type == OP_AEACH)
9488 warnop = ((k1->op_type == OP_NULL)
9489 ? (OPCODE)k1->op_targ : k1->op_type);
9494 const line_t oldline = CopLINE(PL_curcop);
9495 /* This ensures that warnings are reported at the first line
9496 of the construction, not the last. */
9497 CopLINE_set(PL_curcop, PL_parser->copline);
9498 Perl_warner(aTHX_ packWARN(WARN_MISC),
9499 "Value of %s%s can be \"0\"; test with defined()",
9501 ((warnop == OP_READLINE || warnop == OP_GLOB)
9502 ? " construct" : "() operator"));
9503 CopLINE_set(PL_curcop, oldline);
9507 /* optimize AND and OR ops that have NOTs as children */
9508 if (first->op_type == OP_NOT
9509 && (first->op_flags & OPf_KIDS)
9510 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
9511 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
9513 if (type == OP_AND || type == OP_OR) {
9519 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
9521 prepend_not = 1; /* prepend a NOT op later */
9526 logop = alloc_LOGOP(type, first, LINKLIST(other));
9527 logop->op_flags |= (U8)flags;
9528 logop->op_private = (U8)(1 | (flags >> 8));
9530 /* establish postfix order */
9531 logop->op_next = LINKLIST(first);
9532 first->op_next = (OP*)logop;
9533 assert(!OpHAS_SIBLING(first));
9534 op_sibling_splice((OP*)logop, first, 0, other);
9536 CHECKOP(type,logop);
9538 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
9539 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
9547 =for apidoc newCONDOP
9549 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
9550 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
9551 will be set automatically, and, shifted up eight bits, the eight bits of
9552 C<op_private>, except that the bit with value 1 is automatically set.
9553 C<first> supplies the expression selecting between the two branches,
9554 and C<trueop> and C<falseop> supply the branches; they are consumed by
9555 this function and become part of the constructed op tree.
9561 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
9569 PERL_ARGS_ASSERT_NEWCONDOP;
9572 return newLOGOP(OP_AND, 0, first, trueop);
9574 return newLOGOP(OP_OR, 0, first, falseop);
9576 scalarboolean(first);
9577 if ((cstop = search_const(first))) {
9578 /* Left or right arm of the conditional? */
9579 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
9580 OP *live = left ? trueop : falseop;
9581 OP *const dead = left ? falseop : trueop;
9582 if (cstop->op_private & OPpCONST_BARE &&
9583 cstop->op_private & OPpCONST_STRICT) {
9584 no_bareword_allowed(cstop);
9588 if (live->op_type == OP_LEAVE)
9589 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
9590 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
9591 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
9592 /* Mark the op as being unbindable with =~ */
9593 live->op_flags |= OPf_SPECIAL;
9594 live->op_folded = 1;
9597 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
9598 logop->op_flags |= (U8)flags;
9599 logop->op_private = (U8)(1 | (flags >> 8));
9600 logop->op_next = LINKLIST(falseop);
9602 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
9605 /* establish postfix order */
9606 start = LINKLIST(first);
9607 first->op_next = (OP*)logop;
9609 /* make first, trueop, falseop siblings */
9610 op_sibling_splice((OP*)logop, first, 0, trueop);
9611 op_sibling_splice((OP*)logop, trueop, 0, falseop);
9613 o = newUNOP(OP_NULL, 0, (OP*)logop);
9615 trueop->op_next = falseop->op_next = o;
9622 =for apidoc newRANGE
9624 Constructs and returns a C<range> op, with subordinate C<flip> and
9625 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
9626 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
9627 for both the C<flip> and C<range> ops, except that the bit with value
9628 1 is automatically set. C<left> and C<right> supply the expressions
9629 controlling the endpoints of the range; they are consumed by this function
9630 and become part of the constructed op tree.
9636 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
9644 PERL_ARGS_ASSERT_NEWRANGE;
9646 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
9647 range->op_flags = OPf_KIDS;
9648 leftstart = LINKLIST(left);
9649 range->op_private = (U8)(1 | (flags >> 8));
9651 /* make left and right siblings */
9652 op_sibling_splice((OP*)range, left, 0, right);
9654 range->op_next = (OP*)range;
9655 flip = newUNOP(OP_FLIP, flags, (OP*)range);
9656 flop = newUNOP(OP_FLOP, 0, flip);
9657 o = newUNOP(OP_NULL, 0, flop);
9659 range->op_next = leftstart;
9661 left->op_next = flip;
9662 right->op_next = flop;
9665 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9666 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9668 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9669 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9670 SvPADTMP_on(PAD_SV(flip->op_targ));
9672 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9673 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9675 /* check barewords before they might be optimized aways */
9676 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9677 no_bareword_allowed(left);
9678 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9679 no_bareword_allowed(right);
9682 if (!flip->op_private || !flop->op_private)
9683 LINKLIST(o); /* blow off optimizer unless constant */
9689 =for apidoc newLOOPOP
9691 Constructs, checks, and returns an op tree expressing a loop. This is
9692 only a loop in the control flow through the op tree; it does not have
9693 the heavyweight loop structure that allows exiting the loop by C<last>
9694 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9695 top-level op, except that some bits will be set automatically as required.
9696 C<expr> supplies the expression controlling loop iteration, and C<block>
9697 supplies the body of the loop; they are consumed by this function and
9698 become part of the constructed op tree. C<debuggable> is currently
9699 unused and should always be 1.
9705 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9709 const bool once = block && block->op_flags & OPf_SPECIAL &&
9710 block->op_type == OP_NULL;
9712 PERL_UNUSED_ARG(debuggable);
9716 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
9717 || ( expr->op_type == OP_NOT
9718 && cUNOPx(expr)->op_first->op_type == OP_CONST
9719 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9722 /* Return the block now, so that S_new_logop does not try to
9726 return block; /* do {} while 0 does once */
9729 if (expr->op_type == OP_READLINE
9730 || expr->op_type == OP_READDIR
9731 || expr->op_type == OP_GLOB
9732 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9733 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9734 expr = newUNOP(OP_DEFINED, 0,
9735 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9736 } else if (expr->op_flags & OPf_KIDS) {
9737 const OP * const k1 = ((UNOP*)expr)->op_first;
9738 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9739 switch (expr->op_type) {
9741 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9742 && (k2->op_flags & OPf_STACKED)
9743 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9744 expr = newUNOP(OP_DEFINED, 0, expr);
9748 if (k1 && (k1->op_type == OP_READDIR
9749 || k1->op_type == OP_GLOB
9750 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9751 || k1->op_type == OP_EACH
9752 || k1->op_type == OP_AEACH))
9753 expr = newUNOP(OP_DEFINED, 0, expr);
9759 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9760 * op, in listop. This is wrong. [perl #27024] */
9762 block = newOP(OP_NULL, 0);
9763 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9764 o = new_logop(OP_AND, 0, &expr, &listop);
9771 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9773 if (once && o != listop)
9775 assert(cUNOPo->op_first->op_type == OP_AND
9776 || cUNOPo->op_first->op_type == OP_OR);
9777 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9781 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9783 o->op_flags |= flags;
9785 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9790 =for apidoc newWHILEOP
9792 Constructs, checks, and returns an op tree expressing a C<while> loop.
9793 This is a heavyweight loop, with structure that allows exiting the loop
9794 by C<last> and suchlike.
9796 C<loop> is an optional preconstructed C<enterloop> op to use in the
9797 loop; if it is null then a suitable op will be constructed automatically.
9798 C<expr> supplies the loop's controlling expression. C<block> supplies the
9799 main body of the loop, and C<cont> optionally supplies a C<continue> block
9800 that operates as a second half of the body. All of these optree inputs
9801 are consumed by this function and become part of the constructed op tree.
9803 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9804 op and, shifted up eight bits, the eight bits of C<op_private> for
9805 the C<leaveloop> op, except that (in both cases) some bits will be set
9806 automatically. C<debuggable> is currently unused and should always be 1.
9807 C<has_my> can be supplied as true to force the
9808 loop body to be enclosed in its own scope.
9814 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9815 OP *expr, OP *block, OP *cont, I32 has_my)
9824 PERL_UNUSED_ARG(debuggable);
9827 if (expr->op_type == OP_READLINE
9828 || expr->op_type == OP_READDIR
9829 || expr->op_type == OP_GLOB
9830 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9831 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9832 expr = newUNOP(OP_DEFINED, 0,
9833 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9834 } else if (expr->op_flags & OPf_KIDS) {
9835 const OP * const k1 = ((UNOP*)expr)->op_first;
9836 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9837 switch (expr->op_type) {
9839 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9840 && (k2->op_flags & OPf_STACKED)
9841 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9842 expr = newUNOP(OP_DEFINED, 0, expr);
9846 if (k1 && (k1->op_type == OP_READDIR
9847 || k1->op_type == OP_GLOB
9848 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9849 || k1->op_type == OP_EACH
9850 || k1->op_type == OP_AEACH))
9851 expr = newUNOP(OP_DEFINED, 0, expr);
9858 block = newOP(OP_NULL, 0);
9859 else if (cont || has_my) {
9860 block = op_scope(block);
9864 next = LINKLIST(cont);
9867 OP * const unstack = newOP(OP_UNSTACK, 0);
9870 cont = op_append_elem(OP_LINESEQ, cont, unstack);
9874 listop = op_append_list(OP_LINESEQ, block, cont);
9876 redo = LINKLIST(listop);
9880 o = new_logop(OP_AND, 0, &expr, &listop);
9881 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9883 return expr; /* listop already freed by new_logop */
9886 ((LISTOP*)listop)->op_last->op_next =
9887 (o == listop ? redo : LINKLIST(o));
9893 NewOp(1101,loop,1,LOOP);
9894 OpTYPE_set(loop, OP_ENTERLOOP);
9895 loop->op_private = 0;
9896 loop->op_next = (OP*)loop;
9899 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9901 loop->op_redoop = redo;
9902 loop->op_lastop = o;
9903 o->op_private |= loopflags;
9906 loop->op_nextop = next;
9908 loop->op_nextop = o;
9910 o->op_flags |= flags;
9911 o->op_private |= (flags >> 8);
9916 =for apidoc newFOROP
9918 Constructs, checks, and returns an op tree expressing a C<foreach>
9919 loop (iteration through a list of values). This is a heavyweight loop,
9920 with structure that allows exiting the loop by C<last> and suchlike.
9922 C<sv> optionally supplies the variable that will be aliased to each
9923 item in turn; if null, it defaults to C<$_>.
9924 C<expr> supplies the list of values to iterate over. C<block> supplies
9925 the main body of the loop, and C<cont> optionally supplies a C<continue>
9926 block that operates as a second half of the body. All of these optree
9927 inputs are consumed by this function and become part of the constructed
9930 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9931 op and, shifted up eight bits, the eight bits of C<op_private> for
9932 the C<leaveloop> op, except that (in both cases) some bits will be set
9939 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9944 PADOFFSET padoff = 0;
9948 PERL_ARGS_ASSERT_NEWFOROP;
9951 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
9952 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9953 OpTYPE_set(sv, OP_RV2GV);
9955 /* The op_type check is needed to prevent a possible segfault
9956 * if the loop variable is undeclared and 'strict vars' is in
9957 * effect. This is illegal but is nonetheless parsed, so we
9958 * may reach this point with an OP_CONST where we're expecting
9961 if (cUNOPx(sv)->op_first->op_type == OP_GV
9962 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9963 iterpflags |= OPpITER_DEF;
9965 else if (sv->op_type == OP_PADSV) { /* private variable */
9966 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9967 padoff = sv->op_targ;
9971 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9973 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9976 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9978 PADNAME * const pn = PAD_COMPNAME(padoff);
9979 const char * const name = PadnamePV(pn);
9981 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9982 iterpflags |= OPpITER_DEF;
9986 sv = newGVOP(OP_GV, 0, PL_defgv);
9987 iterpflags |= OPpITER_DEF;
9990 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9991 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
9992 iterflags |= OPf_STACKED;
9994 else if (expr->op_type == OP_NULL &&
9995 (expr->op_flags & OPf_KIDS) &&
9996 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
9998 /* Basically turn for($x..$y) into the same as for($x,$y), but we
9999 * set the STACKED flag to indicate that these values are to be
10000 * treated as min/max values by 'pp_enteriter'.
10002 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
10003 LOGOP* const range = (LOGOP*) flip->op_first;
10004 OP* const left = range->op_first;
10005 OP* const right = OpSIBLING(left);
10008 range->op_flags &= ~OPf_KIDS;
10009 /* detach range's children */
10010 op_sibling_splice((OP*)range, NULL, -1, NULL);
10012 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
10013 listop->op_first->op_next = range->op_next;
10014 left->op_next = range->op_other;
10015 right->op_next = (OP*)listop;
10016 listop->op_next = listop->op_first;
10019 expr = (OP*)(listop);
10021 iterflags |= OPf_STACKED;
10024 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
10027 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
10028 op_append_elem(OP_LIST, list(expr),
10030 assert(!loop->op_next);
10031 /* for my $x () sets OPpLVAL_INTRO;
10032 * for our $x () sets OPpOUR_INTRO */
10033 loop->op_private = (U8)iterpflags;
10035 /* upgrade loop from a LISTOP to a LOOPOP;
10036 * keep it in-place if there's space */
10037 if (loop->op_slabbed
10038 && OpSLOT(loop)->opslot_size
10039 < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
10041 /* no space; allocate new op */
10043 NewOp(1234,tmp,1,LOOP);
10044 Copy(loop,tmp,1,LISTOP);
10045 assert(loop->op_last->op_sibparent == (OP*)loop);
10046 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
10047 S_op_destroy(aTHX_ (OP*)loop);
10050 else if (!loop->op_slabbed)
10052 /* loop was malloc()ed */
10053 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
10054 OpLASTSIB_set(loop->op_last, (OP*)loop);
10056 loop->op_targ = padoff;
10057 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
10062 =for apidoc newLOOPEX
10064 Constructs, checks, and returns a loop-exiting op (such as C<goto>
10065 or C<last>). C<type> is the opcode. C<label> supplies the parameter
10066 determining the target of the op; it is consumed by this function and
10067 becomes part of the constructed op tree.
10073 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
10077 PERL_ARGS_ASSERT_NEWLOOPEX;
10079 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
10080 || type == OP_CUSTOM);
10082 if (type != OP_GOTO) {
10083 /* "last()" means "last" */
10084 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
10085 o = newOP(type, OPf_SPECIAL);
10089 /* Check whether it's going to be a goto &function */
10090 if (label->op_type == OP_ENTERSUB
10091 && !(label->op_flags & OPf_STACKED))
10092 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
10095 /* Check for a constant argument */
10096 if (label->op_type == OP_CONST) {
10097 SV * const sv = ((SVOP *)label)->op_sv;
10099 const char *s = SvPV_const(sv,l);
10100 if (l == strlen(s)) {
10102 SvUTF8(((SVOP*)label)->op_sv),
10104 SvPV_nolen_const(((SVOP*)label)->op_sv)));
10108 /* If we have already created an op, we do not need the label. */
10111 else o = newUNOP(type, OPf_STACKED, label);
10113 PL_hints |= HINT_BLOCK_SCOPE;
10117 /* if the condition is a literal array or hash
10118 (or @{ ... } etc), make a reference to it.
10121 S_ref_array_or_hash(pTHX_ OP *cond)
10124 && (cond->op_type == OP_RV2AV
10125 || cond->op_type == OP_PADAV
10126 || cond->op_type == OP_RV2HV
10127 || cond->op_type == OP_PADHV))
10129 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
10132 && (cond->op_type == OP_ASLICE
10133 || cond->op_type == OP_KVASLICE
10134 || cond->op_type == OP_HSLICE
10135 || cond->op_type == OP_KVHSLICE)) {
10137 /* anonlist now needs a list from this op, was previously used in
10138 * scalar context */
10139 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
10140 cond->op_flags |= OPf_WANT_LIST;
10142 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
10149 /* These construct the optree fragments representing given()
10152 entergiven and enterwhen are LOGOPs; the op_other pointer
10153 points up to the associated leave op. We need this so we
10154 can put it in the context and make break/continue work.
10155 (Also, of course, pp_enterwhen will jump straight to
10156 op_other if the match fails.)
10160 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
10161 I32 enter_opcode, I32 leave_opcode,
10162 PADOFFSET entertarg)
10168 PERL_ARGS_ASSERT_NEWGIVWHENOP;
10169 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
10171 enterop = alloc_LOGOP(enter_opcode, block, NULL);
10172 enterop->op_targ = 0;
10173 enterop->op_private = 0;
10175 o = newUNOP(leave_opcode, 0, (OP *) enterop);
10178 /* prepend cond if we have one */
10179 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
10181 o->op_next = LINKLIST(cond);
10182 cond->op_next = (OP *) enterop;
10185 /* This is a default {} block */
10186 enterop->op_flags |= OPf_SPECIAL;
10187 o ->op_flags |= OPf_SPECIAL;
10189 o->op_next = (OP *) enterop;
10192 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
10193 entergiven and enterwhen both
10196 enterop->op_next = LINKLIST(block);
10197 block->op_next = enterop->op_other = o;
10203 /* For the purposes of 'when(implied_smartmatch)'
10204 * versus 'when(boolean_expression)',
10205 * does this look like a boolean operation? For these purposes
10206 a boolean operation is:
10207 - a subroutine call [*]
10208 - a logical connective
10209 - a comparison operator
10210 - a filetest operator, with the exception of -s -M -A -C
10211 - defined(), exists() or eof()
10212 - /$re/ or $foo =~ /$re/
10214 [*] possibly surprising
10217 S_looks_like_bool(pTHX_ const OP *o)
10219 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
10221 switch(o->op_type) {
10224 return looks_like_bool(cLOGOPo->op_first);
10228 OP* sibl = OpSIBLING(cLOGOPo->op_first);
10231 looks_like_bool(cLOGOPo->op_first)
10232 && looks_like_bool(sibl));
10238 o->op_flags & OPf_KIDS
10239 && looks_like_bool(cUNOPo->op_first));
10243 case OP_NOT: case OP_XOR:
10245 case OP_EQ: case OP_NE: case OP_LT:
10246 case OP_GT: case OP_LE: case OP_GE:
10248 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
10249 case OP_I_GT: case OP_I_LE: case OP_I_GE:
10251 case OP_SEQ: case OP_SNE: case OP_SLT:
10252 case OP_SGT: case OP_SLE: case OP_SGE:
10254 case OP_SMARTMATCH:
10256 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
10257 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
10258 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
10259 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
10260 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
10261 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
10262 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
10263 case OP_FTTEXT: case OP_FTBINARY:
10265 case OP_DEFINED: case OP_EXISTS:
10266 case OP_MATCH: case OP_EOF:
10274 /* optimised-away (index() != -1) or similar comparison */
10275 if (o->op_private & OPpTRUEBOOL)
10280 /* Detect comparisons that have been optimized away */
10281 if (cSVOPo->op_sv == &PL_sv_yes
10282 || cSVOPo->op_sv == &PL_sv_no)
10295 =for apidoc newGIVENOP
10297 Constructs, checks, and returns an op tree expressing a C<given> block.
10298 C<cond> supplies the expression to whose value C<$_> will be locally
10299 aliased, and C<block> supplies the body of the C<given> construct; they
10300 are consumed by this function and become part of the constructed op tree.
10301 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
10307 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
10309 PERL_ARGS_ASSERT_NEWGIVENOP;
10310 PERL_UNUSED_ARG(defsv_off);
10312 assert(!defsv_off);
10313 return newGIVWHENOP(
10314 ref_array_or_hash(cond),
10316 OP_ENTERGIVEN, OP_LEAVEGIVEN,
10321 =for apidoc newWHENOP
10323 Constructs, checks, and returns an op tree expressing a C<when> block.
10324 C<cond> supplies the test expression, and C<block> supplies the block
10325 that will be executed if the test evaluates to true; they are consumed
10326 by this function and become part of the constructed op tree. C<cond>
10327 will be interpreted DWIMically, often as a comparison against C<$_>,
10328 and may be null to generate a C<default> block.
10334 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
10336 const bool cond_llb = (!cond || looks_like_bool(cond));
10339 PERL_ARGS_ASSERT_NEWWHENOP;
10344 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
10346 scalar(ref_array_or_hash(cond)));
10349 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
10352 /* must not conflict with SVf_UTF8 */
10353 #define CV_CKPROTO_CURSTASH 0x1
10356 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
10357 const STRLEN len, const U32 flags)
10359 SV *name = NULL, *msg;
10360 const char * cvp = SvROK(cv)
10361 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
10362 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
10365 STRLEN clen = CvPROTOLEN(cv), plen = len;
10367 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
10369 if (p == NULL && cvp == NULL)
10372 if (!ckWARN_d(WARN_PROTOTYPE))
10376 p = S_strip_spaces(aTHX_ p, &plen);
10377 cvp = S_strip_spaces(aTHX_ cvp, &clen);
10378 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
10379 if (plen == clen && memEQ(cvp, p, plen))
10382 if (flags & SVf_UTF8) {
10383 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
10387 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
10393 msg = sv_newmortal();
10398 gv_efullname3(name = sv_newmortal(), gv, NULL);
10399 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
10400 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
10401 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
10402 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
10403 sv_catpvs(name, "::");
10405 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
10406 assert (CvNAMED(SvRV_const(gv)));
10407 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
10409 else sv_catsv(name, (SV *)gv);
10411 else name = (SV *)gv;
10413 sv_setpvs(msg, "Prototype mismatch:");
10415 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
10417 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
10418 UTF8fARG(SvUTF8(cv),clen,cvp)
10421 sv_catpvs(msg, ": none");
10422 sv_catpvs(msg, " vs ");
10424 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
10426 sv_catpvs(msg, "none");
10427 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
10430 static void const_sv_xsub(pTHX_ CV* cv);
10431 static void const_av_xsub(pTHX_ CV* cv);
10435 =head1 Optree Manipulation Functions
10437 =for apidoc cv_const_sv
10439 If C<cv> is a constant sub eligible for inlining, returns the constant
10440 value returned by the sub. Otherwise, returns C<NULL>.
10442 Constant subs can be created with C<newCONSTSUB> or as described in
10443 L<perlsub/"Constant Functions">.
10448 Perl_cv_const_sv(const CV *const cv)
10453 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
10455 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10456 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
10461 Perl_cv_const_sv_or_av(const CV * const cv)
10465 if (SvROK(cv)) return SvRV((SV *)cv);
10466 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
10467 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
10470 /* op_const_sv: examine an optree to determine whether it's in-lineable.
10471 * Can be called in 2 ways:
10474 * look for a single OP_CONST with attached value: return the value
10476 * allow_lex && !CvCONST(cv);
10478 * examine the clone prototype, and if contains only a single
10479 * OP_CONST, return the value; or if it contains a single PADSV ref-
10480 * erencing an outer lexical, turn on CvCONST to indicate the CV is
10481 * a candidate for "constizing" at clone time, and return NULL.
10485 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
10488 bool padsv = FALSE;
10493 for (; o; o = o->op_next) {
10494 const OPCODE type = o->op_type;
10496 if (type == OP_NEXTSTATE || type == OP_LINESEQ
10498 || type == OP_PUSHMARK)
10500 if (type == OP_DBSTATE)
10502 if (type == OP_LEAVESUB)
10506 if (type == OP_CONST && cSVOPo->op_sv)
10507 sv = cSVOPo->op_sv;
10508 else if (type == OP_UNDEF && !o->op_private) {
10512 else if (allow_lex && type == OP_PADSV) {
10513 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
10515 sv = &PL_sv_undef; /* an arbitrary non-null value */
10533 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10534 PADNAME * const name, SV ** const const_svp)
10537 assert (o || name);
10538 assert (const_svp);
10540 if (CvFLAGS(PL_compcv)) {
10541 /* might have had built-in attrs applied */
10542 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10543 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10544 && ckWARN(WARN_MISC))
10546 /* protect against fatal warnings leaking compcv */
10547 SAVEFREESV(PL_compcv);
10548 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10549 SvREFCNT_inc_simple_void_NN(PL_compcv);
10552 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10553 & ~(CVf_LVALUE * pureperl));
10558 /* redundant check for speed: */
10559 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10560 const line_t oldline = CopLINE(PL_curcop);
10563 : sv_2mortal(newSVpvn_utf8(
10564 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
10566 if (PL_parser && PL_parser->copline != NOLINE)
10567 /* This ensures that warnings are reported at the first
10568 line of a redefinition, not the last. */
10569 CopLINE_set(PL_curcop, PL_parser->copline);
10570 /* protect against fatal warnings leaking compcv */
10571 SAVEFREESV(PL_compcv);
10572 report_redefined_cv(namesv, cv, const_svp);
10573 SvREFCNT_inc_simple_void_NN(PL_compcv);
10574 CopLINE_set(PL_curcop, oldline);
10581 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10586 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10589 CV *compcv = PL_compcv;
10592 PADOFFSET pax = o->op_targ;
10593 CV *outcv = CvOUTSIDE(PL_compcv);
10596 bool reusable = FALSE;
10598 #ifdef PERL_DEBUG_READONLY_OPS
10599 OPSLAB *slab = NULL;
10602 PERL_ARGS_ASSERT_NEWMYSUB;
10604 PL_hints |= HINT_BLOCK_SCOPE;
10606 /* Find the pad slot for storing the new sub.
10607 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10608 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10609 ing sub. And then we need to dig deeper if this is a lexical from
10611 my sub foo; sub { sub foo { } }
10614 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10615 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10616 pax = PARENT_PAD_INDEX(name);
10617 outcv = CvOUTSIDE(outcv);
10622 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10623 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10624 spot = (CV **)svspot;
10626 if (!(PL_parser && PL_parser->error_count))
10627 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10630 assert(proto->op_type == OP_CONST);
10631 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10632 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10642 if (PL_parser && PL_parser->error_count) {
10644 SvREFCNT_dec(PL_compcv);
10649 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10651 svspot = (SV **)(spot = &clonee);
10653 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10656 assert (SvTYPE(*spot) == SVt_PVCV);
10657 if (CvNAMED(*spot))
10658 hek = CvNAME_HEK(*spot);
10662 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10663 CvNAME_HEK_set(*spot, hek =
10666 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10670 CvLEXICAL_on(*spot);
10672 cv = PadnamePROTOCV(name);
10673 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10677 /* This makes sub {}; work as expected. */
10678 if (block->op_type == OP_STUB) {
10679 const line_t l = PL_parser->copline;
10681 block = newSTATEOP(0, NULL, 0);
10682 PL_parser->copline = l;
10684 block = CvLVALUE(compcv)
10685 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10686 ? newUNOP(OP_LEAVESUBLV, 0,
10687 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10688 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10689 start = LINKLIST(block);
10690 block->op_next = 0;
10691 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10692 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10700 const bool exists = CvROOT(cv) || CvXSUB(cv);
10702 /* if the subroutine doesn't exist and wasn't pre-declared
10703 * with a prototype, assume it will be AUTOLOADed,
10704 * skipping the prototype check
10706 if (exists || SvPOK(cv))
10707 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10709 /* already defined? */
10711 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10717 /* just a "sub foo;" when &foo is already defined */
10718 SAVEFREESV(compcv);
10722 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10729 SvREFCNT_inc_simple_void_NN(const_sv);
10730 SvFLAGS(const_sv) |= SVs_PADTMP;
10732 assert(!CvROOT(cv) && !CvCONST(cv));
10733 cv_forget_slab(cv);
10736 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10737 CvFILE_set_from_cop(cv, PL_curcop);
10738 CvSTASH_set(cv, PL_curstash);
10741 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10742 CvXSUBANY(cv).any_ptr = const_sv;
10743 CvXSUB(cv) = const_sv_xsub;
10747 CvFLAGS(cv) |= CvMETHOD(compcv);
10749 SvREFCNT_dec(compcv);
10754 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10755 determine whether this sub definition is in the same scope as its
10756 declaration. If this sub definition is inside an inner named pack-
10757 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10758 the package sub. So check PadnameOUTER(name) too.
10760 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10761 assert(!CvWEAKOUTSIDE(compcv));
10762 SvREFCNT_dec(CvOUTSIDE(compcv));
10763 CvWEAKOUTSIDE_on(compcv);
10765 /* XXX else do we have a circular reference? */
10767 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10768 /* transfer PL_compcv to cv */
10770 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10771 cv_flags_t preserved_flags =
10772 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10773 PADLIST *const temp_padl = CvPADLIST(cv);
10774 CV *const temp_cv = CvOUTSIDE(cv);
10775 const cv_flags_t other_flags =
10776 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10777 OP * const cvstart = CvSTART(cv);
10781 CvFLAGS(compcv) | preserved_flags;
10782 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10783 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10784 CvPADLIST_set(cv, CvPADLIST(compcv));
10785 CvOUTSIDE(compcv) = temp_cv;
10786 CvPADLIST_set(compcv, temp_padl);
10787 CvSTART(cv) = CvSTART(compcv);
10788 CvSTART(compcv) = cvstart;
10789 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10790 CvFLAGS(compcv) |= other_flags;
10793 Safefree(CvFILE(cv));
10797 /* inner references to compcv must be fixed up ... */
10798 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10799 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10800 ++PL_sub_generation;
10803 /* Might have had built-in attributes applied -- propagate them. */
10804 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10806 /* ... before we throw it away */
10807 SvREFCNT_dec(compcv);
10808 PL_compcv = compcv = cv;
10817 if (!CvNAME_HEK(cv)) {
10818 if (hek) (void)share_hek_hek(hek);
10822 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10823 hek = share_hek(PadnamePV(name)+1,
10824 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10827 CvNAME_HEK_set(cv, hek);
10833 if (CvFILE(cv) && CvDYNFILE(cv))
10834 Safefree(CvFILE(cv));
10835 CvFILE_set_from_cop(cv, PL_curcop);
10836 CvSTASH_set(cv, PL_curstash);
10839 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10841 SvUTF8_on(MUTABLE_SV(cv));
10845 /* If we assign an optree to a PVCV, then we've defined a
10846 * subroutine that the debugger could be able to set a breakpoint
10847 * in, so signal to pp_entereval that it should not throw away any
10848 * saved lines at scope exit. */
10850 PL_breakable_sub_gen++;
10851 CvROOT(cv) = block;
10852 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10853 itself has a refcount. */
10855 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10856 #ifdef PERL_DEBUG_READONLY_OPS
10857 slab = (OPSLAB *)CvSTART(cv);
10859 S_process_optree(aTHX_ cv, block, start);
10864 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10865 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10869 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10870 SV * const tmpstr = sv_newmortal();
10871 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10872 GV_ADDMULTI, SVt_PVHV);
10874 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10875 CopFILE(PL_curcop),
10877 (long)CopLINE(PL_curcop));
10878 if (HvNAME_HEK(PL_curstash)) {
10879 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10880 sv_catpvs(tmpstr, "::");
10883 sv_setpvs(tmpstr, "__ANON__::");
10885 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10886 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10887 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10888 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10889 hv = GvHVn(db_postponed);
10890 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10891 CV * const pcv = GvCV(db_postponed);
10897 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10905 assert(CvDEPTH(outcv));
10907 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10909 cv_clone_into(clonee, *spot);
10910 else *spot = cv_clone(clonee);
10911 SvREFCNT_dec_NN(clonee);
10915 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10916 PADOFFSET depth = CvDEPTH(outcv);
10919 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10921 *svspot = SvREFCNT_inc_simple_NN(cv);
10922 SvREFCNT_dec(oldcv);
10928 PL_parser->copline = NOLINE;
10929 LEAVE_SCOPE(floor);
10930 #ifdef PERL_DEBUG_READONLY_OPS
10939 =for apidoc newATTRSUB_x
10941 Construct a Perl subroutine, also performing some surrounding jobs.
10943 This function is expected to be called in a Perl compilation context,
10944 and some aspects of the subroutine are taken from global variables
10945 associated with compilation. In particular, C<PL_compcv> represents
10946 the subroutine that is currently being compiled. It must be non-null
10947 when this function is called, and some aspects of the subroutine being
10948 constructed are taken from it. The constructed subroutine may actually
10949 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10951 If C<block> is null then the subroutine will have no body, and for the
10952 time being it will be an error to call it. This represents a forward
10953 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
10954 non-null then it provides the Perl code of the subroutine body, which
10955 will be executed when the subroutine is called. This body includes
10956 any argument unwrapping code resulting from a subroutine signature or
10957 similar. The pad use of the code must correspond to the pad attached
10958 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
10959 C<leavesublv> op; this function will add such an op. C<block> is consumed
10960 by this function and will become part of the constructed subroutine.
10962 C<proto> specifies the subroutine's prototype, unless one is supplied
10963 as an attribute (see below). If C<proto> is null, then the subroutine
10964 will not have a prototype. If C<proto> is non-null, it must point to a
10965 C<const> op whose value is a string, and the subroutine will have that
10966 string as its prototype. If a prototype is supplied as an attribute, the
10967 attribute takes precedence over C<proto>, but in that case C<proto> should
10968 preferably be null. In any case, C<proto> is consumed by this function.
10970 C<attrs> supplies attributes to be applied the subroutine. A handful of
10971 attributes take effect by built-in means, being applied to C<PL_compcv>
10972 immediately when seen. Other attributes are collected up and attached
10973 to the subroutine by this route. C<attrs> may be null to supply no
10974 attributes, or point to a C<const> op for a single attribute, or point
10975 to a C<list> op whose children apart from the C<pushmark> are C<const>
10976 ops for one or more attributes. Each C<const> op must be a string,
10977 giving the attribute name optionally followed by parenthesised arguments,
10978 in the manner in which attributes appear in Perl source. The attributes
10979 will be applied to the sub by this function. C<attrs> is consumed by
10982 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10983 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
10984 must point to a C<const> op, which will be consumed by this function,
10985 and its string value supplies a name for the subroutine. The name may
10986 be qualified or unqualified, and if it is unqualified then a default
10987 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
10988 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10989 by which the subroutine will be named.
10991 If there is already a subroutine of the specified name, then the new
10992 sub will either replace the existing one in the glob or be merged with
10993 the existing one. A warning may be generated about redefinition.
10995 If the subroutine has one of a few special names, such as C<BEGIN> or
10996 C<END>, then it will be claimed by the appropriate queue for automatic
10997 running of phase-related subroutines. In this case the relevant glob will
10998 be left not containing any subroutine, even if it did contain one before.
10999 In the case of C<BEGIN>, the subroutine will be executed and the reference
11000 to it disposed of before this function returns.
11002 The function returns a pointer to the constructed subroutine. If the sub
11003 is anonymous then ownership of one counted reference to the subroutine
11004 is transferred to the caller. If the sub is named then the caller does
11005 not get ownership of a reference. In most such cases, where the sub
11006 has a non-phase name, the sub will be alive at the point it is returned
11007 by virtue of being contained in the glob that names it. A phase-named
11008 subroutine will usually be alive by virtue of the reference owned by the
11009 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11010 been executed, will quite likely have been destroyed already by the
11011 time this function returns, making it erroneous for the caller to make
11012 any use of the returned pointer. It is the caller's responsibility to
11013 ensure that it knows which of these situations applies.
11018 /* _x = extended */
11020 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
11021 OP *block, bool o_is_gv)
11025 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
11027 CV *cv = NULL; /* the previous CV with this name, if any */
11029 const bool ec = PL_parser && PL_parser->error_count;
11030 /* If the subroutine has no body, no attributes, and no builtin attributes
11031 then it's just a sub declaration, and we may be able to get away with
11032 storing with a placeholder scalar in the symbol table, rather than a
11033 full CV. If anything is present then it will take a full CV to
11035 const I32 gv_fetch_flags
11036 = ec ? GV_NOADD_NOINIT :
11037 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
11038 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
11040 const char * const name =
11041 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
11043 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
11044 bool evanescent = FALSE;
11046 #ifdef PERL_DEBUG_READONLY_OPS
11047 OPSLAB *slab = NULL;
11055 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
11056 hek and CvSTASH pointer together can imply the GV. If the name
11057 contains a package name, then GvSTASH(CvGV(cv)) may differ from
11058 CvSTASH, so forego the optimisation if we find any.
11059 Also, we may be called from load_module at run time, so
11060 PL_curstash (which sets CvSTASH) may not point to the stash the
11061 sub is stored in. */
11062 /* XXX This optimization is currently disabled for packages other
11063 than main, since there was too much CPAN breakage. */
11065 ec ? GV_NOADD_NOINIT
11066 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
11067 || PL_curstash != PL_defstash
11068 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
11070 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
11071 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
11073 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
11074 SV * const sv = sv_newmortal();
11075 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
11076 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11077 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11078 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
11080 } else if (PL_curstash) {
11081 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
11084 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
11090 move_proto_attr(&proto, &attrs, gv, 0);
11093 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
11098 assert(proto->op_type == OP_CONST);
11099 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
11100 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
11116 SvREFCNT_dec(PL_compcv);
11121 if (name && block) {
11122 const char *s = (char *) my_memrchr(name, ':', namlen);
11123 s = s ? s+1 : name;
11124 if (strEQ(s, "BEGIN")) {
11125 if (PL_in_eval & EVAL_KEEPERR)
11126 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
11128 SV * const errsv = ERRSV;
11129 /* force display of errors found but not reported */
11130 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
11131 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
11138 if (!block && SvTYPE(gv) != SVt_PVGV) {
11139 /* If we are not defining a new sub and the existing one is not a
11141 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
11142 /* We are applying attributes to an existing sub, so we need it
11143 upgraded if it is a constant. */
11144 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
11145 gv_init_pvn(gv, PL_curstash, name, namlen,
11146 SVf_UTF8 * name_is_utf8);
11148 else { /* Maybe prototype now, and had at maximum
11149 a prototype or const/sub ref before. */
11150 if (SvTYPE(gv) > SVt_NULL) {
11151 cv_ckproto_len_flags((const CV *)gv,
11152 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11158 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
11160 SvUTF8_on(MUTABLE_SV(gv));
11163 sv_setiv(MUTABLE_SV(gv), -1);
11166 SvREFCNT_dec(PL_compcv);
11167 cv = PL_compcv = NULL;
11172 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
11176 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
11182 /* This makes sub {}; work as expected. */
11183 if (block->op_type == OP_STUB) {
11184 const line_t l = PL_parser->copline;
11186 block = newSTATEOP(0, NULL, 0);
11187 PL_parser->copline = l;
11189 block = CvLVALUE(PL_compcv)
11190 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
11191 && (!isGV(gv) || !GvASSUMECV(gv)))
11192 ? newUNOP(OP_LEAVESUBLV, 0,
11193 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
11194 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
11195 start = LINKLIST(block);
11196 block->op_next = 0;
11197 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
11199 S_op_const_sv(aTHX_ start, PL_compcv,
11200 cBOOL(CvCLONE(PL_compcv)));
11207 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
11208 cv_ckproto_len_flags((const CV *)gv,
11209 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
11210 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
11212 /* All the other code for sub redefinition warnings expects the
11213 clobbered sub to be a CV. Instead of making all those code
11214 paths more complex, just inline the RV version here. */
11215 const line_t oldline = CopLINE(PL_curcop);
11216 assert(IN_PERL_COMPILETIME);
11217 if (PL_parser && PL_parser->copline != NOLINE)
11218 /* This ensures that warnings are reported at the first
11219 line of a redefinition, not the last. */
11220 CopLINE_set(PL_curcop, PL_parser->copline);
11221 /* protect against fatal warnings leaking compcv */
11222 SAVEFREESV(PL_compcv);
11224 if (ckWARN(WARN_REDEFINE)
11225 || ( ckWARN_d(WARN_REDEFINE)
11226 && ( !const_sv || SvRV(gv) == const_sv
11227 || sv_cmp(SvRV(gv), const_sv) ))) {
11229 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11230 "Constant subroutine %" SVf " redefined",
11231 SVfARG(cSVOPo->op_sv));
11234 SvREFCNT_inc_simple_void_NN(PL_compcv);
11235 CopLINE_set(PL_curcop, oldline);
11236 SvREFCNT_dec(SvRV(gv));
11241 const bool exists = CvROOT(cv) || CvXSUB(cv);
11243 /* if the subroutine doesn't exist and wasn't pre-declared
11244 * with a prototype, assume it will be AUTOLOADed,
11245 * skipping the prototype check
11247 if (exists || SvPOK(cv))
11248 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
11249 /* already defined (or promised)? */
11250 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
11251 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
11257 /* just a "sub foo;" when &foo is already defined */
11258 SAVEFREESV(PL_compcv);
11265 SvREFCNT_inc_simple_void_NN(const_sv);
11266 SvFLAGS(const_sv) |= SVs_PADTMP;
11268 assert(!CvROOT(cv) && !CvCONST(cv));
11269 cv_forget_slab(cv);
11270 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
11271 CvXSUBANY(cv).any_ptr = const_sv;
11272 CvXSUB(cv) = const_sv_xsub;
11276 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11279 if (isGV(gv) || CvMETHOD(PL_compcv)) {
11280 if (name && isGV(gv))
11281 GvCV_set(gv, NULL);
11282 cv = newCONSTSUB_flags(
11283 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
11287 assert(SvREFCNT((SV*)cv) != 0);
11288 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
11292 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11293 prepare_SV_for_RV((SV *)gv);
11294 SvOK_off((SV *)gv);
11297 SvRV_set(gv, const_sv);
11301 SvREFCNT_dec(PL_compcv);
11306 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
11307 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
11310 if (cv) { /* must reuse cv if autoloaded */
11311 /* transfer PL_compcv to cv */
11313 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
11314 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
11315 PADLIST *const temp_av = CvPADLIST(cv);
11316 CV *const temp_cv = CvOUTSIDE(cv);
11317 const cv_flags_t other_flags =
11318 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
11319 OP * const cvstart = CvSTART(cv);
11323 assert(!CvCVGV_RC(cv));
11324 assert(CvGV(cv) == gv);
11329 PERL_HASH(hash, name, namlen);
11339 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
11341 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
11342 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
11343 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
11344 CvOUTSIDE(PL_compcv) = temp_cv;
11345 CvPADLIST_set(PL_compcv, temp_av);
11346 CvSTART(cv) = CvSTART(PL_compcv);
11347 CvSTART(PL_compcv) = cvstart;
11348 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
11349 CvFLAGS(PL_compcv) |= other_flags;
11352 Safefree(CvFILE(cv));
11354 CvFILE_set_from_cop(cv, PL_curcop);
11355 CvSTASH_set(cv, PL_curstash);
11357 /* inner references to PL_compcv must be fixed up ... */
11358 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
11359 if (PERLDB_INTER)/* Advice debugger on the new sub. */
11360 ++PL_sub_generation;
11363 /* Might have had built-in attributes applied -- propagate them. */
11364 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
11366 /* ... before we throw it away */
11367 SvREFCNT_dec(PL_compcv);
11372 if (name && isGV(gv)) {
11375 if (HvENAME_HEK(GvSTASH(gv)))
11376 /* sub Foo::bar { (shift)+1 } */
11377 gv_method_changed(gv);
11381 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
11382 prepare_SV_for_RV((SV *)gv);
11383 SvOK_off((SV *)gv);
11386 SvRV_set(gv, (SV *)cv);
11387 if (HvENAME_HEK(PL_curstash))
11388 mro_method_changed_in(PL_curstash);
11392 assert(SvREFCNT((SV*)cv) != 0);
11394 if (!CvHASGV(cv)) {
11400 PERL_HASH(hash, name, namlen);
11401 CvNAME_HEK_set(cv, share_hek(name,
11407 CvFILE_set_from_cop(cv, PL_curcop);
11408 CvSTASH_set(cv, PL_curstash);
11412 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
11414 SvUTF8_on(MUTABLE_SV(cv));
11418 /* If we assign an optree to a PVCV, then we've defined a
11419 * subroutine that the debugger could be able to set a breakpoint
11420 * in, so signal to pp_entereval that it should not throw away any
11421 * saved lines at scope exit. */
11423 PL_breakable_sub_gen++;
11424 CvROOT(cv) = block;
11425 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
11426 itself has a refcount. */
11428 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
11429 #ifdef PERL_DEBUG_READONLY_OPS
11430 slab = (OPSLAB *)CvSTART(cv);
11432 S_process_optree(aTHX_ cv, block, start);
11437 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
11438 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
11439 ? GvSTASH(CvGV(cv))
11443 apply_attrs(stash, MUTABLE_SV(cv), attrs);
11445 SvREFCNT_inc_simple_void_NN(cv);
11448 if (block && has_name) {
11449 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
11450 SV * const tmpstr = cv_name(cv,NULL,0);
11451 GV * const db_postponed = gv_fetchpvs("DB::postponed",
11452 GV_ADDMULTI, SVt_PVHV);
11454 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
11455 CopFILE(PL_curcop),
11457 (long)CopLINE(PL_curcop));
11458 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
11459 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
11460 hv = GvHVn(db_postponed);
11461 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
11462 CV * const pcv = GvCV(db_postponed);
11468 call_sv(MUTABLE_SV(pcv), G_DISCARD);
11474 if (PL_parser && PL_parser->error_count)
11475 clear_special_blocks(name, gv, cv);
11478 process_special_blocks(floor, name, gv, cv);
11484 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11486 PL_parser->copline = NOLINE;
11487 LEAVE_SCOPE(floor);
11489 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
11491 #ifdef PERL_DEBUG_READONLY_OPS
11495 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11496 pad_add_weakref(cv);
11502 S_clear_special_blocks(pTHX_ const char *const fullname,
11503 GV *const gv, CV *const cv) {
11507 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11509 colon = strrchr(fullname,':');
11510 name = colon ? colon + 1 : fullname;
11512 if ((*name == 'B' && strEQ(name, "BEGIN"))
11513 || (*name == 'E' && strEQ(name, "END"))
11514 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11515 || (*name == 'C' && strEQ(name, "CHECK"))
11516 || (*name == 'I' && strEQ(name, "INIT"))) {
11521 GvCV_set(gv, NULL);
11522 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11526 /* Returns true if the sub has been freed. */
11528 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11532 const char *const colon = strrchr(fullname,':');
11533 const char *const name = colon ? colon + 1 : fullname;
11535 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11537 if (*name == 'B') {
11538 if (strEQ(name, "BEGIN")) {
11539 const I32 oldscope = PL_scopestack_ix;
11542 if (floor) LEAVE_SCOPE(floor);
11545 SAVEVPTR(PL_curcop);
11546 if (PL_curcop == &PL_compiling) {
11547 /* Avoid pushing the "global" &PL_compiling onto the
11548 * context stack. For example, a stack trace inside
11549 * nested use's would show all calls coming from whoever
11550 * most recently updated PL_compiling.cop_file and
11551 * cop_line. So instead, temporarily set PL_curcop to a
11552 * private copy of &PL_compiling. PL_curcop will soon be
11553 * set to point back to &PL_compiling anyway but only
11554 * after the temp value has been pushed onto the context
11555 * stack as blk_oldcop.
11556 * This is slightly hacky, but necessary. Note also
11557 * that in the brief window before PL_curcop is set back
11558 * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
11559 * will give the wrong answer.
11561 Newx(PL_curcop, 1, COP);
11562 StructCopy(&PL_compiling, PL_curcop, COP);
11563 PL_curcop->op_slabbed = 0;
11564 SAVEFREEPV(PL_curcop);
11567 PUSHSTACKi(PERLSI_REQUIRE);
11568 SAVECOPFILE(&PL_compiling);
11569 SAVECOPLINE(&PL_compiling);
11571 DEBUG_x( dump_sub(gv) );
11572 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11573 GvCV_set(gv,0); /* cv has been hijacked */
11574 call_list(oldscope, PL_beginav);
11578 return !PL_savebegin;
11583 if (*name == 'E') {
11584 if (strEQ(name, "END")) {
11585 DEBUG_x( dump_sub(gv) );
11586 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11589 } else if (*name == 'U') {
11590 if (strEQ(name, "UNITCHECK")) {
11591 /* It's never too late to run a unitcheck block */
11592 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11596 } else if (*name == 'C') {
11597 if (strEQ(name, "CHECK")) {
11599 /* diag_listed_as: Too late to run %s block */
11600 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11601 "Too late to run CHECK block");
11602 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11606 } else if (*name == 'I') {
11607 if (strEQ(name, "INIT")) {
11609 /* diag_listed_as: Too late to run %s block */
11610 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11611 "Too late to run INIT block");
11612 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11618 DEBUG_x( dump_sub(gv) );
11620 GvCV_set(gv,0); /* cv has been hijacked */
11626 =for apidoc newCONSTSUB
11628 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11629 rather than of counted length, and no flags are set. (This means that
11630 C<name> is always interpreted as Latin-1.)
11636 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11638 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11642 =for apidoc newCONSTSUB_flags
11644 Construct a constant subroutine, also performing some surrounding
11645 jobs. A scalar constant-valued subroutine is eligible for inlining
11646 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11647 123 }>>. Other kinds of constant subroutine have other treatment.
11649 The subroutine will have an empty prototype and will ignore any arguments
11650 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11651 is null, the subroutine will yield an empty list. If C<sv> points to a
11652 scalar, the subroutine will always yield that scalar. If C<sv> points
11653 to an array, the subroutine will always yield a list of the elements of
11654 that array in list context, or the number of elements in the array in
11655 scalar context. This function takes ownership of one counted reference
11656 to the scalar or array, and will arrange for the object to live as long
11657 as the subroutine does. If C<sv> points to a scalar then the inlining
11658 assumes that the value of the scalar will never change, so the caller
11659 must ensure that the scalar is not subsequently written to. If C<sv>
11660 points to an array then no such assumption is made, so it is ostensibly
11661 safe to mutate the array or its elements, but whether this is really
11662 supported has not been determined.
11664 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11665 Other aspects of the subroutine will be left in their default state.
11666 The caller is free to mutate the subroutine beyond its initial state
11667 after this function has returned.
11669 If C<name> is null then the subroutine will be anonymous, with its
11670 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11671 subroutine will be named accordingly, referenced by the appropriate glob.
11672 C<name> is a string of length C<len> bytes giving a sigilless symbol
11673 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11674 otherwise. The name may be either qualified or unqualified. If the
11675 name is unqualified then it defaults to being in the stash specified by
11676 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11677 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11680 C<flags> should not have bits set other than C<SVf_UTF8>.
11682 If there is already a subroutine of the specified name, then the new sub
11683 will replace the existing one in the glob. A warning may be generated
11684 about the redefinition.
11686 If the subroutine has one of a few special names, such as C<BEGIN> or
11687 C<END>, then it will be claimed by the appropriate queue for automatic
11688 running of phase-related subroutines. In this case the relevant glob will
11689 be left not containing any subroutine, even if it did contain one before.
11690 Execution of the subroutine will likely be a no-op, unless C<sv> was
11691 a tied array or the caller modified the subroutine in some interesting
11692 way before it was executed. In the case of C<BEGIN>, the treatment is
11693 buggy: the sub will be executed when only half built, and may be deleted
11694 prematurely, possibly causing a crash.
11696 The function returns a pointer to the constructed subroutine. If the sub
11697 is anonymous then ownership of one counted reference to the subroutine
11698 is transferred to the caller. If the sub is named then the caller does
11699 not get ownership of a reference. In most such cases, where the sub
11700 has a non-phase name, the sub will be alive at the point it is returned
11701 by virtue of being contained in the glob that names it. A phase-named
11702 subroutine will usually be alive by virtue of the reference owned by
11703 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11704 destroyed already by the time this function returns, but currently bugs
11705 occur in that case before the caller gets control. It is the caller's
11706 responsibility to ensure that it knows which of these situations applies.
11712 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11716 const char *const file = CopFILE(PL_curcop);
11720 if (IN_PERL_RUNTIME) {
11721 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11722 * an op shared between threads. Use a non-shared COP for our
11724 SAVEVPTR(PL_curcop);
11725 SAVECOMPILEWARNINGS();
11726 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11727 PL_curcop = &PL_compiling;
11729 SAVECOPLINE(PL_curcop);
11730 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11733 PL_hints &= ~HINT_BLOCK_SCOPE;
11736 SAVEGENERICSV(PL_curstash);
11737 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11740 /* Protect sv against leakage caused by fatal warnings. */
11741 if (sv) SAVEFREESV(sv);
11743 /* file becomes the CvFILE. For an XS, it's usually static storage,
11744 and so doesn't get free()d. (It's expected to be from the C pre-
11745 processor __FILE__ directive). But we need a dynamically allocated one,
11746 and we need it to get freed. */
11747 cv = newXS_len_flags(name, len,
11748 sv && SvTYPE(sv) == SVt_PVAV
11751 file ? file : "", "",
11752 &sv, XS_DYNAMIC_FILENAME | flags);
11754 assert(SvREFCNT((SV*)cv) != 0);
11755 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11766 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11767 static storage, as it is used directly as CvFILE(), without a copy being made.
11773 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11775 PERL_ARGS_ASSERT_NEWXS;
11776 return newXS_len_flags(
11777 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11782 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11783 const char *const filename, const char *const proto,
11786 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11787 return newXS_len_flags(
11788 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11793 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11795 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11796 return newXS_len_flags(
11797 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11802 =for apidoc newXS_len_flags
11804 Construct an XS subroutine, also performing some surrounding jobs.
11806 The subroutine will have the entry point C<subaddr>. It will have
11807 the prototype specified by the nul-terminated string C<proto>, or
11808 no prototype if C<proto> is null. The prototype string is copied;
11809 the caller can mutate the supplied string afterwards. If C<filename>
11810 is non-null, it must be a nul-terminated filename, and the subroutine
11811 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11812 point directly to the supplied string, which must be static. If C<flags>
11813 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11816 Other aspects of the subroutine will be left in their default state.
11817 If anything else needs to be done to the subroutine for it to function
11818 correctly, it is the caller's responsibility to do that after this
11819 function has constructed it. However, beware of the subroutine
11820 potentially being destroyed before this function returns, as described
11823 If C<name> is null then the subroutine will be anonymous, with its
11824 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11825 subroutine will be named accordingly, referenced by the appropriate glob.
11826 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11827 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11828 The name may be either qualified or unqualified, with the stash defaulting
11829 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11830 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11831 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11832 the stash if necessary, with C<GV_ADDMULTI> semantics.
11834 If there is already a subroutine of the specified name, then the new sub
11835 will replace the existing one in the glob. A warning may be generated
11836 about the redefinition. If the old subroutine was C<CvCONST> then the
11837 decision about whether to warn is influenced by an expectation about
11838 whether the new subroutine will become a constant of similar value.
11839 That expectation is determined by C<const_svp>. (Note that the call to
11840 this function doesn't make the new subroutine C<CvCONST> in any case;
11841 that is left to the caller.) If C<const_svp> is null then it indicates
11842 that the new subroutine will not become a constant. If C<const_svp>
11843 is non-null then it indicates that the new subroutine will become a
11844 constant, and it points to an C<SV*> that provides the constant value
11845 that the subroutine will have.
11847 If the subroutine has one of a few special names, such as C<BEGIN> or
11848 C<END>, then it will be claimed by the appropriate queue for automatic
11849 running of phase-related subroutines. In this case the relevant glob will
11850 be left not containing any subroutine, even if it did contain one before.
11851 In the case of C<BEGIN>, the subroutine will be executed and the reference
11852 to it disposed of before this function returns, and also before its
11853 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
11854 constructed by this function to be ready for execution then the caller
11855 must prevent this happening by giving the subroutine a different name.
11857 The function returns a pointer to the constructed subroutine. If the sub
11858 is anonymous then ownership of one counted reference to the subroutine
11859 is transferred to the caller. If the sub is named then the caller does
11860 not get ownership of a reference. In most such cases, where the sub
11861 has a non-phase name, the sub will be alive at the point it is returned
11862 by virtue of being contained in the glob that names it. A phase-named
11863 subroutine will usually be alive by virtue of the reference owned by the
11864 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11865 been executed, will quite likely have been destroyed already by the
11866 time this function returns, making it erroneous for the caller to make
11867 any use of the returned pointer. It is the caller's responsibility to
11868 ensure that it knows which of these situations applies.
11874 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11875 XSUBADDR_t subaddr, const char *const filename,
11876 const char *const proto, SV **const_svp,
11880 bool interleave = FALSE;
11881 bool evanescent = FALSE;
11883 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11886 GV * const gv = gv_fetchpvn(
11887 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11888 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11889 sizeof("__ANON__::__ANON__") - 1,
11890 GV_ADDMULTI | flags, SVt_PVCV);
11892 if ((cv = (name ? GvCV(gv) : NULL))) {
11894 /* just a cached method */
11898 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11899 /* already defined (or promised) */
11900 /* Redundant check that allows us to avoid creating an SV
11901 most of the time: */
11902 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11903 report_redefined_cv(newSVpvn_flags(
11904 name,len,(flags&SVf_UTF8)|SVs_TEMP
11915 if (cv) /* must reuse cv if autoloaded */
11918 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11922 if (HvENAME_HEK(GvSTASH(gv)))
11923 gv_method_changed(gv); /* newXS */
11927 assert(SvREFCNT((SV*)cv) != 0);
11931 /* XSUBs can't be perl lang/perl5db.pl debugged
11932 if (PERLDB_LINE_OR_SAVESRC)
11933 (void)gv_fetchfile(filename); */
11934 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11935 if (flags & XS_DYNAMIC_FILENAME) {
11937 CvFILE(cv) = savepv(filename);
11939 /* NOTE: not copied, as it is expected to be an external constant string */
11940 CvFILE(cv) = (char *)filename;
11943 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11944 CvFILE(cv) = (char*)PL_xsubfilename;
11947 CvXSUB(cv) = subaddr;
11948 #ifndef PERL_IMPLICIT_CONTEXT
11949 CvHSCXT(cv) = &PL_stack_sp;
11955 evanescent = process_special_blocks(0, name, gv, cv);
11958 } /* <- not a conditional branch */
11961 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11963 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11964 if (interleave) LEAVE;
11965 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11969 /* Add a stub CV to a typeglob.
11970 * This is the implementation of a forward declaration, 'sub foo';'
11974 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11976 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11978 PERL_ARGS_ASSERT_NEWSTUB;
11979 assert(!GvCVu(gv));
11982 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11983 gv_method_changed(gv);
11985 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11989 CvGV_set(cv, cvgv);
11990 CvFILE_set_from_cop(cv, PL_curcop);
11991 CvSTASH_set(cv, PL_curstash);
11997 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
12004 if (PL_parser && PL_parser->error_count) {
12010 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
12011 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
12014 if ((cv = GvFORM(gv))) {
12015 if (ckWARN(WARN_REDEFINE)) {
12016 const line_t oldline = CopLINE(PL_curcop);
12017 if (PL_parser && PL_parser->copline != NOLINE)
12018 CopLINE_set(PL_curcop, PL_parser->copline);
12020 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12021 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
12023 /* diag_listed_as: Format %s redefined */
12024 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12025 "Format STDOUT redefined");
12027 CopLINE_set(PL_curcop, oldline);
12032 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
12034 CvFILE_set_from_cop(cv, PL_curcop);
12037 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
12039 start = LINKLIST(root);
12041 S_process_optree(aTHX_ cv, root, start);
12042 cv_forget_slab(cv);
12047 PL_parser->copline = NOLINE;
12048 LEAVE_SCOPE(floor);
12049 PL_compiling.cop_seq = 0;
12053 Perl_newANONLIST(pTHX_ OP *o)
12055 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
12059 Perl_newANONHASH(pTHX_ OP *o)
12061 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
12065 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
12067 return newANONATTRSUB(floor, proto, NULL, block);
12071 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
12073 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
12075 newSVOP(OP_ANONCODE, 0,
12077 if (CvANONCONST(cv))
12078 anoncode = newUNOP(OP_ANONCONST, 0,
12079 op_convert_list(OP_ENTERSUB,
12080 OPf_STACKED|OPf_WANT_SCALAR,
12082 return newUNOP(OP_REFGEN, 0, anoncode);
12086 Perl_oopsAV(pTHX_ OP *o)
12090 PERL_ARGS_ASSERT_OOPSAV;
12092 switch (o->op_type) {
12095 OpTYPE_set(o, OP_PADAV);
12096 return ref(o, OP_RV2AV);
12100 OpTYPE_set(o, OP_RV2AV);
12105 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
12112 Perl_oopsHV(pTHX_ OP *o)
12116 PERL_ARGS_ASSERT_OOPSHV;
12118 switch (o->op_type) {
12121 OpTYPE_set(o, OP_PADHV);
12122 return ref(o, OP_RV2HV);
12126 OpTYPE_set(o, OP_RV2HV);
12127 /* rv2hv steals the bottom bit for its own uses */
12128 o->op_private &= ~OPpARG1_MASK;
12133 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
12140 Perl_newAVREF(pTHX_ OP *o)
12144 PERL_ARGS_ASSERT_NEWAVREF;
12146 if (o->op_type == OP_PADANY) {
12147 OpTYPE_set(o, OP_PADAV);
12150 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
12151 Perl_croak(aTHX_ "Can't use an array as a reference");
12153 return newUNOP(OP_RV2AV, 0, scalar(o));
12157 Perl_newGVREF(pTHX_ I32 type, OP *o)
12159 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
12160 return newUNOP(OP_NULL, 0, o);
12161 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
12165 Perl_newHVREF(pTHX_ OP *o)
12169 PERL_ARGS_ASSERT_NEWHVREF;
12171 if (o->op_type == OP_PADANY) {
12172 OpTYPE_set(o, OP_PADHV);
12175 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
12176 Perl_croak(aTHX_ "Can't use a hash as a reference");
12178 return newUNOP(OP_RV2HV, 0, scalar(o));
12182 Perl_newCVREF(pTHX_ I32 flags, OP *o)
12184 if (o->op_type == OP_PADANY) {
12186 OpTYPE_set(o, OP_PADCV);
12188 return newUNOP(OP_RV2CV, flags, scalar(o));
12192 Perl_newSVREF(pTHX_ OP *o)
12196 PERL_ARGS_ASSERT_NEWSVREF;
12198 if (o->op_type == OP_PADANY) {
12199 OpTYPE_set(o, OP_PADSV);
12203 return newUNOP(OP_RV2SV, 0, scalar(o));
12206 /* Check routines. See the comments at the top of this file for details
12207 * on when these are called */
12210 Perl_ck_anoncode(pTHX_ OP *o)
12212 PERL_ARGS_ASSERT_CK_ANONCODE;
12214 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
12215 cSVOPo->op_sv = NULL;
12220 S_io_hints(pTHX_ OP *o)
12222 #if O_BINARY != 0 || O_TEXT != 0
12224 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
12226 SV **svp = hv_fetchs(table, "open_IN", FALSE);
12229 const char *d = SvPV_const(*svp, len);
12230 const I32 mode = mode_from_discipline(d, len);
12231 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12233 if (mode & O_BINARY)
12234 o->op_private |= OPpOPEN_IN_RAW;
12238 o->op_private |= OPpOPEN_IN_CRLF;
12242 svp = hv_fetchs(table, "open_OUT", FALSE);
12245 const char *d = SvPV_const(*svp, len);
12246 const I32 mode = mode_from_discipline(d, len);
12247 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
12249 if (mode & O_BINARY)
12250 o->op_private |= OPpOPEN_OUT_RAW;
12254 o->op_private |= OPpOPEN_OUT_CRLF;
12259 PERL_UNUSED_CONTEXT;
12260 PERL_UNUSED_ARG(o);
12265 Perl_ck_backtick(pTHX_ OP *o)
12270 PERL_ARGS_ASSERT_CK_BACKTICK;
12272 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
12273 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
12274 && (gv = gv_override("readpipe",8)))
12276 /* detach rest of siblings from o and its first child */
12277 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12278 newop = S_new_entersubop(aTHX_ gv, sibl);
12280 else if (!(o->op_flags & OPf_KIDS))
12281 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
12286 S_io_hints(aTHX_ o);
12291 Perl_ck_bitop(pTHX_ OP *o)
12293 PERL_ARGS_ASSERT_CK_BITOP;
12295 o->op_private = (U8)(PL_hints & HINT_INTEGER);
12297 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
12298 && OP_IS_INFIX_BIT(o->op_type))
12300 const OP * const left = cBINOPo->op_first;
12301 const OP * const right = OpSIBLING(left);
12302 if ((OP_IS_NUMCOMPARE(left->op_type) &&
12303 (left->op_flags & OPf_PARENS) == 0) ||
12304 (OP_IS_NUMCOMPARE(right->op_type) &&
12305 (right->op_flags & OPf_PARENS) == 0))
12306 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
12307 "Possible precedence problem on bitwise %s operator",
12308 o->op_type == OP_BIT_OR
12309 ||o->op_type == OP_NBIT_OR ? "|"
12310 : o->op_type == OP_BIT_AND
12311 ||o->op_type == OP_NBIT_AND ? "&"
12312 : o->op_type == OP_BIT_XOR
12313 ||o->op_type == OP_NBIT_XOR ? "^"
12314 : o->op_type == OP_SBIT_OR ? "|."
12315 : o->op_type == OP_SBIT_AND ? "&." : "^."
12321 PERL_STATIC_INLINE bool
12322 is_dollar_bracket(pTHX_ const OP * const o)
12325 PERL_UNUSED_CONTEXT;
12326 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
12327 && (kid = cUNOPx(o)->op_first)
12328 && kid->op_type == OP_GV
12329 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
12332 /* for lt, gt, le, ge, eq, ne and their i_ variants */
12335 Perl_ck_cmp(pTHX_ OP *o)
12341 OP *indexop, *constop, *start;
12345 PERL_ARGS_ASSERT_CK_CMP;
12347 is_eq = ( o->op_type == OP_EQ
12348 || o->op_type == OP_NE
12349 || o->op_type == OP_I_EQ
12350 || o->op_type == OP_I_NE);
12352 if (!is_eq && ckWARN(WARN_SYNTAX)) {
12353 const OP *kid = cUNOPo->op_first;
12356 ( is_dollar_bracket(aTHX_ kid)
12357 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
12359 || ( kid->op_type == OP_CONST
12360 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
12364 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12365 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
12368 /* convert (index(...) == -1) and variations into
12369 * (r)index/BOOL(,NEG)
12374 indexop = cUNOPo->op_first;
12375 constop = OpSIBLING(indexop);
12377 if (indexop->op_type == OP_CONST) {
12379 indexop = OpSIBLING(constop);
12384 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
12387 /* ($lex = index(....)) == -1 */
12388 if (indexop->op_private & OPpTARGET_MY)
12391 if (constop->op_type != OP_CONST)
12394 sv = cSVOPx_sv(constop);
12395 if (!(sv && SvIOK_notUV(sv)))
12399 if (iv != -1 && iv != 0)
12403 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12404 if (!(iv0 ^ reverse))
12408 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12413 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12414 if (!(iv0 ^ reverse))
12418 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12423 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12429 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12435 indexop->op_flags &= ~OPf_PARENS;
12436 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12437 indexop->op_private |= OPpTRUEBOOL;
12439 indexop->op_private |= OPpINDEX_BOOLNEG;
12440 /* cut out the index op and free the eq,const ops */
12441 (void)op_sibling_splice(o, start, 1, NULL);
12449 Perl_ck_concat(pTHX_ OP *o)
12451 const OP * const kid = cUNOPo->op_first;
12453 PERL_ARGS_ASSERT_CK_CONCAT;
12454 PERL_UNUSED_CONTEXT;
12456 /* reuse the padtmp returned by the concat child */
12457 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12458 !(kUNOP->op_first->op_flags & OPf_MOD))
12460 o->op_flags |= OPf_STACKED;
12461 o->op_private |= OPpCONCAT_NESTED;
12467 Perl_ck_spair(pTHX_ OP *o)
12471 PERL_ARGS_ASSERT_CK_SPAIR;
12473 if (o->op_flags & OPf_KIDS) {
12477 const OPCODE type = o->op_type;
12478 o = modkids(ck_fun(o), type);
12479 kid = cUNOPo->op_first;
12480 kidkid = kUNOP->op_first;
12481 newop = OpSIBLING(kidkid);
12483 const OPCODE type = newop->op_type;
12484 if (OpHAS_SIBLING(newop))
12486 if (o->op_type == OP_REFGEN
12487 && ( type == OP_RV2CV
12488 || ( !(newop->op_flags & OPf_PARENS)
12489 && ( type == OP_RV2AV || type == OP_PADAV
12490 || type == OP_RV2HV || type == OP_PADHV))))
12491 NOOP; /* OK (allow srefgen for \@a and \%h) */
12492 else if (OP_GIMME(newop,0) != G_SCALAR)
12495 /* excise first sibling */
12496 op_sibling_splice(kid, NULL, 1, NULL);
12499 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12500 * and OP_CHOMP into OP_SCHOMP */
12501 o->op_ppaddr = PL_ppaddr[++o->op_type];
12506 Perl_ck_delete(pTHX_ OP *o)
12508 PERL_ARGS_ASSERT_CK_DELETE;
12512 if (o->op_flags & OPf_KIDS) {
12513 OP * const kid = cUNOPo->op_first;
12514 switch (kid->op_type) {
12516 o->op_flags |= OPf_SPECIAL;
12519 o->op_private |= OPpSLICE;
12522 o->op_flags |= OPf_SPECIAL;
12527 o->op_flags |= OPf_SPECIAL;
12530 o->op_private |= OPpKVSLICE;
12533 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12534 "element or slice");
12536 if (kid->op_private & OPpLVAL_INTRO)
12537 o->op_private |= OPpLVAL_INTRO;
12544 Perl_ck_eof(pTHX_ OP *o)
12546 PERL_ARGS_ASSERT_CK_EOF;
12548 if (o->op_flags & OPf_KIDS) {
12550 if (cLISTOPo->op_first->op_type == OP_STUB) {
12552 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12557 kid = cLISTOPo->op_first;
12558 if (kid->op_type == OP_RV2GV)
12559 kid->op_private |= OPpALLOW_FAKE;
12566 Perl_ck_eval(pTHX_ OP *o)
12570 PERL_ARGS_ASSERT_CK_EVAL;
12572 PL_hints |= HINT_BLOCK_SCOPE;
12573 if (o->op_flags & OPf_KIDS) {
12574 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12577 if (o->op_type == OP_ENTERTRY) {
12580 /* cut whole sibling chain free from o */
12581 op_sibling_splice(o, NULL, -1, NULL);
12584 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12586 /* establish postfix order */
12587 enter->op_next = (OP*)enter;
12589 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12590 OpTYPE_set(o, OP_LEAVETRY);
12591 enter->op_other = o;
12596 S_set_haseval(aTHX);
12600 const U8 priv = o->op_private;
12602 /* the newUNOP will recursively call ck_eval(), which will handle
12603 * all the stuff at the end of this function, like adding
12606 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12608 o->op_targ = (PADOFFSET)PL_hints;
12609 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12610 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12611 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12612 /* Store a copy of %^H that pp_entereval can pick up. */
12613 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12615 STOREFEATUREBITSHH(hh);
12616 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12617 /* append hhop to only child */
12618 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12620 o->op_private |= OPpEVAL_HAS_HH;
12622 if (!(o->op_private & OPpEVAL_BYTES)
12623 && FEATURE_UNIEVAL_IS_ENABLED)
12624 o->op_private |= OPpEVAL_UNICODE;
12629 Perl_ck_exec(pTHX_ OP *o)
12631 PERL_ARGS_ASSERT_CK_EXEC;
12633 if (o->op_flags & OPf_STACKED) {
12636 kid = OpSIBLING(cUNOPo->op_first);
12637 if (kid->op_type == OP_RV2GV)
12646 Perl_ck_exists(pTHX_ OP *o)
12648 PERL_ARGS_ASSERT_CK_EXISTS;
12651 if (o->op_flags & OPf_KIDS) {
12652 OP * const kid = cUNOPo->op_first;
12653 if (kid->op_type == OP_ENTERSUB) {
12654 (void) ref(kid, o->op_type);
12655 if (kid->op_type != OP_RV2CV
12656 && !(PL_parser && PL_parser->error_count))
12658 "exists argument is not a subroutine name");
12659 o->op_private |= OPpEXISTS_SUB;
12661 else if (kid->op_type == OP_AELEM)
12662 o->op_flags |= OPf_SPECIAL;
12663 else if (kid->op_type != OP_HELEM)
12664 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12665 "element or a subroutine");
12672 Perl_ck_rvconst(pTHX_ OP *o)
12675 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12677 PERL_ARGS_ASSERT_CK_RVCONST;
12679 if (o->op_type == OP_RV2HV)
12680 /* rv2hv steals the bottom bit for its own uses */
12681 o->op_private &= ~OPpARG1_MASK;
12683 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12685 if (kid->op_type == OP_CONST) {
12688 SV * const kidsv = kid->op_sv;
12690 /* Is it a constant from cv_const_sv()? */
12691 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12694 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12695 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12696 const char *badthing;
12697 switch (o->op_type) {
12699 badthing = "a SCALAR";
12702 badthing = "an ARRAY";
12705 badthing = "a HASH";
12713 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12714 SVfARG(kidsv), badthing);
12717 * This is a little tricky. We only want to add the symbol if we
12718 * didn't add it in the lexer. Otherwise we get duplicate strict
12719 * warnings. But if we didn't add it in the lexer, we must at
12720 * least pretend like we wanted to add it even if it existed before,
12721 * or we get possible typo warnings. OPpCONST_ENTERED says
12722 * whether the lexer already added THIS instance of this symbol.
12724 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12725 gv = gv_fetchsv(kidsv,
12726 o->op_type == OP_RV2CV
12727 && o->op_private & OPpMAY_RETURN_CONSTANT
12729 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12732 : o->op_type == OP_RV2SV
12734 : o->op_type == OP_RV2AV
12736 : o->op_type == OP_RV2HV
12743 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12744 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12745 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12747 OpTYPE_set(kid, OP_GV);
12748 SvREFCNT_dec(kid->op_sv);
12749 #ifdef USE_ITHREADS
12750 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12751 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12752 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12753 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12754 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12756 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12758 kid->op_private = 0;
12759 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12767 Perl_ck_ftst(pTHX_ OP *o)
12770 const I32 type = o->op_type;
12772 PERL_ARGS_ASSERT_CK_FTST;
12774 if (o->op_flags & OPf_REF) {
12777 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12778 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12779 const OPCODE kidtype = kid->op_type;
12781 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12782 && !kid->op_folded) {
12783 OP * const newop = newGVOP(type, OPf_REF,
12784 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12789 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12790 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12792 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12793 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12794 array_passed_to_stat, name);
12797 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12798 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12801 scalar((OP *) kid);
12802 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12803 o->op_private |= OPpFT_ACCESS;
12804 if (OP_IS_FILETEST(type)
12805 && OP_IS_FILETEST(kidtype)
12807 o->op_private |= OPpFT_STACKED;
12808 kid->op_private |= OPpFT_STACKING;
12809 if (kidtype == OP_FTTTY && (
12810 !(kid->op_private & OPpFT_STACKED)
12811 || kid->op_private & OPpFT_AFTER_t
12813 o->op_private |= OPpFT_AFTER_t;
12818 if (type == OP_FTTTY)
12819 o = newGVOP(type, OPf_REF, PL_stdingv);
12821 o = newUNOP(type, 0, newDEFSVOP());
12827 Perl_ck_fun(pTHX_ OP *o)
12829 const int type = o->op_type;
12830 I32 oa = PL_opargs[type] >> OASHIFT;
12832 PERL_ARGS_ASSERT_CK_FUN;
12834 if (o->op_flags & OPf_STACKED) {
12835 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12836 oa &= ~OA_OPTIONAL;
12838 return no_fh_allowed(o);
12841 if (o->op_flags & OPf_KIDS) {
12842 OP *prev_kid = NULL;
12843 OP *kid = cLISTOPo->op_first;
12845 bool seen_optional = FALSE;
12847 if (kid->op_type == OP_PUSHMARK ||
12848 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12851 kid = OpSIBLING(kid);
12853 if (kid && kid->op_type == OP_COREARGS) {
12854 bool optional = FALSE;
12857 if (oa & OA_OPTIONAL) optional = TRUE;
12860 if (optional) o->op_private |= numargs;
12865 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12866 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12867 kid = newDEFSVOP();
12868 /* append kid to chain */
12869 op_sibling_splice(o, prev_kid, 0, kid);
12871 seen_optional = TRUE;
12878 /* list seen where single (scalar) arg expected? */
12879 if (numargs == 1 && !(oa >> 4)
12880 && kid->op_type == OP_LIST && type != OP_SCALAR)
12882 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12884 if (type != OP_DELETE) scalar(kid);
12895 if ((type == OP_PUSH || type == OP_UNSHIFT)
12896 && !OpHAS_SIBLING(kid))
12897 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12898 "Useless use of %s with no values",
12901 if (kid->op_type == OP_CONST
12902 && ( !SvROK(cSVOPx_sv(kid))
12903 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
12905 bad_type_pv(numargs, "array", o, kid);
12906 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12907 || kid->op_type == OP_RV2GV) {
12908 bad_type_pv(1, "array", o, kid);
12910 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12911 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12912 PL_op_desc[type]), 0);
12915 op_lvalue(kid, type);
12919 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12920 bad_type_pv(numargs, "hash", o, kid);
12921 op_lvalue(kid, type);
12925 /* replace kid with newop in chain */
12927 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12928 newop->op_next = newop;
12933 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12934 if (kid->op_type == OP_CONST &&
12935 (kid->op_private & OPpCONST_BARE))
12937 OP * const newop = newGVOP(OP_GV, 0,
12938 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
12939 /* replace kid with newop in chain */
12940 op_sibling_splice(o, prev_kid, 1, newop);
12944 else if (kid->op_type == OP_READLINE) {
12945 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12946 bad_type_pv(numargs, "HANDLE", o, kid);
12949 I32 flags = OPf_SPECIAL;
12951 PADOFFSET targ = 0;
12953 /* is this op a FH constructor? */
12954 if (is_handle_constructor(o,numargs)) {
12955 const char *name = NULL;
12958 bool want_dollar = TRUE;
12961 /* Set a flag to tell rv2gv to vivify
12962 * need to "prove" flag does not mean something
12963 * else already - NI-S 1999/05/07
12966 if (kid->op_type == OP_PADSV) {
12968 = PAD_COMPNAME_SV(kid->op_targ);
12969 name = PadnamePV (pn);
12970 len = PadnameLEN(pn);
12971 name_utf8 = PadnameUTF8(pn);
12973 else if (kid->op_type == OP_RV2SV
12974 && kUNOP->op_first->op_type == OP_GV)
12976 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12978 len = GvNAMELEN(gv);
12979 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12981 else if (kid->op_type == OP_AELEM
12982 || kid->op_type == OP_HELEM)
12985 OP *op = ((BINOP*)kid)->op_first;
12989 const char * const a =
12990 kid->op_type == OP_AELEM ?
12992 if (((op->op_type == OP_RV2AV) ||
12993 (op->op_type == OP_RV2HV)) &&
12994 (firstop = ((UNOP*)op)->op_first) &&
12995 (firstop->op_type == OP_GV)) {
12996 /* packagevar $a[] or $h{} */
12997 GV * const gv = cGVOPx_gv(firstop);
13000 Perl_newSVpvf(aTHX_
13005 else if (op->op_type == OP_PADAV
13006 || op->op_type == OP_PADHV) {
13007 /* lexicalvar $a[] or $h{} */
13008 const char * const padname =
13009 PAD_COMPNAME_PV(op->op_targ);
13012 Perl_newSVpvf(aTHX_
13018 name = SvPV_const(tmpstr, len);
13019 name_utf8 = SvUTF8(tmpstr);
13020 sv_2mortal(tmpstr);
13024 name = "__ANONIO__";
13026 want_dollar = FALSE;
13028 op_lvalue(kid, type);
13032 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
13033 namesv = PAD_SVl(targ);
13034 if (want_dollar && *name != '$')
13035 sv_setpvs(namesv, "$");
13038 sv_catpvn(namesv, name, len);
13039 if ( name_utf8 ) SvUTF8_on(namesv);
13043 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
13045 kid->op_targ = targ;
13046 kid->op_private |= priv;
13052 if ((type == OP_UNDEF || type == OP_POS)
13053 && numargs == 1 && !(oa >> 4)
13054 && kid->op_type == OP_LIST)
13055 return too_many_arguments_pv(o,PL_op_desc[type], 0);
13056 op_lvalue(scalar(kid), type);
13061 kid = OpSIBLING(kid);
13063 /* FIXME - should the numargs or-ing move after the too many
13064 * arguments check? */
13065 o->op_private |= numargs;
13067 return too_many_arguments_pv(o,OP_DESC(o), 0);
13070 else if (PL_opargs[type] & OA_DEFGV) {
13071 /* Ordering of these two is important to keep f_map.t passing. */
13073 return newUNOP(type, 0, newDEFSVOP());
13077 while (oa & OA_OPTIONAL)
13079 if (oa && oa != OA_LIST)
13080 return too_few_arguments_pv(o,OP_DESC(o), 0);
13086 Perl_ck_glob(pTHX_ OP *o)
13090 PERL_ARGS_ASSERT_CK_GLOB;
13093 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
13094 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
13096 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
13100 * \ null - const(wildcard)
13105 * \ mark - glob - rv2cv
13106 * | \ gv(CORE::GLOBAL::glob)
13108 * \ null - const(wildcard)
13110 o->op_flags |= OPf_SPECIAL;
13111 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
13112 o = S_new_entersubop(aTHX_ gv, o);
13113 o = newUNOP(OP_NULL, 0, o);
13114 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
13117 else o->op_flags &= ~OPf_SPECIAL;
13118 #if !defined(PERL_EXTERNAL_GLOB)
13119 if (!PL_globhook) {
13121 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
13122 newSVpvs("File::Glob"), NULL, NULL, NULL);
13125 #endif /* !PERL_EXTERNAL_GLOB */
13126 gv = (GV *)newSV(0);
13127 gv_init(gv, 0, "", 0, 0);
13129 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
13130 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
13136 Perl_ck_grep(pTHX_ OP *o)
13140 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
13142 PERL_ARGS_ASSERT_CK_GREP;
13144 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
13146 if (o->op_flags & OPf_STACKED) {
13147 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
13148 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
13149 return no_fh_allowed(o);
13150 o->op_flags &= ~OPf_STACKED;
13152 kid = OpSIBLING(cLISTOPo->op_first);
13153 if (type == OP_MAPWHILE)
13158 if (PL_parser && PL_parser->error_count)
13160 kid = OpSIBLING(cLISTOPo->op_first);
13161 if (kid->op_type != OP_NULL)
13162 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
13163 kid = kUNOP->op_first;
13165 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
13166 kid->op_next = (OP*)gwop;
13167 o->op_private = gwop->op_private = 0;
13168 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
13170 kid = OpSIBLING(cLISTOPo->op_first);
13171 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
13172 op_lvalue(kid, OP_GREPSTART);
13178 Perl_ck_index(pTHX_ OP *o)
13180 PERL_ARGS_ASSERT_CK_INDEX;
13182 if (o->op_flags & OPf_KIDS) {
13183 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13185 kid = OpSIBLING(kid); /* get past "big" */
13186 if (kid && kid->op_type == OP_CONST) {
13187 const bool save_taint = TAINT_get;
13188 SV *sv = kSVOP->op_sv;
13189 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
13190 && SvOK(sv) && !SvROK(sv))
13193 sv_copypv(sv, kSVOP->op_sv);
13194 SvREFCNT_dec_NN(kSVOP->op_sv);
13197 if (SvOK(sv)) fbm_compile(sv, 0);
13198 TAINT_set(save_taint);
13199 #ifdef NO_TAINT_SUPPORT
13200 PERL_UNUSED_VAR(save_taint);
13208 Perl_ck_lfun(pTHX_ OP *o)
13210 const OPCODE type = o->op_type;
13212 PERL_ARGS_ASSERT_CK_LFUN;
13214 return modkids(ck_fun(o), type);
13218 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
13220 PERL_ARGS_ASSERT_CK_DEFINED;
13222 if ((o->op_flags & OPf_KIDS)) {
13223 switch (cUNOPo->op_first->op_type) {
13226 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
13227 " (Maybe you should just omit the defined()?)");
13228 NOT_REACHED; /* NOTREACHED */
13232 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
13233 " (Maybe you should just omit the defined()?)");
13234 NOT_REACHED; /* NOTREACHED */
13245 Perl_ck_readline(pTHX_ OP *o)
13247 PERL_ARGS_ASSERT_CK_READLINE;
13249 if (o->op_flags & OPf_KIDS) {
13250 OP *kid = cLISTOPo->op_first;
13251 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13256 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
13264 Perl_ck_rfun(pTHX_ OP *o)
13266 const OPCODE type = o->op_type;
13268 PERL_ARGS_ASSERT_CK_RFUN;
13270 return refkids(ck_fun(o), type);
13274 Perl_ck_listiob(pTHX_ OP *o)
13278 PERL_ARGS_ASSERT_CK_LISTIOB;
13280 kid = cLISTOPo->op_first;
13282 o = force_list(o, 1);
13283 kid = cLISTOPo->op_first;
13285 if (kid->op_type == OP_PUSHMARK)
13286 kid = OpSIBLING(kid);
13287 if (kid && o->op_flags & OPf_STACKED)
13288 kid = OpSIBLING(kid);
13289 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
13290 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
13291 && !kid->op_folded) {
13292 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13294 /* replace old const op with new OP_RV2GV parent */
13295 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13296 OP_RV2GV, OPf_REF);
13297 kid = OpSIBLING(kid);
13302 op_append_elem(o->op_type, o, newDEFSVOP());
13304 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13305 return listkids(o);
13309 Perl_ck_smartmatch(pTHX_ OP *o)
13312 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13313 if (0 == (o->op_flags & OPf_SPECIAL)) {
13314 OP *first = cBINOPo->op_first;
13315 OP *second = OpSIBLING(first);
13317 /* Implicitly take a reference to an array or hash */
13319 /* remove the original two siblings, then add back the
13320 * (possibly different) first and second sibs.
13322 op_sibling_splice(o, NULL, 1, NULL);
13323 op_sibling_splice(o, NULL, 1, NULL);
13324 first = ref_array_or_hash(first);
13325 second = ref_array_or_hash(second);
13326 op_sibling_splice(o, NULL, 0, second);
13327 op_sibling_splice(o, NULL, 0, first);
13329 /* Implicitly take a reference to a regular expression */
13330 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13331 OpTYPE_set(first, OP_QR);
13333 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13334 OpTYPE_set(second, OP_QR);
13343 S_maybe_targlex(pTHX_ OP *o)
13345 OP * const kid = cLISTOPo->op_first;
13346 /* has a disposable target? */
13347 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13348 && !(kid->op_flags & OPf_STACKED)
13349 /* Cannot steal the second time! */
13350 && !(kid->op_private & OPpTARGET_MY)
13353 OP * const kkid = OpSIBLING(kid);
13355 /* Can just relocate the target. */
13356 if (kkid && kkid->op_type == OP_PADSV
13357 && (!(kkid->op_private & OPpLVAL_INTRO)
13358 || kkid->op_private & OPpPAD_STATE))
13360 kid->op_targ = kkid->op_targ;
13362 /* Now we do not need PADSV and SASSIGN.
13363 * Detach kid and free the rest. */
13364 op_sibling_splice(o, NULL, 1, NULL);
13366 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13374 Perl_ck_sassign(pTHX_ OP *o)
13377 OP * const kid = cBINOPo->op_first;
13379 PERL_ARGS_ASSERT_CK_SASSIGN;
13381 if (OpHAS_SIBLING(kid)) {
13382 OP *kkid = OpSIBLING(kid);
13383 /* For state variable assignment with attributes, kkid is a list op
13384 whose op_last is a padsv. */
13385 if ((kkid->op_type == OP_PADSV ||
13386 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13387 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13390 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13391 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13392 return S_newONCEOP(aTHX_ o, kkid);
13395 return S_maybe_targlex(aTHX_ o);
13400 Perl_ck_match(pTHX_ OP *o)
13402 PERL_UNUSED_CONTEXT;
13403 PERL_ARGS_ASSERT_CK_MATCH;
13409 Perl_ck_method(pTHX_ OP *o)
13411 SV *sv, *methsv, *rclass;
13412 const char* method;
13415 STRLEN len, nsplit = 0, i;
13417 OP * const kid = cUNOPo->op_first;
13419 PERL_ARGS_ASSERT_CK_METHOD;
13420 if (kid->op_type != OP_CONST) return o;
13424 /* replace ' with :: */
13425 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13426 SvEND(sv) - SvPVX(sv) )))
13429 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13432 method = SvPVX_const(sv);
13434 utf8 = SvUTF8(sv) ? -1 : 1;
13436 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13441 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13443 if (!nsplit) { /* $proto->method() */
13445 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13448 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13450 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13453 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13454 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13455 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13456 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13458 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13459 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13461 #ifdef USE_ITHREADS
13462 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13464 cMETHOPx(new_op)->op_rclass_sv = rclass;
13471 Perl_ck_null(pTHX_ OP *o)
13473 PERL_ARGS_ASSERT_CK_NULL;
13474 PERL_UNUSED_CONTEXT;
13479 Perl_ck_open(pTHX_ OP *o)
13481 PERL_ARGS_ASSERT_CK_OPEN;
13483 S_io_hints(aTHX_ o);
13485 /* In case of three-arg dup open remove strictness
13486 * from the last arg if it is a bareword. */
13487 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13488 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13492 if ((last->op_type == OP_CONST) && /* The bareword. */
13493 (last->op_private & OPpCONST_BARE) &&
13494 (last->op_private & OPpCONST_STRICT) &&
13495 (oa = OpSIBLING(first)) && /* The fh. */
13496 (oa = OpSIBLING(oa)) && /* The mode. */
13497 (oa->op_type == OP_CONST) &&
13498 SvPOK(((SVOP*)oa)->op_sv) &&
13499 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
13500 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13501 (last == OpSIBLING(oa))) /* The bareword. */
13502 last->op_private &= ~OPpCONST_STRICT;
13508 Perl_ck_prototype(pTHX_ OP *o)
13510 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13511 if (!(o->op_flags & OPf_KIDS)) {
13513 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13519 Perl_ck_refassign(pTHX_ OP *o)
13521 OP * const right = cLISTOPo->op_first;
13522 OP * const left = OpSIBLING(right);
13523 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13526 PERL_ARGS_ASSERT_CK_REFASSIGN;
13528 assert (left->op_type == OP_SREFGEN);
13531 /* we use OPpPAD_STATE in refassign to mean either of those things,
13532 * and the code assumes the two flags occupy the same bit position
13533 * in the various ops below */
13534 assert(OPpPAD_STATE == OPpOUR_INTRO);
13536 switch (varop->op_type) {
13538 o->op_private |= OPpLVREF_AV;
13541 o->op_private |= OPpLVREF_HV;
13545 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13546 o->op_targ = varop->op_targ;
13547 varop->op_targ = 0;
13548 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13552 o->op_private |= OPpLVREF_AV;
13554 NOT_REACHED; /* NOTREACHED */
13556 o->op_private |= OPpLVREF_HV;
13560 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13561 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13563 /* Point varop to its GV kid, detached. */
13564 varop = op_sibling_splice(varop, NULL, -1, NULL);
13568 OP * const kidparent =
13569 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13570 OP * const kid = cUNOPx(kidparent)->op_first;
13571 o->op_private |= OPpLVREF_CV;
13572 if (kid->op_type == OP_GV) {
13573 SV *sv = (SV*)cGVOPx_gv(kid);
13575 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13576 /* a CVREF here confuses pp_refassign, so make sure
13578 CV *const cv = (CV*)SvRV(sv);
13579 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
13580 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13581 assert(SvTYPE(sv) == SVt_PVGV);
13583 goto detach_and_stack;
13585 if (kid->op_type != OP_PADCV) goto bad;
13586 o->op_targ = kid->op_targ;
13592 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13593 o->op_private |= OPpLVREF_ELEM;
13596 /* Detach varop. */
13597 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13601 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13602 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13607 if (!FEATURE_REFALIASING_IS_ENABLED)
13609 "Experimental aliasing via reference not enabled");
13610 Perl_ck_warner_d(aTHX_
13611 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13612 "Aliasing via reference is experimental");
13614 o->op_flags |= OPf_STACKED;
13615 op_sibling_splice(o, right, 1, varop);
13618 o->op_flags &=~ OPf_STACKED;
13619 op_sibling_splice(o, right, 1, NULL);
13626 Perl_ck_repeat(pTHX_ OP *o)
13628 PERL_ARGS_ASSERT_CK_REPEAT;
13630 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13632 o->op_private |= OPpREPEAT_DOLIST;
13633 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13634 kids = force_list(kids, 1); /* promote it to a list */
13635 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13643 Perl_ck_require(pTHX_ OP *o)
13647 PERL_ARGS_ASSERT_CK_REQUIRE;
13649 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13650 SVOP * const kid = (SVOP*)cUNOPo->op_first;
13654 if (kid->op_type == OP_CONST) {
13655 SV * const sv = kid->op_sv;
13656 U32 const was_readonly = SvREADONLY(sv);
13657 if (kid->op_private & OPpCONST_BARE) {
13662 if (was_readonly) {
13663 SvREADONLY_off(sv);
13666 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13671 /* treat ::foo::bar as foo::bar */
13672 if (len >= 2 && s[0] == ':' && s[1] == ':')
13673 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13675 DIE(aTHX_ "Bareword in require maps to empty filename");
13677 for (; s < end; s++) {
13678 if (*s == ':' && s[1] == ':') {
13680 Move(s+2, s+1, end - s - 1, char);
13684 SvEND_set(sv, end);
13685 sv_catpvs(sv, ".pm");
13686 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13687 hek = share_hek(SvPVX(sv),
13688 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13690 sv_sethek(sv, hek);
13692 SvFLAGS(sv) |= was_readonly;
13694 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13697 if (SvREFCNT(sv) > 1) {
13698 kid->op_sv = newSVpvn_share(
13699 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13700 SvREFCNT_dec_NN(sv);
13705 if (was_readonly) SvREADONLY_off(sv);
13706 PERL_HASH(hash, s, len);
13708 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13710 sv_sethek(sv, hek);
13712 SvFLAGS(sv) |= was_readonly;
13718 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13719 /* handle override, if any */
13720 && (gv = gv_override("require", 7))) {
13722 if (o->op_flags & OPf_KIDS) {
13723 kid = cUNOPo->op_first;
13724 op_sibling_splice(o, NULL, -1, NULL);
13727 kid = newDEFSVOP();
13730 newop = S_new_entersubop(aTHX_ gv, kid);
13738 Perl_ck_return(pTHX_ OP *o)
13742 PERL_ARGS_ASSERT_CK_RETURN;
13744 kid = OpSIBLING(cLISTOPo->op_first);
13745 if (PL_compcv && CvLVALUE(PL_compcv)) {
13746 for (; kid; kid = OpSIBLING(kid))
13747 op_lvalue(kid, OP_LEAVESUBLV);
13754 Perl_ck_select(pTHX_ OP *o)
13759 PERL_ARGS_ASSERT_CK_SELECT;
13761 if (o->op_flags & OPf_KIDS) {
13762 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13763 if (kid && OpHAS_SIBLING(kid)) {
13764 OpTYPE_set(o, OP_SSELECT);
13766 return fold_constants(op_integerize(op_std_init(o)));
13770 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13771 if (kid && kid->op_type == OP_RV2GV)
13772 kid->op_private &= ~HINT_STRICT_REFS;
13777 Perl_ck_shift(pTHX_ OP *o)
13779 const I32 type = o->op_type;
13781 PERL_ARGS_ASSERT_CK_SHIFT;
13783 if (!(o->op_flags & OPf_KIDS)) {
13786 if (!CvUNIQUE(PL_compcv)) {
13787 o->op_flags |= OPf_SPECIAL;
13791 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13793 return newUNOP(type, 0, scalar(argop));
13795 return scalar(ck_fun(o));
13799 Perl_ck_sort(pTHX_ OP *o)
13803 HV * const hinthv =
13804 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13807 PERL_ARGS_ASSERT_CK_SORT;
13810 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13812 const I32 sorthints = (I32)SvIV(*svp);
13813 if ((sorthints & HINT_SORT_STABLE) != 0)
13814 o->op_private |= OPpSORT_STABLE;
13815 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13816 o->op_private |= OPpSORT_UNSTABLE;
13820 if (o->op_flags & OPf_STACKED)
13822 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13824 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13825 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13827 /* if the first arg is a code block, process it and mark sort as
13829 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13831 if (kid->op_type == OP_LEAVE)
13832 op_null(kid); /* wipe out leave */
13833 /* Prevent execution from escaping out of the sort block. */
13836 /* provide scalar context for comparison function/block */
13837 kid = scalar(firstkid);
13838 kid->op_next = kid;
13839 o->op_flags |= OPf_SPECIAL;
13841 else if (kid->op_type == OP_CONST
13842 && kid->op_private & OPpCONST_BARE) {
13846 const char * const name = SvPV(kSVOP_sv, len);
13848 assert (len < 256);
13849 Copy(name, tmpbuf+1, len, char);
13850 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13851 if (off != NOT_IN_PAD) {
13852 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13854 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13855 sv_catpvs(fq, "::");
13856 sv_catsv(fq, kSVOP_sv);
13857 SvREFCNT_dec_NN(kSVOP_sv);
13861 OP * const padop = newOP(OP_PADCV, 0);
13862 padop->op_targ = off;
13863 /* replace the const op with the pad op */
13864 op_sibling_splice(firstkid, NULL, 1, padop);
13870 firstkid = OpSIBLING(firstkid);
13873 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13874 /* provide list context for arguments */
13877 op_lvalue(kid, OP_GREPSTART);
13883 /* for sort { X } ..., where X is one of
13884 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13885 * elide the second child of the sort (the one containing X),
13886 * and set these flags as appropriate
13890 * Also, check and warn on lexical $a, $b.
13894 S_simplify_sort(pTHX_ OP *o)
13896 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13900 const char *gvname;
13903 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13905 kid = kUNOP->op_first; /* get past null */
13906 if (!(have_scopeop = kid->op_type == OP_SCOPE)
13907 && kid->op_type != OP_LEAVE)
13909 kid = kLISTOP->op_last; /* get past scope */
13910 switch(kid->op_type) {
13914 if (!have_scopeop) goto padkids;
13919 k = kid; /* remember this node*/
13920 if (kBINOP->op_first->op_type != OP_RV2SV
13921 || kBINOP->op_last ->op_type != OP_RV2SV)
13924 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13925 then used in a comparison. This catches most, but not
13926 all cases. For instance, it catches
13927 sort { my($a); $a <=> $b }
13929 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13930 (although why you'd do that is anyone's guess).
13934 if (!ckWARN(WARN_SYNTAX)) return;
13935 kid = kBINOP->op_first;
13937 if (kid->op_type == OP_PADSV) {
13938 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13939 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13940 && ( PadnamePV(name)[1] == 'a'
13941 || PadnamePV(name)[1] == 'b' ))
13942 /* diag_listed_as: "my %s" used in sort comparison */
13943 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13944 "\"%s %s\" used in sort comparison",
13945 PadnameIsSTATE(name)
13950 } while ((kid = OpSIBLING(kid)));
13953 kid = kBINOP->op_first; /* get past cmp */
13954 if (kUNOP->op_first->op_type != OP_GV)
13956 kid = kUNOP->op_first; /* get past rv2sv */
13958 if (GvSTASH(gv) != PL_curstash)
13960 gvname = GvNAME(gv);
13961 if (*gvname == 'a' && gvname[1] == '\0')
13963 else if (*gvname == 'b' && gvname[1] == '\0')
13968 kid = k; /* back to cmp */
13969 /* already checked above that it is rv2sv */
13970 kid = kBINOP->op_last; /* down to 2nd arg */
13971 if (kUNOP->op_first->op_type != OP_GV)
13973 kid = kUNOP->op_first; /* get past rv2sv */
13975 if (GvSTASH(gv) != PL_curstash)
13977 gvname = GvNAME(gv);
13979 ? !(*gvname == 'a' && gvname[1] == '\0')
13980 : !(*gvname == 'b' && gvname[1] == '\0'))
13982 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13984 o->op_private |= OPpSORT_DESCEND;
13985 if (k->op_type == OP_NCMP)
13986 o->op_private |= OPpSORT_NUMERIC;
13987 if (k->op_type == OP_I_NCMP)
13988 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13989 kid = OpSIBLING(cLISTOPo->op_first);
13990 /* cut out and delete old block (second sibling) */
13991 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13996 Perl_ck_split(pTHX_ OP *o)
14002 PERL_ARGS_ASSERT_CK_SPLIT;
14004 assert(o->op_type == OP_LIST);
14006 if (o->op_flags & OPf_STACKED)
14007 return no_fh_allowed(o);
14009 kid = cLISTOPo->op_first;
14010 /* delete leading NULL node, then add a CONST if no other nodes */
14011 assert(kid->op_type == OP_NULL);
14012 op_sibling_splice(o, NULL, 1,
14013 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
14015 kid = cLISTOPo->op_first;
14017 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
14018 /* remove match expression, and replace with new optree with
14019 * a match op at its head */
14020 op_sibling_splice(o, NULL, 1, NULL);
14021 /* pmruntime will handle split " " behavior with flag==2 */
14022 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
14023 op_sibling_splice(o, NULL, 0, kid);
14026 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
14028 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
14029 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
14030 "Use of /g modifier is meaningless in split");
14033 /* eliminate the split op, and move the match op (plus any children)
14034 * into its place, then convert the match op into a split op. i.e.
14036 * SPLIT MATCH SPLIT(ex-MATCH)
14038 * MATCH - A - B - C => R - A - B - C => R - A - B - C
14044 * (R, if it exists, will be a regcomp op)
14047 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
14048 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
14049 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
14050 OpTYPE_set(kid, OP_SPLIT);
14051 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
14052 kid->op_private = o->op_private;
14055 kid = sibs; /* kid is now the string arg of the split */
14058 kid = newDEFSVOP();
14059 op_append_elem(OP_SPLIT, o, kid);
14063 kid = OpSIBLING(kid);
14065 kid = newSVOP(OP_CONST, 0, newSViv(0));
14066 op_append_elem(OP_SPLIT, o, kid);
14067 o->op_private |= OPpSPLIT_IMPLIM;
14071 if (OpHAS_SIBLING(kid))
14072 return too_many_arguments_pv(o,OP_DESC(o), 0);
14078 Perl_ck_stringify(pTHX_ OP *o)
14080 OP * const kid = OpSIBLING(cUNOPo->op_first);
14081 PERL_ARGS_ASSERT_CK_STRINGIFY;
14082 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
14083 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
14084 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
14085 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
14087 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
14095 Perl_ck_join(pTHX_ OP *o)
14097 OP * const kid = OpSIBLING(cLISTOPo->op_first);
14099 PERL_ARGS_ASSERT_CK_JOIN;
14101 if (kid && kid->op_type == OP_MATCH) {
14102 if (ckWARN(WARN_SYNTAX)) {
14103 const REGEXP *re = PM_GETRE(kPMOP);
14105 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
14106 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
14107 : newSVpvs_flags( "STRING", SVs_TEMP );
14108 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14109 "/%" SVf "/ should probably be written as \"%" SVf "\"",
14110 SVfARG(msg), SVfARG(msg));
14114 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
14115 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
14116 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
14117 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
14119 const OP * const bairn = OpSIBLING(kid); /* the list */
14120 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
14121 && OP_GIMME(bairn,0) == G_SCALAR)
14123 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
14124 op_sibling_splice(o, kid, 1, NULL));
14134 =for apidoc rv2cv_op_cv
14136 Examines an op, which is expected to identify a subroutine at runtime,
14137 and attempts to determine at compile time which subroutine it identifies.
14138 This is normally used during Perl compilation to determine whether
14139 a prototype can be applied to a function call. C<cvop> is the op
14140 being considered, normally an C<rv2cv> op. A pointer to the identified
14141 subroutine is returned, if it could be determined statically, and a null
14142 pointer is returned if it was not possible to determine statically.
14144 Currently, the subroutine can be identified statically if the RV that the
14145 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
14146 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
14147 suitable if the constant value must be an RV pointing to a CV. Details of
14148 this process may change in future versions of Perl. If the C<rv2cv> op
14149 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
14150 the subroutine statically: this flag is used to suppress compile-time
14151 magic on a subroutine call, forcing it to use default runtime behaviour.
14153 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
14154 of a GV reference is modified. If a GV was examined and its CV slot was
14155 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
14156 If the op is not optimised away, and the CV slot is later populated with
14157 a subroutine having a prototype, that flag eventually triggers the warning
14158 "called too early to check prototype".
14160 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
14161 of returning a pointer to the subroutine it returns a pointer to the
14162 GV giving the most appropriate name for the subroutine in this context.
14163 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
14164 (C<CvANON>) subroutine that is referenced through a GV it will be the
14165 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
14166 A null pointer is returned as usual if there is no statically-determinable
14169 =for apidoc Amnh||OPpEARLY_CV
14170 =for apidoc Amnh||OPpENTERSUB_AMPER
14171 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
14172 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
14177 /* shared by toke.c:yylex */
14179 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
14181 PADNAME *name = PAD_COMPNAME(off);
14182 CV *compcv = PL_compcv;
14183 while (PadnameOUTER(name)) {
14184 assert(PARENT_PAD_INDEX(name));
14185 compcv = CvOUTSIDE(compcv);
14186 name = PadlistNAMESARRAY(CvPADLIST(compcv))
14187 [off = PARENT_PAD_INDEX(name)];
14189 assert(!PadnameIsOUR(name));
14190 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
14191 return PadnamePROTOCV(name);
14193 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
14197 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
14202 PERL_ARGS_ASSERT_RV2CV_OP_CV;
14203 if (flags & ~RV2CVOPCV_FLAG_MASK)
14204 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
14205 if (cvop->op_type != OP_RV2CV)
14207 if (cvop->op_private & OPpENTERSUB_AMPER)
14209 if (!(cvop->op_flags & OPf_KIDS))
14211 rvop = cUNOPx(cvop)->op_first;
14212 switch (rvop->op_type) {
14214 gv = cGVOPx_gv(rvop);
14216 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
14217 cv = MUTABLE_CV(SvRV(gv));
14221 if (flags & RV2CVOPCV_RETURN_STUB)
14227 if (flags & RV2CVOPCV_MARK_EARLY)
14228 rvop->op_private |= OPpEARLY_CV;
14233 SV *rv = cSVOPx_sv(rvop);
14236 cv = (CV*)SvRV(rv);
14240 cv = find_lexical_cv(rvop->op_targ);
14245 } NOT_REACHED; /* NOTREACHED */
14247 if (SvTYPE((SV*)cv) != SVt_PVCV)
14249 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
14250 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
14254 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
14255 if (CvLEXICAL(cv) || CvNAMED(cv))
14257 if (!CvANON(cv) || !gv)
14267 =for apidoc ck_entersub_args_list
14269 Performs the default fixup of the arguments part of an C<entersub>
14270 op tree. This consists of applying list context to each of the
14271 argument ops. This is the standard treatment used on a call marked
14272 with C<&>, or a method call, or a call through a subroutine reference,
14273 or any other call where the callee can't be identified at compile time,
14274 or a call where the callee has no prototype.
14280 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14284 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14286 aop = cUNOPx(entersubop)->op_first;
14287 if (!OpHAS_SIBLING(aop))
14288 aop = cUNOPx(aop)->op_first;
14289 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14290 /* skip the extra attributes->import() call implicitly added in
14291 * something like foo(my $x : bar)
14293 if ( aop->op_type == OP_ENTERSUB
14294 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14298 op_lvalue(aop, OP_ENTERSUB);
14304 =for apidoc ck_entersub_args_proto
14306 Performs the fixup of the arguments part of an C<entersub> op tree
14307 based on a subroutine prototype. This makes various modifications to
14308 the argument ops, from applying context up to inserting C<refgen> ops,
14309 and checking the number and syntactic types of arguments, as directed by
14310 the prototype. This is the standard treatment used on a subroutine call,
14311 not marked with C<&>, where the callee can be identified at compile time
14312 and has a prototype.
14314 C<protosv> supplies the subroutine prototype to be applied to the call.
14315 It may be a normal defined scalar, of which the string value will be used.
14316 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14317 that has been cast to C<SV*>) which has a prototype. The prototype
14318 supplied, in whichever form, does not need to match the actual callee
14319 referenced by the op tree.
14321 If the argument ops disagree with the prototype, for example by having
14322 an unacceptable number of arguments, a valid op tree is returned anyway.
14323 The error is reflected in the parser state, normally resulting in a single
14324 exception at the top level of parsing which covers all the compilation
14325 errors that occurred. In the error message, the callee is referred to
14326 by the name defined by the C<namegv> parameter.
14332 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14335 const char *proto, *proto_end;
14336 OP *aop, *prev, *cvop, *parent;
14339 I32 contextclass = 0;
14340 const char *e = NULL;
14341 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14342 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14343 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14344 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14345 if (SvTYPE(protosv) == SVt_PVCV)
14346 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14347 else proto = SvPV(protosv, proto_len);
14348 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14349 proto_end = proto + proto_len;
14350 parent = entersubop;
14351 aop = cUNOPx(entersubop)->op_first;
14352 if (!OpHAS_SIBLING(aop)) {
14354 aop = cUNOPx(aop)->op_first;
14357 aop = OpSIBLING(aop);
14358 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14359 while (aop != cvop) {
14362 if (proto >= proto_end)
14364 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14365 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14366 SVfARG(namesv)), SvUTF8(namesv));
14376 /* _ must be at the end */
14377 if (proto[1] && !memCHRs(";@%", proto[1]))
14393 if ( o3->op_type != OP_UNDEF
14394 && (o3->op_type != OP_SREFGEN
14395 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14397 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14399 bad_type_gv(arg, namegv, o3,
14400 arg == 1 ? "block or sub {}" : "sub {}");
14403 /* '*' allows any scalar type, including bareword */
14406 if (o3->op_type == OP_RV2GV)
14407 goto wrapref; /* autoconvert GLOB -> GLOBref */
14408 else if (o3->op_type == OP_CONST)
14409 o3->op_private &= ~OPpCONST_STRICT;
14415 if (o3->op_type == OP_RV2AV ||
14416 o3->op_type == OP_PADAV ||
14417 o3->op_type == OP_RV2HV ||
14418 o3->op_type == OP_PADHV
14424 case '[': case ']':
14431 switch (*proto++) {
14433 if (contextclass++ == 0) {
14434 e = (char *) memchr(proto, ']', proto_end - proto);
14435 if (!e || e == proto)
14443 if (contextclass) {
14444 const char *p = proto;
14445 const char *const end = proto;
14447 while (*--p != '[')
14448 /* \[$] accepts any scalar lvalue */
14450 && Perl_op_lvalue_flags(aTHX_
14452 OP_READ, /* not entersub */
14455 bad_type_gv(arg, namegv, o3,
14456 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14461 if (o3->op_type == OP_RV2GV)
14464 bad_type_gv(arg, namegv, o3, "symbol");
14467 if (o3->op_type == OP_ENTERSUB
14468 && !(o3->op_flags & OPf_STACKED))
14471 bad_type_gv(arg, namegv, o3, "subroutine");
14474 if (o3->op_type == OP_RV2SV ||
14475 o3->op_type == OP_PADSV ||
14476 o3->op_type == OP_HELEM ||
14477 o3->op_type == OP_AELEM)
14479 if (!contextclass) {
14480 /* \$ accepts any scalar lvalue */
14481 if (Perl_op_lvalue_flags(aTHX_
14483 OP_READ, /* not entersub */
14486 bad_type_gv(arg, namegv, o3, "scalar");
14490 if (o3->op_type == OP_RV2AV ||
14491 o3->op_type == OP_PADAV)
14493 o3->op_flags &=~ OPf_PARENS;
14497 bad_type_gv(arg, namegv, o3, "array");
14500 if (o3->op_type == OP_RV2HV ||
14501 o3->op_type == OP_PADHV)
14503 o3->op_flags &=~ OPf_PARENS;
14507 bad_type_gv(arg, namegv, o3, "hash");
14510 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14512 if (contextclass && e) {
14517 default: goto oops;
14527 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14528 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14533 op_lvalue(aop, OP_ENTERSUB);
14535 aop = OpSIBLING(aop);
14537 if (aop == cvop && *proto == '_') {
14538 /* generate an access to $_ */
14539 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14541 if (!optional && proto_end > proto &&
14542 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14544 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14545 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14546 SVfARG(namesv)), SvUTF8(namesv));
14552 =for apidoc ck_entersub_args_proto_or_list
14554 Performs the fixup of the arguments part of an C<entersub> op tree either
14555 based on a subroutine prototype or using default list-context processing.
14556 This is the standard treatment used on a subroutine call, not marked
14557 with C<&>, where the callee can be identified at compile time.
14559 C<protosv> supplies the subroutine prototype to be applied to the call,
14560 or indicates that there is no prototype. It may be a normal scalar,
14561 in which case if it is defined then the string value will be used
14562 as a prototype, and if it is undefined then there is no prototype.
14563 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14564 that has been cast to C<SV*>), of which the prototype will be used if it
14565 has one. The prototype (or lack thereof) supplied, in whichever form,
14566 does not need to match the actual callee referenced by the op tree.
14568 If the argument ops disagree with the prototype, for example by having
14569 an unacceptable number of arguments, a valid op tree is returned anyway.
14570 The error is reflected in the parser state, normally resulting in a single
14571 exception at the top level of parsing which covers all the compilation
14572 errors that occurred. In the error message, the callee is referred to
14573 by the name defined by the C<namegv> parameter.
14579 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14580 GV *namegv, SV *protosv)
14582 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14583 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14584 return ck_entersub_args_proto(entersubop, namegv, protosv);
14586 return ck_entersub_args_list(entersubop);
14590 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14592 IV cvflags = SvIVX(protosv);
14593 int opnum = cvflags & 0xffff;
14594 OP *aop = cUNOPx(entersubop)->op_first;
14596 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14600 if (!OpHAS_SIBLING(aop))
14601 aop = cUNOPx(aop)->op_first;
14602 aop = OpSIBLING(aop);
14603 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14605 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14606 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14607 SVfARG(namesv)), SvUTF8(namesv));
14610 op_free(entersubop);
14611 switch(cvflags >> 16) {
14612 case 'F': return newSVOP(OP_CONST, 0,
14613 newSVpv(CopFILE(PL_curcop),0));
14614 case 'L': return newSVOP(
14616 Perl_newSVpvf(aTHX_
14617 "%" IVdf, (IV)CopLINE(PL_curcop)
14620 case 'P': return newSVOP(OP_CONST, 0,
14622 ? newSVhek(HvNAME_HEK(PL_curstash))
14627 NOT_REACHED; /* NOTREACHED */
14630 OP *prev, *cvop, *first, *parent;
14633 parent = entersubop;
14634 if (!OpHAS_SIBLING(aop)) {
14636 aop = cUNOPx(aop)->op_first;
14639 first = prev = aop;
14640 aop = OpSIBLING(aop);
14641 /* find last sibling */
14643 OpHAS_SIBLING(cvop);
14644 prev = cvop, cvop = OpSIBLING(cvop))
14646 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14647 /* Usually, OPf_SPECIAL on an op with no args means that it had
14648 * parens, but these have their own meaning for that flag: */
14649 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14650 && opnum != OP_DELETE && opnum != OP_EXISTS)
14651 flags |= OPf_SPECIAL;
14652 /* excise cvop from end of sibling chain */
14653 op_sibling_splice(parent, prev, 1, NULL);
14655 if (aop == cvop) aop = NULL;
14657 /* detach remaining siblings from the first sibling, then
14658 * dispose of original optree */
14661 op_sibling_splice(parent, first, -1, NULL);
14662 op_free(entersubop);
14664 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14665 flags |= OPpEVAL_BYTES <<8;
14667 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14669 case OA_BASEOP_OR_UNOP:
14670 case OA_FILESTATOP:
14672 return newOP(opnum,flags); /* zero args */
14674 return newUNOP(opnum,flags,aop); /* one arg */
14675 /* too many args */
14682 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14683 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14684 SVfARG(namesv)), SvUTF8(namesv));
14686 nextop = OpSIBLING(aop);
14692 return opnum == OP_RUNCV
14693 ? newPVOP(OP_RUNCV,0,NULL)
14696 return op_convert_list(opnum,0,aop);
14699 NOT_REACHED; /* NOTREACHED */
14704 =for apidoc cv_get_call_checker_flags
14706 Retrieves the function that will be used to fix up a call to C<cv>.
14707 Specifically, the function is applied to an C<entersub> op tree for a
14708 subroutine call, not marked with C<&>, where the callee can be identified
14709 at compile time as C<cv>.
14711 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14712 for it is returned in C<*ckobj_p>, and control flags are returned in
14713 C<*ckflags_p>. The function is intended to be called in this manner:
14715 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14717 In this call, C<entersubop> is a pointer to the C<entersub> op,
14718 which may be replaced by the check function, and C<namegv> supplies
14719 the name that should be used by the check function to refer
14720 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14721 It is permitted to apply the check function in non-standard situations,
14722 such as to a call to a different subroutine or to a method call.
14724 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14725 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14726 instead, anything that can be used as the first argument to L</cv_name>.
14727 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14728 check function requires C<namegv> to be a genuine GV.
14730 By default, the check function is
14731 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14732 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14733 flag is clear. This implements standard prototype processing. It can
14734 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14736 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14737 indicates that the caller only knows about the genuine GV version of
14738 C<namegv>, and accordingly the corresponding bit will always be set in
14739 C<*ckflags_p>, regardless of the check function's recorded requirements.
14740 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14741 indicates the caller knows about the possibility of passing something
14742 other than a GV as C<namegv>, and accordingly the corresponding bit may
14743 be either set or clear in C<*ckflags_p>, indicating the check function's
14744 recorded requirements.
14746 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14747 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14748 (for which see above). All other bits should be clear.
14750 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14752 =for apidoc cv_get_call_checker
14754 The original form of L</cv_get_call_checker_flags>, which does not return
14755 checker flags. When using a checker function returned by this function,
14756 it is only safe to call it with a genuine GV as its C<namegv> argument.
14762 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14763 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14766 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14767 PERL_UNUSED_CONTEXT;
14768 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14770 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14771 *ckobj_p = callmg->mg_obj;
14772 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14774 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14775 *ckobj_p = (SV*)cv;
14776 *ckflags_p = gflags & MGf_REQUIRE_GV;
14781 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14784 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14785 PERL_UNUSED_CONTEXT;
14786 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14791 =for apidoc cv_set_call_checker_flags
14793 Sets the function that will be used to fix up a call to C<cv>.
14794 Specifically, the function is applied to an C<entersub> op tree for a
14795 subroutine call, not marked with C<&>, where the callee can be identified
14796 at compile time as C<cv>.
14798 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14799 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14800 The function should be defined like this:
14802 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14804 It is intended to be called in this manner:
14806 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14808 In this call, C<entersubop> is a pointer to the C<entersub> op,
14809 which may be replaced by the check function, and C<namegv> supplies
14810 the name that should be used by the check function to refer
14811 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14812 It is permitted to apply the check function in non-standard situations,
14813 such as to a call to a different subroutine or to a method call.
14815 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14816 CV or other SV instead. Whatever is passed can be used as the first
14817 argument to L</cv_name>. You can force perl to pass a GV by including
14818 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14820 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14821 bit currently has a defined meaning (for which see above). All other
14822 bits should be clear.
14824 The current setting for a particular CV can be retrieved by
14825 L</cv_get_call_checker_flags>.
14827 =for apidoc cv_set_call_checker
14829 The original form of L</cv_set_call_checker_flags>, which passes it the
14830 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14831 of that flag setting is that the check function is guaranteed to get a
14832 genuine GV as its C<namegv> argument.
14838 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14840 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14841 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14845 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14846 SV *ckobj, U32 ckflags)
14848 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14849 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14850 if (SvMAGICAL((SV*)cv))
14851 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14854 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14855 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14857 if (callmg->mg_flags & MGf_REFCOUNTED) {
14858 SvREFCNT_dec(callmg->mg_obj);
14859 callmg->mg_flags &= ~MGf_REFCOUNTED;
14861 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14862 callmg->mg_obj = ckobj;
14863 if (ckobj != (SV*)cv) {
14864 SvREFCNT_inc_simple_void_NN(ckobj);
14865 callmg->mg_flags |= MGf_REFCOUNTED;
14867 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14868 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14873 S_entersub_alloc_targ(pTHX_ OP * const o)
14875 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14876 o->op_private |= OPpENTERSUB_HASTARG;
14880 Perl_ck_subr(pTHX_ OP *o)
14885 SV **const_class = NULL;
14887 PERL_ARGS_ASSERT_CK_SUBR;
14889 aop = cUNOPx(o)->op_first;
14890 if (!OpHAS_SIBLING(aop))
14891 aop = cUNOPx(aop)->op_first;
14892 aop = OpSIBLING(aop);
14893 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14894 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14895 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14897 o->op_private &= ~1;
14898 o->op_private |= (PL_hints & HINT_STRICT_REFS);
14899 if (PERLDB_SUB && PL_curstash != PL_debstash)
14900 o->op_private |= OPpENTERSUB_DB;
14901 switch (cvop->op_type) {
14903 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14907 case OP_METHOD_NAMED:
14908 case OP_METHOD_SUPER:
14909 case OP_METHOD_REDIR:
14910 case OP_METHOD_REDIR_SUPER:
14911 o->op_flags |= OPf_REF;
14912 if (aop->op_type == OP_CONST) {
14913 aop->op_private &= ~OPpCONST_STRICT;
14914 const_class = &cSVOPx(aop)->op_sv;
14916 else if (aop->op_type == OP_LIST) {
14917 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
14918 if (sib && sib->op_type == OP_CONST) {
14919 sib->op_private &= ~OPpCONST_STRICT;
14920 const_class = &cSVOPx(sib)->op_sv;
14923 /* make class name a shared cow string to speedup method calls */
14924 /* constant string might be replaced with object, f.e. bigint */
14925 if (const_class && SvPOK(*const_class)) {
14927 const char* str = SvPV(*const_class, len);
14929 SV* const shared = newSVpvn_share(
14930 str, SvUTF8(*const_class)
14931 ? -(SSize_t)len : (SSize_t)len,
14934 if (SvREADONLY(*const_class))
14935 SvREADONLY_on(shared);
14936 SvREFCNT_dec(*const_class);
14937 *const_class = shared;
14944 S_entersub_alloc_targ(aTHX_ o);
14945 return ck_entersub_args_list(o);
14947 Perl_call_checker ckfun;
14950 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14951 if (CvISXSUB(cv) || !CvROOT(cv))
14952 S_entersub_alloc_targ(aTHX_ o);
14954 /* The original call checker API guarantees that a GV will be
14955 be provided with the right name. So, if the old API was
14956 used (or the REQUIRE_GV flag was passed), we have to reify
14957 the CV’s GV, unless this is an anonymous sub. This is not
14958 ideal for lexical subs, as its stringification will include
14959 the package. But it is the best we can do. */
14960 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14961 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14964 else namegv = MUTABLE_GV(cv);
14965 /* After a syntax error in a lexical sub, the cv that
14966 rv2cv_op_cv returns may be a nameless stub. */
14967 if (!namegv) return ck_entersub_args_list(o);
14970 return ckfun(aTHX_ o, namegv, ckobj);
14975 Perl_ck_svconst(pTHX_ OP *o)
14977 SV * const sv = cSVOPo->op_sv;
14978 PERL_ARGS_ASSERT_CK_SVCONST;
14979 PERL_UNUSED_CONTEXT;
14980 #ifdef PERL_COPY_ON_WRITE
14981 /* Since the read-only flag may be used to protect a string buffer, we
14982 cannot do copy-on-write with existing read-only scalars that are not
14983 already copy-on-write scalars. To allow $_ = "hello" to do COW with
14984 that constant, mark the constant as COWable here, if it is not
14985 already read-only. */
14986 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14989 # ifdef PERL_DEBUG_READONLY_COW
14999 Perl_ck_trunc(pTHX_ OP *o)
15001 PERL_ARGS_ASSERT_CK_TRUNC;
15003 if (o->op_flags & OPf_KIDS) {
15004 SVOP *kid = (SVOP*)cUNOPo->op_first;
15006 if (kid->op_type == OP_NULL)
15007 kid = (SVOP*)OpSIBLING(kid);
15008 if (kid && kid->op_type == OP_CONST &&
15009 (kid->op_private & OPpCONST_BARE) &&
15012 o->op_flags |= OPf_SPECIAL;
15013 kid->op_private &= ~OPpCONST_STRICT;
15020 Perl_ck_substr(pTHX_ OP *o)
15022 PERL_ARGS_ASSERT_CK_SUBSTR;
15025 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
15026 OP *kid = cLISTOPo->op_first;
15028 if (kid->op_type == OP_NULL)
15029 kid = OpSIBLING(kid);
15031 /* Historically, substr(delete $foo{bar},...) has been allowed
15032 with 4-arg substr. Keep it working by applying entersub
15034 op_lvalue(kid, OP_ENTERSUB);
15041 Perl_ck_tell(pTHX_ OP *o)
15043 PERL_ARGS_ASSERT_CK_TELL;
15045 if (o->op_flags & OPf_KIDS) {
15046 OP *kid = cLISTOPo->op_first;
15047 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
15048 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
15054 Perl_ck_each(pTHX_ OP *o)
15057 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
15058 const unsigned orig_type = o->op_type;
15060 PERL_ARGS_ASSERT_CK_EACH;
15063 switch (kid->op_type) {
15069 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
15070 : orig_type == OP_KEYS ? OP_AKEYS
15074 if (kid->op_private == OPpCONST_BARE
15075 || !SvROK(cSVOPx_sv(kid))
15076 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
15077 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
15082 qerror(Perl_mess(aTHX_
15083 "Experimental %s on scalar is now forbidden",
15084 PL_op_desc[orig_type]));
15086 bad_type_pv(1, "hash or array", o, kid);
15094 Perl_ck_length(pTHX_ OP *o)
15096 PERL_ARGS_ASSERT_CK_LENGTH;
15100 if (ckWARN(WARN_SYNTAX)) {
15101 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
15105 const bool hash = kid->op_type == OP_PADHV
15106 || kid->op_type == OP_RV2HV;
15107 switch (kid->op_type) {
15112 name = S_op_varname(aTHX_ kid);
15118 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15119 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
15121 SVfARG(name), hash ? "keys " : "", SVfARG(name)
15124 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15125 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15126 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
15128 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
15129 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
15130 "length() used on @array (did you mean \"scalar(@array)\"?)");
15139 Perl_ck_isa(pTHX_ OP *o)
15141 OP *classop = cBINOPo->op_last;
15143 PERL_ARGS_ASSERT_CK_ISA;
15145 /* Convert barename into PV */
15146 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
15147 /* TODO: Optionally convert package to raw HV here */
15148 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
15156 ---------------------------------------------------------
15158 Common vars in list assignment
15160 There now follows some enums and static functions for detecting
15161 common variables in list assignments. Here is a little essay I wrote
15162 for myself when trying to get my head around this. DAPM.
15166 First some random observations:
15168 * If a lexical var is an alias of something else, e.g.
15169 for my $x ($lex, $pkg, $a[0]) {...}
15170 then the act of aliasing will increase the reference count of the SV
15172 * If a package var is an alias of something else, it may still have a
15173 reference count of 1, depending on how the alias was created, e.g.
15174 in *a = *b, $a may have a refcount of 1 since the GP is shared
15175 with a single GvSV pointer to the SV. So If it's an alias of another
15176 package var, then RC may be 1; if it's an alias of another scalar, e.g.
15177 a lexical var or an array element, then it will have RC > 1.
15179 * There are many ways to create a package alias; ultimately, XS code
15180 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
15181 run-time tracing mechanisms are unlikely to be able to catch all cases.
15183 * When the LHS is all my declarations, the same vars can't appear directly
15184 on the RHS, but they can indirectly via closures, aliasing and lvalue
15185 subs. But those techniques all involve an increase in the lexical
15186 scalar's ref count.
15188 * When the LHS is all lexical vars (but not necessarily my declarations),
15189 it is possible for the same lexicals to appear directly on the RHS, and
15190 without an increased ref count, since the stack isn't refcounted.
15191 This case can be detected at compile time by scanning for common lex
15192 vars with PL_generation.
15194 * lvalue subs defeat common var detection, but they do at least
15195 return vars with a temporary ref count increment. Also, you can't
15196 tell at compile time whether a sub call is lvalue.
15201 A: There are a few circumstances where there definitely can't be any
15204 LHS empty: () = (...);
15205 RHS empty: (....) = ();
15206 RHS contains only constants or other 'can't possibly be shared'
15207 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
15208 i.e. they only contain ops not marked as dangerous, whose children
15209 are also not dangerous;
15211 LHS contains a single scalar element: e.g. ($x) = (....); because
15212 after $x has been modified, it won't be used again on the RHS;
15213 RHS contains a single element with no aggregate on LHS: e.g.
15214 ($a,$b,$c) = ($x); again, once $a has been modified, its value
15215 won't be used again.
15217 B: If LHS are all 'my' lexical var declarations (or safe ops, which
15220 my ($a, $b, @c) = ...;
15222 Due to closure and goto tricks, these vars may already have content.
15223 For the same reason, an element on the RHS may be a lexical or package
15224 alias of one of the vars on the left, or share common elements, for
15227 my ($x,$y) = f(); # $x and $y on both sides
15228 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
15233 my @a = @$ra; # elements of @a on both sides
15234 sub f { @a = 1..4; \@a }
15237 First, just consider scalar vars on LHS:
15239 RHS is safe only if (A), or in addition,
15240 * contains only lexical *scalar* vars, where neither side's
15241 lexicals have been flagged as aliases
15243 If RHS is not safe, then it's always legal to check LHS vars for
15244 RC==1, since the only RHS aliases will always be associated
15247 Note that in particular, RHS is not safe if:
15249 * it contains package scalar vars; e.g.:
15252 my ($x, $y) = (2, $x_alias);
15253 sub f { $x = 1; *x_alias = \$x; }
15255 * It contains other general elements, such as flattened or
15256 * spliced or single array or hash elements, e.g.
15259 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
15263 use feature 'refaliasing';
15264 \($a[0], $a[1]) = \($y,$x);
15267 It doesn't matter if the array/hash is lexical or package.
15269 * it contains a function call that happens to be an lvalue
15270 sub which returns one or more of the above, e.g.
15281 (so a sub call on the RHS should be treated the same
15282 as having a package var on the RHS).
15284 * any other "dangerous" thing, such an op or built-in that
15285 returns one of the above, e.g. pp_preinc
15288 If RHS is not safe, what we can do however is at compile time flag
15289 that the LHS are all my declarations, and at run time check whether
15290 all the LHS have RC == 1, and if so skip the full scan.
15292 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
15294 Here the issue is whether there can be elements of @a on the RHS
15295 which will get prematurely freed when @a is cleared prior to
15296 assignment. This is only a problem if the aliasing mechanism
15297 is one which doesn't increase the refcount - only if RC == 1
15298 will the RHS element be prematurely freed.
15300 Because the array/hash is being INTROed, it or its elements
15301 can't directly appear on the RHS:
15303 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
15305 but can indirectly, e.g.:
15309 sub f { @a = 1..3; \@a }
15311 So if the RHS isn't safe as defined by (A), we must always
15312 mortalise and bump the ref count of any remaining RHS elements
15313 when assigning to a non-empty LHS aggregate.
15315 Lexical scalars on the RHS aren't safe if they've been involved in
15318 use feature 'refaliasing';
15321 \(my $lex) = \$pkg;
15322 my @a = ($lex,3); # equivalent to ($a[0],3)
15329 Similarly with lexical arrays and hashes on the RHS:
15343 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
15344 my $a; ($a, my $b) = (....);
15346 The difference between (B) and (C) is that it is now physically
15347 possible for the LHS vars to appear on the RHS too, where they
15348 are not reference counted; but in this case, the compile-time
15349 PL_generation sweep will detect such common vars.
15351 So the rules for (C) differ from (B) in that if common vars are
15352 detected, the runtime "test RC==1" optimisation can no longer be used,
15353 and a full mark and sweep is required
15355 D: As (C), but in addition the LHS may contain package vars.
15357 Since package vars can be aliased without a corresponding refcount
15358 increase, all bets are off. It's only safe if (A). E.g.
15360 my ($x, $y) = (1,2);
15362 for $x_alias ($x) {
15363 ($x_alias, $y) = (3, $x); # whoops
15366 Ditto for LHS aggregate package vars.
15368 E: Any other dangerous ops on LHS, e.g.
15369 (f(), $a[0], @$r) = (...);
15371 this is similar to (E) in that all bets are off. In addition, it's
15372 impossible to determine at compile time whether the LHS
15373 contains a scalar or an aggregate, e.g.
15375 sub f : lvalue { @a }
15378 * ---------------------------------------------------------
15382 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
15383 * that at least one of the things flagged was seen.
15387 AAS_MY_SCALAR = 0x001, /* my $scalar */
15388 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
15389 AAS_LEX_SCALAR = 0x004, /* $lexical */
15390 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
15391 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
15392 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
15393 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
15394 AAS_DANGEROUS = 0x080, /* an op (other than the above)
15395 that's flagged OA_DANGEROUS */
15396 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
15397 not in any of the categories above */
15398 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
15403 /* helper function for S_aassign_scan().
15404 * check a PAD-related op for commonality and/or set its generation number.
15405 * Returns a boolean indicating whether its shared */
15408 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
15410 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
15411 /* lexical used in aliasing */
15415 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
15417 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
15424 Helper function for OPpASSIGN_COMMON* detection in rpeep().
15425 It scans the left or right hand subtree of the aassign op, and returns a
15426 set of flags indicating what sorts of things it found there.
15427 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
15428 set PL_generation on lexical vars; if the latter, we see if
15429 PL_generation matches.
15430 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
15431 This fn will increment it by the number seen. It's not intended to
15432 be an accurate count (especially as many ops can push a variable
15433 number of SVs onto the stack); rather it's used as to test whether there
15434 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
15438 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
15441 OP *effective_top_op = o;
15445 bool top = o == effective_top_op;
15447 OP* next_kid = NULL;
15449 /* first, look for a solitary @_ on the RHS */
15452 && (o->op_flags & OPf_KIDS)
15453 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
15455 OP *kid = cUNOPo->op_first;
15456 if ( ( kid->op_type == OP_PUSHMARK
15457 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
15458 && ((kid = OpSIBLING(kid)))
15459 && !OpHAS_SIBLING(kid)
15460 && kid->op_type == OP_RV2AV
15461 && !(kid->op_flags & OPf_REF)
15462 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15463 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
15464 && ((kid = cUNOPx(kid)->op_first))
15465 && kid->op_type == OP_GV
15466 && cGVOPx_gv(kid) == PL_defgv
15471 switch (o->op_type) {
15474 all_flags |= AAS_PKG_SCALAR;
15480 /* if !top, could be e.g. @a[0,1] */
15481 all_flags |= (top && (o->op_flags & OPf_REF))
15482 ? ((o->op_private & OPpLVAL_INTRO)
15483 ? AAS_MY_AGG : AAS_LEX_AGG)
15489 int comm = S_aassign_padcheck(aTHX_ o, rhs)
15490 ? AAS_LEX_SCALAR_COMM : 0;
15492 all_flags |= (o->op_private & OPpLVAL_INTRO)
15493 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
15501 if (cUNOPx(o)->op_first->op_type != OP_GV)
15502 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
15504 /* if !top, could be e.g. @a[0,1] */
15505 else if (top && (o->op_flags & OPf_REF))
15506 all_flags |= AAS_PKG_AGG;
15508 all_flags |= AAS_DANGEROUS;
15513 if (cUNOPx(o)->op_first->op_type != OP_GV) {
15515 all_flags |= AAS_DANGEROUS; /* ${expr} */
15518 all_flags |= AAS_PKG_SCALAR; /* $pkg */
15522 if (o->op_private & OPpSPLIT_ASSIGN) {
15523 /* the assign in @a = split() has been optimised away
15524 * and the @a attached directly to the split op
15525 * Treat the array as appearing on the RHS, i.e.
15526 * ... = (@a = split)
15531 if (o->op_flags & OPf_STACKED) {
15532 /* @{expr} = split() - the array expression is tacked
15533 * on as an extra child to split - process kid */
15534 next_kid = cLISTOPo->op_last;
15538 /* ... else array is directly attached to split op */
15540 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
15541 ? ((o->op_private & OPpLVAL_INTRO)
15542 ? AAS_MY_AGG : AAS_LEX_AGG)
15547 /* other args of split can't be returned */
15548 all_flags |= AAS_SAFE_SCALAR;
15552 /* undef counts as a scalar on the RHS:
15553 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
15554 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
15558 flags = AAS_SAFE_SCALAR;
15563 /* these are all no-ops; they don't push a potentially common SV
15564 * onto the stack, so they are neither AAS_DANGEROUS nor
15565 * AAS_SAFE_SCALAR */
15568 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
15573 /* these do nothing, but may have children */
15577 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
15579 flags = AAS_DANGEROUS;
15583 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
15584 && (o->op_private & OPpTARGET_MY))
15587 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
15588 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
15592 /* if its an unrecognised, non-dangerous op, assume that it
15593 * it the cause of at least one safe scalar */
15595 flags = AAS_SAFE_SCALAR;
15599 all_flags |= flags;
15601 /* by default, process all kids next
15602 * XXX this assumes that all other ops are "transparent" - i.e. that
15603 * they can return some of their children. While this true for e.g.
15604 * sort and grep, it's not true for e.g. map. We really need a
15605 * 'transparent' flag added to regen/opcodes
15607 if (o->op_flags & OPf_KIDS) {
15608 next_kid = cUNOPo->op_first;
15609 /* these ops do nothing but may have children; but their
15610 * children should also be treated as top-level */
15611 if ( o == effective_top_op
15612 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
15614 effective_top_op = next_kid;
15618 /* If next_kid is set, someone in the code above wanted us to process
15619 * that kid and all its remaining siblings. Otherwise, work our way
15620 * back up the tree */
15622 while (!next_kid) {
15624 return all_flags; /* at top; no parents/siblings to try */
15625 if (OpHAS_SIBLING(o)) {
15626 next_kid = o->op_sibparent;
15627 if (o == effective_top_op)
15628 effective_top_op = next_kid;
15631 if (o == effective_top_op)
15632 effective_top_op = o->op_sibparent;
15633 o = o->op_sibparent; /* try parent's next sibling */
15642 /* Check for in place reverse and sort assignments like "@a = reverse @a"
15643 and modify the optree to make them work inplace */
15646 S_inplace_aassign(pTHX_ OP *o) {
15648 OP *modop, *modop_pushmark;
15650 OP *oleft, *oleft_pushmark;
15652 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
15654 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
15656 assert(cUNOPo->op_first->op_type == OP_NULL);
15657 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
15658 assert(modop_pushmark->op_type == OP_PUSHMARK);
15659 modop = OpSIBLING(modop_pushmark);
15661 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
15664 /* no other operation except sort/reverse */
15665 if (OpHAS_SIBLING(modop))
15668 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
15669 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
15671 if (modop->op_flags & OPf_STACKED) {
15672 /* skip sort subroutine/block */
15673 assert(oright->op_type == OP_NULL);
15674 oright = OpSIBLING(oright);
15677 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
15678 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
15679 assert(oleft_pushmark->op_type == OP_PUSHMARK);
15680 oleft = OpSIBLING(oleft_pushmark);
15682 /* Check the lhs is an array */
15684 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
15685 || OpHAS_SIBLING(oleft)
15686 || (oleft->op_private & OPpLVAL_INTRO)
15690 /* Only one thing on the rhs */
15691 if (OpHAS_SIBLING(oright))
15694 /* check the array is the same on both sides */
15695 if (oleft->op_type == OP_RV2AV) {
15696 if (oright->op_type != OP_RV2AV
15697 || !cUNOPx(oright)->op_first
15698 || cUNOPx(oright)->op_first->op_type != OP_GV
15699 || cUNOPx(oleft )->op_first->op_type != OP_GV
15700 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15701 cGVOPx_gv(cUNOPx(oright)->op_first)
15705 else if (oright->op_type != OP_PADAV
15706 || oright->op_targ != oleft->op_targ
15710 /* This actually is an inplace assignment */
15712 modop->op_private |= OPpSORT_INPLACE;
15714 /* transfer MODishness etc from LHS arg to RHS arg */
15715 oright->op_flags = oleft->op_flags;
15717 /* remove the aassign op and the lhs */
15719 op_null(oleft_pushmark);
15720 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15721 op_null(cUNOPx(oleft)->op_first);
15727 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
15728 * that potentially represent a series of one or more aggregate derefs
15729 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
15730 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
15731 * additional ops left in too).
15733 * The caller will have already verified that the first few ops in the
15734 * chain following 'start' indicate a multideref candidate, and will have
15735 * set 'orig_o' to the point further on in the chain where the first index
15736 * expression (if any) begins. 'orig_action' specifies what type of
15737 * beginning has already been determined by the ops between start..orig_o
15738 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
15740 * 'hints' contains any hints flags that need adding (currently just
15741 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
15745 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
15749 UNOP_AUX_item *arg_buf = NULL;
15750 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
15751 int index_skip = -1; /* don't output index arg on this action */
15753 /* similar to regex compiling, do two passes; the first pass
15754 * determines whether the op chain is convertible and calculates the
15755 * buffer size; the second pass populates the buffer and makes any
15756 * changes necessary to ops (such as moving consts to the pad on
15757 * threaded builds).
15759 * NB: for things like Coverity, note that both passes take the same
15760 * path through the logic tree (except for 'if (pass)' bits), since
15761 * both passes are following the same op_next chain; and in
15762 * particular, if it would return early on the second pass, it would
15763 * already have returned early on the first pass.
15765 for (pass = 0; pass < 2; pass++) {
15767 UV action = orig_action;
15768 OP *first_elem_op = NULL; /* first seen aelem/helem */
15769 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
15770 int action_count = 0; /* number of actions seen so far */
15771 int action_ix = 0; /* action_count % (actions per IV) */
15772 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
15773 bool is_last = FALSE; /* no more derefs to follow */
15774 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
15775 UV action_word = 0; /* all actions so far */
15776 UNOP_AUX_item *arg = arg_buf;
15777 UNOP_AUX_item *action_ptr = arg_buf;
15779 arg++; /* reserve slot for first action word */
15782 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15783 case MDEREF_HV_gvhv_helem:
15784 next_is_hash = TRUE;
15786 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15787 case MDEREF_AV_gvav_aelem:
15789 #ifdef USE_ITHREADS
15790 arg->pad_offset = cPADOPx(start)->op_padix;
15791 /* stop it being swiped when nulled */
15792 cPADOPx(start)->op_padix = 0;
15794 arg->sv = cSVOPx(start)->op_sv;
15795 cSVOPx(start)->op_sv = NULL;
15801 case MDEREF_HV_padhv_helem:
15802 case MDEREF_HV_padsv_vivify_rv2hv_helem:
15803 next_is_hash = TRUE;
15805 case MDEREF_AV_padav_aelem:
15806 case MDEREF_AV_padsv_vivify_rv2av_aelem:
15808 arg->pad_offset = start->op_targ;
15809 /* we skip setting op_targ = 0 for now, since the intact
15810 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15811 reset_start_targ = TRUE;
15816 case MDEREF_HV_pop_rv2hv_helem:
15817 next_is_hash = TRUE;
15819 case MDEREF_AV_pop_rv2av_aelem:
15823 NOT_REACHED; /* NOTREACHED */
15828 /* look for another (rv2av/hv; get index;
15829 * aelem/helem/exists/delele) sequence */
15834 UV index_type = MDEREF_INDEX_none;
15836 if (action_count) {
15837 /* if this is not the first lookup, consume the rv2av/hv */
15839 /* for N levels of aggregate lookup, we normally expect
15840 * that the first N-1 [ah]elem ops will be flagged as
15841 * /DEREF (so they autovivifiy if necessary), and the last
15842 * lookup op not to be.
15843 * For other things (like @{$h{k1}{k2}}) extra scope or
15844 * leave ops can appear, so abandon the effort in that
15846 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
15849 /* rv2av or rv2hv sKR/1 */
15851 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15852 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15853 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15856 /* at this point, we wouldn't expect any of these
15857 * possible private flags:
15858 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
15859 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
15861 ASSUME(!(o->op_private &
15862 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
15864 hints = (o->op_private & OPpHINT_STRICT_REFS);
15866 /* make sure the type of the previous /DEREF matches the
15867 * type of the next lookup */
15868 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
15871 action = next_is_hash
15872 ? MDEREF_HV_vivify_rv2hv_helem
15873 : MDEREF_AV_vivify_rv2av_aelem;
15877 /* if this is the second pass, and we're at the depth where
15878 * previously we encountered a non-simple index expression,
15879 * stop processing the index at this point */
15880 if (action_count != index_skip) {
15882 /* look for one or more simple ops that return an array
15883 * index or hash key */
15885 switch (o->op_type) {
15887 /* it may be a lexical var index */
15888 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
15889 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15890 ASSUME(!(o->op_private &
15891 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15893 if ( OP_GIMME(o,0) == G_SCALAR
15894 && !(o->op_flags & (OPf_REF|OPf_MOD))
15895 && o->op_private == 0)
15898 arg->pad_offset = o->op_targ;
15900 index_type = MDEREF_INDEX_padsv;
15906 if (next_is_hash) {
15907 /* it's a constant hash index */
15908 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
15909 /* "use constant foo => FOO; $h{+foo}" for
15910 * some weird FOO, can leave you with constants
15911 * that aren't simple strings. It's not worth
15912 * the extra hassle for those edge cases */
15917 OP * helem_op = o->op_next;
15919 ASSUME( helem_op->op_type == OP_HELEM
15920 || helem_op->op_type == OP_NULL
15922 if (helem_op->op_type == OP_HELEM) {
15923 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
15924 if ( helem_op->op_private & OPpLVAL_INTRO
15925 || rop->op_type != OP_RV2HV
15929 /* on first pass just check; on second pass
15931 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
15936 #ifdef USE_ITHREADS
15937 /* Relocate sv to the pad for thread safety */
15938 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
15939 arg->pad_offset = o->op_targ;
15942 arg->sv = cSVOPx_sv(o);
15947 /* it's a constant array index */
15949 SV *ix_sv = cSVOPo->op_sv;
15954 if ( action_count == 0
15957 && ( action == MDEREF_AV_padav_aelem
15958 || action == MDEREF_AV_gvav_aelem)
15960 maybe_aelemfast = TRUE;
15964 SvREFCNT_dec_NN(cSVOPo->op_sv);
15968 /* we've taken ownership of the SV */
15969 cSVOPo->op_sv = NULL;
15971 index_type = MDEREF_INDEX_const;
15976 /* it may be a package var index */
15978 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
15979 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
15980 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
15981 || o->op_private != 0
15986 if (kid->op_type != OP_RV2SV)
15989 ASSUME(!(kid->op_flags &
15990 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
15991 |OPf_SPECIAL|OPf_PARENS)));
15992 ASSUME(!(kid->op_private &
15994 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
15995 |OPpDEREF|OPpLVAL_INTRO)));
15996 if( (kid->op_flags &~ OPf_PARENS)
15997 != (OPf_WANT_SCALAR|OPf_KIDS)
15998 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
16003 #ifdef USE_ITHREADS
16004 arg->pad_offset = cPADOPx(o)->op_padix;
16005 /* stop it being swiped when nulled */
16006 cPADOPx(o)->op_padix = 0;
16008 arg->sv = cSVOPx(o)->op_sv;
16009 cSVOPo->op_sv = NULL;
16013 index_type = MDEREF_INDEX_gvsv;
16018 } /* action_count != index_skip */
16020 action |= index_type;
16023 /* at this point we have either:
16024 * * detected what looks like a simple index expression,
16025 * and expect the next op to be an [ah]elem, or
16026 * an nulled [ah]elem followed by a delete or exists;
16027 * * found a more complex expression, so something other
16028 * than the above follows.
16031 /* possibly an optimised away [ah]elem (where op_next is
16032 * exists or delete) */
16033 if (o->op_type == OP_NULL)
16036 /* at this point we're looking for an OP_AELEM, OP_HELEM,
16037 * OP_EXISTS or OP_DELETE */
16039 /* if a custom array/hash access checker is in scope,
16040 * abandon optimisation attempt */
16041 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16042 && PL_check[o->op_type] != Perl_ck_null)
16044 /* similarly for customised exists and delete */
16045 if ( (o->op_type == OP_EXISTS)
16046 && PL_check[o->op_type] != Perl_ck_exists)
16048 if ( (o->op_type == OP_DELETE)
16049 && PL_check[o->op_type] != Perl_ck_delete)
16052 if ( o->op_type != OP_AELEM
16053 || (o->op_private &
16054 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
16056 maybe_aelemfast = FALSE;
16058 /* look for aelem/helem/exists/delete. If it's not the last elem
16059 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
16060 * flags; if it's the last, then it mustn't have
16061 * OPpDEREF_AV/HV, but may have lots of other flags, like
16062 * OPpLVAL_INTRO etc
16065 if ( index_type == MDEREF_INDEX_none
16066 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
16067 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
16071 /* we have aelem/helem/exists/delete with valid simple index */
16073 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
16074 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
16075 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
16077 /* This doesn't make much sense but is legal:
16078 * @{ local $x[0][0] } = 1
16079 * Since scope exit will undo the autovivification,
16080 * don't bother in the first place. The OP_LEAVE
16081 * assertion is in case there are other cases of both
16082 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
16083 * exit that would undo the local - in which case this
16084 * block of code would need rethinking.
16086 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
16088 OP *n = o->op_next;
16089 while (n && ( n->op_type == OP_NULL
16090 || n->op_type == OP_LIST
16091 || n->op_type == OP_SCALAR))
16093 assert(n && n->op_type == OP_LEAVE);
16095 o->op_private &= ~OPpDEREF;
16100 ASSUME(!(o->op_flags &
16101 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
16102 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
16104 ok = (o->op_flags &~ OPf_PARENS)
16105 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
16106 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
16108 else if (o->op_type == OP_EXISTS) {
16109 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16110 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16111 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
16112 ok = !(o->op_private & ~OPpARG1_MASK);
16114 else if (o->op_type == OP_DELETE) {
16115 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16116 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
16117 ASSUME(!(o->op_private &
16118 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
16119 /* don't handle slices or 'local delete'; the latter
16120 * is fairly rare, and has a complex runtime */
16121 ok = !(o->op_private & ~OPpARG1_MASK);
16122 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
16123 /* skip handling run-tome error */
16124 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
16127 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
16128 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
16129 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
16130 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
16131 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
16132 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
16137 if (!first_elem_op)
16141 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
16146 action |= MDEREF_FLAG_last;
16150 /* at this point we have something that started
16151 * promisingly enough (with rv2av or whatever), but failed
16152 * to find a simple index followed by an
16153 * aelem/helem/exists/delete. If this is the first action,
16154 * give up; but if we've already seen at least one
16155 * aelem/helem, then keep them and add a new action with
16156 * MDEREF_INDEX_none, which causes it to do the vivify
16157 * from the end of the previous lookup, and do the deref,
16158 * but stop at that point. So $a[0][expr] will do one
16159 * av_fetch, vivify and deref, then continue executing at
16164 index_skip = action_count;
16165 action |= MDEREF_FLAG_last;
16166 if (index_type != MDEREF_INDEX_none)
16170 action_word |= (action << (action_ix * MDEREF_SHIFT));
16173 /* if there's no space for the next action, reserve a new slot
16174 * for it *before* we start adding args for that action */
16175 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
16177 action_ptr->uv = action_word;
16183 } /* while !is_last */
16188 /* slot reserved for next action word not now needed */
16191 action_ptr->uv = action_word;
16197 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
16198 if (index_skip == -1) {
16199 mderef->op_flags = o->op_flags
16200 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
16201 if (o->op_type == OP_EXISTS)
16202 mderef->op_private = OPpMULTIDEREF_EXISTS;
16203 else if (o->op_type == OP_DELETE)
16204 mderef->op_private = OPpMULTIDEREF_DELETE;
16206 mderef->op_private = o->op_private
16207 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
16209 /* accumulate strictness from every level (although I don't think
16210 * they can actually vary) */
16211 mderef->op_private |= hints;
16213 /* integrate the new multideref op into the optree and the
16216 * In general an op like aelem or helem has two child
16217 * sub-trees: the aggregate expression (a_expr) and the
16218 * index expression (i_expr):
16224 * The a_expr returns an AV or HV, while the i-expr returns an
16225 * index. In general a multideref replaces most or all of a
16226 * multi-level tree, e.g.
16242 * With multideref, all the i_exprs will be simple vars or
16243 * constants, except that i_expr1 may be arbitrary in the case
16244 * of MDEREF_INDEX_none.
16246 * The bottom-most a_expr will be either:
16247 * 1) a simple var (so padXv or gv+rv2Xv);
16248 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
16249 * so a simple var with an extra rv2Xv;
16250 * 3) or an arbitrary expression.
16252 * 'start', the first op in the execution chain, will point to
16253 * 1),2): the padXv or gv op;
16254 * 3): the rv2Xv which forms the last op in the a_expr
16255 * execution chain, and the top-most op in the a_expr
16258 * For all cases, the 'start' node is no longer required,
16259 * but we can't free it since one or more external nodes
16260 * may point to it. E.g. consider
16261 * $h{foo} = $a ? $b : $c
16262 * Here, both the op_next and op_other branches of the
16263 * cond_expr point to the gv[*h] of the hash expression, so
16264 * we can't free the 'start' op.
16266 * For expr->[...], we need to save the subtree containing the
16267 * expression; for the other cases, we just need to save the
16269 * So in all cases, we null the start op and keep it around by
16270 * making it the child of the multideref op; for the expr->
16271 * case, the expr will be a subtree of the start node.
16273 * So in the simple 1,2 case the optree above changes to
16279 * ex-gv (or ex-padxv)
16281 * with the op_next chain being
16283 * -> ex-gv -> multideref -> op-following-ex-exists ->
16285 * In the 3 case, we have
16298 * -> rest-of-a_expr subtree ->
16299 * ex-rv2xv -> multideref -> op-following-ex-exists ->
16302 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
16303 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
16304 * multideref attached as the child, e.g.
16310 * ex-rv2av - i_expr1
16318 /* if we free this op, don't free the pad entry */
16319 if (reset_start_targ)
16320 start->op_targ = 0;
16323 /* Cut the bit we need to save out of the tree and attach to
16324 * the multideref op, then free the rest of the tree */
16326 /* find parent of node to be detached (for use by splice) */
16328 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
16329 || orig_action == MDEREF_HV_pop_rv2hv_helem)
16331 /* there is an arbitrary expression preceding us, e.g.
16332 * expr->[..]? so we need to save the 'expr' subtree */
16333 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
16334 p = cUNOPx(p)->op_first;
16335 ASSUME( start->op_type == OP_RV2AV
16336 || start->op_type == OP_RV2HV);
16339 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
16340 * above for exists/delete. */
16341 while ( (p->op_flags & OPf_KIDS)
16342 && cUNOPx(p)->op_first != start
16344 p = cUNOPx(p)->op_first;
16346 ASSUME(cUNOPx(p)->op_first == start);
16348 /* detach from main tree, and re-attach under the multideref */
16349 op_sibling_splice(mderef, NULL, 0,
16350 op_sibling_splice(p, NULL, 1, NULL));
16353 start->op_next = mderef;
16355 mderef->op_next = index_skip == -1 ? o->op_next : o;
16357 /* excise and free the original tree, and replace with
16358 * the multideref op */
16359 p = op_sibling_splice(top_op, NULL, -1, mderef);
16368 Size_t size = arg - arg_buf;
16370 if (maybe_aelemfast && action_count == 1)
16373 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
16374 sizeof(UNOP_AUX_item) * (size + 1));
16375 /* for dumping etc: store the length in a hidden first slot;
16376 * we set the op_aux pointer to the second slot */
16377 arg_buf->uv = size;
16380 } /* for (pass = ...) */
16383 /* See if the ops following o are such that o will always be executed in
16384 * boolean context: that is, the SV which o pushes onto the stack will
16385 * only ever be consumed by later ops via SvTRUE(sv) or similar.
16386 * If so, set a suitable private flag on o. Normally this will be
16387 * bool_flag; but see below why maybe_flag is needed too.
16389 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
16390 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
16391 * already be taken, so you'll have to give that op two different flags.
16393 * More explanation of 'maybe_flag' and 'safe_and' parameters.
16394 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
16395 * those underlying ops) short-circuit, which means that rather than
16396 * necessarily returning a truth value, they may return the LH argument,
16397 * which may not be boolean. For example in $x = (keys %h || -1), keys
16398 * should return a key count rather than a boolean, even though its
16399 * sort-of being used in boolean context.
16401 * So we only consider such logical ops to provide boolean context to
16402 * their LH argument if they themselves are in void or boolean context.
16403 * However, sometimes the context isn't known until run-time. In this
16404 * case the op is marked with the maybe_flag flag it.
16406 * Consider the following.
16408 * sub f { ....; if (%h) { .... } }
16410 * This is actually compiled as
16412 * sub f { ....; %h && do { .... } }
16414 * Here we won't know until runtime whether the final statement (and hence
16415 * the &&) is in void context and so is safe to return a boolean value.
16416 * So mark o with maybe_flag rather than the bool_flag.
16417 * Note that there is cost associated with determining context at runtime
16418 * (e.g. a call to block_gimme()), so it may not be worth setting (at
16419 * compile time) and testing (at runtime) maybe_flag if the scalar verses
16420 * boolean costs savings are marginal.
16422 * However, we can do slightly better with && (compared to || and //):
16423 * this op only returns its LH argument when that argument is false. In
16424 * this case, as long as the op promises to return a false value which is
16425 * valid in both boolean and scalar contexts, we can mark an op consumed
16426 * by && with bool_flag rather than maybe_flag.
16427 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
16428 * than &PL_sv_no for a false result in boolean context, then it's safe. An
16429 * op which promises to handle this case is indicated by setting safe_and
16434 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
16439 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
16441 /* OPpTARGET_MY and boolean context probably don't mix well.
16442 * If someone finds a valid use case, maybe add an extra flag to this
16443 * function which indicates its safe to do so for this op? */
16444 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
16445 && (o->op_private & OPpTARGET_MY)));
16450 switch (lop->op_type) {
16455 /* these two consume the stack argument in the scalar case,
16456 * and treat it as a boolean in the non linenumber case */
16459 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
16460 || (lop->op_private & OPpFLIP_LINENUM))
16466 /* these never leave the original value on the stack */
16475 /* OR DOR and AND evaluate their arg as a boolean, but then may
16476 * leave the original scalar value on the stack when following the
16477 * op_next route. If not in void context, we need to ensure
16478 * that whatever follows consumes the arg only in boolean context
16490 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
16494 else if (!(lop->op_flags & OPf_WANT)) {
16495 /* unknown context - decide at runtime */
16507 lop = lop->op_next;
16510 o->op_private |= flag;
16515 /* mechanism for deferring recursion in rpeep() */
16517 #define MAX_DEFERRED 4
16521 if (defer_ix == (MAX_DEFERRED-1)) { \
16522 OP **defer = defer_queue[defer_base]; \
16523 CALL_RPEEP(*defer); \
16524 S_prune_chain_head(defer); \
16525 defer_base = (defer_base + 1) % MAX_DEFERRED; \
16528 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
16531 #define IS_AND_OP(o) (o->op_type == OP_AND)
16532 #define IS_OR_OP(o) (o->op_type == OP_OR)
16535 /* A peephole optimizer. We visit the ops in the order they're to execute.
16536 * See the comments at the top of this file for more details about when
16537 * peep() is called */
16540 Perl_rpeep(pTHX_ OP *o)
16544 OP* oldoldop = NULL;
16545 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
16546 int defer_base = 0;
16549 if (!o || o->op_opt)
16552 assert(o->op_type != OP_FREED);
16556 SAVEVPTR(PL_curcop);
16557 for (;; o = o->op_next) {
16558 if (o && o->op_opt)
16561 while (defer_ix >= 0) {
16563 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
16564 CALL_RPEEP(*defer);
16565 S_prune_chain_head(defer);
16572 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
16573 assert(!oldoldop || oldoldop->op_next == oldop);
16574 assert(!oldop || oldop->op_next == o);
16576 /* By default, this op has now been optimised. A couple of cases below
16577 clear this again. */
16581 /* look for a series of 1 or more aggregate derefs, e.g.
16582 * $a[1]{foo}[$i]{$k}
16583 * and replace with a single OP_MULTIDEREF op.
16584 * Each index must be either a const, or a simple variable,
16586 * First, look for likely combinations of starting ops,
16587 * corresponding to (global and lexical variants of)
16589 * $r->[...] $r->{...}
16590 * (preceding expression)->[...]
16591 * (preceding expression)->{...}
16592 * and if so, call maybe_multideref() to do a full inspection
16593 * of the op chain and if appropriate, replace with an
16601 switch (o2->op_type) {
16603 /* $pkg[..] : gv[*pkg]
16604 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
16606 /* Fail if there are new op flag combinations that we're
16607 * not aware of, rather than:
16608 * * silently failing to optimise, or
16609 * * silently optimising the flag away.
16610 * If this ASSUME starts failing, examine what new flag
16611 * has been added to the op, and decide whether the
16612 * optimisation should still occur with that flag, then
16613 * update the code accordingly. This applies to all the
16614 * other ASSUMEs in the block of code too.
16616 ASSUME(!(o2->op_flags &
16617 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
16618 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
16622 if (o2->op_type == OP_RV2AV) {
16623 action = MDEREF_AV_gvav_aelem;
16627 if (o2->op_type == OP_RV2HV) {
16628 action = MDEREF_HV_gvhv_helem;
16632 if (o2->op_type != OP_RV2SV)
16635 /* at this point we've seen gv,rv2sv, so the only valid
16636 * construct left is $pkg->[] or $pkg->{} */
16638 ASSUME(!(o2->op_flags & OPf_STACKED));
16639 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16640 != (OPf_WANT_SCALAR|OPf_MOD))
16643 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
16644 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
16645 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
16647 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
16648 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
16652 if (o2->op_type == OP_RV2AV) {
16653 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
16656 if (o2->op_type == OP_RV2HV) {
16657 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
16663 /* $lex->[...]: padsv[$lex] sM/DREFAV */
16665 ASSUME(!(o2->op_flags &
16666 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
16667 if ((o2->op_flags &
16668 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16669 != (OPf_WANT_SCALAR|OPf_MOD))
16672 ASSUME(!(o2->op_private &
16673 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
16674 /* skip if state or intro, or not a deref */
16675 if ( o2->op_private != OPpDEREF_AV
16676 && o2->op_private != OPpDEREF_HV)
16680 if (o2->op_type == OP_RV2AV) {
16681 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
16684 if (o2->op_type == OP_RV2HV) {
16685 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
16692 /* $lex[..]: padav[@lex:1,2] sR *
16693 * or $lex{..}: padhv[%lex:1,2] sR */
16694 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
16695 OPf_REF|OPf_SPECIAL)));
16696 if ((o2->op_flags &
16697 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
16698 != (OPf_WANT_SCALAR|OPf_REF))
16700 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
16702 /* OPf_PARENS isn't currently used in this case;
16703 * if that changes, let us know! */
16704 ASSUME(!(o2->op_flags & OPf_PARENS));
16706 /* at this point, we wouldn't expect any of the remaining
16707 * possible private flags:
16708 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
16709 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
16711 * OPpSLICEWARNING shouldn't affect runtime
16713 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
16715 action = o2->op_type == OP_PADAV
16716 ? MDEREF_AV_padav_aelem
16717 : MDEREF_HV_padhv_helem;
16719 S_maybe_multideref(aTHX_ o, o2, action, 0);
16725 action = o2->op_type == OP_RV2AV
16726 ? MDEREF_AV_pop_rv2av_aelem
16727 : MDEREF_HV_pop_rv2hv_helem;
16730 /* (expr)->[...]: rv2av sKR/1;
16731 * (expr)->{...}: rv2hv sKR/1; */
16733 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
16735 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
16736 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
16737 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
16740 /* at this point, we wouldn't expect any of these
16741 * possible private flags:
16742 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
16743 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
16745 ASSUME(!(o2->op_private &
16746 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
16748 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
16752 S_maybe_multideref(aTHX_ o, o2, action, hints);
16761 switch (o->op_type) {
16763 PL_curcop = ((COP*)o); /* for warnings */
16766 PL_curcop = ((COP*)o); /* for warnings */
16768 /* Optimise a "return ..." at the end of a sub to just be "...".
16769 * This saves 2 ops. Before:
16770 * 1 <;> nextstate(main 1 -e:1) v ->2
16771 * 4 <@> return K ->5
16772 * 2 <0> pushmark s ->3
16773 * - <1> ex-rv2sv sK/1 ->4
16774 * 3 <#> gvsv[*cat] s ->4
16777 * - <@> return K ->-
16778 * - <0> pushmark s ->2
16779 * - <1> ex-rv2sv sK/1 ->-
16780 * 2 <$> gvsv(*cat) s ->3
16783 OP *next = o->op_next;
16784 OP *sibling = OpSIBLING(o);
16785 if ( OP_TYPE_IS(next, OP_PUSHMARK)
16786 && OP_TYPE_IS(sibling, OP_RETURN)
16787 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16788 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16789 ||OP_TYPE_IS(sibling->op_next->op_next,
16791 && cUNOPx(sibling)->op_first == next
16792 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16795 /* Look through the PUSHMARK's siblings for one that
16796 * points to the RETURN */
16797 OP *top = OpSIBLING(next);
16798 while (top && top->op_next) {
16799 if (top->op_next == sibling) {
16800 top->op_next = sibling->op_next;
16801 o->op_next = next->op_next;
16804 top = OpSIBLING(top);
16809 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16811 * This latter form is then suitable for conversion into padrange
16812 * later on. Convert:
16814 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16818 * nextstate1 -> listop -> nextstate3
16820 * pushmark -> padop1 -> padop2
16822 if (o->op_next && (
16823 o->op_next->op_type == OP_PADSV
16824 || o->op_next->op_type == OP_PADAV
16825 || o->op_next->op_type == OP_PADHV
16827 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
16828 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
16829 && o->op_next->op_next->op_next && (
16830 o->op_next->op_next->op_next->op_type == OP_PADSV
16831 || o->op_next->op_next->op_next->op_type == OP_PADAV
16832 || o->op_next->op_next->op_next->op_type == OP_PADHV
16834 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
16835 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
16836 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
16837 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
16839 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
16842 ns2 = pad1->op_next;
16843 pad2 = ns2->op_next;
16844 ns3 = pad2->op_next;
16846 /* we assume here that the op_next chain is the same as
16847 * the op_sibling chain */
16848 assert(OpSIBLING(o) == pad1);
16849 assert(OpSIBLING(pad1) == ns2);
16850 assert(OpSIBLING(ns2) == pad2);
16851 assert(OpSIBLING(pad2) == ns3);
16853 /* excise and delete ns2 */
16854 op_sibling_splice(NULL, pad1, 1, NULL);
16857 /* excise pad1 and pad2 */
16858 op_sibling_splice(NULL, o, 2, NULL);
16860 /* create new listop, with children consisting of:
16861 * a new pushmark, pad1, pad2. */
16862 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
16863 newop->op_flags |= OPf_PARENS;
16864 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16866 /* insert newop between o and ns3 */
16867 op_sibling_splice(NULL, o, 0, newop);
16869 /*fixup op_next chain */
16870 newpm = cUNOPx(newop)->op_first; /* pushmark */
16871 o ->op_next = newpm;
16872 newpm->op_next = pad1;
16873 pad1 ->op_next = pad2;
16874 pad2 ->op_next = newop; /* listop */
16875 newop->op_next = ns3;
16877 /* Ensure pushmark has this flag if padops do */
16878 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
16879 newpm->op_flags |= OPf_MOD;
16885 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
16886 to carry two labels. For now, take the easier option, and skip
16887 this optimisation if the first NEXTSTATE has a label. */
16888 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
16889 OP *nextop = o->op_next;
16891 switch (nextop->op_type) {
16896 nextop = nextop->op_next;
16902 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
16905 oldop->op_next = nextop;
16907 /* Skip (old)oldop assignment since the current oldop's
16908 op_next already points to the next op. */
16915 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
16916 if (o->op_next->op_private & OPpTARGET_MY) {
16917 if (o->op_flags & OPf_STACKED) /* chained concats */
16918 break; /* ignore_optimization */
16920 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
16921 o->op_targ = o->op_next->op_targ;
16922 o->op_next->op_targ = 0;
16923 o->op_private |= OPpTARGET_MY;
16926 op_null(o->op_next);
16930 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
16931 break; /* Scalar stub must produce undef. List stub is noop */
16935 if (o->op_targ == OP_NEXTSTATE
16936 || o->op_targ == OP_DBSTATE)
16938 PL_curcop = ((COP*)o);
16940 /* XXX: We avoid setting op_seq here to prevent later calls
16941 to rpeep() from mistakenly concluding that optimisation
16942 has already occurred. This doesn't fix the real problem,
16943 though (See 20010220.007 (#5874)). AMS 20010719 */
16944 /* op_seq functionality is now replaced by op_opt */
16952 oldop->op_next = o->op_next;
16966 convert repeat into a stub with no kids.
16968 if (o->op_next->op_type == OP_CONST
16969 || ( o->op_next->op_type == OP_PADSV
16970 && !(o->op_next->op_private & OPpLVAL_INTRO))
16971 || ( o->op_next->op_type == OP_GV
16972 && o->op_next->op_next->op_type == OP_RV2SV
16973 && !(o->op_next->op_next->op_private
16974 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
16976 const OP *kid = o->op_next->op_next;
16977 if (o->op_next->op_type == OP_GV)
16978 kid = kid->op_next;
16979 /* kid is now the ex-list. */
16980 if (kid->op_type == OP_NULL
16981 && (kid = kid->op_next)->op_type == OP_CONST
16982 /* kid is now the repeat count. */
16983 && kid->op_next->op_type == OP_REPEAT
16984 && kid->op_next->op_private & OPpREPEAT_DOLIST
16985 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
16986 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
16989 o = kid->op_next; /* repeat */
16990 oldop->op_next = o;
16991 op_free(cBINOPo->op_first);
16992 op_free(cBINOPo->op_last );
16993 o->op_flags &=~ OPf_KIDS;
16994 /* stub is a baseop; repeat is a binop */
16995 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
16996 OpTYPE_set(o, OP_STUB);
17002 /* Convert a series of PAD ops for my vars plus support into a
17003 * single padrange op. Basically
17005 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
17007 * becomes, depending on circumstances, one of
17009 * padrange ----------------------------------> (list) -> rest
17010 * padrange --------------------------------------------> rest
17012 * where all the pad indexes are sequential and of the same type
17014 * We convert the pushmark into a padrange op, then skip
17015 * any other pad ops, and possibly some trailing ops.
17016 * Note that we don't null() the skipped ops, to make it
17017 * easier for Deparse to undo this optimisation (and none of
17018 * the skipped ops are holding any resourses). It also makes
17019 * it easier for find_uninit_var(), as it can just ignore
17020 * padrange, and examine the original pad ops.
17024 OP *followop = NULL; /* the op that will follow the padrange op */
17027 PADOFFSET base = 0; /* init only to stop compiler whining */
17028 bool gvoid = 0; /* init only to stop compiler whining */
17029 bool defav = 0; /* seen (...) = @_ */
17030 bool reuse = 0; /* reuse an existing padrange op */
17032 /* look for a pushmark -> gv[_] -> rv2av */
17037 if ( p->op_type == OP_GV
17038 && cGVOPx_gv(p) == PL_defgv
17039 && (rv2av = p->op_next)
17040 && rv2av->op_type == OP_RV2AV
17041 && !(rv2av->op_flags & OPf_REF)
17042 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
17043 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
17045 q = rv2av->op_next;
17046 if (q->op_type == OP_NULL)
17048 if (q->op_type == OP_PUSHMARK) {
17058 /* scan for PAD ops */
17060 for (p = p->op_next; p; p = p->op_next) {
17061 if (p->op_type == OP_NULL)
17064 if (( p->op_type != OP_PADSV
17065 && p->op_type != OP_PADAV
17066 && p->op_type != OP_PADHV
17068 /* any private flag other than INTRO? e.g. STATE */
17069 || (p->op_private & ~OPpLVAL_INTRO)
17073 /* let $a[N] potentially be optimised into AELEMFAST_LEX
17075 if ( p->op_type == OP_PADAV
17077 && p->op_next->op_type == OP_CONST
17078 && p->op_next->op_next
17079 && p->op_next->op_next->op_type == OP_AELEM
17083 /* for 1st padop, note what type it is and the range
17084 * start; for the others, check that it's the same type
17085 * and that the targs are contiguous */
17087 intro = (p->op_private & OPpLVAL_INTRO);
17089 gvoid = OP_GIMME(p,0) == G_VOID;
17092 if ((p->op_private & OPpLVAL_INTRO) != intro)
17094 /* Note that you'd normally expect targs to be
17095 * contiguous in my($a,$b,$c), but that's not the case
17096 * when external modules start doing things, e.g.
17097 * Function::Parameters */
17098 if (p->op_targ != base + count)
17100 assert(p->op_targ == base + count);
17101 /* Either all the padops or none of the padops should
17102 be in void context. Since we only do the optimisa-
17103 tion for av/hv when the aggregate itself is pushed
17104 on to the stack (one item), there is no need to dis-
17105 tinguish list from scalar context. */
17106 if (gvoid != (OP_GIMME(p,0) == G_VOID))
17110 /* for AV, HV, only when we're not flattening */
17111 if ( p->op_type != OP_PADSV
17113 && !(p->op_flags & OPf_REF)
17117 if (count >= OPpPADRANGE_COUNTMASK)
17120 /* there's a biggest base we can fit into a
17121 * SAVEt_CLEARPADRANGE in pp_padrange.
17122 * (The sizeof() stuff will be constant-folded, and is
17123 * intended to avoid getting "comparison is always false"
17124 * compiler warnings. See the comments above
17125 * MEM_WRAP_CHECK for more explanation on why we do this
17126 * in a weird way to avoid compiler warnings.)
17129 && (8*sizeof(base) >
17130 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
17132 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17134 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
17138 /* Success! We've got another valid pad op to optimise away */
17140 followop = p->op_next;
17143 if (count < 1 || (count == 1 && !defav))
17146 /* pp_padrange in specifically compile-time void context
17147 * skips pushing a mark and lexicals; in all other contexts
17148 * (including unknown till runtime) it pushes a mark and the
17149 * lexicals. We must be very careful then, that the ops we
17150 * optimise away would have exactly the same effect as the
17152 * In particular in void context, we can only optimise to
17153 * a padrange if we see the complete sequence
17154 * pushmark, pad*v, ...., list
17155 * which has the net effect of leaving the markstack as it
17156 * was. Not pushing onto the stack (whereas padsv does touch
17157 * the stack) makes no difference in void context.
17161 if (followop->op_type == OP_LIST
17162 && OP_GIMME(followop,0) == G_VOID
17165 followop = followop->op_next; /* skip OP_LIST */
17167 /* consolidate two successive my(...);'s */
17170 && oldoldop->op_type == OP_PADRANGE
17171 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
17172 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
17173 && !(oldoldop->op_flags & OPf_SPECIAL)
17176 assert(oldoldop->op_next == oldop);
17177 assert( oldop->op_type == OP_NEXTSTATE
17178 || oldop->op_type == OP_DBSTATE);
17179 assert(oldop->op_next == o);
17182 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
17184 /* Do not assume pad offsets for $c and $d are con-
17189 if ( oldoldop->op_targ + old_count == base
17190 && old_count < OPpPADRANGE_COUNTMASK - count) {
17191 base = oldoldop->op_targ;
17192 count += old_count;
17197 /* if there's any immediately following singleton
17198 * my var's; then swallow them and the associated
17200 * my ($a,$b); my $c; my $d;
17202 * my ($a,$b,$c,$d);
17205 while ( ((p = followop->op_next))
17206 && ( p->op_type == OP_PADSV
17207 || p->op_type == OP_PADAV
17208 || p->op_type == OP_PADHV)
17209 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
17210 && (p->op_private & OPpLVAL_INTRO) == intro
17211 && !(p->op_private & ~OPpLVAL_INTRO)
17213 && ( p->op_next->op_type == OP_NEXTSTATE
17214 || p->op_next->op_type == OP_DBSTATE)
17215 && count < OPpPADRANGE_COUNTMASK
17216 && base + count == p->op_targ
17219 followop = p->op_next;
17227 assert(oldoldop->op_type == OP_PADRANGE);
17228 oldoldop->op_next = followop;
17229 oldoldop->op_private = (intro | count);
17235 /* Convert the pushmark into a padrange.
17236 * To make Deparse easier, we guarantee that a padrange was
17237 * *always* formerly a pushmark */
17238 assert(o->op_type == OP_PUSHMARK);
17239 o->op_next = followop;
17240 OpTYPE_set(o, OP_PADRANGE);
17242 /* bit 7: INTRO; bit 6..0: count */
17243 o->op_private = (intro | count);
17244 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
17245 | gvoid * OPf_WANT_VOID
17246 | (defav ? OPf_SPECIAL : 0));
17252 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17253 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17258 /*'keys %h' in void or scalar context: skip the OP_KEYS
17259 * and perform the functionality directly in the RV2HV/PADHV
17262 if (o->op_flags & OPf_REF) {
17263 OP *k = o->op_next;
17264 U8 want = (k->op_flags & OPf_WANT);
17266 && k->op_type == OP_KEYS
17267 && ( want == OPf_WANT_VOID
17268 || want == OPf_WANT_SCALAR)
17269 && !(k->op_private & OPpMAYBE_LVSUB)
17270 && !(k->op_flags & OPf_MOD)
17272 o->op_next = k->op_next;
17273 o->op_flags &= ~(OPf_REF|OPf_WANT);
17274 o->op_flags |= want;
17275 o->op_private |= (o->op_type == OP_PADHV ?
17276 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
17277 /* for keys(%lex), hold onto the OP_KEYS's targ
17278 * since padhv doesn't have its own targ to return
17280 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
17285 /* see if %h is used in boolean context */
17286 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17287 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17290 if (o->op_type != OP_PADHV)
17294 if ( o->op_type == OP_PADAV
17295 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17297 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17300 /* Skip over state($x) in void context. */
17301 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
17302 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
17304 oldop->op_next = o->op_next;
17305 goto redo_nextstate;
17307 if (o->op_type != OP_PADAV)
17311 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
17312 OP* const pop = (o->op_type == OP_PADAV) ?
17313 o->op_next : o->op_next->op_next;
17315 if (pop && pop->op_type == OP_CONST &&
17316 ((PL_op = pop->op_next)) &&
17317 pop->op_next->op_type == OP_AELEM &&
17318 !(pop->op_next->op_private &
17319 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
17320 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
17323 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
17324 no_bareword_allowed(pop);
17325 if (o->op_type == OP_GV)
17326 op_null(o->op_next);
17327 op_null(pop->op_next);
17329 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
17330 o->op_next = pop->op_next->op_next;
17331 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
17332 o->op_private = (U8)i;
17333 if (o->op_type == OP_GV) {
17336 o->op_type = OP_AELEMFAST;
17339 o->op_type = OP_AELEMFAST_LEX;
17341 if (o->op_type != OP_GV)
17345 /* Remove $foo from the op_next chain in void context. */
17347 && ( o->op_next->op_type == OP_RV2SV
17348 || o->op_next->op_type == OP_RV2AV
17349 || o->op_next->op_type == OP_RV2HV )
17350 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17351 && !(o->op_next->op_private & OPpLVAL_INTRO))
17353 oldop->op_next = o->op_next->op_next;
17354 /* Reprocess the previous op if it is a nextstate, to
17355 allow double-nextstate optimisation. */
17357 if (oldop->op_type == OP_NEXTSTATE) {
17364 o = oldop->op_next;
17367 else if (o->op_next->op_type == OP_RV2SV) {
17368 if (!(o->op_next->op_private & OPpDEREF)) {
17369 op_null(o->op_next);
17370 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
17372 o->op_next = o->op_next->op_next;
17373 OpTYPE_set(o, OP_GVSV);
17376 else if (o->op_next->op_type == OP_READLINE
17377 && o->op_next->op_next->op_type == OP_CONCAT
17378 && (o->op_next->op_next->op_flags & OPf_STACKED))
17380 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
17381 OpTYPE_set(o, OP_RCATLINE);
17382 o->op_flags |= OPf_STACKED;
17383 op_null(o->op_next->op_next);
17384 op_null(o->op_next);
17395 while (cLOGOP->op_other->op_type == OP_NULL)
17396 cLOGOP->op_other = cLOGOP->op_other->op_next;
17397 while (o->op_next && ( o->op_type == o->op_next->op_type
17398 || o->op_next->op_type == OP_NULL))
17399 o->op_next = o->op_next->op_next;
17401 /* If we're an OR and our next is an AND in void context, we'll
17402 follow its op_other on short circuit, same for reverse.
17403 We can't do this with OP_DOR since if it's true, its return
17404 value is the underlying value which must be evaluated
17408 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
17409 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
17411 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
17413 o->op_next = ((LOGOP*)o->op_next)->op_other;
17415 DEFER(cLOGOP->op_other);
17420 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17421 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17430 case OP_ARGDEFELEM:
17431 while (cLOGOP->op_other->op_type == OP_NULL)
17432 cLOGOP->op_other = cLOGOP->op_other->op_next;
17433 DEFER(cLOGOP->op_other);
17438 while (cLOOP->op_redoop->op_type == OP_NULL)
17439 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
17440 while (cLOOP->op_nextop->op_type == OP_NULL)
17441 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
17442 while (cLOOP->op_lastop->op_type == OP_NULL)
17443 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
17444 /* a while(1) loop doesn't have an op_next that escapes the
17445 * loop, so we have to explicitly follow the op_lastop to
17446 * process the rest of the code */
17447 DEFER(cLOOP->op_lastop);
17451 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
17452 DEFER(cLOGOPo->op_other);
17456 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17457 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17458 assert(!(cPMOP->op_pmflags & PMf_ONCE));
17459 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
17460 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
17461 cPMOP->op_pmstashstartu.op_pmreplstart
17462 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
17463 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
17469 if (o->op_flags & OPf_SPECIAL) {
17470 /* first arg is a code block */
17471 OP * const nullop = OpSIBLING(cLISTOP->op_first);
17472 OP * kid = cUNOPx(nullop)->op_first;
17474 assert(nullop->op_type == OP_NULL);
17475 assert(kid->op_type == OP_SCOPE
17476 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
17477 /* since OP_SORT doesn't have a handy op_other-style
17478 * field that can point directly to the start of the code
17479 * block, store it in the otherwise-unused op_next field
17480 * of the top-level OP_NULL. This will be quicker at
17481 * run-time, and it will also allow us to remove leading
17482 * OP_NULLs by just messing with op_nexts without
17483 * altering the basic op_first/op_sibling layout. */
17484 kid = kLISTOP->op_first;
17486 (kid->op_type == OP_NULL
17487 && ( kid->op_targ == OP_NEXTSTATE
17488 || kid->op_targ == OP_DBSTATE ))
17489 || kid->op_type == OP_STUB
17490 || kid->op_type == OP_ENTER
17491 || (PL_parser && PL_parser->error_count));
17492 nullop->op_next = kid->op_next;
17493 DEFER(nullop->op_next);
17496 /* check that RHS of sort is a single plain array */
17497 oright = cUNOPo->op_first;
17498 if (!oright || oright->op_type != OP_PUSHMARK)
17501 if (o->op_private & OPpSORT_INPLACE)
17504 /* reverse sort ... can be optimised. */
17505 if (!OpHAS_SIBLING(cUNOPo)) {
17506 /* Nothing follows us on the list. */
17507 OP * const reverse = o->op_next;
17509 if (reverse->op_type == OP_REVERSE &&
17510 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
17511 OP * const pushmark = cUNOPx(reverse)->op_first;
17512 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
17513 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
17514 /* reverse -> pushmark -> sort */
17515 o->op_private |= OPpSORT_REVERSE;
17517 pushmark->op_next = oright->op_next;
17527 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
17529 LISTOP *enter, *exlist;
17531 if (o->op_private & OPpSORT_INPLACE)
17534 enter = (LISTOP *) o->op_next;
17537 if (enter->op_type == OP_NULL) {
17538 enter = (LISTOP *) enter->op_next;
17542 /* for $a (...) will have OP_GV then OP_RV2GV here.
17543 for (...) just has an OP_GV. */
17544 if (enter->op_type == OP_GV) {
17545 gvop = (OP *) enter;
17546 enter = (LISTOP *) enter->op_next;
17549 if (enter->op_type == OP_RV2GV) {
17550 enter = (LISTOP *) enter->op_next;
17556 if (enter->op_type != OP_ENTERITER)
17559 iter = enter->op_next;
17560 if (!iter || iter->op_type != OP_ITER)
17563 expushmark = enter->op_first;
17564 if (!expushmark || expushmark->op_type != OP_NULL
17565 || expushmark->op_targ != OP_PUSHMARK)
17568 exlist = (LISTOP *) OpSIBLING(expushmark);
17569 if (!exlist || exlist->op_type != OP_NULL
17570 || exlist->op_targ != OP_LIST)
17573 if (exlist->op_last != o) {
17574 /* Mmm. Was expecting to point back to this op. */
17577 theirmark = exlist->op_first;
17578 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
17581 if (OpSIBLING(theirmark) != o) {
17582 /* There's something between the mark and the reverse, eg
17583 for (1, reverse (...))
17588 ourmark = ((LISTOP *)o)->op_first;
17589 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
17592 ourlast = ((LISTOP *)o)->op_last;
17593 if (!ourlast || ourlast->op_next != o)
17596 rv2av = OpSIBLING(ourmark);
17597 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
17598 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
17599 /* We're just reversing a single array. */
17600 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
17601 enter->op_flags |= OPf_STACKED;
17604 /* We don't have control over who points to theirmark, so sacrifice
17606 theirmark->op_next = ourmark->op_next;
17607 theirmark->op_flags = ourmark->op_flags;
17608 ourlast->op_next = gvop ? gvop : (OP *) enter;
17611 enter->op_private |= OPpITER_REVERSED;
17612 iter->op_private |= OPpITER_REVERSED;
17616 o = oldop->op_next;
17618 NOT_REACHED; /* NOTREACHED */
17624 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
17625 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
17630 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
17631 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
17634 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
17636 sv = newRV((SV *)PL_compcv);
17640 OpTYPE_set(o, OP_CONST);
17641 o->op_flags |= OPf_SPECIAL;
17642 cSVOPo->op_sv = sv;
17647 if (OP_GIMME(o,0) == G_VOID
17648 || ( o->op_next->op_type == OP_LINESEQ
17649 && ( o->op_next->op_next->op_type == OP_LEAVESUB
17650 || ( o->op_next->op_next->op_type == OP_RETURN
17651 && !CvLVALUE(PL_compcv)))))
17653 OP *right = cBINOP->op_first;
17672 OP *left = OpSIBLING(right);
17673 if (left->op_type == OP_SUBSTR
17674 && (left->op_private & 7) < 4) {
17676 /* cut out right */
17677 op_sibling_splice(o, NULL, 1, NULL);
17678 /* and insert it as second child of OP_SUBSTR */
17679 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
17681 left->op_private |= OPpSUBSTR_REPL_FIRST;
17683 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
17690 int l, r, lr, lscalars, rscalars;
17692 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
17693 Note that we do this now rather than in newASSIGNOP(),
17694 since only by now are aliased lexicals flagged as such
17696 See the essay "Common vars in list assignment" above for
17697 the full details of the rationale behind all the conditions
17700 PL_generation sorcery:
17701 To detect whether there are common vars, the global var
17702 PL_generation is incremented for each assign op we scan.
17703 Then we run through all the lexical variables on the LHS,
17704 of the assignment, setting a spare slot in each of them to
17705 PL_generation. Then we scan the RHS, and if any lexicals
17706 already have that value, we know we've got commonality.
17707 Also, if the generation number is already set to
17708 PERL_INT_MAX, then the variable is involved in aliasing, so
17709 we also have potential commonality in that case.
17715 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
17718 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
17722 /* After looking for things which are *always* safe, this main
17723 * if/else chain selects primarily based on the type of the
17724 * LHS, gradually working its way down from the more dangerous
17725 * to the more restrictive and thus safer cases */
17727 if ( !l /* () = ....; */
17728 || !r /* .... = (); */
17729 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
17730 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
17731 || (lscalars < 2) /* ($x, undef) = ... */
17733 NOOP; /* always safe */
17735 else if (l & AAS_DANGEROUS) {
17736 /* always dangerous */
17737 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17738 o->op_private |= OPpASSIGN_COMMON_AGG;
17740 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
17741 /* package vars are always dangerous - too many
17742 * aliasing possibilities */
17743 if (l & AAS_PKG_SCALAR)
17744 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17745 if (l & AAS_PKG_AGG)
17746 o->op_private |= OPpASSIGN_COMMON_AGG;
17748 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
17749 |AAS_LEX_SCALAR|AAS_LEX_AGG))
17751 /* LHS contains only lexicals and safe ops */
17753 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
17754 o->op_private |= OPpASSIGN_COMMON_AGG;
17756 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
17757 if (lr & AAS_LEX_SCALAR_COMM)
17758 o->op_private |= OPpASSIGN_COMMON_SCALAR;
17759 else if ( !(l & AAS_LEX_SCALAR)
17760 && (r & AAS_DEFAV))
17764 * as scalar-safe for performance reasons.
17765 * (it will still have been marked _AGG if necessary */
17768 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
17769 /* if there are only lexicals on the LHS and no
17770 * common ones on the RHS, then we assume that the
17771 * only way those lexicals could also get
17772 * on the RHS is via some sort of dereffing or
17775 * ($lex, $x) = (1, $$r)
17776 * and in this case we assume the var must have
17777 * a bumped ref count. So if its ref count is 1,
17778 * it must only be on the LHS.
17780 o->op_private |= OPpASSIGN_COMMON_RC1;
17785 * may have to handle aggregate on LHS, but we can't
17786 * have common scalars. */
17789 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17791 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17792 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17797 /* see if ref() is used in boolean context */
17798 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17799 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17803 /* see if the op is used in known boolean context,
17804 * but not if OA_TARGLEX optimisation is enabled */
17805 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17806 && !(o->op_private & OPpTARGET_MY)
17808 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17812 /* see if the op is used in known boolean context */
17813 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17814 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17818 Perl_cpeep_t cpeep =
17819 XopENTRYCUSTOM(o, xop_peep);
17821 cpeep(aTHX_ o, oldop);
17826 /* did we just null the current op? If so, re-process it to handle
17827 * eliding "empty" ops from the chain */
17828 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
17841 Perl_peep(pTHX_ OP *o)
17847 =head1 Custom Operators
17849 =for apidoc Perl_custom_op_xop
17850 Return the XOP structure for a given custom op. This macro should be
17851 considered internal to C<OP_NAME> and the other access macros: use them instead.
17852 This macro does call a function. Prior
17853 to 5.19.6, this was implemented as a
17860 /* use PERL_MAGIC_ext to call a function to free the xop structure when
17861 * freeing PL_custom_ops */
17864 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
17868 PERL_UNUSED_ARG(mg);
17869 xop = INT2PTR(XOP *, SvIV(sv));
17870 Safefree(xop->xop_name);
17871 Safefree(xop->xop_desc);
17877 static const MGVTBL custom_op_register_vtbl = {
17882 custom_op_register_free, /* free */
17892 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
17898 static const XOP xop_null = { 0, 0, 0, 0, 0 };
17900 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
17901 assert(o->op_type == OP_CUSTOM);
17903 /* This is wrong. It assumes a function pointer can be cast to IV,
17904 * which isn't guaranteed, but this is what the old custom OP code
17905 * did. In principle it should be safer to Copy the bytes of the
17906 * pointer into a PV: since the new interface is hidden behind
17907 * functions, this can be changed later if necessary. */
17908 /* Change custom_op_xop if this ever happens */
17909 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
17912 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17914 /* See if the op isn't registered, but its name *is* registered.
17915 * That implies someone is using the pre-5.14 API,where only name and
17916 * description could be registered. If so, fake up a real
17918 * We only check for an existing name, and assume no one will have
17919 * just registered a desc */
17920 if (!he && PL_custom_op_names &&
17921 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
17926 /* XXX does all this need to be shared mem? */
17927 Newxz(xop, 1, XOP);
17928 pv = SvPV(HeVAL(he), l);
17929 XopENTRY_set(xop, xop_name, savepvn(pv, l));
17930 if (PL_custom_op_descs &&
17931 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
17933 pv = SvPV(HeVAL(he), l);
17934 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
17936 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
17937 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17938 /* add magic to the SV so that the xop struct (pointed to by
17939 * SvIV(sv)) is freed. Normally a static xop is registered, but
17940 * for this backcompat hack, we've alloced one */
17941 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
17942 &custom_op_register_vtbl, NULL, 0);
17947 xop = (XOP *)&xop_null;
17949 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
17953 if(field == XOPe_xop_ptr) {
17956 const U32 flags = XopFLAGS(xop);
17957 if(flags & field) {
17959 case XOPe_xop_name:
17960 any.xop_name = xop->xop_name;
17962 case XOPe_xop_desc:
17963 any.xop_desc = xop->xop_desc;
17965 case XOPe_xop_class:
17966 any.xop_class = xop->xop_class;
17968 case XOPe_xop_peep:
17969 any.xop_peep = xop->xop_peep;
17972 NOT_REACHED; /* NOTREACHED */
17977 case XOPe_xop_name:
17978 any.xop_name = XOPd_xop_name;
17980 case XOPe_xop_desc:
17981 any.xop_desc = XOPd_xop_desc;
17983 case XOPe_xop_class:
17984 any.xop_class = XOPd_xop_class;
17986 case XOPe_xop_peep:
17987 any.xop_peep = XOPd_xop_peep;
17990 NOT_REACHED; /* NOTREACHED */
17995 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
17996 * op.c: In function 'Perl_custom_op_get_field':
17997 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
17998 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
17999 * expands to assert(0), which expands to ((0) ? (void)0 :
18000 * __assert(...)), and gcc doesn't know that __assert can never return. */
18006 =for apidoc custom_op_register
18007 Register a custom op. See L<perlguts/"Custom Operators">.
18013 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
18017 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
18019 /* see the comment in custom_op_xop */
18020 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
18022 if (!PL_custom_ops)
18023 PL_custom_ops = newHV();
18025 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
18026 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
18031 =for apidoc core_prototype
18033 This function assigns the prototype of the named core function to C<sv>, or
18034 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
18035 C<NULL> if the core function has no prototype. C<code> is a code as returned
18036 by C<keyword()>. It must not be equal to 0.
18042 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
18045 int i = 0, n = 0, seen_question = 0, defgv = 0;
18047 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
18048 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
18049 bool nullret = FALSE;
18051 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
18055 if (!sv) sv = sv_newmortal();
18057 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
18059 switch (code < 0 ? -code : code) {
18060 case KEY_and : case KEY_chop: case KEY_chomp:
18061 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
18062 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
18063 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
18064 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
18065 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
18066 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
18067 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
18068 case KEY_x : case KEY_xor :
18069 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
18070 case KEY_glob: retsetpvs("_;", OP_GLOB);
18071 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
18072 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
18073 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
18074 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
18075 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
18077 case KEY_evalbytes:
18078 name = "entereval"; break;
18086 while (i < MAXO) { /* The slow way. */
18087 if (strEQ(name, PL_op_name[i])
18088 || strEQ(name, PL_op_desc[i]))
18090 if (nullret) { assert(opnum); *opnum = i; return NULL; }
18097 defgv = PL_opargs[i] & OA_DEFGV;
18098 oa = PL_opargs[i] >> OASHIFT;
18100 if (oa & OA_OPTIONAL && !seen_question && (
18101 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
18106 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
18107 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
18108 /* But globs are already references (kinda) */
18109 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
18113 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
18114 && !scalar_mod_type(NULL, i)) {
18119 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
18123 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
18124 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
18125 str[n-1] = '_'; defgv = 0;
18129 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
18131 sv_setpvn(sv, str, n - 1);
18132 if (opnum) *opnum = i;
18137 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
18140 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
18141 newSVOP(OP_COREARGS,0,coreargssv);
18144 PERL_ARGS_ASSERT_CORESUB_OP;
18148 return op_append_elem(OP_LINESEQ,
18151 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
18158 o = newUNOP(OP_AVHVSWITCH,0,argop);
18159 o->op_private = opnum-OP_EACH;
18161 case OP_SELECT: /* which represents OP_SSELECT as well */
18166 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
18167 newSVOP(OP_CONST, 0, newSVuv(1))
18169 coresub_op(newSVuv((UV)OP_SSELECT), 0,
18171 coresub_op(coreargssv, 0, OP_SELECT)
18175 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
18177 return op_append_elem(
18180 opnum == OP_WANTARRAY || opnum == OP_RUNCV
18181 ? OPpOFFBYONE << 8 : 0)
18183 case OA_BASEOP_OR_UNOP:
18184 if (opnum == OP_ENTEREVAL) {
18185 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
18186 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
18188 else o = newUNOP(opnum,0,argop);
18189 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
18192 if (is_handle_constructor(o, 1))
18193 argop->op_private |= OPpCOREARGS_DEREF1;
18194 if (scalar_mod_type(NULL, opnum))
18195 argop->op_private |= OPpCOREARGS_SCALARMOD;
18199 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
18200 if (is_handle_constructor(o, 2))
18201 argop->op_private |= OPpCOREARGS_DEREF2;
18202 if (opnum == OP_SUBSTR) {
18203 o->op_private |= OPpMAYBE_LVSUB;
18212 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
18213 SV * const *new_const_svp)
18215 const char *hvname;
18216 bool is_const = !!CvCONST(old_cv);
18217 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
18219 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
18221 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
18223 /* They are 2 constant subroutines generated from
18224 the same constant. This probably means that
18225 they are really the "same" proxy subroutine
18226 instantiated in 2 places. Most likely this is
18227 when a constant is exported twice. Don't warn.
18230 (ckWARN(WARN_REDEFINE)
18232 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
18233 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
18234 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
18235 strEQ(hvname, "autouse"))
18239 && ckWARN_d(WARN_REDEFINE)
18240 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
18243 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
18245 ? "Constant subroutine %" SVf " redefined"
18246 : "Subroutine %" SVf " redefined",
18251 =head1 Hook manipulation
18253 These functions provide convenient and thread-safe means of manipulating
18260 =for apidoc wrap_op_checker
18262 Puts a C function into the chain of check functions for a specified op
18263 type. This is the preferred way to manipulate the L</PL_check> array.
18264 C<opcode> specifies which type of op is to be affected. C<new_checker>
18265 is a pointer to the C function that is to be added to that opcode's
18266 check chain, and C<old_checker_p> points to the storage location where a
18267 pointer to the next function in the chain will be stored. The value of
18268 C<new_checker> is written into the L</PL_check> array, while the value
18269 previously stored there is written to C<*old_checker_p>.
18271 L</PL_check> is global to an entire process, and a module wishing to
18272 hook op checking may find itself invoked more than once per process,
18273 typically in different threads. To handle that situation, this function
18274 is idempotent. The location C<*old_checker_p> must initially (once
18275 per process) contain a null pointer. A C variable of static duration
18276 (declared at file scope, typically also marked C<static> to give
18277 it internal linkage) will be implicitly initialised appropriately,
18278 if it does not have an explicit initialiser. This function will only
18279 actually modify the check chain if it finds C<*old_checker_p> to be null.
18280 This function is also thread safe on the small scale. It uses appropriate
18281 locking to avoid race conditions in accessing L</PL_check>.
18283 When this function is called, the function referenced by C<new_checker>
18284 must be ready to be called, except for C<*old_checker_p> being unfilled.
18285 In a threading situation, C<new_checker> may be called immediately,
18286 even before this function has returned. C<*old_checker_p> will always
18287 be appropriately set before C<new_checker> is called. If C<new_checker>
18288 decides not to do anything special with an op that it is given (which
18289 is the usual case for most uses of op check hooking), it must chain the
18290 check function referenced by C<*old_checker_p>.
18292 Taken all together, XS code to hook an op checker should typically look
18293 something like this:
18295 static Perl_check_t nxck_frob;
18296 static OP *myck_frob(pTHX_ OP *op) {
18298 op = nxck_frob(aTHX_ op);
18303 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
18305 If you want to influence compilation of calls to a specific subroutine,
18306 then use L</cv_set_call_checker_flags> rather than hooking checking of
18307 all C<entersub> ops.
18313 Perl_wrap_op_checker(pTHX_ Optype opcode,
18314 Perl_check_t new_checker, Perl_check_t *old_checker_p)
18318 PERL_UNUSED_CONTEXT;
18319 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
18320 if (*old_checker_p) return;
18321 OP_CHECK_MUTEX_LOCK;
18322 if (!*old_checker_p) {
18323 *old_checker_p = PL_check[opcode];
18324 PL_check[opcode] = new_checker;
18326 OP_CHECK_MUTEX_UNLOCK;
18331 /* Efficient sub that returns a constant scalar value. */
18333 const_sv_xsub(pTHX_ CV* cv)
18336 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
18337 PERL_UNUSED_ARG(items);
18347 const_av_xsub(pTHX_ CV* cv)
18350 AV * const av = MUTABLE_AV(XSANY.any_ptr);
18358 if (SvRMAGICAL(av))
18359 Perl_croak(aTHX_ "Magical list constants are not supported");
18360 if (GIMME_V != G_ARRAY) {
18362 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
18365 EXTEND(SP, AvFILLp(av)+1);
18366 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
18367 XSRETURN(AvFILLp(av)+1);
18370 /* Copy an existing cop->cop_warnings field.
18371 * If it's one of the standard addresses, just re-use the address.
18372 * This is the e implementation for the DUP_WARNINGS() macro
18376 Perl_dup_warnings(pTHX_ STRLEN* warnings)
18379 STRLEN *new_warnings;
18381 if (warnings == NULL || specialWARN(warnings))
18384 size = sizeof(*warnings) + *warnings;
18386 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
18387 Copy(warnings, new_warnings, size, char);
18388 return new_warnings;
18392 * ex: set ts=8 sts=4 sw=4 et: