4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
28 * A Perl program is compiled into a tree of OP nodes. Each op contains:
29 * * structural OP pointers to its children and siblings (op_sibling,
30 * op_first etc) that define the tree structure;
31 * * execution order OP pointers (op_next, plus sometimes op_other,
32 * op_lastop etc) that define the execution sequence plus variants;
33 * * a pointer to the C "pp" function that would execute the op;
34 * * any data specific to that op.
35 * For example, an OP_CONST op points to the pp_const() function and to an
36 * SV containing the constant value. When pp_const() is executed, its job
37 * is to push that SV onto the stack.
39 * OPs are mainly created by the newFOO() functions, which are mainly
40 * called from the parser (in perly.y) as the code is parsed. For example
41 * the Perl code $a + $b * $c would cause the equivalent of the following
42 * to be called (oversimplifying a bit):
44 * newBINOP(OP_ADD, flags,
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
49 * As the parser reduces low-level rules, it creates little op subtrees;
50 * as higher-level rules are resolved, these subtrees get joined together
51 * as branches on a bigger subtree, until eventually a top-level rule like
52 * a subroutine definition is reduced, at which point there is one large
55 * The execution order pointers (op_next) are generated as the subtrees
56 * are joined together. Consider this sub-expression: A*B + C/D: at the
57 * point when it's just been parsed, the op tree looks like:
65 * with the intended execution order being:
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
69 * At this point all the nodes' op_next pointers will have been set,
71 * * we don't know what the [NEXT] node will be yet;
72 * * we don't know what the [PREV] node will be yet, but when it gets
73 * created and needs its op_next set, it needs to be set to point to
74 * A, which is non-obvious.
75 * To handle both those cases, we temporarily set the top node's
76 * op_next to point to the first node to be executed in this subtree (A in
77 * this case). This means that initially a subtree's op_next chain,
78 * starting from the top node, will visit each node in execution sequence
79 * then point back at the top node.
80 * When we embed this subtree in a larger tree, its top op_next is used
81 * to get the start node, then is set to point to its new neighbour.
82 * For example the two separate [*],A,B and [/],C,D subtrees would
84 * [*] => A; A => B; B => [*]
86 * [/] => C; C => D; D => [/]
87 * When these two subtrees were joined together to make the [+] subtree,
88 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89 * set to point to [/]'s op_next, i.e. C.
91 * This op_next linking is done by the LINKLIST() macro and its underlying
92 * op_linklist() function. Given a top-level op, if its op_next is
93 * non-null, it's already been linked, so leave it. Otherwise link it with
94 * its children as described above, possibly recursively if any of the
95 * children have a null op_next.
97 * In summary: given a subtree, its top-level node's op_next will either
99 * NULL: the subtree hasn't been LINKLIST()ed yet;
100 * fake: points to the start op for this subtree;
101 * real: once the subtree has been embedded into a larger tree
106 Here's an older description from Larry.
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
112 An execution-order pass
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines. The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order. (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again). As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node. But
130 it's still not the real execution order.
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer. At that point, we can call
135 into peep() to do that code's portion of the 3rd pass. It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140 get the compile time state of %^H for that block. Storing %^H in every
141 block (or even COP) would be very expensive, so a different approach is
142 taken. The (running) state of %^H is serialised into a tree of HE-like
143 structs. Stores into %^H are chained onto the current leaf as a struct
144 refcounted_he * with the key and the value. Deletes from %^H are saved
145 with a value of PL_sv_placeholder. The state of %^H at any point can be
146 turned back into a regular HV by walking back up the tree from that point's
147 leaf, ignoring any key you've already seen (placeholder or not), storing
148 the rest into the HV structure, then removing the placeholders. Hence
149 memory is only used to store the %^H deltas from the enclosing COP, rather
150 than the entire %^H on each COP.
152 To cause actions on %^H to write out the serialisation records, it has
153 magic type 'H'. This magic (itself) does nothing, but its presence causes
154 the values to gain magic type 'h', which has entries for set and clear.
155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158 it will be correctly restored when any inner compiling scope is exited.
164 #include "keywords.h"
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
174 /* remove any leading "empty" ops from the op_next chain whose first
175 * node's address is stored in op_p. Store the updated address of the
176 * first node in op_p.
180 S_prune_chain_head(OP** op_p)
183 && ( (*op_p)->op_type == OP_NULL
184 || (*op_p)->op_type == OP_SCOPE
185 || (*op_p)->op_type == OP_SCALAR
186 || (*op_p)->op_type == OP_LINESEQ)
188 *op_p = (*op_p)->op_next;
192 /* See the explanatory comments above struct opslab in op.h. */
194 #ifdef PERL_DEBUG_READONLY_OPS
195 # define PERL_SLAB_SIZE 128
196 # define PERL_MAX_SLAB_SIZE 4096
197 # include <sys/mman.h>
200 #ifndef PERL_SLAB_SIZE
201 # define PERL_SLAB_SIZE 64
203 #ifndef PERL_MAX_SLAB_SIZE
204 # define PERL_MAX_SLAB_SIZE 2048
207 /* rounds up to nearest pointer */
208 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
209 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
211 /* requires double parens and aTHX_ */
212 #define DEBUG_S_warn(args) \
214 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
218 /* malloc a new op slab (suitable for attaching to PL_compcv).
219 * sz is in units of pointers */
222 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
226 /* opslot_offset is only U16 */
227 assert(sz < U16_MAX);
229 #ifdef PERL_DEBUG_READONLY_OPS
230 slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
231 PROT_READ|PROT_WRITE,
232 MAP_ANON|MAP_PRIVATE, -1, 0);
233 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
234 (unsigned long) sz, slab));
235 if (slab == MAP_FAILED) {
236 perror("mmap failed");
240 slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
242 slab->opslab_size = (U16)sz;
245 /* The context is unused in non-Windows */
248 slab->opslab_free_space = sz - DIFF(slab, &slab->opslab_slots);
249 slab->opslab_head = head ? head : slab;
250 DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
251 (unsigned int)slab->opslab_size, (void*)slab,
252 (void*)(slab->opslab_head)));
257 /* Returns a sz-sized block of memory (suitable for holding an op) from
258 * a free slot in the chain of op slabs attached to PL_compcv.
259 * Allocates a new slab if necessary.
260 * if PL_compcv isn't compiling, malloc() instead.
264 Perl_Slab_Alloc(pTHX_ size_t sz)
266 OPSLAB *head_slab; /* first slab in the chain */
272 /* We only allocate ops from the slab during subroutine compilation.
273 We find the slab via PL_compcv, hence that must be non-NULL. It could
274 also be pointing to a subroutine which is now fully set up (CvROOT()
275 pointing to the top of the optree for that sub), or a subroutine
276 which isn't using the slab allocator. If our sanity checks aren't met,
277 don't use a slab, but allocate the OP directly from the heap. */
278 if (!PL_compcv || CvROOT(PL_compcv)
279 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
281 o = (OP*)PerlMemShared_calloc(1, sz);
285 /* While the subroutine is under construction, the slabs are accessed via
286 CvSTART(), to avoid needing to expand PVCV by one pointer for something
287 unneeded at runtime. Once a subroutine is constructed, the slabs are
288 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
289 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
291 if (!CvSTART(PL_compcv)) {
293 (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
294 CvSLABBED_on(PL_compcv);
295 head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
297 else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
299 opsz = SIZE_TO_PSIZE(sz);
300 sz = opsz + OPSLOT_HEADER_P;
302 /* The slabs maintain a free list of OPs. In particular, constant folding
303 will free up OPs, so it makes sense to re-use them where possible. A
304 freed up slot is used in preference to a new allocation. */
305 if (head_slab->opslab_freed) {
306 OP **too = &head_slab->opslab_freed;
308 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p, head slab %p",
310 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
313 while (o && OpSLOT(o)->opslot_size < sz) {
314 DEBUG_S_warn((aTHX_ "Alas! too small"));
315 o = *(too = &o->op_next);
316 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
319 DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
321 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
324 Zero(o, opsz, I32 *);
330 #define INIT_OPSLOT(s) \
331 slot->opslot_offset = DIFF(slab2, slot) ; \
332 slot->opslot_size = s; \
333 slab2->opslab_free_space -= s; \
334 o = &slot->opslot_op; \
337 /* The partially-filled slab is next in the chain. */
338 slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
339 if (slab2->opslab_free_space < sz) {
340 /* Remaining space is too small. */
341 /* If we can fit a BASEOP, add it to the free chain, so as not
343 if (slab2->opslab_free_space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
344 slot = &slab2->opslab_slots;
345 INIT_OPSLOT(slab2->opslab_free_space);
346 o->op_type = OP_FREED;
347 o->op_next = head_slab->opslab_freed;
348 head_slab->opslab_freed = o;
351 /* Create a new slab. Make this one twice as big. */
352 slab2 = S_new_slab(aTHX_ head_slab,
353 slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
355 : slab2->opslab_size * 2);
356 slab2->opslab_next = head_slab->opslab_next;
357 head_slab->opslab_next = slab2;
359 assert(slab2->opslab_size >= sz);
361 /* Create a new op slot */
363 ((I32 **)&slab2->opslab_slots
364 + slab2->opslab_free_space - sz);
365 assert(slot >= &slab2->opslab_slots);
367 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
368 (void*)o, (void*)slab2, (void*)head_slab));
371 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
372 assert(!o->op_moresib);
373 assert(!o->op_sibparent);
380 #ifdef PERL_DEBUG_READONLY_OPS
382 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
384 PERL_ARGS_ASSERT_SLAB_TO_RO;
386 if (slab->opslab_readonly) return;
387 slab->opslab_readonly = 1;
388 for (; slab; slab = slab->opslab_next) {
389 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
390 (unsigned long) slab->opslab_size, slab));*/
391 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
392 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
393 (unsigned long)slab->opslab_size, errno);
398 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
402 PERL_ARGS_ASSERT_SLAB_TO_RW;
404 if (!slab->opslab_readonly) return;
406 for (; slab2; slab2 = slab2->opslab_next) {
407 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
408 (unsigned long) size, slab2));*/
409 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
410 PROT_READ|PROT_WRITE)) {
411 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
412 (unsigned long)slab2->opslab_size, errno);
415 slab->opslab_readonly = 0;
419 # define Slab_to_rw(op) NOOP
422 /* This cannot possibly be right, but it was copied from the old slab
423 allocator, to which it was originally added, without explanation, in
426 # define PerlMemShared PerlMem
429 /* make freed ops die if they're inadvertently executed */
434 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
439 /* Return the block of memory used by an op to the free list of
440 * the OP slab associated with that op.
444 Perl_Slab_Free(pTHX_ void *op)
446 OP * const o = (OP *)op;
449 PERL_ARGS_ASSERT_SLAB_FREE;
452 o->op_ppaddr = S_pp_freed;
455 if (!o->op_slabbed) {
457 PerlMemShared_free(op);
462 /* If this op is already freed, our refcount will get screwy. */
463 assert(o->op_type != OP_FREED);
464 o->op_type = OP_FREED;
465 o->op_next = slab->opslab_freed;
466 slab->opslab_freed = o;
467 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
469 (I32**)OpSLOT(o) - OpSLOT(o)->opslot_offset,
471 OpslabREFCNT_dec_padok(slab);
475 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
477 const bool havepad = !!PL_comppad;
478 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
481 PAD_SAVE_SETNULLPAD();
487 /* Free a chain of OP slabs. Should only be called after all ops contained
488 * in it have been freed. At this point, its reference count should be 1,
489 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
490 * and just directly calls opslab_free().
491 * (Note that the reference count which PL_compcv held on the slab should
492 * have been removed once compilation of the sub was complete).
498 Perl_opslab_free(pTHX_ OPSLAB *slab)
501 PERL_ARGS_ASSERT_OPSLAB_FREE;
503 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
504 assert(slab->opslab_refcnt == 1);
506 slab2 = slab->opslab_next;
508 slab->opslab_refcnt = ~(size_t)0;
510 #ifdef PERL_DEBUG_READONLY_OPS
511 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
513 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
514 perror("munmap failed");
518 PerlMemShared_free(slab);
524 /* like opslab_free(), but first calls op_free() on any ops in the slab
525 * not marked as OP_FREED
529 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
533 size_t savestack_count = 0;
535 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
538 OPSLOT *slot = (OPSLOT*)
539 ((I32**)&slab2->opslab_slots + slab2->opslab_free_space);
540 OPSLOT *end = (OPSLOT*)
541 ((I32**)slab2 + slab2->opslab_size);
543 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
545 if (slot->opslot_op.op_type != OP_FREED
546 && !(slot->opslot_op.op_savefree
552 assert(slot->opslot_op.op_slabbed);
553 op_free(&slot->opslot_op);
554 if (slab->opslab_refcnt == 1) goto free;
557 } while ((slab2 = slab2->opslab_next));
558 /* > 1 because the CV still holds a reference count. */
559 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
561 assert(savestack_count == slab->opslab_refcnt-1);
563 /* Remove the CV’s reference count. */
564 slab->opslab_refcnt--;
571 #ifdef PERL_DEBUG_READONLY_OPS
573 Perl_op_refcnt_inc(pTHX_ OP *o)
576 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
577 if (slab && slab->opslab_readonly) {
590 Perl_op_refcnt_dec(pTHX_ OP *o)
593 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
595 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
597 if (slab && slab->opslab_readonly) {
599 result = --o->op_targ;
602 result = --o->op_targ;
608 * In the following definition, the ", (OP*)0" is just to make the compiler
609 * think the expression is of the right type: croak actually does a Siglongjmp.
611 #define CHECKOP(type,o) \
612 ((PL_op_mask && PL_op_mask[type]) \
613 ? ( op_free((OP*)o), \
614 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
616 : PL_check[type](aTHX_ (OP*)o))
618 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
620 #define OpTYPE_set(o,type) \
622 o->op_type = (OPCODE)type; \
623 o->op_ppaddr = PL_ppaddr[type]; \
627 S_no_fh_allowed(pTHX_ OP *o)
629 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
631 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
637 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
639 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
640 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
645 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
647 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
649 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
654 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
656 PERL_ARGS_ASSERT_BAD_TYPE_PV;
658 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
659 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
662 /* remove flags var, its unused in all callers, move to to right end since gv
663 and kid are always the same */
665 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
667 SV * const namesv = cv_name((CV *)gv, NULL, 0);
668 PERL_ARGS_ASSERT_BAD_TYPE_GV;
670 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
671 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
675 S_no_bareword_allowed(pTHX_ OP *o)
677 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
679 qerror(Perl_mess(aTHX_
680 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
682 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
685 /* "register" allocation */
688 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
691 const bool is_our = (PL_parser->in_my == KEY_our);
693 PERL_ARGS_ASSERT_ALLOCMY;
695 if (flags & ~SVf_UTF8)
696 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
699 /* complain about "my $<special_var>" etc etc */
703 || ( (flags & SVf_UTF8)
704 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
705 || (name[1] == '_' && len > 2)))
707 const char * const type =
708 PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
709 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
711 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
713 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
714 /* diag_listed_as: Can't use global %s in %s */
715 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
716 name[0], toCTRL(name[1]),
717 (int)(len - 2), name + 2,
720 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
722 type), flags & SVf_UTF8);
726 /* allocate a spare slot and store the name in that slot */
728 off = pad_add_name_pvn(name, len,
729 (is_our ? padadd_OUR :
730 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
731 PL_parser->in_my_stash,
733 /* $_ is always in main::, even with our */
734 ? (PL_curstash && !memEQs(name,len,"$_")
740 /* anon sub prototypes contains state vars should always be cloned,
741 * otherwise the state var would be shared between anon subs */
743 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
744 CvCLONE_on(PL_compcv);
750 =head1 Optree Manipulation Functions
752 =for apidoc alloccopstash
754 Available only under threaded builds, this function allocates an entry in
755 C<PL_stashpad> for the stash passed to it.
762 Perl_alloccopstash(pTHX_ HV *hv)
764 PADOFFSET off = 0, o = 1;
765 bool found_slot = FALSE;
767 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
769 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
771 for (; o < PL_stashpadmax; ++o) {
772 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
773 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
774 found_slot = TRUE, off = o;
777 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
778 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
779 off = PL_stashpadmax;
780 PL_stashpadmax += 10;
783 PL_stashpad[PL_stashpadix = off] = hv;
788 /* free the body of an op without examining its contents.
789 * Always use this rather than FreeOp directly */
792 S_op_destroy(pTHX_ OP *o)
802 Free an op and its children. Only use this when an op is no longer linked
809 Perl_op_free(pTHX_ OP *o)
815 bool went_up = FALSE; /* whether we reached the current node by
816 following the parent pointer from a child, and
817 so have already seen this node */
819 if (!o || o->op_type == OP_FREED)
822 if (o->op_private & OPpREFCOUNTED) {
823 /* if base of tree is refcounted, just decrement */
824 switch (o->op_type) {
834 refcnt = OpREFCNT_dec(o);
837 /* Need to find and remove any pattern match ops from
838 * the list we maintain for reset(). */
839 find_and_forget_pmops(o);
852 /* free child ops before ourself, (then free ourself "on the
855 if (!went_up && o->op_flags & OPf_KIDS) {
856 next_op = cUNOPo->op_first;
860 /* find the next node to visit, *then* free the current node
861 * (can't rely on o->op_* fields being valid after o has been
864 /* The next node to visit will be either the sibling, or the
865 * parent if no siblings left, or NULL if we've worked our way
866 * back up to the top node in the tree */
867 next_op = (o == top_op) ? NULL : o->op_sibparent;
868 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
870 /* Now process the current node */
872 /* Though ops may be freed twice, freeing the op after its slab is a
874 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
875 /* During the forced freeing of ops after compilation failure, kidops
876 may be freed before their parents. */
877 if (!o || o->op_type == OP_FREED)
882 /* an op should only ever acquire op_private flags that we know about.
883 * If this fails, you may need to fix something in regen/op_private.
884 * Don't bother testing if:
885 * * the op_ppaddr doesn't match the op; someone may have
886 * overridden the op and be doing strange things with it;
887 * * we've errored, as op flags are often left in an
888 * inconsistent state then. Note that an error when
889 * compiling the main program leaves PL_parser NULL, so
890 * we can't spot faults in the main code, only
891 * evaled/required code */
893 if ( o->op_ppaddr == PL_ppaddr[type]
895 && !PL_parser->error_count)
897 assert(!(o->op_private & ~PL_op_private_valid[type]));
902 /* Call the op_free hook if it has been set. Do it now so that it's called
903 * at the right time for refcounted ops, but still before all of the kids
908 type = (OPCODE)o->op_targ;
911 Slab_to_rw(OpSLAB(o));
913 /* COP* is not cleared by op_clear() so that we may track line
914 * numbers etc even after null() */
915 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
927 /* S_op_clear_gv(): free a GV attached to an OP */
931 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
933 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
937 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
938 || o->op_type == OP_MULTIDEREF)
941 ? ((GV*)PAD_SVl(*ixp)) : NULL;
943 ? (GV*)(*svp) : NULL;
945 /* It's possible during global destruction that the GV is freed
946 before the optree. Whilst the SvREFCNT_inc is happy to bump from
947 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
948 will trigger an assertion failure, because the entry to sv_clear
949 checks that the scalar is not already freed. A check of for
950 !SvIS_FREED(gv) turns out to be invalid, because during global
951 destruction the reference count can be forced down to zero
952 (with SVf_BREAK set). In which case raising to 1 and then
953 dropping to 0 triggers cleanup before it should happen. I
954 *think* that this might actually be a general, systematic,
955 weakness of the whole idea of SVf_BREAK, in that code *is*
956 allowed to raise and lower references during global destruction,
957 so any *valid* code that happens to do this during global
958 destruction might well trigger premature cleanup. */
959 bool still_valid = gv && SvREFCNT(gv);
962 SvREFCNT_inc_simple_void(gv);
965 pad_swipe(*ixp, TRUE);
973 int try_downgrade = SvREFCNT(gv) == 2;
976 gv_try_downgrade(gv);
982 Perl_op_clear(pTHX_ OP *o)
987 PERL_ARGS_ASSERT_OP_CLEAR;
989 switch (o->op_type) {
990 case OP_NULL: /* Was holding old type, if any. */
993 case OP_ENTEREVAL: /* Was holding hints. */
994 case OP_ARGDEFELEM: /* Was holding signature index. */
998 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1005 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1007 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1010 case OP_METHOD_REDIR:
1011 case OP_METHOD_REDIR_SUPER:
1013 if (cMETHOPx(o)->op_rclass_targ) {
1014 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
1015 cMETHOPx(o)->op_rclass_targ = 0;
1018 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
1019 cMETHOPx(o)->op_rclass_sv = NULL;
1022 case OP_METHOD_NAMED:
1023 case OP_METHOD_SUPER:
1024 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
1025 cMETHOPx(o)->op_u.op_meth_sv = NULL;
1028 pad_swipe(o->op_targ, 1);
1035 SvREFCNT_dec(cSVOPo->op_sv);
1036 cSVOPo->op_sv = NULL;
1039 Even if op_clear does a pad_free for the target of the op,
1040 pad_free doesn't actually remove the sv that exists in the pad;
1041 instead it lives on. This results in that it could be reused as
1042 a target later on when the pad was reallocated.
1045 pad_swipe(o->op_targ,1);
1055 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1060 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1061 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1064 if (cPADOPo->op_padix > 0) {
1065 pad_swipe(cPADOPo->op_padix, TRUE);
1066 cPADOPo->op_padix = 0;
1069 SvREFCNT_dec(cSVOPo->op_sv);
1070 cSVOPo->op_sv = NULL;
1074 PerlMemShared_free(cPVOPo->op_pv);
1075 cPVOPo->op_pv = NULL;
1079 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1083 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1084 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1086 if (o->op_private & OPpSPLIT_LEX)
1087 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1090 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1092 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1099 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1100 op_free(cPMOPo->op_code_list);
1101 cPMOPo->op_code_list = NULL;
1102 forget_pmop(cPMOPo);
1103 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1104 /* we use the same protection as the "SAFE" version of the PM_ macros
1105 * here since sv_clean_all might release some PMOPs
1106 * after PL_regex_padav has been cleared
1107 * and the clearing of PL_regex_padav needs to
1108 * happen before sv_clean_all
1111 if(PL_regex_pad) { /* We could be in destruction */
1112 const IV offset = (cPMOPo)->op_pmoffset;
1113 ReREFCNT_dec(PM_GETRE(cPMOPo));
1114 PL_regex_pad[offset] = &PL_sv_undef;
1115 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1119 ReREFCNT_dec(PM_GETRE(cPMOPo));
1120 PM_SETRE(cPMOPo, NULL);
1126 PerlMemShared_free(cUNOP_AUXo->op_aux);
1129 case OP_MULTICONCAT:
1131 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1132 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1133 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1134 * utf8 shared strings */
1135 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1136 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1138 PerlMemShared_free(p1);
1140 PerlMemShared_free(p2);
1141 PerlMemShared_free(aux);
1147 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1148 UV actions = items->uv;
1150 bool is_hash = FALSE;
1153 switch (actions & MDEREF_ACTION_MASK) {
1156 actions = (++items)->uv;
1159 case MDEREF_HV_padhv_helem:
1162 case MDEREF_AV_padav_aelem:
1163 pad_free((++items)->pad_offset);
1166 case MDEREF_HV_gvhv_helem:
1169 case MDEREF_AV_gvav_aelem:
1171 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1173 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1177 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1180 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1182 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1184 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1186 goto do_vivify_rv2xv_elem;
1188 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1191 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1192 pad_free((++items)->pad_offset);
1193 goto do_vivify_rv2xv_elem;
1195 case MDEREF_HV_pop_rv2hv_helem:
1196 case MDEREF_HV_vivify_rv2hv_helem:
1199 do_vivify_rv2xv_elem:
1200 case MDEREF_AV_pop_rv2av_aelem:
1201 case MDEREF_AV_vivify_rv2av_aelem:
1203 switch (actions & MDEREF_INDEX_MASK) {
1204 case MDEREF_INDEX_none:
1207 case MDEREF_INDEX_const:
1211 pad_swipe((++items)->pad_offset, 1);
1213 SvREFCNT_dec((++items)->sv);
1219 case MDEREF_INDEX_padsv:
1220 pad_free((++items)->pad_offset);
1222 case MDEREF_INDEX_gvsv:
1224 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1226 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1231 if (actions & MDEREF_FLAG_last)
1244 actions >>= MDEREF_SHIFT;
1247 /* start of malloc is at op_aux[-1], where the length is
1249 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1254 if (o->op_targ > 0) {
1255 pad_free(o->op_targ);
1261 S_cop_free(pTHX_ COP* cop)
1263 PERL_ARGS_ASSERT_COP_FREE;
1266 if (! specialWARN(cop->cop_warnings))
1267 PerlMemShared_free(cop->cop_warnings);
1268 cophh_free(CopHINTHASH_get(cop));
1269 if (PL_curcop == cop)
1274 S_forget_pmop(pTHX_ PMOP *const o)
1276 HV * const pmstash = PmopSTASH(o);
1278 PERL_ARGS_ASSERT_FORGET_PMOP;
1280 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1281 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1283 PMOP **const array = (PMOP**) mg->mg_ptr;
1284 U32 count = mg->mg_len / sizeof(PMOP**);
1288 if (array[i] == o) {
1289 /* Found it. Move the entry at the end to overwrite it. */
1290 array[i] = array[--count];
1291 mg->mg_len = count * sizeof(PMOP**);
1292 /* Could realloc smaller at this point always, but probably
1293 not worth it. Probably worth free()ing if we're the
1296 Safefree(mg->mg_ptr);
1310 S_find_and_forget_pmops(pTHX_ OP *o)
1314 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1317 switch (o->op_type) {
1322 forget_pmop((PMOP*)o);
1325 if (o->op_flags & OPf_KIDS) {
1326 o = cUNOPo->op_first;
1332 return; /* at top; no parents/siblings to try */
1333 if (OpHAS_SIBLING(o)) {
1334 o = o->op_sibparent; /* process next sibling */
1337 o = o->op_sibparent; /*try parent's next sibling */
1346 Neutralizes an op when it is no longer needed, but is still linked to from
1353 Perl_op_null(pTHX_ OP *o)
1357 PERL_ARGS_ASSERT_OP_NULL;
1359 if (o->op_type == OP_NULL)
1362 o->op_targ = o->op_type;
1363 OpTYPE_set(o, OP_NULL);
1367 Perl_op_refcnt_lock(pTHX)
1368 PERL_TSA_ACQUIRE(PL_op_mutex)
1373 PERL_UNUSED_CONTEXT;
1378 Perl_op_refcnt_unlock(pTHX)
1379 PERL_TSA_RELEASE(PL_op_mutex)
1384 PERL_UNUSED_CONTEXT;
1390 =for apidoc op_sibling_splice
1392 A general function for editing the structure of an existing chain of
1393 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1394 you to delete zero or more sequential nodes, replacing them with zero or
1395 more different nodes. Performs the necessary op_first/op_last
1396 housekeeping on the parent node and op_sibling manipulation on the
1397 children. The last deleted node will be marked as as the last node by
1398 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1400 Note that op_next is not manipulated, and nodes are not freed; that is the
1401 responsibility of the caller. It also won't create a new list op for an
1402 empty list etc; use higher-level functions like op_append_elem() for that.
1404 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1405 the splicing doesn't affect the first or last op in the chain.
1407 C<start> is the node preceding the first node to be spliced. Node(s)
1408 following it will be deleted, and ops will be inserted after it. If it is
1409 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1412 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1413 If -1 or greater than or equal to the number of remaining kids, all
1414 remaining kids are deleted.
1416 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1417 If C<NULL>, no nodes are inserted.
1419 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1424 action before after returns
1425 ------ ----- ----- -------
1428 splice(P, A, 2, X-Y-Z) | | B-C
1432 splice(P, NULL, 1, X-Y) | | A
1436 splice(P, NULL, 3, NULL) | | A-B-C
1440 splice(P, B, 0, X-Y) | | NULL
1444 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1445 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1451 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1455 OP *last_del = NULL;
1456 OP *last_ins = NULL;
1459 first = OpSIBLING(start);
1463 first = cLISTOPx(parent)->op_first;
1465 assert(del_count >= -1);
1467 if (del_count && first) {
1469 while (--del_count && OpHAS_SIBLING(last_del))
1470 last_del = OpSIBLING(last_del);
1471 rest = OpSIBLING(last_del);
1472 OpLASTSIB_set(last_del, NULL);
1479 while (OpHAS_SIBLING(last_ins))
1480 last_ins = OpSIBLING(last_ins);
1481 OpMAYBESIB_set(last_ins, rest, NULL);
1487 OpMAYBESIB_set(start, insert, NULL);
1491 cLISTOPx(parent)->op_first = insert;
1493 parent->op_flags |= OPf_KIDS;
1495 parent->op_flags &= ~OPf_KIDS;
1499 /* update op_last etc */
1506 /* ought to use OP_CLASS(parent) here, but that can't handle
1507 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1509 type = parent->op_type;
1510 if (type == OP_CUSTOM) {
1512 type = XopENTRYCUSTOM(parent, xop_class);
1515 if (type == OP_NULL)
1516 type = parent->op_targ;
1517 type = PL_opargs[type] & OA_CLASS_MASK;
1520 lastop = last_ins ? last_ins : start ? start : NULL;
1521 if ( type == OA_BINOP
1522 || type == OA_LISTOP
1526 cLISTOPx(parent)->op_last = lastop;
1529 OpLASTSIB_set(lastop, parent);
1531 return last_del ? first : NULL;
1534 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1538 =for apidoc op_parent
1540 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1546 Perl_op_parent(OP *o)
1548 PERL_ARGS_ASSERT_OP_PARENT;
1549 while (OpHAS_SIBLING(o))
1551 return o->op_sibparent;
1554 /* replace the sibling following start with a new UNOP, which becomes
1555 * the parent of the original sibling; e.g.
1557 * op_sibling_newUNOP(P, A, unop-args...)
1565 * where U is the new UNOP.
1567 * parent and start args are the same as for op_sibling_splice();
1568 * type and flags args are as newUNOP().
1570 * Returns the new UNOP.
1574 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1578 kid = op_sibling_splice(parent, start, 1, NULL);
1579 newop = newUNOP(type, flags, kid);
1580 op_sibling_splice(parent, start, 0, newop);
1585 /* lowest-level newLOGOP-style function - just allocates and populates
1586 * the struct. Higher-level stuff should be done by S_new_logop() /
1587 * newLOGOP(). This function exists mainly to avoid op_first assignment
1588 * being spread throughout this file.
1592 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1597 NewOp(1101, logop, 1, LOGOP);
1598 OpTYPE_set(logop, type);
1599 logop->op_first = first;
1600 logop->op_other = other;
1602 logop->op_flags = OPf_KIDS;
1603 while (kid && OpHAS_SIBLING(kid))
1604 kid = OpSIBLING(kid);
1606 OpLASTSIB_set(kid, (OP*)logop);
1611 /* Contextualizers */
1614 =for apidoc op_contextualize
1616 Applies a syntactic context to an op tree representing an expression.
1617 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1618 or C<G_VOID> to specify the context to apply. The modified op tree
1625 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1627 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1629 case G_SCALAR: return scalar(o);
1630 case G_ARRAY: return list(o);
1631 case G_VOID: return scalarvoid(o);
1633 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1640 =for apidoc op_linklist
1641 This function is the implementation of the L</LINKLIST> macro. It should
1642 not be called directly.
1649 Perl_op_linklist(pTHX_ OP *o)
1656 PERL_ARGS_ASSERT_OP_LINKLIST;
1659 /* Descend down the tree looking for any unprocessed subtrees to
1662 if (o->op_flags & OPf_KIDS) {
1663 o = cUNOPo->op_first;
1666 o->op_next = o; /* leaf node; link to self initially */
1669 /* if we're at the top level, there either weren't any children
1670 * to process, or we've worked our way back to the top. */
1674 /* o is now processed. Next, process any sibling subtrees */
1676 if (OpHAS_SIBLING(o)) {
1681 /* Done all the subtrees at this level. Go back up a level and
1682 * link the parent in with all its (processed) children.
1685 o = o->op_sibparent;
1686 assert(!o->op_next);
1687 prevp = &(o->op_next);
1688 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1690 *prevp = kid->op_next;
1691 prevp = &(kid->op_next);
1692 kid = OpSIBLING(kid);
1700 S_scalarkids(pTHX_ OP *o)
1702 if (o && o->op_flags & OPf_KIDS) {
1704 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1711 S_scalarboolean(pTHX_ OP *o)
1713 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1715 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1716 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1717 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1718 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1719 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1720 if (ckWARN(WARN_SYNTAX)) {
1721 const line_t oldline = CopLINE(PL_curcop);
1723 if (PL_parser && PL_parser->copline != NOLINE) {
1724 /* This ensures that warnings are reported at the first line
1725 of the conditional, not the last. */
1726 CopLINE_set(PL_curcop, PL_parser->copline);
1728 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1729 CopLINE_set(PL_curcop, oldline);
1736 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1739 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1740 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1742 const char funny = o->op_type == OP_PADAV
1743 || o->op_type == OP_RV2AV ? '@' : '%';
1744 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1746 if (cUNOPo->op_first->op_type != OP_GV
1747 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1749 return varname(gv, funny, 0, NULL, 0, subscript_type);
1752 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1757 S_op_varname(pTHX_ const OP *o)
1759 return S_op_varname_subscript(aTHX_ o, 1);
1763 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1764 { /* or not so pretty :-) */
1765 if (o->op_type == OP_CONST) {
1767 if (SvPOK(*retsv)) {
1769 *retsv = sv_newmortal();
1770 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1771 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1773 else if (!SvOK(*retsv))
1776 else *retpv = "...";
1780 S_scalar_slice_warning(pTHX_ const OP *o)
1783 const bool h = o->op_type == OP_HSLICE
1784 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1790 SV *keysv = NULL; /* just to silence compiler warnings */
1791 const char *key = NULL;
1793 if (!(o->op_private & OPpSLICEWARNING))
1795 if (PL_parser && PL_parser->error_count)
1796 /* This warning can be nonsensical when there is a syntax error. */
1799 kid = cLISTOPo->op_first;
1800 kid = OpSIBLING(kid); /* get past pushmark */
1801 /* weed out false positives: any ops that can return lists */
1802 switch (kid->op_type) {
1828 /* Don't warn if we have a nulled list either. */
1829 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1832 assert(OpSIBLING(kid));
1833 name = S_op_varname(aTHX_ OpSIBLING(kid));
1834 if (!name) /* XS module fiddling with the op tree */
1836 S_op_pretty(aTHX_ kid, &keysv, &key);
1837 assert(SvPOK(name));
1838 sv_chop(name,SvPVX(name)+1);
1840 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1841 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1842 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1844 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1845 lbrack, key, rbrack);
1847 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1848 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1849 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1851 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1852 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1857 /* apply scalar context to the o subtree */
1860 Perl_scalar(pTHX_ OP *o)
1865 OP *next_kid = NULL; /* what op (if any) to process next */
1868 /* assumes no premature commitment */
1869 if (!o || (PL_parser && PL_parser->error_count)
1870 || (o->op_flags & OPf_WANT)
1871 || o->op_type == OP_RETURN)
1876 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1878 switch (o->op_type) {
1880 scalar(cBINOPo->op_first);
1881 /* convert what initially looked like a list repeat into a
1882 * scalar repeat, e.g. $s = (1) x $n
1884 if (o->op_private & OPpREPEAT_DOLIST) {
1885 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1886 assert(kid->op_type == OP_PUSHMARK);
1887 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1888 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1889 o->op_private &=~ OPpREPEAT_DOLIST;
1897 /* impose scalar context on everything except the condition */
1898 next_kid = OpSIBLING(cUNOPo->op_first);
1902 if (o->op_flags & OPf_KIDS)
1903 next_kid = cUNOPo->op_first; /* do all kids */
1906 /* the children of these ops are usually a list of statements,
1907 * except the leaves, whose first child is a corresponding enter
1912 kid = cLISTOPo->op_first;
1916 kid = cLISTOPo->op_first;
1918 kid = OpSIBLING(kid);
1921 OP *sib = OpSIBLING(kid);
1922 /* Apply void context to all kids except the last, which
1923 * is scalar (ignoring a trailing ex-nextstate in determining
1924 * if it's the last kid). E.g.
1925 * $scalar = do { void; void; scalar }
1926 * Except that 'when's are always scalar, e.g.
1927 * $scalar = do { given(..) {
1928 * when (..) { scalar }
1929 * when (..) { scalar }
1934 || ( !OpHAS_SIBLING(sib)
1935 && sib->op_type == OP_NULL
1936 && ( sib->op_targ == OP_NEXTSTATE
1937 || sib->op_targ == OP_DBSTATE )
1941 /* tail call optimise calling scalar() on the last kid */
1945 else if (kid->op_type == OP_LEAVEWHEN)
1951 NOT_REACHED; /* NOTREACHED */
1955 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1961 /* Warn about scalar context */
1962 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1963 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1966 const char *key = NULL;
1968 /* This warning can be nonsensical when there is a syntax error. */
1969 if (PL_parser && PL_parser->error_count)
1972 if (!ckWARN(WARN_SYNTAX)) break;
1974 kid = cLISTOPo->op_first;
1975 kid = OpSIBLING(kid); /* get past pushmark */
1976 assert(OpSIBLING(kid));
1977 name = S_op_varname(aTHX_ OpSIBLING(kid));
1978 if (!name) /* XS module fiddling with the op tree */
1980 S_op_pretty(aTHX_ kid, &keysv, &key);
1981 assert(SvPOK(name));
1982 sv_chop(name,SvPVX(name)+1);
1984 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1985 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1986 "%%%" SVf "%c%s%c in scalar context better written "
1987 "as $%" SVf "%c%s%c",
1988 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1989 lbrack, key, rbrack);
1991 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1992 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1993 "%%%" SVf "%c%" SVf "%c in scalar context better "
1994 "written as $%" SVf "%c%" SVf "%c",
1995 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1996 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
2000 /* If next_kid is set, someone in the code above wanted us to process
2001 * that kid and all its remaining siblings. Otherwise, work our way
2002 * back up the tree */
2006 return top_op; /* at top; no parents/siblings to try */
2007 if (OpHAS_SIBLING(o))
2008 next_kid = o->op_sibparent;
2010 o = o->op_sibparent; /*try parent's next sibling */
2011 switch (o->op_type) {
2017 /* should really restore PL_curcop to its old value, but
2018 * setting it to PL_compiling is better than do nothing */
2019 PL_curcop = &PL_compiling;
2028 /* apply void context to the optree arg */
2031 Perl_scalarvoid(pTHX_ OP *arg)
2038 PERL_ARGS_ASSERT_SCALARVOID;
2042 SV *useless_sv = NULL;
2043 const char* useless = NULL;
2044 OP * next_kid = NULL;
2046 if (o->op_type == OP_NEXTSTATE
2047 || o->op_type == OP_DBSTATE
2048 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2049 || o->op_targ == OP_DBSTATE)))
2050 PL_curcop = (COP*)o; /* for warning below */
2052 /* assumes no premature commitment */
2053 want = o->op_flags & OPf_WANT;
2054 if ((want && want != OPf_WANT_SCALAR)
2055 || (PL_parser && PL_parser->error_count)
2056 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2061 if ((o->op_private & OPpTARGET_MY)
2062 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2064 /* newASSIGNOP has already applied scalar context, which we
2065 leave, as if this op is inside SASSIGN. */
2069 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2071 switch (o->op_type) {
2073 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2077 if (o->op_flags & OPf_STACKED)
2079 if (o->op_type == OP_REPEAT)
2080 scalar(cBINOPo->op_first);
2083 if ((o->op_flags & OPf_STACKED) &&
2084 !(o->op_private & OPpCONCAT_NESTED))
2088 if (o->op_private == 4)
2123 case OP_GETSOCKNAME:
2124 case OP_GETPEERNAME:
2129 case OP_GETPRIORITY:
2154 useless = OP_DESC(o);
2164 case OP_AELEMFAST_LEX:
2168 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2169 /* Otherwise it's "Useless use of grep iterator" */
2170 useless = OP_DESC(o);
2174 if (!(o->op_private & OPpSPLIT_ASSIGN))
2175 useless = OP_DESC(o);
2179 kid = cUNOPo->op_first;
2180 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2181 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2184 useless = "negative pattern binding (!~)";
2188 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2189 useless = "non-destructive substitution (s///r)";
2193 useless = "non-destructive transliteration (tr///r)";
2200 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2201 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2202 useless = "a variable";
2207 if (cSVOPo->op_private & OPpCONST_STRICT)
2208 no_bareword_allowed(o);
2210 if (ckWARN(WARN_VOID)) {
2212 /* don't warn on optimised away booleans, eg
2213 * use constant Foo, 5; Foo || print; */
2214 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2216 /* the constants 0 and 1 are permitted as they are
2217 conventionally used as dummies in constructs like
2218 1 while some_condition_with_side_effects; */
2219 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2221 else if (SvPOK(sv)) {
2222 SV * const dsv = newSVpvs("");
2224 = Perl_newSVpvf(aTHX_
2226 pv_pretty(dsv, SvPVX_const(sv),
2227 SvCUR(sv), 32, NULL, NULL,
2229 | PERL_PV_ESCAPE_NOCLEAR
2230 | PERL_PV_ESCAPE_UNI_DETECT));
2231 SvREFCNT_dec_NN(dsv);
2233 else if (SvOK(sv)) {
2234 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2237 useless = "a constant (undef)";
2240 op_null(o); /* don't execute or even remember it */
2244 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2248 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2252 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2256 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2261 UNOP *refgen, *rv2cv;
2264 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2267 rv2gv = ((BINOP *)o)->op_last;
2268 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2271 refgen = (UNOP *)((BINOP *)o)->op_first;
2273 if (!refgen || (refgen->op_type != OP_REFGEN
2274 && refgen->op_type != OP_SREFGEN))
2277 exlist = (LISTOP *)refgen->op_first;
2278 if (!exlist || exlist->op_type != OP_NULL
2279 || exlist->op_targ != OP_LIST)
2282 if (exlist->op_first->op_type != OP_PUSHMARK
2283 && exlist->op_first != exlist->op_last)
2286 rv2cv = (UNOP*)exlist->op_last;
2288 if (rv2cv->op_type != OP_RV2CV)
2291 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2292 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2293 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2295 o->op_private |= OPpASSIGN_CV_TO_GV;
2296 rv2gv->op_private |= OPpDONT_INIT_GV;
2297 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2309 kid = cLOGOPo->op_first;
2310 if (kid->op_type == OP_NOT
2311 && (kid->op_flags & OPf_KIDS)) {
2312 if (o->op_type == OP_AND) {
2313 OpTYPE_set(o, OP_OR);
2315 OpTYPE_set(o, OP_AND);
2325 next_kid = OpSIBLING(cUNOPo->op_first);
2329 if (o->op_flags & OPf_STACKED)
2336 if (!(o->op_flags & OPf_KIDS))
2347 next_kid = cLISTOPo->op_first;
2350 /* If the first kid after pushmark is something that the padrange
2351 optimisation would reject, then null the list and the pushmark.
2353 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2354 && ( !(kid = OpSIBLING(kid))
2355 || ( kid->op_type != OP_PADSV
2356 && kid->op_type != OP_PADAV
2357 && kid->op_type != OP_PADHV)
2358 || kid->op_private & ~OPpLVAL_INTRO
2359 || !(kid = OpSIBLING(kid))
2360 || ( kid->op_type != OP_PADSV
2361 && kid->op_type != OP_PADAV
2362 && kid->op_type != OP_PADHV)
2363 || kid->op_private & ~OPpLVAL_INTRO)
2365 op_null(cUNOPo->op_first); /* NULL the pushmark */
2366 op_null(o); /* NULL the list */
2378 /* mortalise it, in case warnings are fatal. */
2379 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2380 "Useless use of %" SVf " in void context",
2381 SVfARG(sv_2mortal(useless_sv)));
2384 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2385 "Useless use of %s in void context",
2390 /* if a kid hasn't been nominated to process, continue with the
2391 * next sibling, or if no siblings left, go back to the parent's
2392 * siblings and so on
2396 return arg; /* at top; no parents/siblings to try */
2397 if (OpHAS_SIBLING(o))
2398 next_kid = o->op_sibparent;
2400 o = o->op_sibparent; /*try parent's next sibling */
2410 S_listkids(pTHX_ OP *o)
2412 if (o && o->op_flags & OPf_KIDS) {
2414 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2421 /* apply list context to the o subtree */
2424 Perl_list(pTHX_ OP *o)
2429 OP *next_kid = NULL; /* what op (if any) to process next */
2433 /* assumes no premature commitment */
2434 if (!o || (o->op_flags & OPf_WANT)
2435 || (PL_parser && PL_parser->error_count)
2436 || o->op_type == OP_RETURN)
2441 if ((o->op_private & OPpTARGET_MY)
2442 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2444 goto do_next; /* As if inside SASSIGN */
2447 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2449 switch (o->op_type) {
2451 if (o->op_private & OPpREPEAT_DOLIST
2452 && !(o->op_flags & OPf_STACKED))
2454 list(cBINOPo->op_first);
2455 kid = cBINOPo->op_last;
2456 /* optimise away (.....) x 1 */
2457 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2458 && SvIVX(kSVOP_sv) == 1)
2460 op_null(o); /* repeat */
2461 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2463 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2471 /* impose list context on everything except the condition */
2472 next_kid = OpSIBLING(cUNOPo->op_first);
2476 if (!(o->op_flags & OPf_KIDS))
2478 /* possibly flatten 1..10 into a constant array */
2479 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2480 list(cBINOPo->op_first);
2481 gen_constant_list(o);
2484 next_kid = cUNOPo->op_first; /* do all kids */
2488 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2489 op_null(cUNOPo->op_first); /* NULL the pushmark */
2490 op_null(o); /* NULL the list */
2492 if (o->op_flags & OPf_KIDS)
2493 next_kid = cUNOPo->op_first; /* do all kids */
2496 /* the children of these ops are usually a list of statements,
2497 * except the leaves, whose first child is a corresponding enter
2501 kid = cLISTOPo->op_first;
2505 kid = cLISTOPo->op_first;
2507 kid = OpSIBLING(kid);
2510 OP *sib = OpSIBLING(kid);
2511 /* Apply void context to all kids except the last, which
2513 * @a = do { void; void; list }
2514 * Except that 'when's are always list context, e.g.
2515 * @a = do { given(..) {
2516 * when (..) { list }
2517 * when (..) { list }
2522 /* tail call optimise calling list() on the last kid */
2526 else if (kid->op_type == OP_LEAVEWHEN)
2532 NOT_REACHED; /* NOTREACHED */
2537 /* If next_kid is set, someone in the code above wanted us to process
2538 * that kid and all its remaining siblings. Otherwise, work our way
2539 * back up the tree */
2543 return top_op; /* at top; no parents/siblings to try */
2544 if (OpHAS_SIBLING(o))
2545 next_kid = o->op_sibparent;
2547 o = o->op_sibparent; /*try parent's next sibling */
2548 switch (o->op_type) {
2554 /* should really restore PL_curcop to its old value, but
2555 * setting it to PL_compiling is better than do nothing */
2556 PL_curcop = &PL_compiling;
2568 S_scalarseq(pTHX_ OP *o)
2571 const OPCODE type = o->op_type;
2573 if (type == OP_LINESEQ || type == OP_SCOPE ||
2574 type == OP_LEAVE || type == OP_LEAVETRY)
2577 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2578 if ((sib = OpSIBLING(kid))
2579 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2580 || ( sib->op_targ != OP_NEXTSTATE
2581 && sib->op_targ != OP_DBSTATE )))
2586 PL_curcop = &PL_compiling;
2588 o->op_flags &= ~OPf_PARENS;
2589 if (PL_hints & HINT_BLOCK_SCOPE)
2590 o->op_flags |= OPf_PARENS;
2593 o = newOP(OP_STUB, 0);
2598 S_modkids(pTHX_ OP *o, I32 type)
2600 if (o && o->op_flags & OPf_KIDS) {
2602 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2603 op_lvalue(kid, type);
2609 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2610 * const fields. Also, convert CONST keys to HEK-in-SVs.
2611 * rop is the op that retrieves the hash;
2612 * key_op is the first key
2613 * real if false, only check (and possibly croak); don't update op
2617 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2623 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2625 if (rop->op_first->op_type == OP_PADSV)
2626 /* @$hash{qw(keys here)} */
2627 rop = (UNOP*)rop->op_first;
2629 /* @{$hash}{qw(keys here)} */
2630 if (rop->op_first->op_type == OP_SCOPE
2631 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2633 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2640 lexname = NULL; /* just to silence compiler warnings */
2641 fields = NULL; /* just to silence compiler warnings */
2645 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2646 SvPAD_TYPED(lexname))
2647 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2648 && isGV(*fields) && GvHV(*fields);
2650 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2652 if (key_op->op_type != OP_CONST)
2654 svp = cSVOPx_svp(key_op);
2656 /* make sure it's not a bareword under strict subs */
2657 if (key_op->op_private & OPpCONST_BARE &&
2658 key_op->op_private & OPpCONST_STRICT)
2660 no_bareword_allowed((OP*)key_op);
2663 /* Make the CONST have a shared SV */
2664 if ( !SvIsCOW_shared_hash(sv = *svp)
2665 && SvTYPE(sv) < SVt_PVMG
2671 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2672 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2673 SvREFCNT_dec_NN(sv);
2678 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2680 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2681 "in variable %" PNf " of type %" HEKf,
2682 SVfARG(*svp), PNfARG(lexname),
2683 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2688 /* info returned by S_sprintf_is_multiconcatable() */
2690 struct sprintf_ismc_info {
2691 SSize_t nargs; /* num of args to sprintf (not including the format) */
2692 char *start; /* start of raw format string */
2693 char *end; /* bytes after end of raw format string */
2694 STRLEN total_len; /* total length (in bytes) of format string, not
2695 including '%s' and half of '%%' */
2696 STRLEN variant; /* number of bytes by which total_len_p would grow
2697 if upgraded to utf8 */
2698 bool utf8; /* whether the format is utf8 */
2702 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2703 * i.e. its format argument is a const string with only '%s' and '%%'
2704 * formats, and the number of args is known, e.g.
2705 * sprintf "a=%s f=%s", $a[0], scalar(f());
2707 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2709 * If successful, the sprintf_ismc_info struct pointed to by info will be
2714 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2716 OP *pm, *constop, *kid;
2719 SSize_t nargs, nformats;
2720 STRLEN cur, total_len, variant;
2723 /* if sprintf's behaviour changes, die here so that someone
2724 * can decide whether to enhance this function or skip optimising
2725 * under those new circumstances */
2726 assert(!(o->op_flags & OPf_STACKED));
2727 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2728 assert(!(o->op_private & ~OPpARG4_MASK));
2730 pm = cUNOPo->op_first;
2731 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2733 constop = OpSIBLING(pm);
2734 if (!constop || constop->op_type != OP_CONST)
2736 sv = cSVOPx_sv(constop);
2737 if (SvMAGICAL(sv) || !SvPOK(sv))
2743 /* Scan format for %% and %s and work out how many %s there are.
2744 * Abandon if other format types are found.
2751 for (p = s; p < e; p++) {
2754 if (!UTF8_IS_INVARIANT(*p))
2760 return FALSE; /* lone % at end gives "Invalid conversion" */
2769 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2772 utf8 = cBOOL(SvUTF8(sv));
2776 /* scan args; they must all be in scalar cxt */
2779 kid = OpSIBLING(constop);
2782 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2785 kid = OpSIBLING(kid);
2788 if (nargs != nformats)
2789 return FALSE; /* e.g. sprintf("%s%s", $a); */
2792 info->nargs = nargs;
2795 info->total_len = total_len;
2796 info->variant = variant;
2804 /* S_maybe_multiconcat():
2806 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2807 * convert it (and its children) into an OP_MULTICONCAT. See the code
2808 * comments just before pp_multiconcat() for the full details of what
2809 * OP_MULTICONCAT supports.
2811 * Basically we're looking for an optree with a chain of OP_CONCATS down
2812 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2813 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2821 * STRINGIFY -- PADSV[$x]
2824 * ex-PUSHMARK -- CONCAT/S
2826 * CONCAT/S -- PADSV[$d]
2828 * CONCAT -- CONST["-"]
2830 * PADSV[$a] -- PADSV[$b]
2832 * Note that at this stage the OP_SASSIGN may have already been optimised
2833 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2837 S_maybe_multiconcat(pTHX_ OP *o)
2840 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2841 OP *topop; /* the top-most op in the concat tree (often equals o,
2842 unless there are assign/stringify ops above it */
2843 OP *parentop; /* the parent op of topop (or itself if no parent) */
2844 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2845 OP *targetop; /* the op corresponding to target=... or target.=... */
2846 OP *stringop; /* the OP_STRINGIFY op, if any */
2847 OP *nextop; /* used for recreating the op_next chain without consts */
2848 OP *kid; /* general-purpose op pointer */
2850 UNOP_AUX_item *lenp;
2851 char *const_str, *p;
2852 struct sprintf_ismc_info sprintf_info;
2854 /* store info about each arg in args[];
2855 * toparg is the highest used slot; argp is a general
2856 * pointer to args[] slots */
2858 void *p; /* initially points to const sv (or null for op);
2859 later, set to SvPV(constsv), with ... */
2860 STRLEN len; /* ... len set to SvPV(..., len) */
2861 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2865 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2868 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2869 the last-processed arg will the LHS of one,
2870 as args are processed in reverse order */
2871 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2872 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2873 U8 flags = 0; /* what will become the op_flags and ... */
2874 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2875 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2876 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2877 bool prev_was_const = FALSE; /* previous arg was a const */
2879 /* -----------------------------------------------------------------
2882 * Examine the optree non-destructively to determine whether it's
2883 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2884 * information about the optree in args[].
2894 assert( o->op_type == OP_SASSIGN
2895 || o->op_type == OP_CONCAT
2896 || o->op_type == OP_SPRINTF
2897 || o->op_type == OP_STRINGIFY);
2899 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2901 /* first see if, at the top of the tree, there is an assign,
2902 * append and/or stringify */
2904 if (topop->op_type == OP_SASSIGN) {
2906 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2908 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2910 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2913 topop = cBINOPo->op_first;
2914 targetop = OpSIBLING(topop);
2915 if (!targetop) /* probably some sort of syntax error */
2918 else if ( topop->op_type == OP_CONCAT
2919 && (topop->op_flags & OPf_STACKED)
2920 && (!(topop->op_private & OPpCONCAT_NESTED))
2925 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2926 * decide what to do about it */
2927 assert(!(o->op_private & OPpTARGET_MY));
2929 /* barf on unknown flags */
2930 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2931 private_flags |= OPpMULTICONCAT_APPEND;
2932 targetop = cBINOPo->op_first;
2934 topop = OpSIBLING(targetop);
2936 /* $x .= <FOO> gets optimised to rcatline instead */
2937 if (topop->op_type == OP_READLINE)
2942 /* Can targetop (the LHS) if it's a padsv, be be optimised
2943 * away and use OPpTARGET_MY instead?
2945 if ( (targetop->op_type == OP_PADSV)
2946 && !(targetop->op_private & OPpDEREF)
2947 && !(targetop->op_private & OPpPAD_STATE)
2948 /* we don't support 'my $x .= ...' */
2949 && ( o->op_type == OP_SASSIGN
2950 || !(targetop->op_private & OPpLVAL_INTRO))
2955 if (topop->op_type == OP_STRINGIFY) {
2956 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2960 /* barf on unknown flags */
2961 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2963 if ((topop->op_private & OPpTARGET_MY)) {
2964 if (o->op_type == OP_SASSIGN)
2965 return; /* can't have two assigns */
2969 private_flags |= OPpMULTICONCAT_STRINGIFY;
2971 topop = cBINOPx(topop)->op_first;
2972 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2973 topop = OpSIBLING(topop);
2976 if (topop->op_type == OP_SPRINTF) {
2977 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2979 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2980 nargs = sprintf_info.nargs;
2981 total_len = sprintf_info.total_len;
2982 variant = sprintf_info.variant;
2983 utf8 = sprintf_info.utf8;
2985 private_flags |= OPpMULTICONCAT_FAKE;
2987 /* we have an sprintf op rather than a concat optree.
2988 * Skip most of the code below which is associated with
2989 * processing that optree. We also skip phase 2, determining
2990 * whether its cost effective to optimise, since for sprintf,
2991 * multiconcat is *always* faster */
2994 /* note that even if the sprintf itself isn't multiconcatable,
2995 * the expression as a whole may be, e.g. in
2996 * $x .= sprintf("%d",...)
2997 * the sprintf op will be left as-is, but the concat/S op may
2998 * be upgraded to multiconcat
3001 else if (topop->op_type == OP_CONCAT) {
3002 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
3005 if ((topop->op_private & OPpTARGET_MY)) {
3006 if (o->op_type == OP_SASSIGN || targmyop)
3007 return; /* can't have two assigns */
3012 /* Is it safe to convert a sassign/stringify/concat op into
3014 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
3015 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
3016 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
3017 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
3018 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
3019 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3020 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
3021 == STRUCT_OFFSET(UNOP_AUX, op_aux));
3023 /* Now scan the down the tree looking for a series of
3024 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
3025 * stacked). For example this tree:
3030 * CONCAT/STACKED -- EXPR5
3032 * CONCAT/STACKED -- EXPR4
3038 * corresponds to an expression like
3040 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
3042 * Record info about each EXPR in args[]: in particular, whether it is
3043 * a stringifiable OP_CONST and if so what the const sv is.
3045 * The reason why the last concat can't be STACKED is the difference
3048 * ((($a .= $a) .= $a) .= $a) .= $a
3051 * $a . $a . $a . $a . $a
3053 * The main difference between the optrees for those two constructs
3054 * is the presence of the last STACKED. As well as modifying $a,
3055 * the former sees the changed $a between each concat, so if $s is
3056 * initially 'a', the first returns 'a' x 16, while the latter returns
3057 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3067 if ( kid->op_type == OP_CONCAT
3071 k1 = cUNOPx(kid)->op_first;
3073 /* shouldn't happen except maybe after compile err? */
3077 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
3078 if (kid->op_private & OPpTARGET_MY)
3081 stacked_last = (kid->op_flags & OPf_STACKED);
3093 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
3094 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3096 /* At least two spare slots are needed to decompose both
3097 * concat args. If there are no slots left, continue to
3098 * examine the rest of the optree, but don't push new values
3099 * on args[]. If the optree as a whole is legal for conversion
3100 * (in particular that the last concat isn't STACKED), then
3101 * the first PERL_MULTICONCAT_MAXARG elements of the optree
3102 * can be converted into an OP_MULTICONCAT now, with the first
3103 * child of that op being the remainder of the optree -
3104 * which may itself later be converted to a multiconcat op
3108 /* the last arg is the rest of the optree */
3113 else if ( argop->op_type == OP_CONST
3114 && ((sv = cSVOPx_sv(argop)))
3115 /* defer stringification until runtime of 'constant'
3116 * things that might stringify variantly, e.g. the radix
3117 * point of NVs, or overloaded RVs */
3118 && (SvPOK(sv) || SvIOK(sv))
3119 && (!SvGMAGICAL(sv))
3122 utf8 |= cBOOL(SvUTF8(sv));
3125 /* this const may be demoted back to a plain arg later;
3126 * make sure we have enough arg slots left */
3128 prev_was_const = !prev_was_const;
3133 prev_was_const = FALSE;
3143 return; /* we don't support ((A.=B).=C)...) */
3145 /* look for two adjacent consts and don't fold them together:
3148 * $o->concat("a")->concat("b")
3151 * (but $o .= "a" . "b" should still fold)
3154 bool seen_nonconst = FALSE;
3155 for (argp = toparg; argp >= args; argp--) {
3156 if (argp->p == NULL) {
3157 seen_nonconst = TRUE;
3163 /* both previous and current arg were constants;
3164 * leave the current OP_CONST as-is */
3172 /* -----------------------------------------------------------------
3175 * At this point we have determined that the optree *can* be converted
3176 * into a multiconcat. Having gathered all the evidence, we now decide
3177 * whether it *should*.
3181 /* we need at least one concat action, e.g.:
3187 * otherwise we could be doing something like $x = "foo", which
3188 * if treated as as a concat, would fail to COW.
3190 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3193 /* Benchmarking seems to indicate that we gain if:
3194 * * we optimise at least two actions into a single multiconcat
3195 * (e.g concat+concat, sassign+concat);
3196 * * or if we can eliminate at least 1 OP_CONST;
3197 * * or if we can eliminate a padsv via OPpTARGET_MY
3201 /* eliminated at least one OP_CONST */
3203 /* eliminated an OP_SASSIGN */
3204 || o->op_type == OP_SASSIGN
3205 /* eliminated an OP_PADSV */
3206 || (!targmyop && is_targable)
3208 /* definitely a net gain to optimise */
3211 /* ... if not, what else? */
3213 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3214 * multiconcat is faster (due to not creating a temporary copy of
3215 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3221 && topop->op_type == OP_CONCAT
3223 PADOFFSET t = targmyop->op_targ;
3224 OP *k1 = cBINOPx(topop)->op_first;
3225 OP *k2 = cBINOPx(topop)->op_last;
3226 if ( k2->op_type == OP_PADSV
3228 && ( k1->op_type != OP_PADSV
3229 || k1->op_targ != t)
3234 /* need at least two concats */
3235 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3240 /* -----------------------------------------------------------------
3243 * At this point the optree has been verified as ok to be optimised
3244 * into an OP_MULTICONCAT. Now start changing things.
3249 /* stringify all const args and determine utf8ness */
3252 for (argp = args; argp <= toparg; argp++) {
3253 SV *sv = (SV*)argp->p;
3255 continue; /* not a const op */
3256 if (utf8 && !SvUTF8(sv))
3257 sv_utf8_upgrade_nomg(sv);
3258 argp->p = SvPV_nomg(sv, argp->len);
3259 total_len += argp->len;
3261 /* see if any strings would grow if converted to utf8 */
3263 variant += variant_under_utf8_count((U8 *) argp->p,
3264 (U8 *) argp->p + argp->len);
3268 /* create and populate aux struct */
3272 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3273 sizeof(UNOP_AUX_item)
3275 PERL_MULTICONCAT_HEADER_SIZE
3276 + ((nargs + 1) * (variant ? 2 : 1))
3279 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3281 /* Extract all the non-const expressions from the concat tree then
3282 * dispose of the old tree, e.g. convert the tree from this:
3286 * STRINGIFY -- TARGET
3288 * ex-PUSHMARK -- CONCAT
3303 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3305 * except that if EXPRi is an OP_CONST, it's discarded.
3307 * During the conversion process, EXPR ops are stripped from the tree
3308 * and unshifted onto o. Finally, any of o's remaining original
3309 * childen are discarded and o is converted into an OP_MULTICONCAT.
3311 * In this middle of this, o may contain both: unshifted args on the
3312 * left, and some remaining original args on the right. lastkidop
3313 * is set to point to the right-most unshifted arg to delineate
3314 * between the two sets.
3319 /* create a copy of the format with the %'s removed, and record
3320 * the sizes of the const string segments in the aux struct */
3322 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3324 p = sprintf_info.start;
3327 for (; p < sprintf_info.end; p++) {
3331 (lenp++)->ssize = q - oldq;
3338 lenp->ssize = q - oldq;
3339 assert((STRLEN)(q - const_str) == total_len);
3341 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3342 * may or may not be topop) The pushmark and const ops need to be
3343 * kept in case they're an op_next entry point.
3345 lastkidop = cLISTOPx(topop)->op_last;
3346 kid = cUNOPx(topop)->op_first; /* pushmark */
3348 op_null(OpSIBLING(kid)); /* const */
3350 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3351 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3352 lastkidop->op_next = o;
3357 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3361 /* Concatenate all const strings into const_str.
3362 * Note that args[] contains the RHS args in reverse order, so
3363 * we scan args[] from top to bottom to get constant strings
3366 for (argp = toparg; argp >= args; argp--) {
3368 /* not a const op */
3369 (++lenp)->ssize = -1;
3371 STRLEN l = argp->len;
3372 Copy(argp->p, p, l, char);
3374 if (lenp->ssize == -1)
3385 for (argp = args; argp <= toparg; argp++) {
3386 /* only keep non-const args, except keep the first-in-next-chain
3387 * arg no matter what it is (but nulled if OP_CONST), because it
3388 * may be the entry point to this subtree from the previous
3391 bool last = (argp == toparg);
3394 /* set prev to the sibling *before* the arg to be cut out,
3395 * e.g. when cutting EXPR:
3400 * prev= CONCAT -- EXPR
3403 if (argp == args && kid->op_type != OP_CONCAT) {
3404 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3405 * so the expression to be cut isn't kid->op_last but
3408 /* find the op before kid */
3410 o2 = cUNOPx(parentop)->op_first;
3411 while (o2 && o2 != kid) {
3419 else if (kid == o && lastkidop)
3420 prev = last ? lastkidop : OpSIBLING(lastkidop);
3422 prev = last ? NULL : cUNOPx(kid)->op_first;
3424 if (!argp->p || last) {
3426 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3427 /* and unshift to front of o */
3428 op_sibling_splice(o, NULL, 0, aop);
3429 /* record the right-most op added to o: later we will
3430 * free anything to the right of it */
3433 aop->op_next = nextop;
3436 /* null the const at start of op_next chain */
3440 nextop = prev->op_next;
3443 /* the last two arguments are both attached to the same concat op */
3444 if (argp < toparg - 1)
3449 /* Populate the aux struct */
3451 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3452 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3453 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3454 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3455 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3457 /* if variant > 0, calculate a variant const string and lengths where
3458 * the utf8 version of the string will take 'variant' more bytes than
3462 char *p = const_str;
3463 STRLEN ulen = total_len + variant;
3464 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3465 UNOP_AUX_item *ulens = lens + (nargs + 1);
3466 char *up = (char*)PerlMemShared_malloc(ulen);
3469 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3470 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3472 for (n = 0; n < (nargs + 1); n++) {
3474 char * orig_up = up;
3475 for (i = (lens++)->ssize; i > 0; i--) {
3477 append_utf8_from_native_byte(c, (U8**)&up);
3479 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3484 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3485 * that op's first child - an ex-PUSHMARK - because the op_next of
3486 * the previous op may point to it (i.e. it's the entry point for
3491 ? op_sibling_splice(o, lastkidop, 1, NULL)
3492 : op_sibling_splice(stringop, NULL, 1, NULL);
3493 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3494 op_sibling_splice(o, NULL, 0, pmop);
3501 * target .= A.B.C...
3507 if (o->op_type == OP_SASSIGN) {
3508 /* Move the target subtree from being the last of o's children
3509 * to being the last of o's preserved children.
3510 * Note the difference between 'target = ...' and 'target .= ...':
3511 * for the former, target is executed last; for the latter,
3514 kid = OpSIBLING(lastkidop);
3515 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3516 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3517 lastkidop->op_next = kid->op_next;
3518 lastkidop = targetop;
3521 /* Move the target subtree from being the first of o's
3522 * original children to being the first of *all* o's children.
3525 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3526 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3529 /* if the RHS of .= doesn't contain a concat (e.g.
3530 * $x .= "foo"), it gets missed by the "strip ops from the
3531 * tree and add to o" loop earlier */
3532 assert(topop->op_type != OP_CONCAT);
3534 /* in e.g. $x .= "$y", move the $y expression
3535 * from being a child of OP_STRINGIFY to being the
3536 * second child of the OP_CONCAT
3538 assert(cUNOPx(stringop)->op_first == topop);
3539 op_sibling_splice(stringop, NULL, 1, NULL);
3540 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3542 assert(topop == OpSIBLING(cBINOPo->op_first));
3551 * my $lex = A.B.C...
3554 * The original padsv op is kept but nulled in case it's the
3555 * entry point for the optree (which it will be for
3558 private_flags |= OPpTARGET_MY;
3559 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3560 o->op_targ = targetop->op_targ;
3561 targetop->op_targ = 0;
3565 flags |= OPf_STACKED;
3567 else if (targmyop) {
3568 private_flags |= OPpTARGET_MY;
3569 if (o != targmyop) {
3570 o->op_targ = targmyop->op_targ;
3571 targmyop->op_targ = 0;
3575 /* detach the emaciated husk of the sprintf/concat optree and free it */
3577 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3583 /* and convert o into a multiconcat */
3585 o->op_flags = (flags|OPf_KIDS|stacked_last
3586 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3587 o->op_private = private_flags;
3588 o->op_type = OP_MULTICONCAT;
3589 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3590 cUNOP_AUXo->op_aux = aux;
3594 /* do all the final processing on an optree (e.g. running the peephole
3595 * optimiser on it), then attach it to cv (if cv is non-null)
3599 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3603 /* XXX for some reason, evals, require and main optrees are
3604 * never attached to their CV; instead they just hang off
3605 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3606 * and get manually freed when appropriate */
3608 startp = &CvSTART(cv);
3610 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3613 optree->op_private |= OPpREFCOUNTED;
3614 OpREFCNT_set(optree, 1);
3615 optimize_optree(optree);
3617 finalize_optree(optree);
3618 S_prune_chain_head(startp);
3621 /* now that optimizer has done its work, adjust pad values */
3622 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3623 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3629 =for apidoc optimize_optree
3631 This function applies some optimisations to the optree in top-down order.
3632 It is called before the peephole optimizer, which processes ops in
3633 execution order. Note that finalize_optree() also does a top-down scan,
3634 but is called *after* the peephole optimizer.
3640 Perl_optimize_optree(pTHX_ OP* o)
3642 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3645 SAVEVPTR(PL_curcop);
3653 /* helper for optimize_optree() which optimises one op then recurses
3654 * to optimise any children.
3658 S_optimize_op(pTHX_ OP* o)
3662 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3665 OP * next_kid = NULL;
3667 assert(o->op_type != OP_FREED);
3669 switch (o->op_type) {
3672 PL_curcop = ((COP*)o); /* for warnings */
3680 S_maybe_multiconcat(aTHX_ o);
3684 if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3685 /* we can't assume that op_pmreplroot->op_sibparent == o
3686 * and that it is thus possible to walk back up the tree
3687 * past op_pmreplroot. So, although we try to avoid
3688 * recursing through op trees, do it here. After all,
3689 * there are unlikely to be many nested s///e's within
3690 * the replacement part of a s///e.
3692 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3700 if (o->op_flags & OPf_KIDS)
3701 next_kid = cUNOPo->op_first;
3703 /* if a kid hasn't been nominated to process, continue with the
3704 * next sibling, or if no siblings left, go back to the parent's
3705 * siblings and so on
3709 return; /* at top; no parents/siblings to try */
3710 if (OpHAS_SIBLING(o))
3711 next_kid = o->op_sibparent;
3713 o = o->op_sibparent; /*try parent's next sibling */
3716 /* this label not yet used. Goto here if any code above sets
3726 =for apidoc finalize_optree
3728 This function finalizes the optree. Should be called directly after
3729 the complete optree is built. It does some additional
3730 checking which can't be done in the normal C<ck_>xxx functions and makes
3731 the tree thread-safe.
3736 Perl_finalize_optree(pTHX_ OP* o)
3738 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3741 SAVEVPTR(PL_curcop);
3749 /* Relocate sv to the pad for thread safety.
3750 * Despite being a "constant", the SV is written to,
3751 * for reference counts, sv_upgrade() etc. */
3752 PERL_STATIC_INLINE void
3753 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3756 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3758 ix = pad_alloc(OP_CONST, SVf_READONLY);
3759 SvREFCNT_dec(PAD_SVl(ix));
3760 PAD_SETSV(ix, *svp);
3761 /* XXX I don't know how this isn't readonly already. */
3762 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3769 =for apidoc traverse_op_tree
3771 Return the next op in a depth-first traversal of the op tree,
3772 returning NULL when the traversal is complete.
3774 The initial call must supply the root of the tree as both top and o.
3776 For now it's static, but it may be exposed to the API in the future.
3782 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3785 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3787 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3788 return cUNOPo->op_first;
3790 else if ((sib = OpSIBLING(o))) {
3794 OP *parent = o->op_sibparent;
3795 assert(!(o->op_moresib));
3796 while (parent && parent != top) {
3797 OP *sib = OpSIBLING(parent);
3800 parent = parent->op_sibparent;
3808 S_finalize_op(pTHX_ OP* o)
3811 PERL_ARGS_ASSERT_FINALIZE_OP;
3814 assert(o->op_type != OP_FREED);
3816 switch (o->op_type) {
3819 PL_curcop = ((COP*)o); /* for warnings */
3822 if (OpHAS_SIBLING(o)) {
3823 OP *sib = OpSIBLING(o);
3824 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3825 && ckWARN(WARN_EXEC)
3826 && OpHAS_SIBLING(sib))
3828 const OPCODE type = OpSIBLING(sib)->op_type;
3829 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3830 const line_t oldline = CopLINE(PL_curcop);
3831 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3832 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3833 "Statement unlikely to be reached");
3834 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3835 "\t(Maybe you meant system() when you said exec()?)\n");
3836 CopLINE_set(PL_curcop, oldline);
3843 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3844 GV * const gv = cGVOPo_gv;
3845 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3846 /* XXX could check prototype here instead of just carping */
3847 SV * const sv = sv_newmortal();
3848 gv_efullname3(sv, gv, NULL);
3849 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3850 "%" SVf "() called too early to check prototype",
3857 if (cSVOPo->op_private & OPpCONST_STRICT)
3858 no_bareword_allowed(o);
3862 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3867 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3868 case OP_METHOD_NAMED:
3869 case OP_METHOD_SUPER:
3870 case OP_METHOD_REDIR:
3871 case OP_METHOD_REDIR_SUPER:
3872 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3881 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3884 rop = (UNOP*)((BINOP*)o)->op_first;
3889 S_scalar_slice_warning(aTHX_ o);
3893 kid = OpSIBLING(cLISTOPo->op_first);
3894 if (/* I bet there's always a pushmark... */
3895 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3896 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3901 key_op = (SVOP*)(kid->op_type == OP_CONST
3903 : OpSIBLING(kLISTOP->op_first));
3905 rop = (UNOP*)((LISTOP*)o)->op_last;
3908 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3910 S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3914 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3918 S_scalar_slice_warning(aTHX_ o);
3922 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3923 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3931 if (o->op_flags & OPf_KIDS) {
3934 /* check that op_last points to the last sibling, and that
3935 * the last op_sibling/op_sibparent field points back to the
3936 * parent, and that the only ops with KIDS are those which are
3937 * entitled to them */
3938 U32 type = o->op_type;
3942 if (type == OP_NULL) {
3944 /* ck_glob creates a null UNOP with ex-type GLOB
3945 * (which is a list op. So pretend it wasn't a listop */
3946 if (type == OP_GLOB)
3949 family = PL_opargs[type] & OA_CLASS_MASK;
3951 has_last = ( family == OA_BINOP
3952 || family == OA_LISTOP
3953 || family == OA_PMOP
3954 || family == OA_LOOP
3956 assert( has_last /* has op_first and op_last, or ...
3957 ... has (or may have) op_first: */
3958 || family == OA_UNOP
3959 || family == OA_UNOP_AUX
3960 || family == OA_LOGOP
3961 || family == OA_BASEOP_OR_UNOP
3962 || family == OA_FILESTATOP
3963 || family == OA_LOOPEXOP
3964 || family == OA_METHOP
3965 || type == OP_CUSTOM
3966 || type == OP_NULL /* new_logop does this */
3969 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3970 if (!OpHAS_SIBLING(kid)) {
3972 assert(kid == cLISTOPo->op_last);
3973 assert(kid->op_sibparent == o);
3978 } while (( o = traverse_op_tree(top, o)) != NULL);
3982 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3985 PadnameLVALUE_on(pn);
3986 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3988 /* RT #127786: cv can be NULL due to an eval within the DB package
3989 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3990 * unless they contain an eval, but calling eval within DB
3991 * pretends the eval was done in the caller's scope.
3995 assert(CvPADLIST(cv));
3997 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3998 assert(PadnameLEN(pn));
3999 PadnameLVALUE_on(pn);
4004 S_vivifies(const OPCODE type)
4007 case OP_RV2AV: case OP_ASLICE:
4008 case OP_RV2HV: case OP_KVASLICE:
4009 case OP_RV2SV: case OP_HSLICE:
4010 case OP_AELEMFAST: case OP_KVHSLICE:
4019 /* apply lvalue reference (aliasing) context to the optree o.
4022 * o would be the list ($x,$y) and type would be OP_AASSIGN.
4023 * It may descend and apply this to children too, for example in
4024 * \( $cond ? $x, $y) = (...)
4028 S_lvref(pTHX_ OP *o, I32 type)
4035 switch (o->op_type) {
4037 o = OpSIBLING(cUNOPo->op_first);
4044 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4045 o->op_flags |= OPf_STACKED;
4046 if (o->op_flags & OPf_PARENS) {
4047 if (o->op_private & OPpLVAL_INTRO) {
4048 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4049 "localized parenthesized array in list assignment"));
4053 OpTYPE_set(o, OP_LVAVREF);
4054 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4055 o->op_flags |= OPf_MOD|OPf_REF;
4058 o->op_private |= OPpLVREF_AV;
4062 kid = cUNOPo->op_first;
4063 if (kid->op_type == OP_NULL)
4064 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4066 o->op_private = OPpLVREF_CV;
4067 if (kid->op_type == OP_GV)
4068 o->op_flags |= OPf_STACKED;
4069 else if (kid->op_type == OP_PADCV) {
4070 o->op_targ = kid->op_targ;
4072 op_free(cUNOPo->op_first);
4073 cUNOPo->op_first = NULL;
4074 o->op_flags &=~ OPf_KIDS;
4080 if (o->op_flags & OPf_PARENS) {
4082 yyerror(Perl_form(aTHX_ "Can't modify reference to "
4083 "parenthesized hash in list assignment"));
4086 o->op_private |= OPpLVREF_HV;
4090 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4091 o->op_flags |= OPf_STACKED;
4095 if (o->op_flags & OPf_PARENS) goto parenhash;
4096 o->op_private |= OPpLVREF_HV;
4099 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4103 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4104 if (o->op_flags & OPf_PARENS) goto slurpy;
4105 o->op_private |= OPpLVREF_AV;
4110 o->op_private |= OPpLVREF_ELEM;
4111 o->op_flags |= OPf_STACKED;
4116 OpTYPE_set(o, OP_LVREFSLICE);
4117 o->op_private &= OPpLVAL_INTRO;
4121 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4123 else if (!(o->op_flags & OPf_KIDS))
4126 /* the code formerly only recursed into the first child of
4127 * a non ex-list OP_NULL. if we ever encounter such a null op with
4128 * more than one child, need to decide whether its ok to process
4129 * *all* its kids or not */
4130 assert(o->op_targ == OP_LIST
4131 || !(OpHAS_SIBLING(cBINOPo->op_first)));
4134 o = cLISTOPo->op_first;
4138 if (o->op_flags & OPf_PARENS)
4143 /* diag_listed_as: Can't modify reference to %s in %s assignment */
4144 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4145 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4152 OpTYPE_set(o, OP_LVREF);
4154 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4155 if (type == OP_ENTERLOOP)
4156 o->op_private |= OPpLVREF_ITER;
4161 return; /* at top; no parents/siblings to try */
4162 if (OpHAS_SIBLING(o)) {
4163 o = o->op_sibparent;
4166 o = o->op_sibparent; /*try parent's next sibling */
4172 PERL_STATIC_INLINE bool
4173 S_potential_mod_type(I32 type)
4175 /* Types that only potentially result in modification. */
4176 return type == OP_GREPSTART || type == OP_ENTERSUB
4177 || type == OP_REFGEN || type == OP_LEAVESUBLV;
4182 =for apidoc op_lvalue
4184 Propagate lvalue ("modifiable") context to an op and its children.
4185 C<type> represents the context type, roughly based on the type of op that
4186 would do the modifying, although C<local()> is represented by C<OP_NULL>,
4187 because it has no op type of its own (it is signalled by a flag on
4190 This function detects things that can't be modified, such as C<$x+1>, and
4191 generates errors for them. For example, C<$x+1 = 2> would cause it to be
4192 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
4194 It also flags things that need to behave specially in an lvalue context,
4195 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
4199 Perl_op_lvalue_flags() is a non-API lower-level interface to
4200 op_lvalue(). The flags param has these bits:
4201 OP_LVALUE_NO_CROAK: return rather than croaking on error
4206 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4211 if (!o || (PL_parser && PL_parser->error_count))
4216 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4218 OP *next_kid = NULL;
4220 if ((o->op_private & OPpTARGET_MY)
4221 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4226 /* elements of a list might be in void context because the list is
4227 in scalar context or because they are attribute sub calls */
4228 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
4231 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4233 switch (o->op_type) {
4239 if ((o->op_flags & OPf_PARENS))
4244 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4245 !(o->op_flags & OPf_STACKED)) {
4246 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4247 assert(cUNOPo->op_first->op_type == OP_NULL);
4248 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4251 else { /* lvalue subroutine call */
4252 o->op_private |= OPpLVAL_INTRO;
4253 PL_modcount = RETURN_UNLIMITED_NUMBER;
4254 if (S_potential_mod_type(type)) {
4255 o->op_private |= OPpENTERSUB_INARGS;
4258 else { /* Compile-time error message: */
4259 OP *kid = cUNOPo->op_first;
4264 if (kid->op_type != OP_PUSHMARK) {
4265 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4267 "panic: unexpected lvalue entersub "
4268 "args: type/targ %ld:%" UVuf,
4269 (long)kid->op_type, (UV)kid->op_targ);
4270 kid = kLISTOP->op_first;
4272 while (OpHAS_SIBLING(kid))
4273 kid = OpSIBLING(kid);
4274 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4275 break; /* Postpone until runtime */
4278 kid = kUNOP->op_first;
4279 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4280 kid = kUNOP->op_first;
4281 if (kid->op_type == OP_NULL)
4283 "Unexpected constant lvalue entersub "
4284 "entry via type/targ %ld:%" UVuf,
4285 (long)kid->op_type, (UV)kid->op_targ);
4286 if (kid->op_type != OP_GV) {
4293 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4294 ? MUTABLE_CV(SvRV(gv))
4300 if (flags & OP_LVALUE_NO_CROAK)
4303 namesv = cv_name(cv, NULL, 0);
4304 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4305 "subroutine call of &%" SVf " in %s",
4306 SVfARG(namesv), PL_op_desc[type]),
4314 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4315 /* grep, foreach, subcalls, refgen */
4316 if (S_potential_mod_type(type))
4318 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4319 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4322 type ? PL_op_desc[type] : "local"));
4335 case OP_RIGHT_SHIFT:
4344 if (!(o->op_flags & OPf_STACKED))
4350 if (o->op_flags & OPf_STACKED) {
4354 if (!(o->op_private & OPpREPEAT_DOLIST))
4357 const I32 mods = PL_modcount;
4358 /* we recurse rather than iterate here because we need to
4359 * calculate and use the delta applied to PL_modcount by the
4360 * first child. So in something like
4361 * ($x, ($y) x 3) = split;
4362 * split knows that 4 elements are wanted
4364 modkids(cBINOPo->op_first, type);
4365 if (type != OP_AASSIGN)
4367 kid = cBINOPo->op_last;
4368 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4369 const IV iv = SvIV(kSVOP_sv);
4370 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4372 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4375 PL_modcount = RETURN_UNLIMITED_NUMBER;
4381 next_kid = OpSIBLING(cUNOPo->op_first);
4386 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4387 PL_modcount = RETURN_UNLIMITED_NUMBER;
4388 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4389 fiable since some contexts need to know. */
4390 o->op_flags |= OPf_MOD;
4395 if (scalar_mod_type(o, type))
4397 ref(cUNOPo->op_first, o->op_type);
4404 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4405 if (type == OP_LEAVESUBLV && (
4406 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4407 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4409 o->op_private |= OPpMAYBE_LVSUB;
4413 PL_modcount = RETURN_UNLIMITED_NUMBER;
4419 if (type == OP_LEAVESUBLV)
4420 o->op_private |= OPpMAYBE_LVSUB;
4424 if (type == OP_LEAVESUBLV
4425 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4426 o->op_private |= OPpMAYBE_LVSUB;
4430 PL_hints |= HINT_BLOCK_SCOPE;
4431 if (type == OP_LEAVESUBLV)
4432 o->op_private |= OPpMAYBE_LVSUB;
4437 ref(cUNOPo->op_first, o->op_type);
4441 PL_hints |= HINT_BLOCK_SCOPE;
4451 case OP_AELEMFAST_LEX:
4458 PL_modcount = RETURN_UNLIMITED_NUMBER;
4459 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4461 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4462 fiable since some contexts need to know. */
4463 o->op_flags |= OPf_MOD;
4466 if (scalar_mod_type(o, type))
4468 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4469 && type == OP_LEAVESUBLV)
4470 o->op_private |= OPpMAYBE_LVSUB;
4474 if (!type) /* local() */
4475 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4476 PNfARG(PAD_COMPNAME(o->op_targ)));
4477 if (!(o->op_private & OPpLVAL_INTRO)
4478 || ( type != OP_SASSIGN && type != OP_AASSIGN
4479 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4480 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4488 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4492 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4498 if (type == OP_LEAVESUBLV)
4499 o->op_private |= OPpMAYBE_LVSUB;
4500 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4501 /* we recurse rather than iterate here because the child
4502 * needs to be processed with a different 'type' parameter */
4504 /* substr and vec */
4505 /* If this op is in merely potential (non-fatal) modifiable
4506 context, then apply OP_ENTERSUB context to
4507 the kid op (to avoid croaking). Other-
4508 wise pass this op’s own type so the correct op is mentioned
4509 in error messages. */
4510 op_lvalue(OpSIBLING(cBINOPo->op_first),
4511 S_potential_mod_type(type)
4519 ref(cBINOPo->op_first, o->op_type);
4520 if (type == OP_ENTERSUB &&
4521 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4522 o->op_private |= OPpLVAL_DEFER;
4523 if (type == OP_LEAVESUBLV)
4524 o->op_private |= OPpMAYBE_LVSUB;
4531 o->op_private |= OPpLVALUE;
4537 if (o->op_flags & OPf_KIDS)
4538 next_kid = cLISTOPo->op_last;
4543 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4545 else if (!(o->op_flags & OPf_KIDS))
4548 if (o->op_targ != OP_LIST) {
4549 OP *sib = OpSIBLING(cLISTOPo->op_first);
4550 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4557 * compared with things like OP_MATCH which have the argument
4563 * so handle specially to correctly get "Can't modify" croaks etc
4566 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4568 /* this should trigger a "Can't modify transliteration" err */
4569 op_lvalue(sib, type);
4571 next_kid = cBINOPo->op_first;
4572 /* we assume OP_NULLs which aren't ex-list have no more than 2
4573 * children. If this assumption is wrong, increase the scan
4575 assert( !OpHAS_SIBLING(next_kid)
4576 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
4582 next_kid = cLISTOPo->op_first;
4590 if (type == OP_LEAVESUBLV
4591 || !S_vivifies(cLOGOPo->op_first->op_type))
4592 next_kid = cLOGOPo->op_first;
4593 else if (type == OP_LEAVESUBLV
4594 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4595 next_kid = OpSIBLING(cLOGOPo->op_first);
4599 if (type == OP_NULL) { /* local */
4601 if (!FEATURE_MYREF_IS_ENABLED)
4602 Perl_croak(aTHX_ "The experimental declared_refs "
4603 "feature is not enabled");
4604 Perl_ck_warner_d(aTHX_
4605 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4606 "Declaring references is experimental");
4607 next_kid = cUNOPo->op_first;
4610 if (type != OP_AASSIGN && type != OP_SASSIGN
4611 && type != OP_ENTERLOOP)
4613 /* Don’t bother applying lvalue context to the ex-list. */
4614 kid = cUNOPx(cUNOPo->op_first)->op_first;
4615 assert (!OpHAS_SIBLING(kid));
4618 if (type == OP_NULL) /* local */
4620 if (type != OP_AASSIGN) goto nomod;
4621 kid = cUNOPo->op_first;
4624 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4625 S_lvref(aTHX_ kid, type);
4626 if (!PL_parser || PL_parser->error_count == ec) {
4627 if (!FEATURE_REFALIASING_IS_ENABLED)
4629 "Experimental aliasing via reference not enabled");
4630 Perl_ck_warner_d(aTHX_
4631 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4632 "Aliasing via reference is experimental");
4635 if (o->op_type == OP_REFGEN)
4636 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4641 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4642 /* This is actually @array = split. */
4643 PL_modcount = RETURN_UNLIMITED_NUMBER;
4649 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4653 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4654 their argument is a filehandle; thus \stat(".") should not set
4656 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4659 if (type != OP_LEAVESUBLV)
4660 o->op_flags |= OPf_MOD;
4662 if (type == OP_AASSIGN || type == OP_SASSIGN)
4663 o->op_flags |= OPf_SPECIAL
4664 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4665 else if (!type) { /* local() */
4668 o->op_private |= OPpLVAL_INTRO;
4669 o->op_flags &= ~OPf_SPECIAL;
4670 PL_hints |= HINT_BLOCK_SCOPE;
4675 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4676 "Useless localization of %s", OP_DESC(o));
4679 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4680 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4681 o->op_flags |= OPf_REF;
4686 return top_op; /* at top; no parents/siblings to try */
4687 if (OpHAS_SIBLING(o)) {
4688 next_kid = o->op_sibparent;
4689 if (!OpHAS_SIBLING(next_kid)) {
4690 /* a few node types don't recurse into their second child */
4691 OP *parent = next_kid->op_sibparent;
4692 I32 ptype = parent->op_type;
4693 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
4694 || ( (ptype == OP_AND || ptype == OP_OR)
4695 && (type != OP_LEAVESUBLV
4696 && S_vivifies(next_kid->op_type))
4699 /*try parent's next sibling */
4706 o = o->op_sibparent; /*try parent's next sibling */
4717 S_scalar_mod_type(const OP *o, I32 type)
4722 if (o && o->op_type == OP_RV2GV)
4746 case OP_RIGHT_SHIFT:
4775 S_is_handle_constructor(const OP *o, I32 numargs)
4777 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4779 switch (o->op_type) {
4787 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4800 S_refkids(pTHX_ OP *o, I32 type)
4802 if (o && o->op_flags & OPf_KIDS) {
4804 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4811 /* Apply reference (autovivification) context to the subtree at o.
4813 * push @{expression}, ....;
4814 * o will be the head of 'expression' and type will be OP_RV2AV.
4815 * It marks the op o (or a suitable child) as autovivifying, e.g. by
4817 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
4818 * set_op_ref is true.
4820 * Also calls scalar(o).
4824 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4829 PERL_ARGS_ASSERT_DOREF;
4831 if (PL_parser && PL_parser->error_count)
4835 switch (o->op_type) {
4837 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4838 !(o->op_flags & OPf_STACKED)) {
4839 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4840 assert(cUNOPo->op_first->op_type == OP_NULL);
4841 /* disable pushmark */
4842 op_null(((LISTOP*)cUNOPo->op_first)->op_first);
4843 o->op_flags |= OPf_SPECIAL;
4845 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4846 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4847 : type == OP_RV2HV ? OPpDEREF_HV
4849 o->op_flags |= OPf_MOD;
4855 o = OpSIBLING(cUNOPo->op_first);
4859 if (type == OP_DEFINED)
4860 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4863 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4864 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4865 : type == OP_RV2HV ? OPpDEREF_HV
4867 o->op_flags |= OPf_MOD;
4869 if (o->op_flags & OPf_KIDS) {
4871 o = cUNOPo->op_first;
4879 o->op_flags |= OPf_REF;
4882 if (type == OP_DEFINED)
4883 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4885 o = cUNOPo->op_first;
4891 o->op_flags |= OPf_REF;
4896 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4898 o = cBINOPo->op_first;
4903 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4904 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4905 : type == OP_RV2HV ? OPpDEREF_HV
4907 o->op_flags |= OPf_MOD;
4910 o = cBINOPo->op_first;
4919 if (!(o->op_flags & OPf_KIDS))
4921 o = cLISTOPo->op_last;
4930 return scalar(top_op); /* at top; no parents/siblings to try */
4931 if (OpHAS_SIBLING(o)) {
4932 o = o->op_sibparent;
4933 /* Normally skip all siblings and go straight to the parent;
4934 * the only op that requires two children to be processed
4935 * is OP_COND_EXPR */
4936 if (!OpHAS_SIBLING(o)
4937 && o->op_sibparent->op_type == OP_COND_EXPR)
4941 o = o->op_sibparent; /*try parent's next sibling */
4948 S_dup_attrlist(pTHX_ OP *o)
4952 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4954 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4955 * where the first kid is OP_PUSHMARK and the remaining ones
4956 * are OP_CONST. We need to push the OP_CONST values.
4958 if (o->op_type == OP_CONST)
4959 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4961 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4963 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4964 if (o->op_type == OP_CONST)
4965 rop = op_append_elem(OP_LIST, rop,
4966 newSVOP(OP_CONST, o->op_flags,
4967 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4974 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4976 PERL_ARGS_ASSERT_APPLY_ATTRS;
4978 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4980 /* fake up C<use attributes $pkg,$rv,@attrs> */
4982 #define ATTRSMODULE "attributes"
4983 #define ATTRSMODULE_PM "attributes.pm"
4986 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4987 newSVpvs(ATTRSMODULE),
4989 op_prepend_elem(OP_LIST,
4990 newSVOP(OP_CONST, 0, stashsv),
4991 op_prepend_elem(OP_LIST,
4992 newSVOP(OP_CONST, 0,
4994 dup_attrlist(attrs))));
4999 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
5001 OP *pack, *imop, *arg;
5002 SV *meth, *stashsv, **svp;
5004 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
5009 assert(target->op_type == OP_PADSV ||
5010 target->op_type == OP_PADHV ||
5011 target->op_type == OP_PADAV);
5013 /* Ensure that attributes.pm is loaded. */
5014 /* Don't force the C<use> if we don't need it. */
5015 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
5016 if (svp && *svp != &PL_sv_undef)
5017 NOOP; /* already in %INC */
5019 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5020 newSVpvs(ATTRSMODULE), NULL);
5022 /* Need package name for method call. */
5023 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
5025 /* Build up the real arg-list. */
5026 stashsv = newSVhek(HvNAME_HEK(stash));
5028 arg = newOP(OP_PADSV, 0);
5029 arg->op_targ = target->op_targ;
5030 arg = op_prepend_elem(OP_LIST,
5031 newSVOP(OP_CONST, 0, stashsv),
5032 op_prepend_elem(OP_LIST,
5033 newUNOP(OP_REFGEN, 0,
5035 dup_attrlist(attrs)));
5037 /* Fake up a method call to import */
5038 meth = newSVpvs_share("import");
5039 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
5040 op_append_elem(OP_LIST,
5041 op_prepend_elem(OP_LIST, pack, arg),
5042 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5044 /* Combine the ops. */
5045 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
5049 =notfor apidoc apply_attrs_string
5051 Attempts to apply a list of attributes specified by the C<attrstr> and
5052 C<len> arguments to the subroutine identified by the C<cv> argument which
5053 is expected to be associated with the package identified by the C<stashpv>
5054 argument (see L<attributes>). It gets this wrong, though, in that it
5055 does not correctly identify the boundaries of the individual attribute
5056 specifications within C<attrstr>. This is not really intended for the
5057 public API, but has to be listed here for systems such as AIX which
5058 need an explicit export list for symbols. (It's called from XS code
5059 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
5060 to respect attribute syntax properly would be welcome.
5066 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
5067 const char *attrstr, STRLEN len)
5071 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
5074 len = strlen(attrstr);
5078 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
5080 const char * const sstr = attrstr;
5081 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
5082 attrs = op_append_elem(OP_LIST, attrs,
5083 newSVOP(OP_CONST, 0,
5084 newSVpvn(sstr, attrstr-sstr)));
5088 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
5089 newSVpvs(ATTRSMODULE),
5090 NULL, op_prepend_elem(OP_LIST,
5091 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
5092 op_prepend_elem(OP_LIST,
5093 newSVOP(OP_CONST, 0,
5094 newRV(MUTABLE_SV(cv))),
5099 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
5102 OP *new_proto = NULL;
5107 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
5113 if (o->op_type == OP_CONST) {
5114 pv = SvPV(cSVOPo_sv, pvlen);
5115 if (memBEGINs(pv, pvlen, "prototype(")) {
5116 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5117 SV ** const tmpo = cSVOPx_svp(o);
5118 SvREFCNT_dec(cSVOPo_sv);
5123 } else if (o->op_type == OP_LIST) {
5125 assert(o->op_flags & OPf_KIDS);
5126 lasto = cLISTOPo->op_first;
5127 assert(lasto->op_type == OP_PUSHMARK);
5128 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
5129 if (o->op_type == OP_CONST) {
5130 pv = SvPV(cSVOPo_sv, pvlen);
5131 if (memBEGINs(pv, pvlen, "prototype(")) {
5132 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
5133 SV ** const tmpo = cSVOPx_svp(o);
5134 SvREFCNT_dec(cSVOPo_sv);
5136 if (new_proto && ckWARN(WARN_MISC)) {
5138 const char * newp = SvPV(cSVOPo_sv, new_len);
5139 Perl_warner(aTHX_ packWARN(WARN_MISC),
5140 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
5141 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
5147 /* excise new_proto from the list */
5148 op_sibling_splice(*attrs, lasto, 1, NULL);
5155 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
5156 would get pulled in with no real need */
5157 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
5166 svname = sv_newmortal();
5167 gv_efullname3(svname, name, NULL);
5169 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
5170 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
5172 svname = (SV *)name;
5173 if (ckWARN(WARN_ILLEGALPROTO))
5174 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
5176 if (*proto && ckWARN(WARN_PROTOTYPE)) {
5177 STRLEN old_len, new_len;
5178 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
5179 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
5181 if (curstash && svname == (SV *)name
5182 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
5183 svname = sv_2mortal(newSVsv(PL_curstname));
5184 sv_catpvs(svname, "::");
5185 sv_catsv(svname, (SV *)name);
5188 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
5189 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
5191 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
5192 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
5202 S_cant_declare(pTHX_ OP *o)
5204 if (o->op_type == OP_NULL
5205 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
5206 o = cUNOPo->op_first;
5207 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
5208 o->op_type == OP_NULL
5209 && o->op_flags & OPf_SPECIAL
5212 PL_parser->in_my == KEY_our ? "our" :
5213 PL_parser->in_my == KEY_state ? "state" :
5218 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
5221 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
5223 PERL_ARGS_ASSERT_MY_KID;
5225 if (!o || (PL_parser && PL_parser->error_count))
5230 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
5232 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
5233 my_kid(kid, attrs, imopsp);
5235 } else if (type == OP_UNDEF || type == OP_STUB) {
5237 } else if (type == OP_RV2SV || /* "our" declaration */
5240 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
5241 S_cant_declare(aTHX_ o);
5243 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
5245 PL_parser->in_my = FALSE;
5246 PL_parser->in_my_stash = NULL;
5247 apply_attrs(GvSTASH(gv),
5248 (type == OP_RV2SV ? GvSVn(gv) :
5249 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
5250 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
5253 o->op_private |= OPpOUR_INTRO;
5256 else if (type == OP_REFGEN || type == OP_SREFGEN) {
5257 if (!FEATURE_MYREF_IS_ENABLED)
5258 Perl_croak(aTHX_ "The experimental declared_refs "
5259 "feature is not enabled");
5260 Perl_ck_warner_d(aTHX_
5261 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
5262 "Declaring references is experimental");
5263 /* Kid is a nulled OP_LIST, handled above. */
5264 my_kid(cUNOPo->op_first, attrs, imopsp);
5267 else if (type != OP_PADSV &&
5270 type != OP_PUSHMARK)
5272 S_cant_declare(aTHX_ o);
5275 else if (attrs && type != OP_PUSHMARK) {
5279 PL_parser->in_my = FALSE;
5280 PL_parser->in_my_stash = NULL;
5282 /* check for C<my Dog $spot> when deciding package */
5283 stash = PAD_COMPNAME_TYPE(o->op_targ);
5285 stash = PL_curstash;
5286 apply_attrs_my(stash, o, attrs, imopsp);
5288 o->op_flags |= OPf_MOD;
5289 o->op_private |= OPpLVAL_INTRO;
5291 o->op_private |= OPpPAD_STATE;
5296 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
5299 int maybe_scalar = 0;
5301 PERL_ARGS_ASSERT_MY_ATTRS;
5303 /* [perl #17376]: this appears to be premature, and results in code such as
5304 C< our(%x); > executing in list mode rather than void mode */
5306 if (o->op_flags & OPf_PARENS)
5316 o = my_kid(o, attrs, &rops);
5318 if (maybe_scalar && o->op_type == OP_PADSV) {
5319 o = scalar(op_append_list(OP_LIST, rops, o));
5320 o->op_private |= OPpLVAL_INTRO;
5323 /* The listop in rops might have a pushmark at the beginning,
5324 which will mess up list assignment. */
5325 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
5326 if (rops->op_type == OP_LIST &&
5327 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
5329 OP * const pushmark = lrops->op_first;
5330 /* excise pushmark */
5331 op_sibling_splice(rops, NULL, 1, NULL);
5334 o = op_append_list(OP_LIST, o, rops);
5337 PL_parser->in_my = FALSE;
5338 PL_parser->in_my_stash = NULL;
5343 Perl_sawparens(pTHX_ OP *o)
5345 PERL_UNUSED_CONTEXT;
5347 o->op_flags |= OPf_PARENS;
5352 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5356 const OPCODE ltype = left->op_type;
5357 const OPCODE rtype = right->op_type;
5359 PERL_ARGS_ASSERT_BIND_MATCH;
5361 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5362 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5364 const char * const desc
5366 rtype == OP_SUBST || rtype == OP_TRANS
5367 || rtype == OP_TRANSR
5369 ? (int)rtype : OP_MATCH];
5370 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5372 S_op_varname(aTHX_ left);
5374 Perl_warner(aTHX_ packWARN(WARN_MISC),
5375 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5376 desc, SVfARG(name), SVfARG(name));
5378 const char * const sample = (isary
5379 ? "@array" : "%hash");
5380 Perl_warner(aTHX_ packWARN(WARN_MISC),
5381 "Applying %s to %s will act on scalar(%s)",
5382 desc, sample, sample);
5386 if (rtype == OP_CONST &&
5387 cSVOPx(right)->op_private & OPpCONST_BARE &&
5388 cSVOPx(right)->op_private & OPpCONST_STRICT)
5390 no_bareword_allowed(right);
5393 /* !~ doesn't make sense with /r, so error on it for now */
5394 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5396 /* diag_listed_as: Using !~ with %s doesn't make sense */
5397 yyerror("Using !~ with s///r doesn't make sense");
5398 if (rtype == OP_TRANSR && type == OP_NOT)
5399 /* diag_listed_as: Using !~ with %s doesn't make sense */
5400 yyerror("Using !~ with tr///r doesn't make sense");
5402 ismatchop = (rtype == OP_MATCH ||
5403 rtype == OP_SUBST ||
5404 rtype == OP_TRANS || rtype == OP_TRANSR)
5405 && !(right->op_flags & OPf_SPECIAL);
5406 if (ismatchop && right->op_private & OPpTARGET_MY) {
5408 right->op_private &= ~OPpTARGET_MY;
5410 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5411 if (left->op_type == OP_PADSV
5412 && !(left->op_private & OPpLVAL_INTRO))
5414 right->op_targ = left->op_targ;
5419 right->op_flags |= OPf_STACKED;
5420 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5421 ! (rtype == OP_TRANS &&
5422 right->op_private & OPpTRANS_IDENTICAL) &&
5423 ! (rtype == OP_SUBST &&
5424 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5425 left = op_lvalue(left, rtype);
5426 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5427 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5429 o = op_prepend_elem(rtype, scalar(left), right);
5432 return newUNOP(OP_NOT, 0, scalar(o));
5436 return bind_match(type, left,
5437 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5441 Perl_invert(pTHX_ OP *o)
5445 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5449 =for apidoc op_scope
5451 Wraps up an op tree with some additional ops so that at runtime a dynamic
5452 scope will be created. The original ops run in the new dynamic scope,
5453 and then, provided that they exit normally, the scope will be unwound.
5454 The additional ops used to create and unwind the dynamic scope will
5455 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5456 instead if the ops are simple enough to not need the full dynamic scope
5463 Perl_op_scope(pTHX_ OP *o)
5467 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5468 o = op_prepend_elem(OP_LINESEQ,
5469 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
5470 OpTYPE_set(o, OP_LEAVE);
5472 else if (o->op_type == OP_LINESEQ) {
5474 OpTYPE_set(o, OP_SCOPE);
5475 kid = ((LISTOP*)o)->op_first;
5476 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5479 /* The following deals with things like 'do {1 for 1}' */
5480 kid = OpSIBLING(kid);
5482 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5487 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5493 Perl_op_unscope(pTHX_ OP *o)
5495 if (o && o->op_type == OP_LINESEQ) {
5496 OP *kid = cLISTOPo->op_first;
5497 for(; kid; kid = OpSIBLING(kid))
5498 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5505 =for apidoc block_start
5507 Handles compile-time scope entry.
5508 Arranges for hints to be restored on block
5509 exit and also handles pad sequence numbers to make lexical variables scope
5510 right. Returns a savestack index for use with C<block_end>.
5516 Perl_block_start(pTHX_ int full)
5518 const int retval = PL_savestack_ix;
5520 PL_compiling.cop_seq = PL_cop_seqmax;
5522 pad_block_start(full);
5524 PL_hints &= ~HINT_BLOCK_SCOPE;
5525 SAVECOMPILEWARNINGS();
5526 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5527 SAVEI32(PL_compiling.cop_seq);
5528 PL_compiling.cop_seq = 0;
5530 CALL_BLOCK_HOOKS(bhk_start, full);
5536 =for apidoc block_end
5538 Handles compile-time scope exit. C<floor>
5539 is the savestack index returned by
5540 C<block_start>, and C<seq> is the body of the block. Returns the block,
5547 Perl_block_end(pTHX_ I32 floor, OP *seq)
5549 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5550 OP* retval = scalarseq(seq);
5553 /* XXX Is the null PL_parser check necessary here? */
5554 assert(PL_parser); /* Let’s find out under debugging builds. */
5555 if (PL_parser && PL_parser->parsed_sub) {
5556 o = newSTATEOP(0, NULL, NULL);
5558 retval = op_append_elem(OP_LINESEQ, retval, o);
5561 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5565 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5569 /* pad_leavemy has created a sequence of introcv ops for all my
5570 subs declared in the block. We have to replicate that list with
5571 clonecv ops, to deal with this situation:
5576 sub s1 { state sub foo { \&s2 } }
5579 Originally, I was going to have introcv clone the CV and turn
5580 off the stale flag. Since &s1 is declared before &s2, the
5581 introcv op for &s1 is executed (on sub entry) before the one for
5582 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5583 cloned, since it is a state sub) closes over &s2 and expects
5584 to see it in its outer CV’s pad. If the introcv op clones &s1,
5585 then &s2 is still marked stale. Since &s1 is not active, and
5586 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5587 ble will not stay shared’ warning. Because it is the same stub
5588 that will be used when the introcv op for &s2 is executed, clos-
5589 ing over it is safe. Hence, we have to turn off the stale flag
5590 on all lexical subs in the block before we clone any of them.
5591 Hence, having introcv clone the sub cannot work. So we create a
5592 list of ops like this:
5616 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5617 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5618 for (;; kid = OpSIBLING(kid)) {
5619 OP *newkid = newOP(OP_CLONECV, 0);
5620 newkid->op_targ = kid->op_targ;
5621 o = op_append_elem(OP_LINESEQ, o, newkid);
5622 if (kid == last) break;
5624 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5627 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5633 =head1 Compile-time scope hooks
5635 =for apidoc blockhook_register
5637 Register a set of hooks to be called when the Perl lexical scope changes
5638 at compile time. See L<perlguts/"Compile-time scope hooks">.
5644 Perl_blockhook_register(pTHX_ BHK *hk)
5646 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5648 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5652 Perl_newPROG(pTHX_ OP *o)
5656 PERL_ARGS_ASSERT_NEWPROG;
5663 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5664 ((PL_in_eval & EVAL_KEEPERR)
5665 ? OPf_SPECIAL : 0), o);
5668 assert(CxTYPE(cx) == CXt_EVAL);
5670 if ((cx->blk_gimme & G_WANT) == G_VOID)
5671 scalarvoid(PL_eval_root);
5672 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5675 scalar(PL_eval_root);
5677 start = op_linklist(PL_eval_root);
5678 PL_eval_root->op_next = 0;
5679 i = PL_savestack_ix;
5682 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5684 PL_savestack_ix = i;
5687 if (o->op_type == OP_STUB) {
5688 /* This block is entered if nothing is compiled for the main
5689 program. This will be the case for an genuinely empty main
5690 program, or one which only has BEGIN blocks etc, so already
5693 Historically (5.000) the guard above was !o. However, commit
5694 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5695 c71fccf11fde0068, changed perly.y so that newPROG() is now
5696 called with the output of block_end(), which returns a new
5697 OP_STUB for the case of an empty optree. ByteLoader (and
5698 maybe other things) also take this path, because they set up
5699 PL_main_start and PL_main_root directly, without generating an
5702 If the parsing the main program aborts (due to parse errors,
5703 or due to BEGIN or similar calling exit), then newPROG()
5704 isn't even called, and hence this code path and its cleanups
5705 are skipped. This shouldn't make a make a difference:
5706 * a non-zero return from perl_parse is a failure, and
5707 perl_destruct() should be called immediately.
5708 * however, if exit(0) is called during the parse, then
5709 perl_parse() returns 0, and perl_run() is called. As
5710 PL_main_start will be NULL, perl_run() will return
5711 promptly, and the exit code will remain 0.
5714 PL_comppad_name = 0;
5716 S_op_destroy(aTHX_ o);
5719 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5720 PL_curcop = &PL_compiling;
5721 start = LINKLIST(PL_main_root);
5722 PL_main_root->op_next = 0;
5723 S_process_optree(aTHX_ NULL, PL_main_root, start);
5724 if (!PL_parser->error_count)
5725 /* on error, leave CV slabbed so that ops left lying around
5726 * will eb cleaned up. Else unslab */
5727 cv_forget_slab(PL_compcv);
5730 /* Register with debugger */
5732 CV * const cv = get_cvs("DB::postponed", 0);
5736 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5738 call_sv(MUTABLE_SV(cv), G_DISCARD);
5745 Perl_localize(pTHX_ OP *o, I32 lex)
5747 PERL_ARGS_ASSERT_LOCALIZE;
5749 if (o->op_flags & OPf_PARENS)
5750 /* [perl #17376]: this appears to be premature, and results in code such as
5751 C< our(%x); > executing in list mode rather than void mode */
5758 if ( PL_parser->bufptr > PL_parser->oldbufptr
5759 && PL_parser->bufptr[-1] == ','
5760 && ckWARN(WARN_PARENTHESIS))
5762 char *s = PL_parser->bufptr;
5765 /* some heuristics to detect a potential error */
5766 while (*s && (strchr(", \t\n", *s)))
5770 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5772 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5775 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5777 while (*s && (strchr(", \t\n", *s)))
5783 if (sigil && (*s == ';' || *s == '=')) {
5784 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5785 "Parentheses missing around \"%s\" list",
5787 ? (PL_parser->in_my == KEY_our
5789 : PL_parser->in_my == KEY_state
5799 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5800 PL_parser->in_my = FALSE;
5801 PL_parser->in_my_stash = NULL;
5806 Perl_jmaybe(pTHX_ OP *o)
5808 PERL_ARGS_ASSERT_JMAYBE;
5810 if (o->op_type == OP_LIST) {
5812 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5813 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5818 PERL_STATIC_INLINE OP *
5819 S_op_std_init(pTHX_ OP *o)
5821 I32 type = o->op_type;
5823 PERL_ARGS_ASSERT_OP_STD_INIT;
5825 if (PL_opargs[type] & OA_RETSCALAR)
5827 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5828 o->op_targ = pad_alloc(type, SVs_PADTMP);
5833 PERL_STATIC_INLINE OP *
5834 S_op_integerize(pTHX_ OP *o)
5836 I32 type = o->op_type;
5838 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5840 /* integerize op. */
5841 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5844 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5847 if (type == OP_NEGATE)
5848 /* XXX might want a ck_negate() for this */
5849 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5854 /* This function exists solely to provide a scope to limit
5855 setjmp/longjmp() messing with auto variables.
5857 PERL_STATIC_INLINE int
5858 S_fold_constants_eval(pTHX) {
5874 S_fold_constants(pTHX_ OP *const o)
5879 I32 type = o->op_type;
5884 SV * const oldwarnhook = PL_warnhook;
5885 SV * const olddiehook = PL_diehook;
5887 U8 oldwarn = PL_dowarn;
5890 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5892 if (!(PL_opargs[type] & OA_FOLDCONST))
5901 #ifdef USE_LOCALE_CTYPE
5902 if (IN_LC_COMPILETIME(LC_CTYPE))
5911 #ifdef USE_LOCALE_COLLATE
5912 if (IN_LC_COMPILETIME(LC_COLLATE))
5917 /* XXX what about the numeric ops? */
5918 #ifdef USE_LOCALE_NUMERIC
5919 if (IN_LC_COMPILETIME(LC_NUMERIC))
5924 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5925 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5928 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5929 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5931 const char *s = SvPVX_const(sv);
5932 while (s < SvEND(sv)) {
5933 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5940 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5943 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5944 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5948 if (PL_parser && PL_parser->error_count)
5949 goto nope; /* Don't try to run w/ errors */
5951 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5952 switch (curop->op_type) {
5954 if ( (curop->op_private & OPpCONST_BARE)
5955 && (curop->op_private & OPpCONST_STRICT)) {
5956 no_bareword_allowed(curop);
5964 /* Foldable; move to next op in list */
5968 /* No other op types are considered foldable */
5973 curop = LINKLIST(o);
5974 old_next = o->op_next;
5978 old_cxix = cxstack_ix;
5979 create_eval_scope(NULL, G_FAKINGEVAL);
5981 /* Verify that we don't need to save it: */
5982 assert(PL_curcop == &PL_compiling);
5983 StructCopy(&PL_compiling, ¬_compiling, COP);
5984 PL_curcop = ¬_compiling;
5985 /* The above ensures that we run with all the correct hints of the
5986 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5987 assert(IN_PERL_RUNTIME);
5988 PL_warnhook = PERL_WARNHOOK_FATAL;
5991 /* Effective $^W=1. */
5992 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5993 PL_dowarn |= G_WARN_ON;
5995 ret = S_fold_constants_eval(aTHX);
5999 sv = *(PL_stack_sp--);
6000 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
6001 pad_swipe(o->op_targ, FALSE);
6003 else if (SvTEMP(sv)) { /* grab mortal temp? */
6004 SvREFCNT_inc_simple_void(sv);
6007 else { assert(SvIMMORTAL(sv)); }
6010 /* Something tried to die. Abandon constant folding. */
6011 /* Pretend the error never happened. */
6013 o->op_next = old_next;
6016 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
6017 PL_warnhook = oldwarnhook;
6018 PL_diehook = olddiehook;
6019 /* XXX note that this croak may fail as we've already blown away
6020 * the stack - eg any nested evals */
6021 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
6023 PL_dowarn = oldwarn;
6024 PL_warnhook = oldwarnhook;
6025 PL_diehook = olddiehook;
6026 PL_curcop = &PL_compiling;
6028 /* if we croaked, depending on how we croaked the eval scope
6029 * may or may not have already been popped */
6030 if (cxstack_ix > old_cxix) {
6031 assert(cxstack_ix == old_cxix + 1);
6032 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6033 delete_eval_scope();
6038 /* OP_STRINGIFY and constant folding are used to implement qq.
6039 Here the constant folding is an implementation detail that we
6040 want to hide. If the stringify op is itself already marked
6041 folded, however, then it is actually a folded join. */
6042 is_stringify = type == OP_STRINGIFY && !o->op_folded;
6047 else if (!SvIMMORTAL(sv)) {
6051 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
6052 if (!is_stringify) newop->op_folded = 1;
6059 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
6060 * the constant value being an AV holding the flattened range.
6064 S_gen_constant_list(pTHX_ OP *o)
6067 OP *curop, *old_next;
6068 SV * const oldwarnhook = PL_warnhook;
6069 SV * const olddiehook = PL_diehook;
6071 U8 oldwarn = PL_dowarn;
6081 if (PL_parser && PL_parser->error_count)
6082 return; /* Don't attempt to run with errors */
6084 curop = LINKLIST(o);
6085 old_next = o->op_next;
6087 op_was_null = o->op_type == OP_NULL;
6088 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
6089 o->op_type = OP_CUSTOM;
6092 o->op_type = OP_NULL;
6093 S_prune_chain_head(&curop);
6096 old_cxix = cxstack_ix;
6097 create_eval_scope(NULL, G_FAKINGEVAL);
6099 old_curcop = PL_curcop;
6100 StructCopy(old_curcop, ¬_compiling, COP);
6101 PL_curcop = ¬_compiling;
6102 /* The above ensures that we run with all the correct hints of the
6103 current COP, but that IN_PERL_RUNTIME is true. */
6104 assert(IN_PERL_RUNTIME);
6105 PL_warnhook = PERL_WARNHOOK_FATAL;
6109 /* Effective $^W=1. */
6110 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
6111 PL_dowarn |= G_WARN_ON;
6115 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
6116 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
6118 Perl_pp_pushmark(aTHX);
6121 assert (!(curop->op_flags & OPf_SPECIAL));
6122 assert(curop->op_type == OP_RANGE);
6123 Perl_pp_anonlist(aTHX);
6127 o->op_next = old_next;
6131 PL_warnhook = oldwarnhook;
6132 PL_diehook = olddiehook;
6133 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
6138 PL_dowarn = oldwarn;
6139 PL_warnhook = oldwarnhook;
6140 PL_diehook = olddiehook;
6141 PL_curcop = old_curcop;
6143 if (cxstack_ix > old_cxix) {
6144 assert(cxstack_ix == old_cxix + 1);
6145 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
6146 delete_eval_scope();
6151 OpTYPE_set(o, OP_RV2AV);
6152 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
6153 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
6154 o->op_opt = 0; /* needs to be revisited in rpeep() */
6155 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
6157 /* replace subtree with an OP_CONST */
6158 curop = ((UNOP*)o)->op_first;
6159 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
6162 if (AvFILLp(av) != -1)
6163 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
6166 SvREADONLY_on(*svp);
6174 =head1 Optree Manipulation Functions
6177 /* List constructors */
6180 =for apidoc op_append_elem
6182 Append an item to the list of ops contained directly within a list-type
6183 op, returning the lengthened list. C<first> is the list-type op,
6184 and C<last> is the op to append to the list. C<optype> specifies the
6185 intended opcode for the list. If C<first> is not already a list of the
6186 right type, it will be upgraded into one. If either C<first> or C<last>
6187 is null, the other is returned unchanged.
6193 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
6201 if (first->op_type != (unsigned)type
6202 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
6204 return newLISTOP(type, 0, first, last);
6207 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
6208 first->op_flags |= OPf_KIDS;
6213 =for apidoc op_append_list
6215 Concatenate the lists of ops contained directly within two list-type ops,
6216 returning the combined list. C<first> and C<last> are the list-type ops
6217 to concatenate. C<optype> specifies the intended opcode for the list.
6218 If either C<first> or C<last> is not already a list of the right type,
6219 it will be upgraded into one. If either C<first> or C<last> is null,
6220 the other is returned unchanged.
6226 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
6234 if (first->op_type != (unsigned)type)
6235 return op_prepend_elem(type, first, last);
6237 if (last->op_type != (unsigned)type)
6238 return op_append_elem(type, first, last);
6240 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
6241 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
6242 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
6243 first->op_flags |= (last->op_flags & OPf_KIDS);
6245 S_op_destroy(aTHX_ last);
6251 =for apidoc op_prepend_elem
6253 Prepend an item to the list of ops contained directly within a list-type
6254 op, returning the lengthened list. C<first> is the op to prepend to the
6255 list, and C<last> is the list-type op. C<optype> specifies the intended
6256 opcode for the list. If C<last> is not already a list of the right type,
6257 it will be upgraded into one. If either C<first> or C<last> is null,
6258 the other is returned unchanged.
6264 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
6272 if (last->op_type == (unsigned)type) {
6273 if (type == OP_LIST) { /* already a PUSHMARK there */
6274 /* insert 'first' after pushmark */
6275 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
6276 if (!(first->op_flags & OPf_PARENS))
6277 last->op_flags &= ~OPf_PARENS;
6280 op_sibling_splice(last, NULL, 0, first);
6281 last->op_flags |= OPf_KIDS;
6285 return newLISTOP(type, 0, first, last);
6289 =for apidoc op_convert_list
6291 Converts C<o> into a list op if it is not one already, and then converts it
6292 into the specified C<type>, calling its check function, allocating a target if
6293 it needs one, and folding constants.
6295 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
6296 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
6297 C<op_convert_list> to make it the right type.
6303 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
6306 if (type < 0) type = -type, flags |= OPf_SPECIAL;
6307 if (!o || o->op_type != OP_LIST)
6308 o = force_list(o, 0);
6311 o->op_flags &= ~OPf_WANT;
6312 o->op_private &= ~OPpLVAL_INTRO;
6315 if (!(PL_opargs[type] & OA_MARK))
6316 op_null(cLISTOPo->op_first);
6318 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
6319 if (kid2 && kid2->op_type == OP_COREARGS) {
6320 op_null(cLISTOPo->op_first);
6321 kid2->op_private |= OPpCOREARGS_PUSHMARK;
6325 if (type != OP_SPLIT)
6326 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
6327 * ck_split() create a real PMOP and leave the op's type as listop
6328 * for now. Otherwise op_free() etc will crash.
6330 OpTYPE_set(o, type);
6332 o->op_flags |= flags;
6333 if (flags & OPf_FOLDED)
6336 o = CHECKOP(type, o);
6337 if (o->op_type != (unsigned)type)
6340 return fold_constants(op_integerize(op_std_init(o)));
6347 =head1 Optree construction
6349 =for apidoc newNULLLIST
6351 Constructs, checks, and returns a new C<stub> op, which represents an
6352 empty list expression.
6358 Perl_newNULLLIST(pTHX)
6360 return newOP(OP_STUB, 0);
6363 /* promote o and any siblings to be a list if its not already; i.e.
6371 * pushmark - o - A - B
6373 * If nullit it true, the list op is nulled.
6377 S_force_list(pTHX_ OP *o, bool nullit)
6379 if (!o || o->op_type != OP_LIST) {
6382 /* manually detach any siblings then add them back later */
6383 rest = OpSIBLING(o);
6384 OpLASTSIB_set(o, NULL);
6386 o = newLISTOP(OP_LIST, 0, o, NULL);
6388 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6396 =for apidoc newLISTOP
6398 Constructs, checks, and returns an op of any list type. C<type> is
6399 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6400 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6401 supply up to two ops to be direct children of the list op; they are
6402 consumed by this function and become part of the constructed op tree.
6404 For most list operators, the check function expects all the kid ops to be
6405 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6406 appropriate. What you want to do in that case is create an op of type
6407 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6408 See L</op_convert_list> for more information.
6415 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6419 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
6420 * pushmark is banned. So do it now while existing ops are in a
6421 * consistent state, in case they suddenly get freed */
6422 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
6424 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6425 || type == OP_CUSTOM);
6427 NewOp(1101, listop, 1, LISTOP);
6428 OpTYPE_set(listop, type);
6431 listop->op_flags = (U8)flags;
6435 else if (!first && last)
6438 OpMORESIB_set(first, last);
6439 listop->op_first = first;
6440 listop->op_last = last;
6443 OpMORESIB_set(pushop, first);
6444 listop->op_first = pushop;
6445 listop->op_flags |= OPf_KIDS;
6447 listop->op_last = pushop;
6449 if (listop->op_last)
6450 OpLASTSIB_set(listop->op_last, (OP*)listop);
6452 return CHECKOP(type, listop);
6458 Constructs, checks, and returns an op of any base type (any type that
6459 has no extra fields). C<type> is the opcode. C<flags> gives the
6460 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6467 Perl_newOP(pTHX_ I32 type, I32 flags)
6472 if (type == -OP_ENTEREVAL) {
6473 type = OP_ENTEREVAL;
6474 flags |= OPpEVAL_BYTES<<8;
6477 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6478 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6479 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6480 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6482 NewOp(1101, o, 1, OP);
6483 OpTYPE_set(o, type);
6484 o->op_flags = (U8)flags;
6487 o->op_private = (U8)(0 | (flags >> 8));
6488 if (PL_opargs[type] & OA_RETSCALAR)
6490 if (PL_opargs[type] & OA_TARGET)
6491 o->op_targ = pad_alloc(type, SVs_PADTMP);
6492 return CHECKOP(type, o);
6498 Constructs, checks, and returns an op of any unary type. C<type> is
6499 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6500 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6501 bits, the eight bits of C<op_private>, except that the bit with value 1
6502 is automatically set. C<first> supplies an optional op to be the direct
6503 child of the unary op; it is consumed by this function and become part
6504 of the constructed op tree.
6510 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6515 if (type == -OP_ENTEREVAL) {
6516 type = OP_ENTEREVAL;
6517 flags |= OPpEVAL_BYTES<<8;
6520 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6521 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6522 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6523 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6524 || type == OP_SASSIGN
6525 || type == OP_ENTERTRY
6526 || type == OP_CUSTOM
6527 || type == OP_NULL );
6530 first = newOP(OP_STUB, 0);
6531 if (PL_opargs[type] & OA_MARK)
6532 first = force_list(first, 1);
6534 NewOp(1101, unop, 1, UNOP);
6535 OpTYPE_set(unop, type);
6536 unop->op_first = first;
6537 unop->op_flags = (U8)(flags | OPf_KIDS);
6538 unop->op_private = (U8)(1 | (flags >> 8));
6540 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6541 OpLASTSIB_set(first, (OP*)unop);
6543 unop = (UNOP*) CHECKOP(type, unop);
6547 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6551 =for apidoc newUNOP_AUX
6553 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6554 initialised to C<aux>
6560 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6565 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6566 || type == OP_CUSTOM);
6568 NewOp(1101, unop, 1, UNOP_AUX);
6569 unop->op_type = (OPCODE)type;
6570 unop->op_ppaddr = PL_ppaddr[type];
6571 unop->op_first = first;
6572 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6573 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6576 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6577 OpLASTSIB_set(first, (OP*)unop);
6579 unop = (UNOP_AUX*) CHECKOP(type, unop);
6581 return op_std_init((OP *) unop);
6585 =for apidoc newMETHOP
6587 Constructs, checks, and returns an op of method type with a method name
6588 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6589 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6590 and, shifted up eight bits, the eight bits of C<op_private>, except that
6591 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6592 op which evaluates method name; it is consumed by this function and
6593 become part of the constructed op tree.
6594 Supported optypes: C<OP_METHOD>.
6600 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6604 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6605 || type == OP_CUSTOM);
6607 NewOp(1101, methop, 1, METHOP);
6609 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6610 methop->op_flags = (U8)(flags | OPf_KIDS);
6611 methop->op_u.op_first = dynamic_meth;
6612 methop->op_private = (U8)(1 | (flags >> 8));
6614 if (!OpHAS_SIBLING(dynamic_meth))
6615 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6619 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6620 methop->op_u.op_meth_sv = const_meth;
6621 methop->op_private = (U8)(0 | (flags >> 8));
6622 methop->op_next = (OP*)methop;
6626 methop->op_rclass_targ = 0;
6628 methop->op_rclass_sv = NULL;
6631 OpTYPE_set(methop, type);
6632 return CHECKOP(type, methop);
6636 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6637 PERL_ARGS_ASSERT_NEWMETHOP;
6638 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6642 =for apidoc newMETHOP_named
6644 Constructs, checks, and returns an op of method type with a constant
6645 method name. C<type> is the opcode. C<flags> gives the eight bits of
6646 C<op_flags>, and, shifted up eight bits, the eight bits of
6647 C<op_private>. C<const_meth> supplies a constant method name;
6648 it must be a shared COW string.
6649 Supported optypes: C<OP_METHOD_NAMED>.
6655 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6656 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6657 return newMETHOP_internal(type, flags, NULL, const_meth);
6661 =for apidoc newBINOP
6663 Constructs, checks, and returns an op of any binary type. C<type>
6664 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6665 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6666 the eight bits of C<op_private>, except that the bit with value 1 or
6667 2 is automatically set as required. C<first> and C<last> supply up to
6668 two ops to be the direct children of the binary op; they are consumed
6669 by this function and become part of the constructed op tree.
6675 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6680 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6681 || type == OP_NULL || type == OP_CUSTOM);
6683 NewOp(1101, binop, 1, BINOP);
6686 first = newOP(OP_NULL, 0);
6688 OpTYPE_set(binop, type);
6689 binop->op_first = first;
6690 binop->op_flags = (U8)(flags | OPf_KIDS);
6693 binop->op_private = (U8)(1 | (flags >> 8));
6696 binop->op_private = (U8)(2 | (flags >> 8));
6697 OpMORESIB_set(first, last);
6700 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6701 OpLASTSIB_set(last, (OP*)binop);
6703 binop->op_last = OpSIBLING(binop->op_first);
6705 OpLASTSIB_set(binop->op_last, (OP*)binop);
6707 binop = (BINOP*)CHECKOP(type, binop);
6708 if (binop->op_next || binop->op_type != (OPCODE)type)
6711 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6714 /* Helper function for S_pmtrans(): comparison function to sort an array
6715 * of codepoint range pairs. Sorts by start point, or if equal, by end
6718 static int uvcompare(const void *a, const void *b)
6719 __attribute__nonnull__(1)
6720 __attribute__nonnull__(2)
6721 __attribute__pure__;
6722 static int uvcompare(const void *a, const void *b)
6724 if (*((const UV *)a) < (*(const UV *)b))
6726 if (*((const UV *)a) > (*(const UV *)b))
6728 if (*((const UV *)a+1) < (*(const UV *)b+1))
6730 if (*((const UV *)a+1) > (*(const UV *)b+1))
6735 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6736 * containing the search and replacement strings, assemble into
6737 * a translation table attached as o->op_pv.
6738 * Free expr and repl.
6739 * It expects the toker to have already set the
6740 * OPpTRANS_COMPLEMENT
6743 * flags as appropriate; this function may add
6746 * OPpTRANS_IDENTICAL
6752 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6754 SV * const tstr = ((SVOP*)expr)->op_sv;
6755 SV * const rstr = ((SVOP*)repl)->op_sv;
6758 const U8 *t = (U8*)SvPV_const(tstr, tlen);
6759 const U8 *r = (U8*)SvPV_const(rstr, rlen);
6763 SSize_t struct_size; /* malloced size of table struct */
6765 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6766 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6767 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6770 PERL_ARGS_ASSERT_PMTRANS;
6772 PL_hints |= HINT_BLOCK_SCOPE;
6775 o->op_private |= OPpTRANS_FROM_UTF;
6778 o->op_private |= OPpTRANS_TO_UTF;
6780 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6782 /* for utf8 translations, op_sv will be set to point to a swash
6783 * containing codepoint ranges. This is done by first assembling
6784 * a textual representation of the ranges in listsv then compiling
6785 * it using swash_init(). For more details of the textual format,
6786 * see L<perlunicode.pod/"User-Defined Character Properties"> .
6789 SV* const listsv = newSVpvs("# comment\n");
6791 const U8* tend = t + tlen;
6792 const U8* rend = r + rlen;
6808 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
6809 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
6812 const U32 flags = UTF8_ALLOW_DEFAULT;
6816 t = tsave = bytes_to_utf8(t, &len);
6819 if (!to_utf && rlen) {
6821 r = rsave = bytes_to_utf8(r, &len);
6825 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6826 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6831 * replace t/tlen/tend with a version that has the ranges
6834 U8 tmpbuf[UTF8_MAXBYTES+1];
6837 Newx(cp, 2*tlen, UV);
6839 transv = newSVpvs("");
6841 /* convert search string into array of (start,end) range
6842 * codepoint pairs stored in cp[]. Most "ranges" will start
6843 * and end at the same char */
6845 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6847 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6848 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6850 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6854 cp[2*i+1] = cp[2*i];
6859 /* sort the ranges */
6860 qsort(cp, i, 2*sizeof(UV), uvcompare);
6862 /* Create a utf8 string containing the complement of the
6863 * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6864 * then transv will contain the equivalent of:
6865 * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
6866 * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6867 * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6868 * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6871 for (j = 0; j < i; j++) {
6873 diff = val - nextmin;
6875 t = uvchr_to_utf8(tmpbuf,nextmin);
6876 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6878 U8 range_mark = ILLEGAL_UTF8_BYTE;
6879 t = uvchr_to_utf8(tmpbuf, val - 1);
6880 sv_catpvn(transv, (char *)&range_mark, 1);
6881 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6889 t = uvchr_to_utf8(tmpbuf,nextmin);
6890 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6892 U8 range_mark = ILLEGAL_UTF8_BYTE;
6893 sv_catpvn(transv, (char *)&range_mark, 1);
6895 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6896 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6897 t = (const U8*)SvPVX_const(transv);
6898 tlen = SvCUR(transv);
6902 else if (!rlen && !del) {
6903 r = t; rlen = tlen; rend = tend;
6907 if ((!rlen && !del) || t == r ||
6908 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6910 o->op_private |= OPpTRANS_IDENTICAL;
6914 /* extract char ranges from t and r and append them to listsv */
6916 while (t < tend || tfirst <= tlast) {
6917 /* see if we need more "t" chars */
6918 if (tfirst > tlast) {
6919 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6921 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6923 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6930 /* now see if we need more "r" chars */
6931 if (rfirst > rlast) {
6933 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6935 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6937 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6946 rfirst = rlast = 0xffffffff;
6950 /* now see which range will peter out first, if either. */
6951 tdiff = tlast - tfirst;
6952 rdiff = rlast - rfirst;
6953 tcount += tdiff + 1;
6954 rcount += rdiff + 1;
6961 if (rfirst == 0xffffffff) {
6962 diff = tdiff; /* oops, pretend rdiff is infinite */
6964 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6965 (long)tfirst, (long)tlast);
6967 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6971 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6972 (long)tfirst, (long)(tfirst + diff),
6975 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6976 (long)tfirst, (long)rfirst);
6978 if (rfirst + diff > max)
6979 max = rfirst + diff;
6981 grows = (tfirst < rfirst &&
6982 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6988 /* compile listsv into a swash and attach to o */
6996 else if (max > 0xff)
7001 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
7003 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
7004 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
7005 PAD_SETSV(cPADOPo->op_padix, swash);
7007 SvREADONLY_on(swash);
7009 cSVOPo->op_sv = swash;
7011 SvREFCNT_dec(listsv);
7012 SvREFCNT_dec(transv);
7014 if (!del && havefinal && rlen)
7015 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
7016 newSVuv((UV)final), 0);
7025 else if (rlast == 0xffffffff)
7031 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
7032 * table. Entries with the value -1 indicate chars not to be
7033 * translated, while -2 indicates a search char without a
7034 * corresponding replacement char under /d.
7036 * Normally, the table has 256 slots. However, in the presence of
7037 * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
7038 * added, and if there are enough replacement chars to start pairing
7039 * with the \x{100},... search chars, then a larger (> 256) table
7042 * In addition, regardless of whether under /c, an extra slot at the
7043 * end is used to store the final repeating char, or -3 under an empty
7044 * replacement list, or -2 under /d; which makes the runtime code
7047 * The toker will have already expanded char ranges in t and r.
7050 /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
7051 * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
7052 * The OPtrans_map struct already contains one slot; hence the -1.
7054 struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
7055 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7057 cPVOPo->op_pv = (char*)tbl;
7062 /* in this branch, j is a count of 'consumed' (i.e. paired off
7063 * with a search char) replacement chars (so j <= rlen always)
7065 for (i = 0; i < tlen; i++)
7066 tbl->map[t[i]] = -1;
7068 for (i = 0, j = 0; i < 256; i++) {
7074 tbl->map[i] = r[j-1];
7076 tbl->map[i] = (short)i;
7079 tbl->map[i] = r[j++];
7081 if ( tbl->map[i] >= 0
7082 && UVCHR_IS_INVARIANT((UV)i)
7083 && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
7093 /* More replacement chars than search chars:
7094 * store excess replacement chars at end of main table.
7097 struct_size += excess;
7098 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
7099 struct_size + excess * sizeof(short));
7100 tbl->size += excess;
7101 cPVOPo->op_pv = (char*)tbl;
7103 for (i = 0; i < excess; i++)
7104 tbl->map[i + 256] = r[j+i];
7107 /* no more replacement chars than search chars */
7108 if (!rlen && !del && !squash)
7109 o->op_private |= OPpTRANS_IDENTICAL;
7112 tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
7115 if (!rlen && !del) {
7118 o->op_private |= OPpTRANS_IDENTICAL;
7120 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
7121 o->op_private |= OPpTRANS_IDENTICAL;
7124 for (i = 0; i < 256; i++)
7126 for (i = 0, j = 0; i < tlen; i++,j++) {
7129 if (tbl->map[t[i]] == -1)
7130 tbl->map[t[i]] = -2;
7135 if (tbl->map[t[i]] == -1) {
7136 if ( UVCHR_IS_INVARIANT(t[i])
7137 && ! UVCHR_IS_INVARIANT(r[j]))
7139 tbl->map[t[i]] = r[j];
7142 tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
7145 /* both non-utf8 and utf8 code paths end up here */
7148 if(del && rlen == tlen) {
7149 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7150 } else if(rlen > tlen && !complement) {
7151 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7155 o->op_private |= OPpTRANS_GROWS;
7166 Constructs, checks, and returns an op of any pattern matching type.
7167 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
7168 and, shifted up eight bits, the eight bits of C<op_private>.
7174 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7179 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7180 || type == OP_CUSTOM);
7182 NewOp(1101, pmop, 1, PMOP);
7183 OpTYPE_set(pmop, type);
7184 pmop->op_flags = (U8)flags;
7185 pmop->op_private = (U8)(0 | (flags >> 8));
7186 if (PL_opargs[type] & OA_RETSCALAR)
7189 if (PL_hints & HINT_RE_TAINT)
7190 pmop->op_pmflags |= PMf_RETAINT;
7191 #ifdef USE_LOCALE_CTYPE
7192 if (IN_LC_COMPILETIME(LC_CTYPE)) {
7193 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7198 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7200 if (PL_hints & HINT_RE_FLAGS) {
7201 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7202 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7204 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7205 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7206 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7208 if (reflags && SvOK(reflags)) {
7209 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7215 assert(SvPOK(PL_regex_pad[0]));
7216 if (SvCUR(PL_regex_pad[0])) {
7217 /* Pop off the "packed" IV from the end. */
7218 SV *const repointer_list = PL_regex_pad[0];
7219 const char *p = SvEND(repointer_list) - sizeof(IV);
7220 const IV offset = *((IV*)p);
7222 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7224 SvEND_set(repointer_list, p);
7226 pmop->op_pmoffset = offset;
7227 /* This slot should be free, so assert this: */
7228 assert(PL_regex_pad[offset] == &PL_sv_undef);
7230 SV * const repointer = &PL_sv_undef;
7231 av_push(PL_regex_padav, repointer);
7232 pmop->op_pmoffset = av_tindex(PL_regex_padav);
7233 PL_regex_pad = AvARRAY(PL_regex_padav);
7237 return CHECKOP(type, pmop);
7245 /* Any pad names in scope are potentially lvalues. */
7246 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7247 PADNAME *pn = PAD_COMPNAME_SV(i);
7248 if (!pn || !PadnameLEN(pn))
7250 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7251 S_mark_padname_lvalue(aTHX_ pn);
7255 /* Given some sort of match op o, and an expression expr containing a
7256 * pattern, either compile expr into a regex and attach it to o (if it's
7257 * constant), or convert expr into a runtime regcomp op sequence (if it's
7260 * Flags currently has 2 bits of meaning:
7261 * 1: isreg indicates that the pattern is part of a regex construct, eg
7262 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7263 * split "pattern", which aren't. In the former case, expr will be a list
7264 * if the pattern contains more than one term (eg /a$b/).
7265 * 2: The pattern is for a split.
7267 * When the pattern has been compiled within a new anon CV (for
7268 * qr/(?{...})/ ), then floor indicates the savestack level just before
7269 * the new sub was created
7273 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
7277 I32 repl_has_vars = 0;
7278 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
7279 bool is_compiletime;
7281 bool isreg = cBOOL(flags & 1);
7282 bool is_split = cBOOL(flags & 2);
7284 PERL_ARGS_ASSERT_PMRUNTIME;
7287 return pmtrans(o, expr, repl);
7290 /* find whether we have any runtime or code elements;
7291 * at the same time, temporarily set the op_next of each DO block;
7292 * then when we LINKLIST, this will cause the DO blocks to be excluded
7293 * from the op_next chain (and from having LINKLIST recursively
7294 * applied to them). We fix up the DOs specially later */
7298 if (expr->op_type == OP_LIST) {
7300 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7301 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
7303 assert(!o->op_next);
7304 if (UNLIKELY(!OpHAS_SIBLING(o))) {
7305 assert(PL_parser && PL_parser->error_count);
7306 /* This can happen with qr/ (?{(^{})/. Just fake up
7307 the op we were expecting to see, to avoid crashing
7309 op_sibling_splice(expr, o, 0,
7310 newSVOP(OP_CONST, 0, &PL_sv_no));
7312 o->op_next = OpSIBLING(o);
7314 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
7318 else if (expr->op_type != OP_CONST)
7323 /* fix up DO blocks; treat each one as a separate little sub;
7324 * also, mark any arrays as LIST/REF */
7326 if (expr->op_type == OP_LIST) {
7328 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7330 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
7331 assert( !(o->op_flags & OPf_WANT));
7332 /* push the array rather than its contents. The regex
7333 * engine will retrieve and join the elements later */
7334 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
7338 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
7340 o->op_next = NULL; /* undo temporary hack from above */
7343 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
7344 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7346 assert(leaveop->op_first->op_type == OP_ENTER);
7347 assert(OpHAS_SIBLING(leaveop->op_first));
7348 o->op_next = OpSIBLING(leaveop->op_first);
7350 assert(leaveop->op_flags & OPf_KIDS);
7351 assert(leaveop->op_last->op_next == (OP*)leaveop);
7352 leaveop->op_next = NULL; /* stop on last op */
7353 op_null((OP*)leaveop);
7357 OP *scope = cLISTOPo->op_first;
7358 assert(scope->op_type == OP_SCOPE);
7359 assert(scope->op_flags & OPf_KIDS);
7360 scope->op_next = NULL; /* stop on last op */
7364 /* XXX optimize_optree() must be called on o before
7365 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7366 * currently cope with a peephole-optimised optree.
7367 * Calling optimize_optree() here ensures that condition
7368 * is met, but may mean optimize_optree() is applied
7369 * to the same optree later (where hopefully it won't do any
7370 * harm as it can't convert an op to multiconcat if it's
7371 * already been converted */
7374 /* have to peep the DOs individually as we've removed it from
7375 * the op_next chain */
7377 S_prune_chain_head(&(o->op_next));
7379 /* runtime finalizes as part of finalizing whole tree */
7383 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7384 assert( !(expr->op_flags & OPf_WANT));
7385 /* push the array rather than its contents. The regex
7386 * engine will retrieve and join the elements later */
7387 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7390 PL_hints |= HINT_BLOCK_SCOPE;
7392 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7394 if (is_compiletime) {
7395 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7396 regexp_engine const *eng = current_re_engine();
7399 /* make engine handle split ' ' specially */
7400 pm->op_pmflags |= PMf_SPLIT;
7401 rx_flags |= RXf_SPLIT;
7404 if (!has_code || !eng->op_comp) {
7405 /* compile-time simple constant pattern */
7407 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7408 /* whoops! we guessed that a qr// had a code block, but we
7409 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7410 * that isn't required now. Note that we have to be pretty
7411 * confident that nothing used that CV's pad while the
7412 * regex was parsed, except maybe op targets for \Q etc.
7413 * If there were any op targets, though, they should have
7414 * been stolen by constant folding.
7418 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7419 while (++i <= AvFILLp(PL_comppad)) {
7420 # ifdef USE_PAD_RESET
7421 /* under USE_PAD_RESET, pad swipe replaces a swiped
7422 * folded constant with a fresh padtmp */
7423 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7425 assert(!PL_curpad[i]);
7429 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7430 * outer CV (the one whose slab holds the pm op). The
7431 * inner CV (which holds expr) will be freed later, once
7432 * all the entries on the parse stack have been popped on
7433 * return from this function. Which is why its safe to
7434 * call op_free(expr) below.
7437 pm->op_pmflags &= ~PMf_HAS_CV;
7440 /* Skip compiling if parser found an error for this pattern */
7441 if (pm->op_pmflags & PMf_HAS_ERROR) {
7447 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7448 rx_flags, pm->op_pmflags)
7449 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7450 rx_flags, pm->op_pmflags)
7455 /* compile-time pattern that includes literal code blocks */
7459 /* Skip compiling if parser found an error for this pattern */
7460 if (pm->op_pmflags & PMf_HAS_ERROR) {
7464 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7467 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7470 if (pm->op_pmflags & PMf_HAS_CV) {
7472 /* this QR op (and the anon sub we embed it in) is never
7473 * actually executed. It's just a placeholder where we can
7474 * squirrel away expr in op_code_list without the peephole
7475 * optimiser etc processing it for a second time */
7476 OP *qr = newPMOP(OP_QR, 0);
7477 ((PMOP*)qr)->op_code_list = expr;
7479 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7480 SvREFCNT_inc_simple_void(PL_compcv);
7481 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7482 ReANY(re)->qr_anoncv = cv;
7484 /* attach the anon CV to the pad so that
7485 * pad_fixup_inner_anons() can find it */
7486 (void)pad_add_anon(cv, o->op_type);
7487 SvREFCNT_inc_simple_void(cv);
7490 pm->op_code_list = expr;
7495 /* runtime pattern: build chain of regcomp etc ops */
7497 PADOFFSET cv_targ = 0;
7499 reglist = isreg && expr->op_type == OP_LIST;
7504 pm->op_code_list = expr;
7505 /* don't free op_code_list; its ops are embedded elsewhere too */
7506 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7510 /* make engine handle split ' ' specially */
7511 pm->op_pmflags |= PMf_SPLIT;
7513 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7514 * to allow its op_next to be pointed past the regcomp and
7515 * preceding stacking ops;
7516 * OP_REGCRESET is there to reset taint before executing the
7518 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7519 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7521 if (pm->op_pmflags & PMf_HAS_CV) {
7522 /* we have a runtime qr with literal code. This means
7523 * that the qr// has been wrapped in a new CV, which
7524 * means that runtime consts, vars etc will have been compiled
7525 * against a new pad. So... we need to execute those ops
7526 * within the environment of the new CV. So wrap them in a call
7527 * to a new anon sub. i.e. for
7531 * we build an anon sub that looks like
7533 * sub { "a", $b, '(?{...})' }
7535 * and call it, passing the returned list to regcomp.
7536 * Or to put it another way, the list of ops that get executed
7540 * ------ -------------------
7541 * pushmark (for regcomp)
7542 * pushmark (for entersub)
7546 * regcreset regcreset
7548 * const("a") const("a")
7550 * const("(?{...})") const("(?{...})")
7555 SvREFCNT_inc_simple_void(PL_compcv);
7556 CvLVALUE_on(PL_compcv);
7557 /* these lines are just an unrolled newANONATTRSUB */
7558 expr = newSVOP(OP_ANONCODE, 0,
7559 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7560 cv_targ = expr->op_targ;
7561 expr = newUNOP(OP_REFGEN, 0, expr);
7563 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7566 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7567 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7568 | (reglist ? OPf_STACKED : 0);
7569 rcop->op_targ = cv_targ;
7571 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7572 if (PL_hints & HINT_RE_EVAL)
7573 S_set_haseval(aTHX);
7575 /* establish postfix order */
7576 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7578 rcop->op_next = expr;
7579 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7582 rcop->op_next = LINKLIST(expr);
7583 expr->op_next = (OP*)rcop;
7586 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7592 /* If we are looking at s//.../e with a single statement, get past
7593 the implicit do{}. */
7594 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7595 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7596 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7599 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7600 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7601 && !OpHAS_SIBLING(sib))
7604 if (curop->op_type == OP_CONST)
7606 else if (( (curop->op_type == OP_RV2SV ||
7607 curop->op_type == OP_RV2AV ||
7608 curop->op_type == OP_RV2HV ||
7609 curop->op_type == OP_RV2GV)
7610 && cUNOPx(curop)->op_first
7611 && cUNOPx(curop)->op_first->op_type == OP_GV )
7612 || curop->op_type == OP_PADSV
7613 || curop->op_type == OP_PADAV
7614 || curop->op_type == OP_PADHV
7615 || curop->op_type == OP_PADANY) {
7623 || !RX_PRELEN(PM_GETRE(pm))
7624 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7626 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7627 op_prepend_elem(o->op_type, scalar(repl), o);
7630 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7631 rcop->op_private = 1;
7633 /* establish postfix order */
7634 rcop->op_next = LINKLIST(repl);
7635 repl->op_next = (OP*)rcop;
7637 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7638 assert(!(pm->op_pmflags & PMf_ONCE));
7639 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7650 Constructs, checks, and returns an op of any type that involves an
7651 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7652 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7653 takes ownership of one reference to it.
7659 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7664 PERL_ARGS_ASSERT_NEWSVOP;
7666 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7667 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7668 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7669 || type == OP_CUSTOM);
7671 NewOp(1101, svop, 1, SVOP);
7672 OpTYPE_set(svop, type);
7674 svop->op_next = (OP*)svop;
7675 svop->op_flags = (U8)flags;
7676 svop->op_private = (U8)(0 | (flags >> 8));
7677 if (PL_opargs[type] & OA_RETSCALAR)
7679 if (PL_opargs[type] & OA_TARGET)
7680 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7681 return CHECKOP(type, svop);
7685 =for apidoc newDEFSVOP
7687 Constructs and returns an op to access C<$_>.
7693 Perl_newDEFSVOP(pTHX)
7695 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7701 =for apidoc newPADOP
7703 Constructs, checks, and returns an op of any type that involves a
7704 reference to a pad element. C<type> is the opcode. C<flags> gives the
7705 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7706 is populated with C<sv>; this function takes ownership of one reference
7709 This function only exists if Perl has been compiled to use ithreads.
7715 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7720 PERL_ARGS_ASSERT_NEWPADOP;
7722 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7723 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7724 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7725 || type == OP_CUSTOM);
7727 NewOp(1101, padop, 1, PADOP);
7728 OpTYPE_set(padop, type);
7730 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7731 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7732 PAD_SETSV(padop->op_padix, sv);
7734 padop->op_next = (OP*)padop;
7735 padop->op_flags = (U8)flags;
7736 if (PL_opargs[type] & OA_RETSCALAR)
7738 if (PL_opargs[type] & OA_TARGET)
7739 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7740 return CHECKOP(type, padop);
7743 #endif /* USE_ITHREADS */
7748 Constructs, checks, and returns an op of any type that involves an
7749 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7750 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7751 reference; calling this function does not transfer ownership of any
7758 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7760 PERL_ARGS_ASSERT_NEWGVOP;
7763 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7765 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7772 Constructs, checks, and returns an op of any type that involves an
7773 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7774 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7775 Depending on the op type, the memory referenced by C<pv> may be freed
7776 when the op is destroyed. If the op is of a freeing type, C<pv> must
7777 have been allocated using C<PerlMemShared_malloc>.
7783 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7786 const bool utf8 = cBOOL(flags & SVf_UTF8);
7791 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7792 || type == OP_RUNCV || type == OP_CUSTOM
7793 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7795 NewOp(1101, pvop, 1, PVOP);
7796 OpTYPE_set(pvop, type);
7798 pvop->op_next = (OP*)pvop;
7799 pvop->op_flags = (U8)flags;
7800 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7801 if (PL_opargs[type] & OA_RETSCALAR)
7803 if (PL_opargs[type] & OA_TARGET)
7804 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7805 return CHECKOP(type, pvop);
7809 Perl_package(pTHX_ OP *o)
7811 SV *const sv = cSVOPo->op_sv;
7813 PERL_ARGS_ASSERT_PACKAGE;
7815 SAVEGENERICSV(PL_curstash);
7816 save_item(PL_curstname);
7818 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7820 sv_setsv(PL_curstname, sv);
7822 PL_hints |= HINT_BLOCK_SCOPE;
7823 PL_parser->copline = NOLINE;
7829 Perl_package_version( pTHX_ OP *v )
7831 U32 savehints = PL_hints;
7832 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7833 PL_hints &= ~HINT_STRICT_VARS;
7834 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7835 PL_hints = savehints;
7840 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7845 SV *use_version = NULL;
7847 PERL_ARGS_ASSERT_UTILIZE;
7849 if (idop->op_type != OP_CONST)
7850 Perl_croak(aTHX_ "Module name must be constant");
7855 SV * const vesv = ((SVOP*)version)->op_sv;
7857 if (!arg && !SvNIOKp(vesv)) {
7864 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7865 Perl_croak(aTHX_ "Version number must be a constant number");
7867 /* Make copy of idop so we don't free it twice */
7868 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7870 /* Fake up a method call to VERSION */
7871 meth = newSVpvs_share("VERSION");
7872 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7873 op_append_elem(OP_LIST,
7874 op_prepend_elem(OP_LIST, pack, version),
7875 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7879 /* Fake up an import/unimport */
7880 if (arg && arg->op_type == OP_STUB) {
7881 imop = arg; /* no import on explicit () */
7883 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7884 imop = NULL; /* use 5.0; */
7886 use_version = ((SVOP*)idop)->op_sv;
7888 idop->op_private |= OPpCONST_NOVER;
7893 /* Make copy of idop so we don't free it twice */
7894 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7896 /* Fake up a method call to import/unimport */
7898 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7899 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7900 op_append_elem(OP_LIST,
7901 op_prepend_elem(OP_LIST, pack, arg),
7902 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7906 /* Fake up the BEGIN {}, which does its thing immediately. */
7908 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7911 op_append_elem(OP_LINESEQ,
7912 op_append_elem(OP_LINESEQ,
7913 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7914 newSTATEOP(0, NULL, veop)),
7915 newSTATEOP(0, NULL, imop) ));
7919 * feature bundle that corresponds to the required version. */
7920 use_version = sv_2mortal(new_version(use_version));
7921 S_enable_feature_bundle(aTHX_ use_version);
7923 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7924 if (vcmp(use_version,
7925 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7926 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7927 PL_hints |= HINT_STRICT_REFS;
7928 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7929 PL_hints |= HINT_STRICT_SUBS;
7930 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7931 PL_hints |= HINT_STRICT_VARS;
7933 /* otherwise they are off */
7935 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7936 PL_hints &= ~HINT_STRICT_REFS;
7937 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7938 PL_hints &= ~HINT_STRICT_SUBS;
7939 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7940 PL_hints &= ~HINT_STRICT_VARS;
7944 /* The "did you use incorrect case?" warning used to be here.
7945 * The problem is that on case-insensitive filesystems one
7946 * might get false positives for "use" (and "require"):
7947 * "use Strict" or "require CARP" will work. This causes
7948 * portability problems for the script: in case-strict
7949 * filesystems the script will stop working.
7951 * The "incorrect case" warning checked whether "use Foo"
7952 * imported "Foo" to your namespace, but that is wrong, too:
7953 * there is no requirement nor promise in the language that
7954 * a Foo.pm should or would contain anything in package "Foo".
7956 * There is very little Configure-wise that can be done, either:
7957 * the case-sensitivity of the build filesystem of Perl does not
7958 * help in guessing the case-sensitivity of the runtime environment.
7961 PL_hints |= HINT_BLOCK_SCOPE;
7962 PL_parser->copline = NOLINE;
7963 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7967 =head1 Embedding Functions
7969 =for apidoc load_module
7971 Loads the module whose name is pointed to by the string part of C<name>.
7972 Note that the actual module name, not its filename, should be given.
7973 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7974 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7975 trailing arguments can be used to specify arguments to the module's C<import()>
7976 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7977 on the flags. The flags argument is a bitwise-ORed collection of any of
7978 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7979 (or 0 for no flags).
7981 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7982 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7983 the trailing optional arguments may be omitted entirely. Otherwise, if
7984 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7985 exactly one C<OP*>, containing the op tree that produces the relevant import
7986 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7987 will be used as import arguments; and the list must be terminated with C<(SV*)
7988 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7989 set, the trailing C<NULL> pointer is needed even if no import arguments are
7990 desired. The reference count for each specified C<SV*> argument is
7991 decremented. In addition, the C<name> argument is modified.
7993 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7999 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8003 PERL_ARGS_ASSERT_LOAD_MODULE;
8005 va_start(args, ver);
8006 vload_module(flags, name, ver, &args);
8010 #ifdef PERL_IMPLICIT_CONTEXT
8012 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8016 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8017 va_start(args, ver);
8018 vload_module(flags, name, ver, &args);
8024 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8030 PERL_ARGS_ASSERT_VLOAD_MODULE;
8032 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8033 * that it has a PL_parser to play with while doing that, and also
8034 * that it doesn't mess with any existing parser, by creating a tmp
8035 * new parser with lex_start(). This won't actually be used for much,
8036 * since pp_require() will create another parser for the real work.
8037 * The ENTER/LEAVE pair protect callers from any side effects of use.
8039 * start_subparse() creates a new PL_compcv. This means that any ops
8040 * allocated below will be allocated from that CV's op slab, and so
8041 * will be automatically freed if the utilise() fails
8045 SAVEVPTR(PL_curcop);
8046 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8047 floor = start_subparse(FALSE, 0);
8049 modname = newSVOP(OP_CONST, 0, name);
8050 modname->op_private |= OPpCONST_BARE;
8052 veop = newSVOP(OP_CONST, 0, ver);
8056 if (flags & PERL_LOADMOD_NOIMPORT) {
8057 imop = sawparens(newNULLLIST());
8059 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8060 imop = va_arg(*args, OP*);
8065 sv = va_arg(*args, SV*);
8067 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8068 sv = va_arg(*args, SV*);
8072 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8076 PERL_STATIC_INLINE OP *
8077 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8079 return newUNOP(OP_ENTERSUB, OPf_STACKED,
8080 newLISTOP(OP_LIST, 0, arg,
8081 newUNOP(OP_RV2CV, 0,
8082 newGVOP(OP_GV, 0, gv))));
8086 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8091 PERL_ARGS_ASSERT_DOFILE;
8093 if (!force_builtin && (gv = gv_override("do", 2))) {
8094 doop = S_new_entersubop(aTHX_ gv, term);
8097 doop = newUNOP(OP_DOFILE, 0, scalar(term));
8103 =head1 Optree construction
8105 =for apidoc newSLICEOP
8107 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
8108 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8109 be set automatically, and, shifted up eight bits, the eight bits of
8110 C<op_private>, except that the bit with value 1 or 2 is automatically
8111 set as required. C<listval> and C<subscript> supply the parameters of
8112 the slice; they are consumed by this function and become part of the
8113 constructed op tree.
8119 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8121 return newBINOP(OP_LSLICE, flags,
8122 list(force_list(subscript, 1)),
8123 list(force_list(listval, 1)) );
8126 #define ASSIGN_SCALAR 0
8127 #define ASSIGN_LIST 1
8128 #define ASSIGN_REF 2
8130 /* given the optree o on the LHS of an assignment, determine whether its:
8131 * ASSIGN_SCALAR $x = ...
8132 * ASSIGN_LIST ($x) = ...
8133 * ASSIGN_REF \$x = ...
8137 S_assignment_type(pTHX_ const OP *o)
8146 if (o->op_type == OP_SREFGEN)
8148 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8149 type = kid->op_type;
8150 flags = o->op_flags | kid->op_flags;
8151 if (!(flags & OPf_PARENS)
8152 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8153 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8157 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8158 o = cUNOPo->op_first;
8159 flags = o->op_flags;
8161 ret = ASSIGN_SCALAR;
8164 if (type == OP_COND_EXPR) {
8165 OP * const sib = OpSIBLING(cLOGOPo->op_first);
8166 const I32 t = assignment_type(sib);
8167 const I32 f = assignment_type(OpSIBLING(sib));
8169 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8171 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8172 yyerror("Assignment to both a list and a scalar");
8173 return ASSIGN_SCALAR;
8176 if (type == OP_LIST &&
8177 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8178 o->op_private & OPpLVAL_INTRO)
8181 if (type == OP_LIST || flags & OPf_PARENS ||
8182 type == OP_RV2AV || type == OP_RV2HV ||
8183 type == OP_ASLICE || type == OP_HSLICE ||
8184 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8187 if (type == OP_PADAV || type == OP_PADHV)
8190 if (type == OP_RV2SV)
8197 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8200 const PADOFFSET target = padop->op_targ;
8201 OP *const other = newOP(OP_PADSV,
8203 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8204 OP *const first = newOP(OP_NULL, 0);
8205 OP *const nullop = newCONDOP(0, first, initop, other);
8206 /* XXX targlex disabled for now; see ticket #124160
8207 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8209 OP *const condop = first->op_next;
8211 OpTYPE_set(condop, OP_ONCE);
8212 other->op_targ = target;
8213 nullop->op_flags |= OPf_WANT_SCALAR;
8215 /* Store the initializedness of state vars in a separate
8218 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8219 /* hijacking PADSTALE for uninitialized state variables */
8220 SvPADSTALE_on(PAD_SVl(condop->op_targ));
8226 =for apidoc newASSIGNOP
8228 Constructs, checks, and returns an assignment op. C<left> and C<right>
8229 supply the parameters of the assignment; they are consumed by this
8230 function and become part of the constructed op tree.
8232 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8233 a suitable conditional optree is constructed. If C<optype> is the opcode
8234 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8235 performs the binary operation and assigns the result to the left argument.
8236 Either way, if C<optype> is non-zero then C<flags> has no effect.
8238 If C<optype> is zero, then a plain scalar or list assignment is
8239 constructed. Which type of assignment it is is automatically determined.
8240 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8241 will be set automatically, and, shifted up eight bits, the eight bits
8242 of C<op_private>, except that the bit with value 1 or 2 is automatically
8249 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8255 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
8256 right = scalar(right);
8257 return newLOGOP(optype, 0,
8258 op_lvalue(scalar(left), optype),
8259 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8262 return newBINOP(optype, OPf_STACKED,
8263 op_lvalue(scalar(left), optype), scalar(right));
8267 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8268 OP *state_var_op = NULL;
8269 static const char no_list_state[] = "Initialization of state variables"
8270 " in list currently forbidden";
8273 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8274 left->op_private &= ~ OPpSLICEWARNING;
8277 left = op_lvalue(left, OP_AASSIGN);
8278 curop = list(force_list(left, 1));
8279 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
8280 o->op_private = (U8)(0 | (flags >> 8));
8282 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8284 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
8285 if (!(left->op_flags & OPf_PARENS) &&
8286 lop->op_type == OP_PUSHMARK &&
8287 (vop = OpSIBLING(lop)) &&
8288 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8289 !(vop->op_flags & OPf_PARENS) &&
8290 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8291 (OPpLVAL_INTRO|OPpPAD_STATE) &&
8292 (eop = OpSIBLING(vop)) &&
8293 eop->op_type == OP_ENTERSUB &&
8294 !OpHAS_SIBLING(eop)) {
8298 if ((lop->op_type == OP_PADSV ||
8299 lop->op_type == OP_PADAV ||
8300 lop->op_type == OP_PADHV ||
8301 lop->op_type == OP_PADANY)
8302 && (lop->op_private & OPpPAD_STATE)
8304 yyerror(no_list_state);
8305 lop = OpSIBLING(lop);
8309 else if ( (left->op_private & OPpLVAL_INTRO)
8310 && (left->op_private & OPpPAD_STATE)
8311 && ( left->op_type == OP_PADSV
8312 || left->op_type == OP_PADAV
8313 || left->op_type == OP_PADHV
8314 || left->op_type == OP_PADANY)
8316 /* All single variable list context state assignments, hence
8326 if (left->op_flags & OPf_PARENS)
8327 yyerror(no_list_state);
8329 state_var_op = left;
8332 /* optimise @a = split(...) into:
8333 * @{expr}: split(..., @{expr}) (where @a is not flattened)
8334 * @a, my @a, local @a: split(...) (where @a is attached to
8335 * the split op itself)
8339 && right->op_type == OP_SPLIT
8340 /* don't do twice, e.g. @b = (@a = split) */
8341 && !(right->op_private & OPpSPLIT_ASSIGN))
8345 if ( ( left->op_type == OP_RV2AV
8346 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
8347 || left->op_type == OP_PADAV)
8349 /* @pkg or @lex or local @pkg' or 'my @lex' */
8353 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
8354 = cPADOPx(gvop)->op_padix;
8355 cPADOPx(gvop)->op_padix = 0; /* steal it */
8357 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
8358 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8359 cSVOPx(gvop)->op_sv = NULL; /* steal it */
8361 right->op_private |=
8362 left->op_private & OPpOUR_INTRO;
8365 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8366 left->op_targ = 0; /* steal it */
8367 right->op_private |= OPpSPLIT_LEX;
8369 right->op_private |= left->op_private & OPpLVAL_INTRO;
8372 tmpop = cUNOPo->op_first; /* to list (nulled) */
8373 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8374 assert(OpSIBLING(tmpop) == right);
8375 assert(!OpHAS_SIBLING(right));
8376 /* detach the split subtreee from the o tree,
8377 * then free the residual o tree */
8378 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8379 op_free(o); /* blow off assign */
8380 right->op_private |= OPpSPLIT_ASSIGN;
8381 right->op_flags &= ~OPf_WANT;
8382 /* "I don't know and I don't care." */
8385 else if (left->op_type == OP_RV2AV) {
8388 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8389 assert(OpSIBLING(pushop) == left);
8390 /* Detach the array ... */
8391 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8392 /* ... and attach it to the split. */
8393 op_sibling_splice(right, cLISTOPx(right)->op_last,
8395 right->op_flags |= OPf_STACKED;
8396 /* Detach split and expunge aassign as above. */
8399 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8400 ((LISTOP*)right)->op_last->op_type == OP_CONST)
8402 /* convert split(...,0) to split(..., PL_modcount+1) */
8404 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8405 SV * const sv = *svp;
8406 if (SvIOK(sv) && SvIVX(sv) == 0)
8408 if (right->op_private & OPpSPLIT_IMPLIM) {
8409 /* our own SV, created in ck_split */
8411 sv_setiv(sv, PL_modcount+1);
8414 /* SV may belong to someone else */
8416 *svp = newSViv(PL_modcount+1);
8423 o = S_newONCEOP(aTHX_ o, state_var_op);
8426 if (assign_type == ASSIGN_REF)
8427 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8429 right = newOP(OP_UNDEF, 0);
8430 if (right->op_type == OP_READLINE) {
8431 right->op_flags |= OPf_STACKED;
8432 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8436 o = newBINOP(OP_SASSIGN, flags,
8437 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8443 =for apidoc newSTATEOP
8445 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8446 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8447 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8448 If C<label> is non-null, it supplies the name of a label to attach to
8449 the state op; this function takes ownership of the memory pointed at by
8450 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8453 If C<o> is null, the state op is returned. Otherwise the state op is
8454 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8455 is consumed by this function and becomes part of the returned op tree.
8461 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8464 const U32 seq = intro_my();
8465 const U32 utf8 = flags & SVf_UTF8;
8468 PL_parser->parsed_sub = 0;
8472 NewOp(1101, cop, 1, COP);
8473 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8474 OpTYPE_set(cop, OP_DBSTATE);
8477 OpTYPE_set(cop, OP_NEXTSTATE);
8479 cop->op_flags = (U8)flags;
8480 CopHINTS_set(cop, PL_hints);
8482 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8484 cop->op_next = (OP*)cop;
8487 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8488 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8490 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8492 PL_hints |= HINT_BLOCK_SCOPE;
8493 /* It seems that we need to defer freeing this pointer, as other parts
8494 of the grammar end up wanting to copy it after this op has been
8499 if (PL_parser->preambling != NOLINE) {
8500 CopLINE_set(cop, PL_parser->preambling);
8501 PL_parser->copline = NOLINE;
8503 else if (PL_parser->copline == NOLINE)
8504 CopLINE_set(cop, CopLINE(PL_curcop));
8506 CopLINE_set(cop, PL_parser->copline);
8507 PL_parser->copline = NOLINE;
8510 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
8512 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8514 CopSTASH_set(cop, PL_curstash);
8516 if (cop->op_type == OP_DBSTATE) {
8517 /* this line can have a breakpoint - store the cop in IV */
8518 AV *av = CopFILEAVx(PL_curcop);
8520 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8521 if (svp && *svp != &PL_sv_undef ) {
8522 (void)SvIOK_on(*svp);
8523 SvIV_set(*svp, PTR2IV(cop));
8528 if (flags & OPf_SPECIAL)
8530 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8534 =for apidoc newLOGOP
8536 Constructs, checks, and returns a logical (flow control) op. C<type>
8537 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8538 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8539 the eight bits of C<op_private>, except that the bit with value 1 is
8540 automatically set. C<first> supplies the expression controlling the
8541 flow, and C<other> supplies the side (alternate) chain of ops; they are
8542 consumed by this function and become part of the constructed op tree.
8548 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8550 PERL_ARGS_ASSERT_NEWLOGOP;
8552 return new_logop(type, flags, &first, &other);
8556 /* See if the optree o contains a single OP_CONST (plus possibly
8557 * surrounding enter/nextstate/null etc). If so, return it, else return
8562 S_search_const(pTHX_ OP *o)
8564 PERL_ARGS_ASSERT_SEARCH_CONST;
8567 switch (o->op_type) {
8571 if (o->op_flags & OPf_KIDS) {
8572 o = cUNOPo->op_first;
8581 if (!(o->op_flags & OPf_KIDS))
8583 kid = cLISTOPo->op_first;
8586 switch (kid->op_type) {
8590 kid = OpSIBLING(kid);
8593 if (kid != cLISTOPo->op_last)
8600 kid = cLISTOPo->op_last;
8612 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8620 int prepend_not = 0;
8622 PERL_ARGS_ASSERT_NEW_LOGOP;
8627 /* [perl #59802]: Warn about things like "return $a or $b", which
8628 is parsed as "(return $a) or $b" rather than "return ($a or
8629 $b)". NB: This also applies to xor, which is why we do it
8632 switch (first->op_type) {
8636 /* XXX: Perhaps we should emit a stronger warning for these.
8637 Even with the high-precedence operator they don't seem to do
8640 But until we do, fall through here.
8646 /* XXX: Currently we allow people to "shoot themselves in the
8647 foot" by explicitly writing "(return $a) or $b".
8649 Warn unless we are looking at the result from folding or if
8650 the programmer explicitly grouped the operators like this.
8651 The former can occur with e.g.
8653 use constant FEATURE => ( $] >= ... );
8654 sub { not FEATURE and return or do_stuff(); }
8656 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8657 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8658 "Possible precedence issue with control flow operator");
8659 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8665 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8666 return newBINOP(type, flags, scalar(first), scalar(other));
8668 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8669 || type == OP_CUSTOM);
8671 scalarboolean(first);
8673 /* search for a constant op that could let us fold the test */
8674 if ((cstop = search_const(first))) {
8675 if (cstop->op_private & OPpCONST_STRICT)
8676 no_bareword_allowed(cstop);
8677 else if ((cstop->op_private & OPpCONST_BARE))
8678 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8679 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8680 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8681 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8682 /* Elide the (constant) lhs, since it can't affect the outcome */
8684 if (other->op_type == OP_CONST)
8685 other->op_private |= OPpCONST_SHORTCIRCUIT;
8687 if (other->op_type == OP_LEAVE)
8688 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8689 else if (other->op_type == OP_MATCH
8690 || other->op_type == OP_SUBST
8691 || other->op_type == OP_TRANSR
8692 || other->op_type == OP_TRANS)
8693 /* Mark the op as being unbindable with =~ */
8694 other->op_flags |= OPf_SPECIAL;
8696 other->op_folded = 1;
8700 /* Elide the rhs, since the outcome is entirely determined by
8701 * the (constant) lhs */
8703 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8704 const OP *o2 = other;
8705 if ( ! (o2->op_type == OP_LIST
8706 && (( o2 = cUNOPx(o2)->op_first))
8707 && o2->op_type == OP_PUSHMARK
8708 && (( o2 = OpSIBLING(o2))) )
8711 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8712 || o2->op_type == OP_PADHV)
8713 && o2->op_private & OPpLVAL_INTRO
8714 && !(o2->op_private & OPpPAD_STATE))
8716 Perl_croak(aTHX_ "This use of my() in false conditional is "
8717 "no longer allowed");
8721 if (cstop->op_type == OP_CONST)
8722 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8727 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8728 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8730 const OP * const k1 = ((UNOP*)first)->op_first;
8731 const OP * const k2 = OpSIBLING(k1);
8733 switch (first->op_type)
8736 if (k2 && k2->op_type == OP_READLINE
8737 && (k2->op_flags & OPf_STACKED)
8738 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8740 warnop = k2->op_type;
8745 if (k1->op_type == OP_READDIR
8746 || k1->op_type == OP_GLOB
8747 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8748 || k1->op_type == OP_EACH
8749 || k1->op_type == OP_AEACH)
8751 warnop = ((k1->op_type == OP_NULL)
8752 ? (OPCODE)k1->op_targ : k1->op_type);
8757 const line_t oldline = CopLINE(PL_curcop);
8758 /* This ensures that warnings are reported at the first line
8759 of the construction, not the last. */
8760 CopLINE_set(PL_curcop, PL_parser->copline);
8761 Perl_warner(aTHX_ packWARN(WARN_MISC),
8762 "Value of %s%s can be \"0\"; test with defined()",
8764 ((warnop == OP_READLINE || warnop == OP_GLOB)
8765 ? " construct" : "() operator"));
8766 CopLINE_set(PL_curcop, oldline);
8770 /* optimize AND and OR ops that have NOTs as children */
8771 if (first->op_type == OP_NOT
8772 && (first->op_flags & OPf_KIDS)
8773 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8774 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8776 if (type == OP_AND || type == OP_OR) {
8782 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8784 prepend_not = 1; /* prepend a NOT op later */
8789 logop = alloc_LOGOP(type, first, LINKLIST(other));
8790 logop->op_flags |= (U8)flags;
8791 logop->op_private = (U8)(1 | (flags >> 8));
8793 /* establish postfix order */
8794 logop->op_next = LINKLIST(first);
8795 first->op_next = (OP*)logop;
8796 assert(!OpHAS_SIBLING(first));
8797 op_sibling_splice((OP*)logop, first, 0, other);
8799 CHECKOP(type,logop);
8801 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8802 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8810 =for apidoc newCONDOP
8812 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8813 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8814 will be set automatically, and, shifted up eight bits, the eight bits of
8815 C<op_private>, except that the bit with value 1 is automatically set.
8816 C<first> supplies the expression selecting between the two branches,
8817 and C<trueop> and C<falseop> supply the branches; they are consumed by
8818 this function and become part of the constructed op tree.
8824 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8832 PERL_ARGS_ASSERT_NEWCONDOP;
8835 return newLOGOP(OP_AND, 0, first, trueop);
8837 return newLOGOP(OP_OR, 0, first, falseop);
8839 scalarboolean(first);
8840 if ((cstop = search_const(first))) {
8841 /* Left or right arm of the conditional? */
8842 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8843 OP *live = left ? trueop : falseop;
8844 OP *const dead = left ? falseop : trueop;
8845 if (cstop->op_private & OPpCONST_BARE &&
8846 cstop->op_private & OPpCONST_STRICT) {
8847 no_bareword_allowed(cstop);
8851 if (live->op_type == OP_LEAVE)
8852 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8853 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8854 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8855 /* Mark the op as being unbindable with =~ */
8856 live->op_flags |= OPf_SPECIAL;
8857 live->op_folded = 1;
8860 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8861 logop->op_flags |= (U8)flags;
8862 logop->op_private = (U8)(1 | (flags >> 8));
8863 logop->op_next = LINKLIST(falseop);
8865 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8868 /* establish postfix order */
8869 start = LINKLIST(first);
8870 first->op_next = (OP*)logop;
8872 /* make first, trueop, falseop siblings */
8873 op_sibling_splice((OP*)logop, first, 0, trueop);
8874 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8876 o = newUNOP(OP_NULL, 0, (OP*)logop);
8878 trueop->op_next = falseop->op_next = o;
8885 =for apidoc newRANGE
8887 Constructs and returns a C<range> op, with subordinate C<flip> and
8888 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8889 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8890 for both the C<flip> and C<range> ops, except that the bit with value
8891 1 is automatically set. C<left> and C<right> supply the expressions
8892 controlling the endpoints of the range; they are consumed by this function
8893 and become part of the constructed op tree.
8899 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8907 PERL_ARGS_ASSERT_NEWRANGE;
8909 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8910 range->op_flags = OPf_KIDS;
8911 leftstart = LINKLIST(left);
8912 range->op_private = (U8)(1 | (flags >> 8));
8914 /* make left and right siblings */
8915 op_sibling_splice((OP*)range, left, 0, right);
8917 range->op_next = (OP*)range;
8918 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8919 flop = newUNOP(OP_FLOP, 0, flip);
8920 o = newUNOP(OP_NULL, 0, flop);
8922 range->op_next = leftstart;
8924 left->op_next = flip;
8925 right->op_next = flop;
8928 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8929 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8931 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8932 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8933 SvPADTMP_on(PAD_SV(flip->op_targ));
8935 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8936 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8938 /* check barewords before they might be optimized aways */
8939 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8940 no_bareword_allowed(left);
8941 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8942 no_bareword_allowed(right);
8945 if (!flip->op_private || !flop->op_private)
8946 LINKLIST(o); /* blow off optimizer unless constant */
8952 =for apidoc newLOOPOP
8954 Constructs, checks, and returns an op tree expressing a loop. This is
8955 only a loop in the control flow through the op tree; it does not have
8956 the heavyweight loop structure that allows exiting the loop by C<last>
8957 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8958 top-level op, except that some bits will be set automatically as required.
8959 C<expr> supplies the expression controlling loop iteration, and C<block>
8960 supplies the body of the loop; they are consumed by this function and
8961 become part of the constructed op tree. C<debuggable> is currently
8962 unused and should always be 1.
8968 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8972 const bool once = block && block->op_flags & OPf_SPECIAL &&
8973 block->op_type == OP_NULL;
8975 PERL_UNUSED_ARG(debuggable);
8979 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8980 || ( expr->op_type == OP_NOT
8981 && cUNOPx(expr)->op_first->op_type == OP_CONST
8982 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8985 /* Return the block now, so that S_new_logop does not try to
8989 return block; /* do {} while 0 does once */
8992 if (expr->op_type == OP_READLINE
8993 || expr->op_type == OP_READDIR
8994 || expr->op_type == OP_GLOB
8995 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8996 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8997 expr = newUNOP(OP_DEFINED, 0,
8998 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8999 } else if (expr->op_flags & OPf_KIDS) {
9000 const OP * const k1 = ((UNOP*)expr)->op_first;
9001 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9002 switch (expr->op_type) {
9004 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9005 && (k2->op_flags & OPf_STACKED)
9006 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9007 expr = newUNOP(OP_DEFINED, 0, expr);
9011 if (k1 && (k1->op_type == OP_READDIR
9012 || k1->op_type == OP_GLOB
9013 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9014 || k1->op_type == OP_EACH
9015 || k1->op_type == OP_AEACH))
9016 expr = newUNOP(OP_DEFINED, 0, expr);
9022 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9023 * op, in listop. This is wrong. [perl #27024] */
9025 block = newOP(OP_NULL, 0);
9026 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9027 o = new_logop(OP_AND, 0, &expr, &listop);
9034 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
9036 if (once && o != listop)
9038 assert(cUNOPo->op_first->op_type == OP_AND
9039 || cUNOPo->op_first->op_type == OP_OR);
9040 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
9044 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9046 o->op_flags |= flags;
9048 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9053 =for apidoc newWHILEOP
9055 Constructs, checks, and returns an op tree expressing a C<while> loop.
9056 This is a heavyweight loop, with structure that allows exiting the loop
9057 by C<last> and suchlike.
9059 C<loop> is an optional preconstructed C<enterloop> op to use in the
9060 loop; if it is null then a suitable op will be constructed automatically.
9061 C<expr> supplies the loop's controlling expression. C<block> supplies the
9062 main body of the loop, and C<cont> optionally supplies a C<continue> block
9063 that operates as a second half of the body. All of these optree inputs
9064 are consumed by this function and become part of the constructed op tree.
9066 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9067 op and, shifted up eight bits, the eight bits of C<op_private> for
9068 the C<leaveloop> op, except that (in both cases) some bits will be set
9069 automatically. C<debuggable> is currently unused and should always be 1.
9070 C<has_my> can be supplied as true to force the
9071 loop body to be enclosed in its own scope.
9077 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9078 OP *expr, OP *block, OP *cont, I32 has_my)
9087 PERL_UNUSED_ARG(debuggable);
9090 if (expr->op_type == OP_READLINE
9091 || expr->op_type == OP_READDIR
9092 || expr->op_type == OP_GLOB
9093 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9094 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9095 expr = newUNOP(OP_DEFINED, 0,
9096 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9097 } else if (expr->op_flags & OPf_KIDS) {
9098 const OP * const k1 = ((UNOP*)expr)->op_first;
9099 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9100 switch (expr->op_type) {
9102 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9103 && (k2->op_flags & OPf_STACKED)
9104 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9105 expr = newUNOP(OP_DEFINED, 0, expr);
9109 if (k1 && (k1->op_type == OP_READDIR
9110 || k1->op_type == OP_GLOB
9111 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9112 || k1->op_type == OP_EACH
9113 || k1->op_type == OP_AEACH))
9114 expr = newUNOP(OP_DEFINED, 0, expr);
9121 block = newOP(OP_NULL, 0);
9122 else if (cont || has_my) {
9123 block = op_scope(block);
9127 next = LINKLIST(cont);
9130 OP * const unstack = newOP(OP_UNSTACK, 0);
9133 cont = op_append_elem(OP_LINESEQ, cont, unstack);
9137 listop = op_append_list(OP_LINESEQ, block, cont);
9139 redo = LINKLIST(listop);
9143 o = new_logop(OP_AND, 0, &expr, &listop);
9144 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9146 return expr; /* listop already freed by new_logop */
9149 ((LISTOP*)listop)->op_last->op_next =
9150 (o == listop ? redo : LINKLIST(o));
9156 NewOp(1101,loop,1,LOOP);
9157 OpTYPE_set(loop, OP_ENTERLOOP);
9158 loop->op_private = 0;
9159 loop->op_next = (OP*)loop;
9162 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9164 loop->op_redoop = redo;
9165 loop->op_lastop = o;
9166 o->op_private |= loopflags;
9169 loop->op_nextop = next;
9171 loop->op_nextop = o;
9173 o->op_flags |= flags;
9174 o->op_private |= (flags >> 8);
9179 =for apidoc newFOROP
9181 Constructs, checks, and returns an op tree expressing a C<foreach>
9182 loop (iteration through a list of values). This is a heavyweight loop,
9183 with structure that allows exiting the loop by C<last> and suchlike.
9185 C<sv> optionally supplies the variable that will be aliased to each
9186 item in turn; if null, it defaults to C<$_>.
9187 C<expr> supplies the list of values to iterate over. C<block> supplies
9188 the main body of the loop, and C<cont> optionally supplies a C<continue>
9189 block that operates as a second half of the body. All of these optree
9190 inputs are consumed by this function and become part of the constructed
9193 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9194 op and, shifted up eight bits, the eight bits of C<op_private> for
9195 the C<leaveloop> op, except that (in both cases) some bits will be set
9202 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9207 PADOFFSET padoff = 0;
9211 PERL_ARGS_ASSERT_NEWFOROP;
9214 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
9215 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9216 OpTYPE_set(sv, OP_RV2GV);
9218 /* The op_type check is needed to prevent a possible segfault
9219 * if the loop variable is undeclared and 'strict vars' is in
9220 * effect. This is illegal but is nonetheless parsed, so we
9221 * may reach this point with an OP_CONST where we're expecting
9224 if (cUNOPx(sv)->op_first->op_type == OP_GV
9225 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9226 iterpflags |= OPpITER_DEF;
9228 else if (sv->op_type == OP_PADSV) { /* private variable */
9229 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9230 padoff = sv->op_targ;
9234 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9236 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9239 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9241 PADNAME * const pn = PAD_COMPNAME(padoff);
9242 const char * const name = PadnamePV(pn);
9244 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9245 iterpflags |= OPpITER_DEF;
9249 sv = newGVOP(OP_GV, 0, PL_defgv);
9250 iterpflags |= OPpITER_DEF;
9253 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9254 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
9255 iterflags |= OPf_STACKED;
9257 else if (expr->op_type == OP_NULL &&
9258 (expr->op_flags & OPf_KIDS) &&
9259 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
9261 /* Basically turn for($x..$y) into the same as for($x,$y), but we
9262 * set the STACKED flag to indicate that these values are to be
9263 * treated as min/max values by 'pp_enteriter'.
9265 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
9266 LOGOP* const range = (LOGOP*) flip->op_first;
9267 OP* const left = range->op_first;
9268 OP* const right = OpSIBLING(left);
9271 range->op_flags &= ~OPf_KIDS;
9272 /* detach range's children */
9273 op_sibling_splice((OP*)range, NULL, -1, NULL);
9275 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
9276 listop->op_first->op_next = range->op_next;
9277 left->op_next = range->op_other;
9278 right->op_next = (OP*)listop;
9279 listop->op_next = listop->op_first;
9282 expr = (OP*)(listop);
9284 iterflags |= OPf_STACKED;
9287 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
9290 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9291 op_append_elem(OP_LIST, list(expr),
9293 assert(!loop->op_next);
9294 /* for my $x () sets OPpLVAL_INTRO;
9295 * for our $x () sets OPpOUR_INTRO */
9296 loop->op_private = (U8)iterpflags;
9298 /* upgrade loop from a LISTOP to a LOOPOP;
9299 * keep it in-place if there's space */
9300 if (loop->op_slabbed
9301 && OpSLOT(loop)->opslot_size
9302 < SIZE_TO_PSIZE(sizeof(LOOP)) + OPSLOT_HEADER_P)
9304 /* no space; allocate new op */
9306 NewOp(1234,tmp,1,LOOP);
9307 Copy(loop,tmp,1,LISTOP);
9308 assert(loop->op_last->op_sibparent == (OP*)loop);
9309 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9310 S_op_destroy(aTHX_ (OP*)loop);
9313 else if (!loop->op_slabbed)
9315 /* loop was malloc()ed */
9316 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9317 OpLASTSIB_set(loop->op_last, (OP*)loop);
9319 loop->op_targ = padoff;
9320 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
9325 =for apidoc newLOOPEX
9327 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9328 or C<last>). C<type> is the opcode. C<label> supplies the parameter
9329 determining the target of the op; it is consumed by this function and
9330 becomes part of the constructed op tree.
9336 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9340 PERL_ARGS_ASSERT_NEWLOOPEX;
9342 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9343 || type == OP_CUSTOM);
9345 if (type != OP_GOTO) {
9346 /* "last()" means "last" */
9347 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9348 o = newOP(type, OPf_SPECIAL);
9352 /* Check whether it's going to be a goto &function */
9353 if (label->op_type == OP_ENTERSUB
9354 && !(label->op_flags & OPf_STACKED))
9355 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9358 /* Check for a constant argument */
9359 if (label->op_type == OP_CONST) {
9360 SV * const sv = ((SVOP *)label)->op_sv;
9362 const char *s = SvPV_const(sv,l);
9363 if (l == strlen(s)) {
9365 SvUTF8(((SVOP*)label)->op_sv),
9367 SvPV_nolen_const(((SVOP*)label)->op_sv)));
9371 /* If we have already created an op, we do not need the label. */
9374 else o = newUNOP(type, OPf_STACKED, label);
9376 PL_hints |= HINT_BLOCK_SCOPE;
9380 /* if the condition is a literal array or hash
9381 (or @{ ... } etc), make a reference to it.
9384 S_ref_array_or_hash(pTHX_ OP *cond)
9387 && (cond->op_type == OP_RV2AV
9388 || cond->op_type == OP_PADAV
9389 || cond->op_type == OP_RV2HV
9390 || cond->op_type == OP_PADHV))
9392 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9395 && (cond->op_type == OP_ASLICE
9396 || cond->op_type == OP_KVASLICE
9397 || cond->op_type == OP_HSLICE
9398 || cond->op_type == OP_KVHSLICE)) {
9400 /* anonlist now needs a list from this op, was previously used in
9402 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9403 cond->op_flags |= OPf_WANT_LIST;
9405 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9412 /* These construct the optree fragments representing given()
9415 entergiven and enterwhen are LOGOPs; the op_other pointer
9416 points up to the associated leave op. We need this so we
9417 can put it in the context and make break/continue work.
9418 (Also, of course, pp_enterwhen will jump straight to
9419 op_other if the match fails.)
9423 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9424 I32 enter_opcode, I32 leave_opcode,
9425 PADOFFSET entertarg)
9431 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9432 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9434 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9435 enterop->op_targ = 0;
9436 enterop->op_private = 0;
9438 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9441 /* prepend cond if we have one */
9442 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9444 o->op_next = LINKLIST(cond);
9445 cond->op_next = (OP *) enterop;
9448 /* This is a default {} block */
9449 enterop->op_flags |= OPf_SPECIAL;
9450 o ->op_flags |= OPf_SPECIAL;
9452 o->op_next = (OP *) enterop;
9455 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9456 entergiven and enterwhen both
9459 enterop->op_next = LINKLIST(block);
9460 block->op_next = enterop->op_other = o;
9466 /* For the purposes of 'when(implied_smartmatch)'
9467 * versus 'when(boolean_expression)',
9468 * does this look like a boolean operation? For these purposes
9469 a boolean operation is:
9470 - a subroutine call [*]
9471 - a logical connective
9472 - a comparison operator
9473 - a filetest operator, with the exception of -s -M -A -C
9474 - defined(), exists() or eof()
9475 - /$re/ or $foo =~ /$re/
9477 [*] possibly surprising
9480 S_looks_like_bool(pTHX_ const OP *o)
9482 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9484 switch(o->op_type) {
9487 return looks_like_bool(cLOGOPo->op_first);
9491 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9494 looks_like_bool(cLOGOPo->op_first)
9495 && looks_like_bool(sibl));
9501 o->op_flags & OPf_KIDS
9502 && looks_like_bool(cUNOPo->op_first));
9506 case OP_NOT: case OP_XOR:
9508 case OP_EQ: case OP_NE: case OP_LT:
9509 case OP_GT: case OP_LE: case OP_GE:
9511 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9512 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9514 case OP_SEQ: case OP_SNE: case OP_SLT:
9515 case OP_SGT: case OP_SLE: case OP_SGE:
9519 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9520 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9521 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9522 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9523 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9524 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9525 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9526 case OP_FTTEXT: case OP_FTBINARY:
9528 case OP_DEFINED: case OP_EXISTS:
9529 case OP_MATCH: case OP_EOF:
9537 /* optimised-away (index() != -1) or similar comparison */
9538 if (o->op_private & OPpTRUEBOOL)
9543 /* Detect comparisons that have been optimized away */
9544 if (cSVOPo->op_sv == &PL_sv_yes
9545 || cSVOPo->op_sv == &PL_sv_no)
9558 =for apidoc newGIVENOP
9560 Constructs, checks, and returns an op tree expressing a C<given> block.
9561 C<cond> supplies the expression to whose value C<$_> will be locally
9562 aliased, and C<block> supplies the body of the C<given> construct; they
9563 are consumed by this function and become part of the constructed op tree.
9564 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9570 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9572 PERL_ARGS_ASSERT_NEWGIVENOP;
9573 PERL_UNUSED_ARG(defsv_off);
9576 return newGIVWHENOP(
9577 ref_array_or_hash(cond),
9579 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9584 =for apidoc newWHENOP
9586 Constructs, checks, and returns an op tree expressing a C<when> block.
9587 C<cond> supplies the test expression, and C<block> supplies the block
9588 that will be executed if the test evaluates to true; they are consumed
9589 by this function and become part of the constructed op tree. C<cond>
9590 will be interpreted DWIMically, often as a comparison against C<$_>,
9591 and may be null to generate a C<default> block.
9597 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9599 const bool cond_llb = (!cond || looks_like_bool(cond));
9602 PERL_ARGS_ASSERT_NEWWHENOP;
9607 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9609 scalar(ref_array_or_hash(cond)));
9612 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9615 /* must not conflict with SVf_UTF8 */
9616 #define CV_CKPROTO_CURSTASH 0x1
9619 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9620 const STRLEN len, const U32 flags)
9622 SV *name = NULL, *msg;
9623 const char * cvp = SvROK(cv)
9624 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9625 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9628 STRLEN clen = CvPROTOLEN(cv), plen = len;
9630 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9632 if (p == NULL && cvp == NULL)
9635 if (!ckWARN_d(WARN_PROTOTYPE))
9639 p = S_strip_spaces(aTHX_ p, &plen);
9640 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9641 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9642 if (plen == clen && memEQ(cvp, p, plen))
9645 if (flags & SVf_UTF8) {
9646 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9650 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9656 msg = sv_newmortal();
9661 gv_efullname3(name = sv_newmortal(), gv, NULL);
9662 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9663 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9664 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9665 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9666 sv_catpvs(name, "::");
9668 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9669 assert (CvNAMED(SvRV_const(gv)));
9670 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9672 else sv_catsv(name, (SV *)gv);
9674 else name = (SV *)gv;
9676 sv_setpvs(msg, "Prototype mismatch:");
9678 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9680 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9681 UTF8fARG(SvUTF8(cv),clen,cvp)
9684 sv_catpvs(msg, ": none");
9685 sv_catpvs(msg, " vs ");
9687 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9689 sv_catpvs(msg, "none");
9690 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9693 static void const_sv_xsub(pTHX_ CV* cv);
9694 static void const_av_xsub(pTHX_ CV* cv);
9698 =head1 Optree Manipulation Functions
9700 =for apidoc cv_const_sv
9702 If C<cv> is a constant sub eligible for inlining, returns the constant
9703 value returned by the sub. Otherwise, returns C<NULL>.
9705 Constant subs can be created with C<newCONSTSUB> or as described in
9706 L<perlsub/"Constant Functions">.
9711 Perl_cv_const_sv(const CV *const cv)
9716 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9718 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9719 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9724 Perl_cv_const_sv_or_av(const CV * const cv)
9728 if (SvROK(cv)) return SvRV((SV *)cv);
9729 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9730 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9733 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9734 * Can be called in 2 ways:
9737 * look for a single OP_CONST with attached value: return the value
9739 * allow_lex && !CvCONST(cv);
9741 * examine the clone prototype, and if contains only a single
9742 * OP_CONST, return the value; or if it contains a single PADSV ref-
9743 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9744 * a candidate for "constizing" at clone time, and return NULL.
9748 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9756 for (; o; o = o->op_next) {
9757 const OPCODE type = o->op_type;
9759 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9761 || type == OP_PUSHMARK)
9763 if (type == OP_DBSTATE)
9765 if (type == OP_LEAVESUB)
9769 if (type == OP_CONST && cSVOPo->op_sv)
9771 else if (type == OP_UNDEF && !o->op_private) {
9775 else if (allow_lex && type == OP_PADSV) {
9776 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9778 sv = &PL_sv_undef; /* an arbitrary non-null value */
9796 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9797 PADNAME * const name, SV ** const const_svp)
9803 if (CvFLAGS(PL_compcv)) {
9804 /* might have had built-in attrs applied */
9805 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9806 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9807 && ckWARN(WARN_MISC))
9809 /* protect against fatal warnings leaking compcv */
9810 SAVEFREESV(PL_compcv);
9811 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9812 SvREFCNT_inc_simple_void_NN(PL_compcv);
9815 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9816 & ~(CVf_LVALUE * pureperl));
9821 /* redundant check for speed: */
9822 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9823 const line_t oldline = CopLINE(PL_curcop);
9826 : sv_2mortal(newSVpvn_utf8(
9827 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9829 if (PL_parser && PL_parser->copline != NOLINE)
9830 /* This ensures that warnings are reported at the first
9831 line of a redefinition, not the last. */
9832 CopLINE_set(PL_curcop, PL_parser->copline);
9833 /* protect against fatal warnings leaking compcv */
9834 SAVEFREESV(PL_compcv);
9835 report_redefined_cv(namesv, cv, const_svp);
9836 SvREFCNT_inc_simple_void_NN(PL_compcv);
9837 CopLINE_set(PL_curcop, oldline);
9844 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9849 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9852 CV *compcv = PL_compcv;
9855 PADOFFSET pax = o->op_targ;
9856 CV *outcv = CvOUTSIDE(PL_compcv);
9859 bool reusable = FALSE;
9861 #ifdef PERL_DEBUG_READONLY_OPS
9862 OPSLAB *slab = NULL;
9865 PERL_ARGS_ASSERT_NEWMYSUB;
9867 PL_hints |= HINT_BLOCK_SCOPE;
9869 /* Find the pad slot for storing the new sub.
9870 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9871 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9872 ing sub. And then we need to dig deeper if this is a lexical from
9874 my sub foo; sub { sub foo { } }
9877 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9878 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9879 pax = PARENT_PAD_INDEX(name);
9880 outcv = CvOUTSIDE(outcv);
9885 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9886 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9887 spot = (CV **)svspot;
9889 if (!(PL_parser && PL_parser->error_count))
9890 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9893 assert(proto->op_type == OP_CONST);
9894 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9895 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9905 if (PL_parser && PL_parser->error_count) {
9907 SvREFCNT_dec(PL_compcv);
9912 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9914 svspot = (SV **)(spot = &clonee);
9916 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9919 assert (SvTYPE(*spot) == SVt_PVCV);
9921 hek = CvNAME_HEK(*spot);
9925 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9926 CvNAME_HEK_set(*spot, hek =
9929 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9933 CvLEXICAL_on(*spot);
9935 cv = PadnamePROTOCV(name);
9936 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9940 /* This makes sub {}; work as expected. */
9941 if (block->op_type == OP_STUB) {
9942 const line_t l = PL_parser->copline;
9944 block = newSTATEOP(0, NULL, 0);
9945 PL_parser->copline = l;
9947 block = CvLVALUE(compcv)
9948 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9949 ? newUNOP(OP_LEAVESUBLV, 0,
9950 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9951 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9952 start = LINKLIST(block);
9954 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9955 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9963 const bool exists = CvROOT(cv) || CvXSUB(cv);
9965 /* if the subroutine doesn't exist and wasn't pre-declared
9966 * with a prototype, assume it will be AUTOLOADed,
9967 * skipping the prototype check
9969 if (exists || SvPOK(cv))
9970 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9972 /* already defined? */
9974 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9980 /* just a "sub foo;" when &foo is already defined */
9985 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9992 SvREFCNT_inc_simple_void_NN(const_sv);
9993 SvFLAGS(const_sv) |= SVs_PADTMP;
9995 assert(!CvROOT(cv) && !CvCONST(cv));
9999 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10000 CvFILE_set_from_cop(cv, PL_curcop);
10001 CvSTASH_set(cv, PL_curstash);
10004 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10005 CvXSUBANY(cv).any_ptr = const_sv;
10006 CvXSUB(cv) = const_sv_xsub;
10010 CvFLAGS(cv) |= CvMETHOD(compcv);
10012 SvREFCNT_dec(compcv);
10017 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10018 determine whether this sub definition is in the same scope as its
10019 declaration. If this sub definition is inside an inner named pack-
10020 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10021 the package sub. So check PadnameOUTER(name) too.
10023 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10024 assert(!CvWEAKOUTSIDE(compcv));
10025 SvREFCNT_dec(CvOUTSIDE(compcv));
10026 CvWEAKOUTSIDE_on(compcv);
10028 /* XXX else do we have a circular reference? */
10030 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10031 /* transfer PL_compcv to cv */
10033 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10034 cv_flags_t preserved_flags =
10035 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10036 PADLIST *const temp_padl = CvPADLIST(cv);
10037 CV *const temp_cv = CvOUTSIDE(cv);
10038 const cv_flags_t other_flags =
10039 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10040 OP * const cvstart = CvSTART(cv);
10044 CvFLAGS(compcv) | preserved_flags;
10045 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10046 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10047 CvPADLIST_set(cv, CvPADLIST(compcv));
10048 CvOUTSIDE(compcv) = temp_cv;
10049 CvPADLIST_set(compcv, temp_padl);
10050 CvSTART(cv) = CvSTART(compcv);
10051 CvSTART(compcv) = cvstart;
10052 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10053 CvFLAGS(compcv) |= other_flags;
10056 Safefree(CvFILE(cv));
10060 /* inner references to compcv must be fixed up ... */
10061 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10062 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10063 ++PL_sub_generation;
10066 /* Might have had built-in attributes applied -- propagate them. */
10067 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10069 /* ... before we throw it away */
10070 SvREFCNT_dec(compcv);
10071 PL_compcv = compcv = cv;
10080 if (!CvNAME_HEK(cv)) {
10081 if (hek) (void)share_hek_hek(hek);
10085 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10086 hek = share_hek(PadnamePV(name)+1,
10087 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10090 CvNAME_HEK_set(cv, hek);
10096 if (CvFILE(cv) && CvDYNFILE(cv))
10097 Safefree(CvFILE(cv));
10098 CvFILE_set_from_cop(cv, PL_curcop);
10099 CvSTASH_set(cv, PL_curstash);
10102 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10104 SvUTF8_on(MUTABLE_SV(cv));
10108 /* If we assign an optree to a PVCV, then we've defined a
10109 * subroutine that the debugger could be able to set a breakpoint
10110 * in, so signal to pp_entereval that it should not throw away any
10111 * saved lines at scope exit. */
10113 PL_breakable_sub_gen++;
10114 CvROOT(cv) = block;
10115 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10116 itself has a refcount. */
10118 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10119 #ifdef PERL_DEBUG_READONLY_OPS
10120 slab = (OPSLAB *)CvSTART(cv);
10122 S_process_optree(aTHX_ cv, block, start);
10127 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10128 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10132 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10133 SV * const tmpstr = sv_newmortal();
10134 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10135 GV_ADDMULTI, SVt_PVHV);
10137 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10138 CopFILE(PL_curcop),
10140 (long)CopLINE(PL_curcop));
10141 if (HvNAME_HEK(PL_curstash)) {
10142 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10143 sv_catpvs(tmpstr, "::");
10146 sv_setpvs(tmpstr, "__ANON__::");
10148 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10149 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10150 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10151 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10152 hv = GvHVn(db_postponed);
10153 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10154 CV * const pcv = GvCV(db_postponed);
10160 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10168 assert(CvDEPTH(outcv));
10170 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10172 cv_clone_into(clonee, *spot);
10173 else *spot = cv_clone(clonee);
10174 SvREFCNT_dec_NN(clonee);
10178 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10179 PADOFFSET depth = CvDEPTH(outcv);
10182 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10184 *svspot = SvREFCNT_inc_simple_NN(cv);
10185 SvREFCNT_dec(oldcv);
10191 PL_parser->copline = NOLINE;
10192 LEAVE_SCOPE(floor);
10193 #ifdef PERL_DEBUG_READONLY_OPS
10202 =for apidoc newATTRSUB_x
10204 Construct a Perl subroutine, also performing some surrounding jobs.
10206 This function is expected to be called in a Perl compilation context,
10207 and some aspects of the subroutine are taken from global variables
10208 associated with compilation. In particular, C<PL_compcv> represents
10209 the subroutine that is currently being compiled. It must be non-null
10210 when this function is called, and some aspects of the subroutine being
10211 constructed are taken from it. The constructed subroutine may actually
10212 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10214 If C<block> is null then the subroutine will have no body, and for the
10215 time being it will be an error to call it. This represents a forward
10216 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
10217 non-null then it provides the Perl code of the subroutine body, which
10218 will be executed when the subroutine is called. This body includes
10219 any argument unwrapping code resulting from a subroutine signature or
10220 similar. The pad use of the code must correspond to the pad attached
10221 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
10222 C<leavesublv> op; this function will add such an op. C<block> is consumed
10223 by this function and will become part of the constructed subroutine.
10225 C<proto> specifies the subroutine's prototype, unless one is supplied
10226 as an attribute (see below). If C<proto> is null, then the subroutine
10227 will not have a prototype. If C<proto> is non-null, it must point to a
10228 C<const> op whose value is a string, and the subroutine will have that
10229 string as its prototype. If a prototype is supplied as an attribute, the
10230 attribute takes precedence over C<proto>, but in that case C<proto> should
10231 preferably be null. In any case, C<proto> is consumed by this function.
10233 C<attrs> supplies attributes to be applied the subroutine. A handful of
10234 attributes take effect by built-in means, being applied to C<PL_compcv>
10235 immediately when seen. Other attributes are collected up and attached
10236 to the subroutine by this route. C<attrs> may be null to supply no
10237 attributes, or point to a C<const> op for a single attribute, or point
10238 to a C<list> op whose children apart from the C<pushmark> are C<const>
10239 ops for one or more attributes. Each C<const> op must be a string,
10240 giving the attribute name optionally followed by parenthesised arguments,
10241 in the manner in which attributes appear in Perl source. The attributes
10242 will be applied to the sub by this function. C<attrs> is consumed by
10245 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10246 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
10247 must point to a C<const> op, which will be consumed by this function,
10248 and its string value supplies a name for the subroutine. The name may
10249 be qualified or unqualified, and if it is unqualified then a default
10250 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
10251 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10252 by which the subroutine will be named.
10254 If there is already a subroutine of the specified name, then the new
10255 sub will either replace the existing one in the glob or be merged with
10256 the existing one. A warning may be generated about redefinition.
10258 If the subroutine has one of a few special names, such as C<BEGIN> or
10259 C<END>, then it will be claimed by the appropriate queue for automatic
10260 running of phase-related subroutines. In this case the relevant glob will
10261 be left not containing any subroutine, even if it did contain one before.
10262 In the case of C<BEGIN>, the subroutine will be executed and the reference
10263 to it disposed of before this function returns.
10265 The function returns a pointer to the constructed subroutine. If the sub
10266 is anonymous then ownership of one counted reference to the subroutine
10267 is transferred to the caller. If the sub is named then the caller does
10268 not get ownership of a reference. In most such cases, where the sub
10269 has a non-phase name, the sub will be alive at the point it is returned
10270 by virtue of being contained in the glob that names it. A phase-named
10271 subroutine will usually be alive by virtue of the reference owned by the
10272 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10273 been executed, will quite likely have been destroyed already by the
10274 time this function returns, making it erroneous for the caller to make
10275 any use of the returned pointer. It is the caller's responsibility to
10276 ensure that it knows which of these situations applies.
10281 /* _x = extended */
10283 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10284 OP *block, bool o_is_gv)
10288 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10290 CV *cv = NULL; /* the previous CV with this name, if any */
10292 const bool ec = PL_parser && PL_parser->error_count;
10293 /* If the subroutine has no body, no attributes, and no builtin attributes
10294 then it's just a sub declaration, and we may be able to get away with
10295 storing with a placeholder scalar in the symbol table, rather than a
10296 full CV. If anything is present then it will take a full CV to
10298 const I32 gv_fetch_flags
10299 = ec ? GV_NOADD_NOINIT :
10300 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10301 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10303 const char * const name =
10304 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10306 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10307 bool evanescent = FALSE;
10309 #ifdef PERL_DEBUG_READONLY_OPS
10310 OPSLAB *slab = NULL;
10318 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
10319 hek and CvSTASH pointer together can imply the GV. If the name
10320 contains a package name, then GvSTASH(CvGV(cv)) may differ from
10321 CvSTASH, so forego the optimisation if we find any.
10322 Also, we may be called from load_module at run time, so
10323 PL_curstash (which sets CvSTASH) may not point to the stash the
10324 sub is stored in. */
10325 /* XXX This optimization is currently disabled for packages other
10326 than main, since there was too much CPAN breakage. */
10328 ec ? GV_NOADD_NOINIT
10329 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10330 || PL_curstash != PL_defstash
10331 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10333 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10334 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10336 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10337 SV * const sv = sv_newmortal();
10338 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
10339 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10340 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10341 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10343 } else if (PL_curstash) {
10344 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10347 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10353 move_proto_attr(&proto, &attrs, gv, 0);
10356 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10361 assert(proto->op_type == OP_CONST);
10362 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
10363 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
10379 SvREFCNT_dec(PL_compcv);
10384 if (name && block) {
10385 const char *s = (char *) my_memrchr(name, ':', namlen);
10386 s = s ? s+1 : name;
10387 if (strEQ(s, "BEGIN")) {
10388 if (PL_in_eval & EVAL_KEEPERR)
10389 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10391 SV * const errsv = ERRSV;
10392 /* force display of errors found but not reported */
10393 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10394 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10401 if (!block && SvTYPE(gv) != SVt_PVGV) {
10402 /* If we are not defining a new sub and the existing one is not a
10404 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10405 /* We are applying attributes to an existing sub, so we need it
10406 upgraded if it is a constant. */
10407 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10408 gv_init_pvn(gv, PL_curstash, name, namlen,
10409 SVf_UTF8 * name_is_utf8);
10411 else { /* Maybe prototype now, and had at maximum
10412 a prototype or const/sub ref before. */
10413 if (SvTYPE(gv) > SVt_NULL) {
10414 cv_ckproto_len_flags((const CV *)gv,
10415 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10421 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10423 SvUTF8_on(MUTABLE_SV(gv));
10426 sv_setiv(MUTABLE_SV(gv), -1);
10429 SvREFCNT_dec(PL_compcv);
10430 cv = PL_compcv = NULL;
10435 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10439 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10445 /* This makes sub {}; work as expected. */
10446 if (block->op_type == OP_STUB) {
10447 const line_t l = PL_parser->copline;
10449 block = newSTATEOP(0, NULL, 0);
10450 PL_parser->copline = l;
10452 block = CvLVALUE(PL_compcv)
10453 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10454 && (!isGV(gv) || !GvASSUMECV(gv)))
10455 ? newUNOP(OP_LEAVESUBLV, 0,
10456 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10457 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10458 start = LINKLIST(block);
10459 block->op_next = 0;
10460 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10462 S_op_const_sv(aTHX_ start, PL_compcv,
10463 cBOOL(CvCLONE(PL_compcv)));
10470 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10471 cv_ckproto_len_flags((const CV *)gv,
10472 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10473 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10475 /* All the other code for sub redefinition warnings expects the
10476 clobbered sub to be a CV. Instead of making all those code
10477 paths more complex, just inline the RV version here. */
10478 const line_t oldline = CopLINE(PL_curcop);
10479 assert(IN_PERL_COMPILETIME);
10480 if (PL_parser && PL_parser->copline != NOLINE)
10481 /* This ensures that warnings are reported at the first
10482 line of a redefinition, not the last. */
10483 CopLINE_set(PL_curcop, PL_parser->copline);
10484 /* protect against fatal warnings leaking compcv */
10485 SAVEFREESV(PL_compcv);
10487 if (ckWARN(WARN_REDEFINE)
10488 || ( ckWARN_d(WARN_REDEFINE)
10489 && ( !const_sv || SvRV(gv) == const_sv
10490 || sv_cmp(SvRV(gv), const_sv) ))) {
10492 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10493 "Constant subroutine %" SVf " redefined",
10494 SVfARG(cSVOPo->op_sv));
10497 SvREFCNT_inc_simple_void_NN(PL_compcv);
10498 CopLINE_set(PL_curcop, oldline);
10499 SvREFCNT_dec(SvRV(gv));
10504 const bool exists = CvROOT(cv) || CvXSUB(cv);
10506 /* if the subroutine doesn't exist and wasn't pre-declared
10507 * with a prototype, assume it will be AUTOLOADed,
10508 * skipping the prototype check
10510 if (exists || SvPOK(cv))
10511 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10512 /* already defined (or promised)? */
10513 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10514 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10520 /* just a "sub foo;" when &foo is already defined */
10521 SAVEFREESV(PL_compcv);
10528 SvREFCNT_inc_simple_void_NN(const_sv);
10529 SvFLAGS(const_sv) |= SVs_PADTMP;
10531 assert(!CvROOT(cv) && !CvCONST(cv));
10532 cv_forget_slab(cv);
10533 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10534 CvXSUBANY(cv).any_ptr = const_sv;
10535 CvXSUB(cv) = const_sv_xsub;
10539 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10542 if (isGV(gv) || CvMETHOD(PL_compcv)) {
10543 if (name && isGV(gv))
10544 GvCV_set(gv, NULL);
10545 cv = newCONSTSUB_flags(
10546 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10550 assert(SvREFCNT((SV*)cv) != 0);
10551 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10555 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10556 prepare_SV_for_RV((SV *)gv);
10557 SvOK_off((SV *)gv);
10560 SvRV_set(gv, const_sv);
10564 SvREFCNT_dec(PL_compcv);
10569 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10570 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10573 if (cv) { /* must reuse cv if autoloaded */
10574 /* transfer PL_compcv to cv */
10576 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10577 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10578 PADLIST *const temp_av = CvPADLIST(cv);
10579 CV *const temp_cv = CvOUTSIDE(cv);
10580 const cv_flags_t other_flags =
10581 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10582 OP * const cvstart = CvSTART(cv);
10586 assert(!CvCVGV_RC(cv));
10587 assert(CvGV(cv) == gv);
10592 PERL_HASH(hash, name, namlen);
10602 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10604 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10605 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10606 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10607 CvOUTSIDE(PL_compcv) = temp_cv;
10608 CvPADLIST_set(PL_compcv, temp_av);
10609 CvSTART(cv) = CvSTART(PL_compcv);
10610 CvSTART(PL_compcv) = cvstart;
10611 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10612 CvFLAGS(PL_compcv) |= other_flags;
10615 Safefree(CvFILE(cv));
10617 CvFILE_set_from_cop(cv, PL_curcop);
10618 CvSTASH_set(cv, PL_curstash);
10620 /* inner references to PL_compcv must be fixed up ... */
10621 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10622 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10623 ++PL_sub_generation;
10626 /* Might have had built-in attributes applied -- propagate them. */
10627 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10629 /* ... before we throw it away */
10630 SvREFCNT_dec(PL_compcv);
10635 if (name && isGV(gv)) {
10638 if (HvENAME_HEK(GvSTASH(gv)))
10639 /* sub Foo::bar { (shift)+1 } */
10640 gv_method_changed(gv);
10644 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10645 prepare_SV_for_RV((SV *)gv);
10646 SvOK_off((SV *)gv);
10649 SvRV_set(gv, (SV *)cv);
10650 if (HvENAME_HEK(PL_curstash))
10651 mro_method_changed_in(PL_curstash);
10655 assert(SvREFCNT((SV*)cv) != 0);
10657 if (!CvHASGV(cv)) {
10663 PERL_HASH(hash, name, namlen);
10664 CvNAME_HEK_set(cv, share_hek(name,
10670 CvFILE_set_from_cop(cv, PL_curcop);
10671 CvSTASH_set(cv, PL_curstash);
10675 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10677 SvUTF8_on(MUTABLE_SV(cv));
10681 /* If we assign an optree to a PVCV, then we've defined a
10682 * subroutine that the debugger could be able to set a breakpoint
10683 * in, so signal to pp_entereval that it should not throw away any
10684 * saved lines at scope exit. */
10686 PL_breakable_sub_gen++;
10687 CvROOT(cv) = block;
10688 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10689 itself has a refcount. */
10691 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10692 #ifdef PERL_DEBUG_READONLY_OPS
10693 slab = (OPSLAB *)CvSTART(cv);
10695 S_process_optree(aTHX_ cv, block, start);
10700 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10701 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10702 ? GvSTASH(CvGV(cv))
10706 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10708 SvREFCNT_inc_simple_void_NN(cv);
10711 if (block && has_name) {
10712 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10713 SV * const tmpstr = cv_name(cv,NULL,0);
10714 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10715 GV_ADDMULTI, SVt_PVHV);
10717 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10718 CopFILE(PL_curcop),
10720 (long)CopLINE(PL_curcop));
10721 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10722 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10723 hv = GvHVn(db_postponed);
10724 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10725 CV * const pcv = GvCV(db_postponed);
10731 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10737 if (PL_parser && PL_parser->error_count)
10738 clear_special_blocks(name, gv, cv);
10741 process_special_blocks(floor, name, gv, cv);
10747 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10749 PL_parser->copline = NOLINE;
10750 LEAVE_SCOPE(floor);
10752 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10754 #ifdef PERL_DEBUG_READONLY_OPS
10758 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10759 pad_add_weakref(cv);
10765 S_clear_special_blocks(pTHX_ const char *const fullname,
10766 GV *const gv, CV *const cv) {
10770 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10772 colon = strrchr(fullname,':');
10773 name = colon ? colon + 1 : fullname;
10775 if ((*name == 'B' && strEQ(name, "BEGIN"))
10776 || (*name == 'E' && strEQ(name, "END"))
10777 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10778 || (*name == 'C' && strEQ(name, "CHECK"))
10779 || (*name == 'I' && strEQ(name, "INIT"))) {
10784 GvCV_set(gv, NULL);
10785 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10789 /* Returns true if the sub has been freed. */
10791 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10795 const char *const colon = strrchr(fullname,':');
10796 const char *const name = colon ? colon + 1 : fullname;
10798 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10800 if (*name == 'B') {
10801 if (strEQ(name, "BEGIN")) {
10802 const I32 oldscope = PL_scopestack_ix;
10805 if (floor) LEAVE_SCOPE(floor);
10807 PUSHSTACKi(PERLSI_REQUIRE);
10808 SAVECOPFILE(&PL_compiling);
10809 SAVECOPLINE(&PL_compiling);
10810 SAVEVPTR(PL_curcop);
10812 DEBUG_x( dump_sub(gv) );
10813 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10814 GvCV_set(gv,0); /* cv has been hijacked */
10815 call_list(oldscope, PL_beginav);
10819 return !PL_savebegin;
10824 if (*name == 'E') {
10825 if (strEQ(name, "END")) {
10826 DEBUG_x( dump_sub(gv) );
10827 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10830 } else if (*name == 'U') {
10831 if (strEQ(name, "UNITCHECK")) {
10832 /* It's never too late to run a unitcheck block */
10833 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10837 } else if (*name == 'C') {
10838 if (strEQ(name, "CHECK")) {
10840 /* diag_listed_as: Too late to run %s block */
10841 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10842 "Too late to run CHECK block");
10843 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10847 } else if (*name == 'I') {
10848 if (strEQ(name, "INIT")) {
10850 /* diag_listed_as: Too late to run %s block */
10851 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10852 "Too late to run INIT block");
10853 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10859 DEBUG_x( dump_sub(gv) );
10861 GvCV_set(gv,0); /* cv has been hijacked */
10867 =for apidoc newCONSTSUB
10869 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10870 rather than of counted length, and no flags are set. (This means that
10871 C<name> is always interpreted as Latin-1.)
10877 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10879 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10883 =for apidoc newCONSTSUB_flags
10885 Construct a constant subroutine, also performing some surrounding
10886 jobs. A scalar constant-valued subroutine is eligible for inlining
10887 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10888 123 }>>. Other kinds of constant subroutine have other treatment.
10890 The subroutine will have an empty prototype and will ignore any arguments
10891 when called. Its constant behaviour is determined by C<sv>. If C<sv>
10892 is null, the subroutine will yield an empty list. If C<sv> points to a
10893 scalar, the subroutine will always yield that scalar. If C<sv> points
10894 to an array, the subroutine will always yield a list of the elements of
10895 that array in list context, or the number of elements in the array in
10896 scalar context. This function takes ownership of one counted reference
10897 to the scalar or array, and will arrange for the object to live as long
10898 as the subroutine does. If C<sv> points to a scalar then the inlining
10899 assumes that the value of the scalar will never change, so the caller
10900 must ensure that the scalar is not subsequently written to. If C<sv>
10901 points to an array then no such assumption is made, so it is ostensibly
10902 safe to mutate the array or its elements, but whether this is really
10903 supported has not been determined.
10905 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10906 Other aspects of the subroutine will be left in their default state.
10907 The caller is free to mutate the subroutine beyond its initial state
10908 after this function has returned.
10910 If C<name> is null then the subroutine will be anonymous, with its
10911 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10912 subroutine will be named accordingly, referenced by the appropriate glob.
10913 C<name> is a string of length C<len> bytes giving a sigilless symbol
10914 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10915 otherwise. The name may be either qualified or unqualified. If the
10916 name is unqualified then it defaults to being in the stash specified by
10917 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10918 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10921 C<flags> should not have bits set other than C<SVf_UTF8>.
10923 If there is already a subroutine of the specified name, then the new sub
10924 will replace the existing one in the glob. A warning may be generated
10925 about the redefinition.
10927 If the subroutine has one of a few special names, such as C<BEGIN> or
10928 C<END>, then it will be claimed by the appropriate queue for automatic
10929 running of phase-related subroutines. In this case the relevant glob will
10930 be left not containing any subroutine, even if it did contain one before.
10931 Execution of the subroutine will likely be a no-op, unless C<sv> was
10932 a tied array or the caller modified the subroutine in some interesting
10933 way before it was executed. In the case of C<BEGIN>, the treatment is
10934 buggy: the sub will be executed when only half built, and may be deleted
10935 prematurely, possibly causing a crash.
10937 The function returns a pointer to the constructed subroutine. If the sub
10938 is anonymous then ownership of one counted reference to the subroutine
10939 is transferred to the caller. If the sub is named then the caller does
10940 not get ownership of a reference. In most such cases, where the sub
10941 has a non-phase name, the sub will be alive at the point it is returned
10942 by virtue of being contained in the glob that names it. A phase-named
10943 subroutine will usually be alive by virtue of the reference owned by
10944 the phase's automatic run queue. A C<BEGIN> subroutine may have been
10945 destroyed already by the time this function returns, but currently bugs
10946 occur in that case before the caller gets control. It is the caller's
10947 responsibility to ensure that it knows which of these situations applies.
10953 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10957 const char *const file = CopFILE(PL_curcop);
10961 if (IN_PERL_RUNTIME) {
10962 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10963 * an op shared between threads. Use a non-shared COP for our
10965 SAVEVPTR(PL_curcop);
10966 SAVECOMPILEWARNINGS();
10967 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10968 PL_curcop = &PL_compiling;
10970 SAVECOPLINE(PL_curcop);
10971 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10974 PL_hints &= ~HINT_BLOCK_SCOPE;
10977 SAVEGENERICSV(PL_curstash);
10978 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10981 /* Protect sv against leakage caused by fatal warnings. */
10982 if (sv) SAVEFREESV(sv);
10984 /* file becomes the CvFILE. For an XS, it's usually static storage,
10985 and so doesn't get free()d. (It's expected to be from the C pre-
10986 processor __FILE__ directive). But we need a dynamically allocated one,
10987 and we need it to get freed. */
10988 cv = newXS_len_flags(name, len,
10989 sv && SvTYPE(sv) == SVt_PVAV
10992 file ? file : "", "",
10993 &sv, XS_DYNAMIC_FILENAME | flags);
10995 assert(SvREFCNT((SV*)cv) != 0);
10996 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11007 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11008 static storage, as it is used directly as CvFILE(), without a copy being made.
11014 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11016 PERL_ARGS_ASSERT_NEWXS;
11017 return newXS_len_flags(
11018 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11023 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11024 const char *const filename, const char *const proto,
11027 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11028 return newXS_len_flags(
11029 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11034 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11036 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11037 return newXS_len_flags(
11038 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11043 =for apidoc newXS_len_flags
11045 Construct an XS subroutine, also performing some surrounding jobs.
11047 The subroutine will have the entry point C<subaddr>. It will have
11048 the prototype specified by the nul-terminated string C<proto>, or
11049 no prototype if C<proto> is null. The prototype string is copied;
11050 the caller can mutate the supplied string afterwards. If C<filename>
11051 is non-null, it must be a nul-terminated filename, and the subroutine
11052 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11053 point directly to the supplied string, which must be static. If C<flags>
11054 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11057 Other aspects of the subroutine will be left in their default state.
11058 If anything else needs to be done to the subroutine for it to function
11059 correctly, it is the caller's responsibility to do that after this
11060 function has constructed it. However, beware of the subroutine
11061 potentially being destroyed before this function returns, as described
11064 If C<name> is null then the subroutine will be anonymous, with its
11065 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11066 subroutine will be named accordingly, referenced by the appropriate glob.
11067 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11068 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11069 The name may be either qualified or unqualified, with the stash defaulting
11070 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11071 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11072 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11073 the stash if necessary, with C<GV_ADDMULTI> semantics.
11075 If there is already a subroutine of the specified name, then the new sub
11076 will replace the existing one in the glob. A warning may be generated
11077 about the redefinition. If the old subroutine was C<CvCONST> then the
11078 decision about whether to warn is influenced by an expectation about
11079 whether the new subroutine will become a constant of similar value.
11080 That expectation is determined by C<const_svp>. (Note that the call to
11081 this function doesn't make the new subroutine C<CvCONST> in any case;
11082 that is left to the caller.) If C<const_svp> is null then it indicates
11083 that the new subroutine will not become a constant. If C<const_svp>
11084 is non-null then it indicates that the new subroutine will become a
11085 constant, and it points to an C<SV*> that provides the constant value
11086 that the subroutine will have.
11088 If the subroutine has one of a few special names, such as C<BEGIN> or
11089 C<END>, then it will be claimed by the appropriate queue for automatic
11090 running of phase-related subroutines. In this case the relevant glob will
11091 be left not containing any subroutine, even if it did contain one before.
11092 In the case of C<BEGIN>, the subroutine will be executed and the reference
11093 to it disposed of before this function returns, and also before its
11094 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
11095 constructed by this function to be ready for execution then the caller
11096 must prevent this happening by giving the subroutine a different name.
11098 The function returns a pointer to the constructed subroutine. If the sub
11099 is anonymous then ownership of one counted reference to the subroutine
11100 is transferred to the caller. If the sub is named then the caller does
11101 not get ownership of a reference. In most such cases, where the sub
11102 has a non-phase name, the sub will be alive at the point it is returned
11103 by virtue of being contained in the glob that names it. A phase-named
11104 subroutine will usually be alive by virtue of the reference owned by the
11105 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11106 been executed, will quite likely have been destroyed already by the
11107 time this function returns, making it erroneous for the caller to make
11108 any use of the returned pointer. It is the caller's responsibility to
11109 ensure that it knows which of these situations applies.
11115 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11116 XSUBADDR_t subaddr, const char *const filename,
11117 const char *const proto, SV **const_svp,
11121 bool interleave = FALSE;
11122 bool evanescent = FALSE;
11124 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11127 GV * const gv = gv_fetchpvn(
11128 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11129 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11130 sizeof("__ANON__::__ANON__") - 1,
11131 GV_ADDMULTI | flags, SVt_PVCV);
11133 if ((cv = (name ? GvCV(gv) : NULL))) {
11135 /* just a cached method */
11139 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11140 /* already defined (or promised) */
11141 /* Redundant check that allows us to avoid creating an SV
11142 most of the time: */
11143 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11144 report_redefined_cv(newSVpvn_flags(
11145 name,len,(flags&SVf_UTF8)|SVs_TEMP
11156 if (cv) /* must reuse cv if autoloaded */
11159 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11163 if (HvENAME_HEK(GvSTASH(gv)))
11164 gv_method_changed(gv); /* newXS */
11168 assert(SvREFCNT((SV*)cv) != 0);
11172 /* XSUBs can't be perl lang/perl5db.pl debugged
11173 if (PERLDB_LINE_OR_SAVESRC)
11174 (void)gv_fetchfile(filename); */
11175 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11176 if (flags & XS_DYNAMIC_FILENAME) {
11178 CvFILE(cv) = savepv(filename);
11180 /* NOTE: not copied, as it is expected to be an external constant string */
11181 CvFILE(cv) = (char *)filename;
11184 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11185 CvFILE(cv) = (char*)PL_xsubfilename;
11188 CvXSUB(cv) = subaddr;
11189 #ifndef PERL_IMPLICIT_CONTEXT
11190 CvHSCXT(cv) = &PL_stack_sp;
11196 evanescent = process_special_blocks(0, name, gv, cv);
11199 } /* <- not a conditional branch */
11202 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11204 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11205 if (interleave) LEAVE;
11206 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11210 /* Add a stub CV to a typeglob.
11211 * This is the implementation of a forward declaration, 'sub foo';'
11215 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11217 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11219 PERL_ARGS_ASSERT_NEWSTUB;
11220 assert(!GvCVu(gv));
11223 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11224 gv_method_changed(gv);
11226 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11230 CvGV_set(cv, cvgv);
11231 CvFILE_set_from_cop(cv, PL_curcop);
11232 CvSTASH_set(cv, PL_curstash);
11238 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11245 if (PL_parser && PL_parser->error_count) {
11251 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11252 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11255 if ((cv = GvFORM(gv))) {
11256 if (ckWARN(WARN_REDEFINE)) {
11257 const line_t oldline = CopLINE(PL_curcop);
11258 if (PL_parser && PL_parser->copline != NOLINE)
11259 CopLINE_set(PL_curcop, PL_parser->copline);
11261 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11262 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11264 /* diag_listed_as: Format %s redefined */
11265 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11266 "Format STDOUT redefined");
11268 CopLINE_set(PL_curcop, oldline);
11273 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11275 CvFILE_set_from_cop(cv, PL_curcop);
11278 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
11280 start = LINKLIST(root);
11282 S_process_optree(aTHX_ cv, root, start);
11283 cv_forget_slab(cv);
11288 PL_parser->copline = NOLINE;
11289 LEAVE_SCOPE(floor);
11290 PL_compiling.cop_seq = 0;
11294 Perl_newANONLIST(pTHX_ OP *o)
11296 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
11300 Perl_newANONHASH(pTHX_ OP *o)
11302 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
11306 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11308 return newANONATTRSUB(floor, proto, NULL, block);
11312 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11314 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11316 newSVOP(OP_ANONCODE, 0,
11318 if (CvANONCONST(cv))
11319 anoncode = newUNOP(OP_ANONCONST, 0,
11320 op_convert_list(OP_ENTERSUB,
11321 OPf_STACKED|OPf_WANT_SCALAR,
11323 return newUNOP(OP_REFGEN, 0, anoncode);
11327 Perl_oopsAV(pTHX_ OP *o)
11331 PERL_ARGS_ASSERT_OOPSAV;
11333 switch (o->op_type) {
11336 OpTYPE_set(o, OP_PADAV);
11337 return ref(o, OP_RV2AV);
11341 OpTYPE_set(o, OP_RV2AV);
11346 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11353 Perl_oopsHV(pTHX_ OP *o)
11357 PERL_ARGS_ASSERT_OOPSHV;
11359 switch (o->op_type) {
11362 OpTYPE_set(o, OP_PADHV);
11363 return ref(o, OP_RV2HV);
11367 OpTYPE_set(o, OP_RV2HV);
11368 /* rv2hv steals the bottom bit for its own uses */
11369 o->op_private &= ~OPpARG1_MASK;
11374 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11381 Perl_newAVREF(pTHX_ OP *o)
11385 PERL_ARGS_ASSERT_NEWAVREF;
11387 if (o->op_type == OP_PADANY) {
11388 OpTYPE_set(o, OP_PADAV);
11391 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11392 Perl_croak(aTHX_ "Can't use an array as a reference");
11394 return newUNOP(OP_RV2AV, 0, scalar(o));
11398 Perl_newGVREF(pTHX_ I32 type, OP *o)
11400 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11401 return newUNOP(OP_NULL, 0, o);
11402 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11406 Perl_newHVREF(pTHX_ OP *o)
11410 PERL_ARGS_ASSERT_NEWHVREF;
11412 if (o->op_type == OP_PADANY) {
11413 OpTYPE_set(o, OP_PADHV);
11416 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11417 Perl_croak(aTHX_ "Can't use a hash as a reference");
11419 return newUNOP(OP_RV2HV, 0, scalar(o));
11423 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11425 if (o->op_type == OP_PADANY) {
11427 OpTYPE_set(o, OP_PADCV);
11429 return newUNOP(OP_RV2CV, flags, scalar(o));
11433 Perl_newSVREF(pTHX_ OP *o)
11437 PERL_ARGS_ASSERT_NEWSVREF;
11439 if (o->op_type == OP_PADANY) {
11440 OpTYPE_set(o, OP_PADSV);
11444 return newUNOP(OP_RV2SV, 0, scalar(o));
11447 /* Check routines. See the comments at the top of this file for details
11448 * on when these are called */
11451 Perl_ck_anoncode(pTHX_ OP *o)
11453 PERL_ARGS_ASSERT_CK_ANONCODE;
11455 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11456 cSVOPo->op_sv = NULL;
11461 S_io_hints(pTHX_ OP *o)
11463 #if O_BINARY != 0 || O_TEXT != 0
11465 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11467 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11470 const char *d = SvPV_const(*svp, len);
11471 const I32 mode = mode_from_discipline(d, len);
11472 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11474 if (mode & O_BINARY)
11475 o->op_private |= OPpOPEN_IN_RAW;
11479 o->op_private |= OPpOPEN_IN_CRLF;
11483 svp = hv_fetchs(table, "open_OUT", FALSE);
11486 const char *d = SvPV_const(*svp, len);
11487 const I32 mode = mode_from_discipline(d, len);
11488 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11490 if (mode & O_BINARY)
11491 o->op_private |= OPpOPEN_OUT_RAW;
11495 o->op_private |= OPpOPEN_OUT_CRLF;
11500 PERL_UNUSED_CONTEXT;
11501 PERL_UNUSED_ARG(o);
11506 Perl_ck_backtick(pTHX_ OP *o)
11511 PERL_ARGS_ASSERT_CK_BACKTICK;
11513 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11514 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11515 && (gv = gv_override("readpipe",8)))
11517 /* detach rest of siblings from o and its first child */
11518 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11519 newop = S_new_entersubop(aTHX_ gv, sibl);
11521 else if (!(o->op_flags & OPf_KIDS))
11522 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11527 S_io_hints(aTHX_ o);
11532 Perl_ck_bitop(pTHX_ OP *o)
11534 PERL_ARGS_ASSERT_CK_BITOP;
11536 o->op_private = (U8)(PL_hints & HINT_INTEGER);
11538 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11539 && OP_IS_INFIX_BIT(o->op_type))
11541 const OP * const left = cBINOPo->op_first;
11542 const OP * const right = OpSIBLING(left);
11543 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11544 (left->op_flags & OPf_PARENS) == 0) ||
11545 (OP_IS_NUMCOMPARE(right->op_type) &&
11546 (right->op_flags & OPf_PARENS) == 0))
11547 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11548 "Possible precedence problem on bitwise %s operator",
11549 o->op_type == OP_BIT_OR
11550 ||o->op_type == OP_NBIT_OR ? "|"
11551 : o->op_type == OP_BIT_AND
11552 ||o->op_type == OP_NBIT_AND ? "&"
11553 : o->op_type == OP_BIT_XOR
11554 ||o->op_type == OP_NBIT_XOR ? "^"
11555 : o->op_type == OP_SBIT_OR ? "|."
11556 : o->op_type == OP_SBIT_AND ? "&." : "^."
11562 PERL_STATIC_INLINE bool
11563 is_dollar_bracket(pTHX_ const OP * const o)
11566 PERL_UNUSED_CONTEXT;
11567 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11568 && (kid = cUNOPx(o)->op_first)
11569 && kid->op_type == OP_GV
11570 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11573 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11576 Perl_ck_cmp(pTHX_ OP *o)
11582 OP *indexop, *constop, *start;
11586 PERL_ARGS_ASSERT_CK_CMP;
11588 is_eq = ( o->op_type == OP_EQ
11589 || o->op_type == OP_NE
11590 || o->op_type == OP_I_EQ
11591 || o->op_type == OP_I_NE);
11593 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11594 const OP *kid = cUNOPo->op_first;
11597 ( is_dollar_bracket(aTHX_ kid)
11598 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11600 || ( kid->op_type == OP_CONST
11601 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11605 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11606 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11609 /* convert (index(...) == -1) and variations into
11610 * (r)index/BOOL(,NEG)
11615 indexop = cUNOPo->op_first;
11616 constop = OpSIBLING(indexop);
11618 if (indexop->op_type == OP_CONST) {
11620 indexop = OpSIBLING(constop);
11625 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11628 /* ($lex = index(....)) == -1 */
11629 if (indexop->op_private & OPpTARGET_MY)
11632 if (constop->op_type != OP_CONST)
11635 sv = cSVOPx_sv(constop);
11636 if (!(sv && SvIOK_notUV(sv)))
11640 if (iv != -1 && iv != 0)
11644 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11645 if (!(iv0 ^ reverse))
11649 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11654 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11655 if (!(iv0 ^ reverse))
11659 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11664 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11670 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11676 indexop->op_flags &= ~OPf_PARENS;
11677 indexop->op_flags |= (o->op_flags & OPf_PARENS);
11678 indexop->op_private |= OPpTRUEBOOL;
11680 indexop->op_private |= OPpINDEX_BOOLNEG;
11681 /* cut out the index op and free the eq,const ops */
11682 (void)op_sibling_splice(o, start, 1, NULL);
11690 Perl_ck_concat(pTHX_ OP *o)
11692 const OP * const kid = cUNOPo->op_first;
11694 PERL_ARGS_ASSERT_CK_CONCAT;
11695 PERL_UNUSED_CONTEXT;
11697 /* reuse the padtmp returned by the concat child */
11698 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11699 !(kUNOP->op_first->op_flags & OPf_MOD))
11701 o->op_flags |= OPf_STACKED;
11702 o->op_private |= OPpCONCAT_NESTED;
11708 Perl_ck_spair(pTHX_ OP *o)
11712 PERL_ARGS_ASSERT_CK_SPAIR;
11714 if (o->op_flags & OPf_KIDS) {
11718 const OPCODE type = o->op_type;
11719 o = modkids(ck_fun(o), type);
11720 kid = cUNOPo->op_first;
11721 kidkid = kUNOP->op_first;
11722 newop = OpSIBLING(kidkid);
11724 const OPCODE type = newop->op_type;
11725 if (OpHAS_SIBLING(newop))
11727 if (o->op_type == OP_REFGEN
11728 && ( type == OP_RV2CV
11729 || ( !(newop->op_flags & OPf_PARENS)
11730 && ( type == OP_RV2AV || type == OP_PADAV
11731 || type == OP_RV2HV || type == OP_PADHV))))
11732 NOOP; /* OK (allow srefgen for \@a and \%h) */
11733 else if (OP_GIMME(newop,0) != G_SCALAR)
11736 /* excise first sibling */
11737 op_sibling_splice(kid, NULL, 1, NULL);
11740 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11741 * and OP_CHOMP into OP_SCHOMP */
11742 o->op_ppaddr = PL_ppaddr[++o->op_type];
11747 Perl_ck_delete(pTHX_ OP *o)
11749 PERL_ARGS_ASSERT_CK_DELETE;
11753 if (o->op_flags & OPf_KIDS) {
11754 OP * const kid = cUNOPo->op_first;
11755 switch (kid->op_type) {
11757 o->op_flags |= OPf_SPECIAL;
11760 o->op_private |= OPpSLICE;
11763 o->op_flags |= OPf_SPECIAL;
11768 o->op_flags |= OPf_SPECIAL;
11771 o->op_private |= OPpKVSLICE;
11774 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11775 "element or slice");
11777 if (kid->op_private & OPpLVAL_INTRO)
11778 o->op_private |= OPpLVAL_INTRO;
11785 Perl_ck_eof(pTHX_ OP *o)
11787 PERL_ARGS_ASSERT_CK_EOF;
11789 if (o->op_flags & OPf_KIDS) {
11791 if (cLISTOPo->op_first->op_type == OP_STUB) {
11793 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11798 kid = cLISTOPo->op_first;
11799 if (kid->op_type == OP_RV2GV)
11800 kid->op_private |= OPpALLOW_FAKE;
11807 Perl_ck_eval(pTHX_ OP *o)
11811 PERL_ARGS_ASSERT_CK_EVAL;
11813 PL_hints |= HINT_BLOCK_SCOPE;
11814 if (o->op_flags & OPf_KIDS) {
11815 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11818 if (o->op_type == OP_ENTERTRY) {
11821 /* cut whole sibling chain free from o */
11822 op_sibling_splice(o, NULL, -1, NULL);
11825 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11827 /* establish postfix order */
11828 enter->op_next = (OP*)enter;
11830 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11831 OpTYPE_set(o, OP_LEAVETRY);
11832 enter->op_other = o;
11837 S_set_haseval(aTHX);
11841 const U8 priv = o->op_private;
11843 /* the newUNOP will recursively call ck_eval(), which will handle
11844 * all the stuff at the end of this function, like adding
11847 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11849 o->op_targ = (PADOFFSET)PL_hints;
11850 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11851 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11852 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11853 /* Store a copy of %^H that pp_entereval can pick up. */
11854 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
11856 STOREFEATUREBITSHH(hh);
11857 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
11858 /* append hhop to only child */
11859 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11861 o->op_private |= OPpEVAL_HAS_HH;
11863 if (!(o->op_private & OPpEVAL_BYTES)
11864 && FEATURE_UNIEVAL_IS_ENABLED)
11865 o->op_private |= OPpEVAL_UNICODE;
11870 Perl_ck_exec(pTHX_ OP *o)
11872 PERL_ARGS_ASSERT_CK_EXEC;
11874 if (o->op_flags & OPf_STACKED) {
11877 kid = OpSIBLING(cUNOPo->op_first);
11878 if (kid->op_type == OP_RV2GV)
11887 Perl_ck_exists(pTHX_ OP *o)
11889 PERL_ARGS_ASSERT_CK_EXISTS;
11892 if (o->op_flags & OPf_KIDS) {
11893 OP * const kid = cUNOPo->op_first;
11894 if (kid->op_type == OP_ENTERSUB) {
11895 (void) ref(kid, o->op_type);
11896 if (kid->op_type != OP_RV2CV
11897 && !(PL_parser && PL_parser->error_count))
11899 "exists argument is not a subroutine name");
11900 o->op_private |= OPpEXISTS_SUB;
11902 else if (kid->op_type == OP_AELEM)
11903 o->op_flags |= OPf_SPECIAL;
11904 else if (kid->op_type != OP_HELEM)
11905 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11906 "element or a subroutine");
11913 Perl_ck_rvconst(pTHX_ OP *o)
11916 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11918 PERL_ARGS_ASSERT_CK_RVCONST;
11920 if (o->op_type == OP_RV2HV)
11921 /* rv2hv steals the bottom bit for its own uses */
11922 o->op_private &= ~OPpARG1_MASK;
11924 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11926 if (kid->op_type == OP_CONST) {
11929 SV * const kidsv = kid->op_sv;
11931 /* Is it a constant from cv_const_sv()? */
11932 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11935 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11936 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11937 const char *badthing;
11938 switch (o->op_type) {
11940 badthing = "a SCALAR";
11943 badthing = "an ARRAY";
11946 badthing = "a HASH";
11954 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11955 SVfARG(kidsv), badthing);
11958 * This is a little tricky. We only want to add the symbol if we
11959 * didn't add it in the lexer. Otherwise we get duplicate strict
11960 * warnings. But if we didn't add it in the lexer, we must at
11961 * least pretend like we wanted to add it even if it existed before,
11962 * or we get possible typo warnings. OPpCONST_ENTERED says
11963 * whether the lexer already added THIS instance of this symbol.
11965 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11966 gv = gv_fetchsv(kidsv,
11967 o->op_type == OP_RV2CV
11968 && o->op_private & OPpMAY_RETURN_CONSTANT
11970 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11973 : o->op_type == OP_RV2SV
11975 : o->op_type == OP_RV2AV
11977 : o->op_type == OP_RV2HV
11984 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11985 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11986 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11988 OpTYPE_set(kid, OP_GV);
11989 SvREFCNT_dec(kid->op_sv);
11990 #ifdef USE_ITHREADS
11991 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11992 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11993 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11994 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11995 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11997 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11999 kid->op_private = 0;
12000 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12008 Perl_ck_ftst(pTHX_ OP *o)
12011 const I32 type = o->op_type;
12013 PERL_ARGS_ASSERT_CK_FTST;
12015 if (o->op_flags & OPf_REF) {
12018 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12019 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12020 const OPCODE kidtype = kid->op_type;
12022 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12023 && !kid->op_folded) {
12024 OP * const newop = newGVOP(type, OPf_REF,
12025 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12030 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12031 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12033 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12034 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12035 array_passed_to_stat, name);
12038 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12039 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12042 scalar((OP *) kid);
12043 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12044 o->op_private |= OPpFT_ACCESS;
12045 if (OP_IS_FILETEST(type)
12046 && OP_IS_FILETEST(kidtype)
12048 o->op_private |= OPpFT_STACKED;
12049 kid->op_private |= OPpFT_STACKING;
12050 if (kidtype == OP_FTTTY && (
12051 !(kid->op_private & OPpFT_STACKED)
12052 || kid->op_private & OPpFT_AFTER_t
12054 o->op_private |= OPpFT_AFTER_t;
12059 if (type == OP_FTTTY)
12060 o = newGVOP(type, OPf_REF, PL_stdingv);
12062 o = newUNOP(type, 0, newDEFSVOP());
12068 Perl_ck_fun(pTHX_ OP *o)
12070 const int type = o->op_type;
12071 I32 oa = PL_opargs[type] >> OASHIFT;
12073 PERL_ARGS_ASSERT_CK_FUN;
12075 if (o->op_flags & OPf_STACKED) {
12076 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12077 oa &= ~OA_OPTIONAL;
12079 return no_fh_allowed(o);
12082 if (o->op_flags & OPf_KIDS) {
12083 OP *prev_kid = NULL;
12084 OP *kid = cLISTOPo->op_first;
12086 bool seen_optional = FALSE;
12088 if (kid->op_type == OP_PUSHMARK ||
12089 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12092 kid = OpSIBLING(kid);
12094 if (kid && kid->op_type == OP_COREARGS) {
12095 bool optional = FALSE;
12098 if (oa & OA_OPTIONAL) optional = TRUE;
12101 if (optional) o->op_private |= numargs;
12106 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12107 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12108 kid = newDEFSVOP();
12109 /* append kid to chain */
12110 op_sibling_splice(o, prev_kid, 0, kid);
12112 seen_optional = TRUE;
12119 /* list seen where single (scalar) arg expected? */
12120 if (numargs == 1 && !(oa >> 4)
12121 && kid->op_type == OP_LIST && type != OP_SCALAR)
12123 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12125 if (type != OP_DELETE) scalar(kid);
12136 if ((type == OP_PUSH || type == OP_UNSHIFT)
12137 && !OpHAS_SIBLING(kid))
12138 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12139 "Useless use of %s with no values",
12142 if (kid->op_type == OP_CONST
12143 && ( !SvROK(cSVOPx_sv(kid))
12144 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
12146 bad_type_pv(numargs, "array", o, kid);
12147 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12148 || kid->op_type == OP_RV2GV) {
12149 bad_type_pv(1, "array", o, kid);
12151 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12152 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12153 PL_op_desc[type]), 0);
12156 op_lvalue(kid, type);
12160 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12161 bad_type_pv(numargs, "hash", o, kid);
12162 op_lvalue(kid, type);
12166 /* replace kid with newop in chain */
12168 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12169 newop->op_next = newop;
12174 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12175 if (kid->op_type == OP_CONST &&
12176 (kid->op_private & OPpCONST_BARE))
12178 OP * const newop = newGVOP(OP_GV, 0,
12179 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
12180 /* replace kid with newop in chain */
12181 op_sibling_splice(o, prev_kid, 1, newop);
12185 else if (kid->op_type == OP_READLINE) {
12186 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12187 bad_type_pv(numargs, "HANDLE", o, kid);
12190 I32 flags = OPf_SPECIAL;
12192 PADOFFSET targ = 0;
12194 /* is this op a FH constructor? */
12195 if (is_handle_constructor(o,numargs)) {
12196 const char *name = NULL;
12199 bool want_dollar = TRUE;
12202 /* Set a flag to tell rv2gv to vivify
12203 * need to "prove" flag does not mean something
12204 * else already - NI-S 1999/05/07
12207 if (kid->op_type == OP_PADSV) {
12209 = PAD_COMPNAME_SV(kid->op_targ);
12210 name = PadnamePV (pn);
12211 len = PadnameLEN(pn);
12212 name_utf8 = PadnameUTF8(pn);
12214 else if (kid->op_type == OP_RV2SV
12215 && kUNOP->op_first->op_type == OP_GV)
12217 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12219 len = GvNAMELEN(gv);
12220 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12222 else if (kid->op_type == OP_AELEM
12223 || kid->op_type == OP_HELEM)
12226 OP *op = ((BINOP*)kid)->op_first;
12230 const char * const a =
12231 kid->op_type == OP_AELEM ?
12233 if (((op->op_type == OP_RV2AV) ||
12234 (op->op_type == OP_RV2HV)) &&
12235 (firstop = ((UNOP*)op)->op_first) &&
12236 (firstop->op_type == OP_GV)) {
12237 /* packagevar $a[] or $h{} */
12238 GV * const gv = cGVOPx_gv(firstop);
12241 Perl_newSVpvf(aTHX_
12246 else if (op->op_type == OP_PADAV
12247 || op->op_type == OP_PADHV) {
12248 /* lexicalvar $a[] or $h{} */
12249 const char * const padname =
12250 PAD_COMPNAME_PV(op->op_targ);
12253 Perl_newSVpvf(aTHX_
12259 name = SvPV_const(tmpstr, len);
12260 name_utf8 = SvUTF8(tmpstr);
12261 sv_2mortal(tmpstr);
12265 name = "__ANONIO__";
12267 want_dollar = FALSE;
12269 op_lvalue(kid, type);
12273 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12274 namesv = PAD_SVl(targ);
12275 if (want_dollar && *name != '$')
12276 sv_setpvs(namesv, "$");
12279 sv_catpvn(namesv, name, len);
12280 if ( name_utf8 ) SvUTF8_on(namesv);
12284 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12286 kid->op_targ = targ;
12287 kid->op_private |= priv;
12293 if ((type == OP_UNDEF || type == OP_POS)
12294 && numargs == 1 && !(oa >> 4)
12295 && kid->op_type == OP_LIST)
12296 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12297 op_lvalue(scalar(kid), type);
12302 kid = OpSIBLING(kid);
12304 /* FIXME - should the numargs or-ing move after the too many
12305 * arguments check? */
12306 o->op_private |= numargs;
12308 return too_many_arguments_pv(o,OP_DESC(o), 0);
12311 else if (PL_opargs[type] & OA_DEFGV) {
12312 /* Ordering of these two is important to keep f_map.t passing. */
12314 return newUNOP(type, 0, newDEFSVOP());
12318 while (oa & OA_OPTIONAL)
12320 if (oa && oa != OA_LIST)
12321 return too_few_arguments_pv(o,OP_DESC(o), 0);
12327 Perl_ck_glob(pTHX_ OP *o)
12331 PERL_ARGS_ASSERT_CK_GLOB;
12334 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12335 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12337 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12341 * \ null - const(wildcard)
12346 * \ mark - glob - rv2cv
12347 * | \ gv(CORE::GLOBAL::glob)
12349 * \ null - const(wildcard)
12351 o->op_flags |= OPf_SPECIAL;
12352 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12353 o = S_new_entersubop(aTHX_ gv, o);
12354 o = newUNOP(OP_NULL, 0, o);
12355 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12358 else o->op_flags &= ~OPf_SPECIAL;
12359 #if !defined(PERL_EXTERNAL_GLOB)
12360 if (!PL_globhook) {
12362 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12363 newSVpvs("File::Glob"), NULL, NULL, NULL);
12366 #endif /* !PERL_EXTERNAL_GLOB */
12367 gv = (GV *)newSV(0);
12368 gv_init(gv, 0, "", 0, 0);
12370 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12371 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12377 Perl_ck_grep(pTHX_ OP *o)
12381 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12383 PERL_ARGS_ASSERT_CK_GREP;
12385 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12387 if (o->op_flags & OPf_STACKED) {
12388 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12389 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12390 return no_fh_allowed(o);
12391 o->op_flags &= ~OPf_STACKED;
12393 kid = OpSIBLING(cLISTOPo->op_first);
12394 if (type == OP_MAPWHILE)
12399 if (PL_parser && PL_parser->error_count)
12401 kid = OpSIBLING(cLISTOPo->op_first);
12402 if (kid->op_type != OP_NULL)
12403 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12404 kid = kUNOP->op_first;
12406 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12407 kid->op_next = (OP*)gwop;
12408 o->op_private = gwop->op_private = 0;
12409 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12411 kid = OpSIBLING(cLISTOPo->op_first);
12412 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12413 op_lvalue(kid, OP_GREPSTART);
12419 Perl_ck_index(pTHX_ OP *o)
12421 PERL_ARGS_ASSERT_CK_INDEX;
12423 if (o->op_flags & OPf_KIDS) {
12424 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12426 kid = OpSIBLING(kid); /* get past "big" */
12427 if (kid && kid->op_type == OP_CONST) {
12428 const bool save_taint = TAINT_get;
12429 SV *sv = kSVOP->op_sv;
12430 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12431 && SvOK(sv) && !SvROK(sv))
12434 sv_copypv(sv, kSVOP->op_sv);
12435 SvREFCNT_dec_NN(kSVOP->op_sv);
12438 if (SvOK(sv)) fbm_compile(sv, 0);
12439 TAINT_set(save_taint);
12440 #ifdef NO_TAINT_SUPPORT
12441 PERL_UNUSED_VAR(save_taint);
12449 Perl_ck_lfun(pTHX_ OP *o)
12451 const OPCODE type = o->op_type;
12453 PERL_ARGS_ASSERT_CK_LFUN;
12455 return modkids(ck_fun(o), type);
12459 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12461 PERL_ARGS_ASSERT_CK_DEFINED;
12463 if ((o->op_flags & OPf_KIDS)) {
12464 switch (cUNOPo->op_first->op_type) {
12467 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12468 " (Maybe you should just omit the defined()?)");
12469 NOT_REACHED; /* NOTREACHED */
12473 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12474 " (Maybe you should just omit the defined()?)");
12475 NOT_REACHED; /* NOTREACHED */
12486 Perl_ck_readline(pTHX_ OP *o)
12488 PERL_ARGS_ASSERT_CK_READLINE;
12490 if (o->op_flags & OPf_KIDS) {
12491 OP *kid = cLISTOPo->op_first;
12492 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12497 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12505 Perl_ck_rfun(pTHX_ OP *o)
12507 const OPCODE type = o->op_type;
12509 PERL_ARGS_ASSERT_CK_RFUN;
12511 return refkids(ck_fun(o), type);
12515 Perl_ck_listiob(pTHX_ OP *o)
12519 PERL_ARGS_ASSERT_CK_LISTIOB;
12521 kid = cLISTOPo->op_first;
12523 o = force_list(o, 1);
12524 kid = cLISTOPo->op_first;
12526 if (kid->op_type == OP_PUSHMARK)
12527 kid = OpSIBLING(kid);
12528 if (kid && o->op_flags & OPf_STACKED)
12529 kid = OpSIBLING(kid);
12530 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12531 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12532 && !kid->op_folded) {
12533 o->op_flags |= OPf_STACKED; /* make it a filehandle */
12535 /* replace old const op with new OP_RV2GV parent */
12536 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12537 OP_RV2GV, OPf_REF);
12538 kid = OpSIBLING(kid);
12543 op_append_elem(o->op_type, o, newDEFSVOP());
12545 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12546 return listkids(o);
12550 Perl_ck_smartmatch(pTHX_ OP *o)
12553 PERL_ARGS_ASSERT_CK_SMARTMATCH;
12554 if (0 == (o->op_flags & OPf_SPECIAL)) {
12555 OP *first = cBINOPo->op_first;
12556 OP *second = OpSIBLING(first);
12558 /* Implicitly take a reference to an array or hash */
12560 /* remove the original two siblings, then add back the
12561 * (possibly different) first and second sibs.
12563 op_sibling_splice(o, NULL, 1, NULL);
12564 op_sibling_splice(o, NULL, 1, NULL);
12565 first = ref_array_or_hash(first);
12566 second = ref_array_or_hash(second);
12567 op_sibling_splice(o, NULL, 0, second);
12568 op_sibling_splice(o, NULL, 0, first);
12570 /* Implicitly take a reference to a regular expression */
12571 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12572 OpTYPE_set(first, OP_QR);
12574 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12575 OpTYPE_set(second, OP_QR);
12584 S_maybe_targlex(pTHX_ OP *o)
12586 OP * const kid = cLISTOPo->op_first;
12587 /* has a disposable target? */
12588 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12589 && !(kid->op_flags & OPf_STACKED)
12590 /* Cannot steal the second time! */
12591 && !(kid->op_private & OPpTARGET_MY)
12594 OP * const kkid = OpSIBLING(kid);
12596 /* Can just relocate the target. */
12597 if (kkid && kkid->op_type == OP_PADSV
12598 && (!(kkid->op_private & OPpLVAL_INTRO)
12599 || kkid->op_private & OPpPAD_STATE))
12601 kid->op_targ = kkid->op_targ;
12603 /* Now we do not need PADSV and SASSIGN.
12604 * Detach kid and free the rest. */
12605 op_sibling_splice(o, NULL, 1, NULL);
12607 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
12615 Perl_ck_sassign(pTHX_ OP *o)
12618 OP * const kid = cBINOPo->op_first;
12620 PERL_ARGS_ASSERT_CK_SASSIGN;
12622 if (OpHAS_SIBLING(kid)) {
12623 OP *kkid = OpSIBLING(kid);
12624 /* For state variable assignment with attributes, kkid is a list op
12625 whose op_last is a padsv. */
12626 if ((kkid->op_type == OP_PADSV ||
12627 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12628 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12631 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12632 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12633 return S_newONCEOP(aTHX_ o, kkid);
12636 return S_maybe_targlex(aTHX_ o);
12641 Perl_ck_match(pTHX_ OP *o)
12643 PERL_UNUSED_CONTEXT;
12644 PERL_ARGS_ASSERT_CK_MATCH;
12650 Perl_ck_method(pTHX_ OP *o)
12652 SV *sv, *methsv, *rclass;
12653 const char* method;
12656 STRLEN len, nsplit = 0, i;
12658 OP * const kid = cUNOPo->op_first;
12660 PERL_ARGS_ASSERT_CK_METHOD;
12661 if (kid->op_type != OP_CONST) return o;
12665 /* replace ' with :: */
12666 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12667 SvEND(sv) - SvPVX(sv) )))
12670 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12673 method = SvPVX_const(sv);
12675 utf8 = SvUTF8(sv) ? -1 : 1;
12677 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12682 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12684 if (!nsplit) { /* $proto->method() */
12686 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12689 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12691 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12694 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12695 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12696 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12697 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12699 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12700 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12702 #ifdef USE_ITHREADS
12703 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12705 cMETHOPx(new_op)->op_rclass_sv = rclass;
12712 Perl_ck_null(pTHX_ OP *o)
12714 PERL_ARGS_ASSERT_CK_NULL;
12715 PERL_UNUSED_CONTEXT;
12720 Perl_ck_open(pTHX_ OP *o)
12722 PERL_ARGS_ASSERT_CK_OPEN;
12724 S_io_hints(aTHX_ o);
12726 /* In case of three-arg dup open remove strictness
12727 * from the last arg if it is a bareword. */
12728 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12729 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
12733 if ((last->op_type == OP_CONST) && /* The bareword. */
12734 (last->op_private & OPpCONST_BARE) &&
12735 (last->op_private & OPpCONST_STRICT) &&
12736 (oa = OpSIBLING(first)) && /* The fh. */
12737 (oa = OpSIBLING(oa)) && /* The mode. */
12738 (oa->op_type == OP_CONST) &&
12739 SvPOK(((SVOP*)oa)->op_sv) &&
12740 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12741 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
12742 (last == OpSIBLING(oa))) /* The bareword. */
12743 last->op_private &= ~OPpCONST_STRICT;
12749 Perl_ck_prototype(pTHX_ OP *o)
12751 PERL_ARGS_ASSERT_CK_PROTOTYPE;
12752 if (!(o->op_flags & OPf_KIDS)) {
12754 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12760 Perl_ck_refassign(pTHX_ OP *o)
12762 OP * const right = cLISTOPo->op_first;
12763 OP * const left = OpSIBLING(right);
12764 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12767 PERL_ARGS_ASSERT_CK_REFASSIGN;
12769 assert (left->op_type == OP_SREFGEN);
12772 /* we use OPpPAD_STATE in refassign to mean either of those things,
12773 * and the code assumes the two flags occupy the same bit position
12774 * in the various ops below */
12775 assert(OPpPAD_STATE == OPpOUR_INTRO);
12777 switch (varop->op_type) {
12779 o->op_private |= OPpLVREF_AV;
12782 o->op_private |= OPpLVREF_HV;
12786 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12787 o->op_targ = varop->op_targ;
12788 varop->op_targ = 0;
12789 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12793 o->op_private |= OPpLVREF_AV;
12795 NOT_REACHED; /* NOTREACHED */
12797 o->op_private |= OPpLVREF_HV;
12801 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12802 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12804 /* Point varop to its GV kid, detached. */
12805 varop = op_sibling_splice(varop, NULL, -1, NULL);
12809 OP * const kidparent =
12810 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12811 OP * const kid = cUNOPx(kidparent)->op_first;
12812 o->op_private |= OPpLVREF_CV;
12813 if (kid->op_type == OP_GV) {
12814 SV *sv = (SV*)cGVOPx_gv(kid);
12816 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
12817 /* a CVREF here confuses pp_refassign, so make sure
12819 CV *const cv = (CV*)SvRV(sv);
12820 SV *name_sv = sv_2mortal(newSVhek(CvNAME_HEK(cv)));
12821 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
12822 assert(SvTYPE(sv) == SVt_PVGV);
12824 goto detach_and_stack;
12826 if (kid->op_type != OP_PADCV) goto bad;
12827 o->op_targ = kid->op_targ;
12833 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12834 o->op_private |= OPpLVREF_ELEM;
12837 /* Detach varop. */
12838 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12842 /* diag_listed_as: Can't modify reference to %s in %s assignment */
12843 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12848 if (!FEATURE_REFALIASING_IS_ENABLED)
12850 "Experimental aliasing via reference not enabled");
12851 Perl_ck_warner_d(aTHX_
12852 packWARN(WARN_EXPERIMENTAL__REFALIASING),
12853 "Aliasing via reference is experimental");
12855 o->op_flags |= OPf_STACKED;
12856 op_sibling_splice(o, right, 1, varop);
12859 o->op_flags &=~ OPf_STACKED;
12860 op_sibling_splice(o, right, 1, NULL);
12867 Perl_ck_repeat(pTHX_ OP *o)
12869 PERL_ARGS_ASSERT_CK_REPEAT;
12871 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12873 o->op_private |= OPpREPEAT_DOLIST;
12874 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12875 kids = force_list(kids, 1); /* promote it to a list */
12876 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12884 Perl_ck_require(pTHX_ OP *o)
12888 PERL_ARGS_ASSERT_CK_REQUIRE;
12890 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12891 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12895 if (kid->op_type == OP_CONST) {
12896 SV * const sv = kid->op_sv;
12897 U32 const was_readonly = SvREADONLY(sv);
12898 if (kid->op_private & OPpCONST_BARE) {
12903 if (was_readonly) {
12904 SvREADONLY_off(sv);
12906 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12911 /* treat ::foo::bar as foo::bar */
12912 if (len >= 2 && s[0] == ':' && s[1] == ':')
12913 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12915 DIE(aTHX_ "Bareword in require maps to empty filename");
12917 for (; s < end; s++) {
12918 if (*s == ':' && s[1] == ':') {
12920 Move(s+2, s+1, end - s - 1, char);
12924 SvEND_set(sv, end);
12925 sv_catpvs(sv, ".pm");
12926 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12927 hek = share_hek(SvPVX(sv),
12928 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12930 sv_sethek(sv, hek);
12932 SvFLAGS(sv) |= was_readonly;
12934 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12937 if (SvREFCNT(sv) > 1) {
12938 kid->op_sv = newSVpvn_share(
12939 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12940 SvREFCNT_dec_NN(sv);
12945 if (was_readonly) SvREADONLY_off(sv);
12946 PERL_HASH(hash, s, len);
12948 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12950 sv_sethek(sv, hek);
12952 SvFLAGS(sv) |= was_readonly;
12958 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12959 /* handle override, if any */
12960 && (gv = gv_override("require", 7))) {
12962 if (o->op_flags & OPf_KIDS) {
12963 kid = cUNOPo->op_first;
12964 op_sibling_splice(o, NULL, -1, NULL);
12967 kid = newDEFSVOP();
12970 newop = S_new_entersubop(aTHX_ gv, kid);
12978 Perl_ck_return(pTHX_ OP *o)
12982 PERL_ARGS_ASSERT_CK_RETURN;
12984 kid = OpSIBLING(cLISTOPo->op_first);
12985 if (PL_compcv && CvLVALUE(PL_compcv)) {
12986 for (; kid; kid = OpSIBLING(kid))
12987 op_lvalue(kid, OP_LEAVESUBLV);
12994 Perl_ck_select(pTHX_ OP *o)
12999 PERL_ARGS_ASSERT_CK_SELECT;
13001 if (o->op_flags & OPf_KIDS) {
13002 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13003 if (kid && OpHAS_SIBLING(kid)) {
13004 OpTYPE_set(o, OP_SSELECT);
13006 return fold_constants(op_integerize(op_std_init(o)));
13010 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13011 if (kid && kid->op_type == OP_RV2GV)
13012 kid->op_private &= ~HINT_STRICT_REFS;
13017 Perl_ck_shift(pTHX_ OP *o)
13019 const I32 type = o->op_type;
13021 PERL_ARGS_ASSERT_CK_SHIFT;
13023 if (!(o->op_flags & OPf_KIDS)) {
13026 if (!CvUNIQUE(PL_compcv)) {
13027 o->op_flags |= OPf_SPECIAL;
13031 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13033 return newUNOP(type, 0, scalar(argop));
13035 return scalar(ck_fun(o));
13039 Perl_ck_sort(pTHX_ OP *o)
13043 HV * const hinthv =
13044 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
13047 PERL_ARGS_ASSERT_CK_SORT;
13050 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
13052 const I32 sorthints = (I32)SvIV(*svp);
13053 if ((sorthints & HINT_SORT_STABLE) != 0)
13054 o->op_private |= OPpSORT_STABLE;
13055 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
13056 o->op_private |= OPpSORT_UNSTABLE;
13060 if (o->op_flags & OPf_STACKED)
13062 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13064 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13065 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13067 /* if the first arg is a code block, process it and mark sort as
13069 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13071 if (kid->op_type == OP_LEAVE)
13072 op_null(kid); /* wipe out leave */
13073 /* Prevent execution from escaping out of the sort block. */
13076 /* provide scalar context for comparison function/block */
13077 kid = scalar(firstkid);
13078 kid->op_next = kid;
13079 o->op_flags |= OPf_SPECIAL;
13081 else if (kid->op_type == OP_CONST
13082 && kid->op_private & OPpCONST_BARE) {
13086 const char * const name = SvPV(kSVOP_sv, len);
13088 assert (len < 256);
13089 Copy(name, tmpbuf+1, len, char);
13090 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13091 if (off != NOT_IN_PAD) {
13092 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13094 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13095 sv_catpvs(fq, "::");
13096 sv_catsv(fq, kSVOP_sv);
13097 SvREFCNT_dec_NN(kSVOP_sv);
13101 OP * const padop = newOP(OP_PADCV, 0);
13102 padop->op_targ = off;
13103 /* replace the const op with the pad op */
13104 op_sibling_splice(firstkid, NULL, 1, padop);
13110 firstkid = OpSIBLING(firstkid);
13113 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13114 /* provide list context for arguments */
13117 op_lvalue(kid, OP_GREPSTART);
13123 /* for sort { X } ..., where X is one of
13124 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13125 * elide the second child of the sort (the one containing X),
13126 * and set these flags as appropriate
13130 * Also, check and warn on lexical $a, $b.
13134 S_simplify_sort(pTHX_ OP *o)
13136 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13140 const char *gvname;
13143 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13145 kid = kUNOP->op_first; /* get past null */
13146 if (!(have_scopeop = kid->op_type == OP_SCOPE)
13147 && kid->op_type != OP_LEAVE)
13149 kid = kLISTOP->op_last; /* get past scope */
13150 switch(kid->op_type) {
13154 if (!have_scopeop) goto padkids;
13159 k = kid; /* remember this node*/
13160 if (kBINOP->op_first->op_type != OP_RV2SV
13161 || kBINOP->op_last ->op_type != OP_RV2SV)
13164 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13165 then used in a comparison. This catches most, but not
13166 all cases. For instance, it catches
13167 sort { my($a); $a <=> $b }
13169 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13170 (although why you'd do that is anyone's guess).
13174 if (!ckWARN(WARN_SYNTAX)) return;
13175 kid = kBINOP->op_first;
13177 if (kid->op_type == OP_PADSV) {
13178 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13179 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13180 && ( PadnamePV(name)[1] == 'a'
13181 || PadnamePV(name)[1] == 'b' ))
13182 /* diag_listed_as: "my %s" used in sort comparison */
13183 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13184 "\"%s %s\" used in sort comparison",
13185 PadnameIsSTATE(name)
13190 } while ((kid = OpSIBLING(kid)));
13193 kid = kBINOP->op_first; /* get past cmp */
13194 if (kUNOP->op_first->op_type != OP_GV)
13196 kid = kUNOP->op_first; /* get past rv2sv */
13198 if (GvSTASH(gv) != PL_curstash)
13200 gvname = GvNAME(gv);
13201 if (*gvname == 'a' && gvname[1] == '\0')
13203 else if (*gvname == 'b' && gvname[1] == '\0')
13208 kid = k; /* back to cmp */
13209 /* already checked above that it is rv2sv */
13210 kid = kBINOP->op_last; /* down to 2nd arg */
13211 if (kUNOP->op_first->op_type != OP_GV)
13213 kid = kUNOP->op_first; /* get past rv2sv */
13215 if (GvSTASH(gv) != PL_curstash)
13217 gvname = GvNAME(gv);
13219 ? !(*gvname == 'a' && gvname[1] == '\0')
13220 : !(*gvname == 'b' && gvname[1] == '\0'))
13222 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13224 o->op_private |= OPpSORT_DESCEND;
13225 if (k->op_type == OP_NCMP)
13226 o->op_private |= OPpSORT_NUMERIC;
13227 if (k->op_type == OP_I_NCMP)
13228 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13229 kid = OpSIBLING(cLISTOPo->op_first);
13230 /* cut out and delete old block (second sibling) */
13231 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13236 Perl_ck_split(pTHX_ OP *o)
13242 PERL_ARGS_ASSERT_CK_SPLIT;
13244 assert(o->op_type == OP_LIST);
13246 if (o->op_flags & OPf_STACKED)
13247 return no_fh_allowed(o);
13249 kid = cLISTOPo->op_first;
13250 /* delete leading NULL node, then add a CONST if no other nodes */
13251 assert(kid->op_type == OP_NULL);
13252 op_sibling_splice(o, NULL, 1,
13253 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13255 kid = cLISTOPo->op_first;
13257 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13258 /* remove match expression, and replace with new optree with
13259 * a match op at its head */
13260 op_sibling_splice(o, NULL, 1, NULL);
13261 /* pmruntime will handle split " " behavior with flag==2 */
13262 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13263 op_sibling_splice(o, NULL, 0, kid);
13266 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13268 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
13269 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13270 "Use of /g modifier is meaningless in split");
13273 /* eliminate the split op, and move the match op (plus any children)
13274 * into its place, then convert the match op into a split op. i.e.
13276 * SPLIT MATCH SPLIT(ex-MATCH)
13278 * MATCH - A - B - C => R - A - B - C => R - A - B - C
13284 * (R, if it exists, will be a regcomp op)
13287 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
13288 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
13289 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
13290 OpTYPE_set(kid, OP_SPLIT);
13291 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
13292 kid->op_private = o->op_private;
13295 kid = sibs; /* kid is now the string arg of the split */
13298 kid = newDEFSVOP();
13299 op_append_elem(OP_SPLIT, o, kid);
13303 kid = OpSIBLING(kid);
13305 kid = newSVOP(OP_CONST, 0, newSViv(0));
13306 op_append_elem(OP_SPLIT, o, kid);
13307 o->op_private |= OPpSPLIT_IMPLIM;
13311 if (OpHAS_SIBLING(kid))
13312 return too_many_arguments_pv(o,OP_DESC(o), 0);
13318 Perl_ck_stringify(pTHX_ OP *o)
13320 OP * const kid = OpSIBLING(cUNOPo->op_first);
13321 PERL_ARGS_ASSERT_CK_STRINGIFY;
13322 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13323 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
13324 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
13325 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13327 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13335 Perl_ck_join(pTHX_ OP *o)
13337 OP * const kid = OpSIBLING(cLISTOPo->op_first);
13339 PERL_ARGS_ASSERT_CK_JOIN;
13341 if (kid && kid->op_type == OP_MATCH) {
13342 if (ckWARN(WARN_SYNTAX)) {
13343 const REGEXP *re = PM_GETRE(kPMOP);
13345 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13346 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13347 : newSVpvs_flags( "STRING", SVs_TEMP );
13348 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13349 "/%" SVf "/ should probably be written as \"%" SVf "\"",
13350 SVfARG(msg), SVfARG(msg));
13354 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13355 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13356 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13357 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13359 const OP * const bairn = OpSIBLING(kid); /* the list */
13360 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13361 && OP_GIMME(bairn,0) == G_SCALAR)
13363 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13364 op_sibling_splice(o, kid, 1, NULL));
13374 =for apidoc rv2cv_op_cv
13376 Examines an op, which is expected to identify a subroutine at runtime,
13377 and attempts to determine at compile time which subroutine it identifies.
13378 This is normally used during Perl compilation to determine whether
13379 a prototype can be applied to a function call. C<cvop> is the op
13380 being considered, normally an C<rv2cv> op. A pointer to the identified
13381 subroutine is returned, if it could be determined statically, and a null
13382 pointer is returned if it was not possible to determine statically.
13384 Currently, the subroutine can be identified statically if the RV that the
13385 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13386 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
13387 suitable if the constant value must be an RV pointing to a CV. Details of
13388 this process may change in future versions of Perl. If the C<rv2cv> op
13389 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13390 the subroutine statically: this flag is used to suppress compile-time
13391 magic on a subroutine call, forcing it to use default runtime behaviour.
13393 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13394 of a GV reference is modified. If a GV was examined and its CV slot was
13395 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13396 If the op is not optimised away, and the CV slot is later populated with
13397 a subroutine having a prototype, that flag eventually triggers the warning
13398 "called too early to check prototype".
13400 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13401 of returning a pointer to the subroutine it returns a pointer to the
13402 GV giving the most appropriate name for the subroutine in this context.
13403 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13404 (C<CvANON>) subroutine that is referenced through a GV it will be the
13405 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
13406 A null pointer is returned as usual if there is no statically-determinable
13412 /* shared by toke.c:yylex */
13414 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13416 PADNAME *name = PAD_COMPNAME(off);
13417 CV *compcv = PL_compcv;
13418 while (PadnameOUTER(name)) {
13419 assert(PARENT_PAD_INDEX(name));
13420 compcv = CvOUTSIDE(compcv);
13421 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13422 [off = PARENT_PAD_INDEX(name)];
13424 assert(!PadnameIsOUR(name));
13425 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13426 return PadnamePROTOCV(name);
13428 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13432 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13437 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13438 if (flags & ~RV2CVOPCV_FLAG_MASK)
13439 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13440 if (cvop->op_type != OP_RV2CV)
13442 if (cvop->op_private & OPpENTERSUB_AMPER)
13444 if (!(cvop->op_flags & OPf_KIDS))
13446 rvop = cUNOPx(cvop)->op_first;
13447 switch (rvop->op_type) {
13449 gv = cGVOPx_gv(rvop);
13451 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13452 cv = MUTABLE_CV(SvRV(gv));
13456 if (flags & RV2CVOPCV_RETURN_STUB)
13462 if (flags & RV2CVOPCV_MARK_EARLY)
13463 rvop->op_private |= OPpEARLY_CV;
13468 SV *rv = cSVOPx_sv(rvop);
13471 cv = (CV*)SvRV(rv);
13475 cv = find_lexical_cv(rvop->op_targ);
13480 } NOT_REACHED; /* NOTREACHED */
13482 if (SvTYPE((SV*)cv) != SVt_PVCV)
13484 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13485 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13489 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13490 if (CvLEXICAL(cv) || CvNAMED(cv))
13492 if (!CvANON(cv) || !gv)
13502 =for apidoc ck_entersub_args_list
13504 Performs the default fixup of the arguments part of an C<entersub>
13505 op tree. This consists of applying list context to each of the
13506 argument ops. This is the standard treatment used on a call marked
13507 with C<&>, or a method call, or a call through a subroutine reference,
13508 or any other call where the callee can't be identified at compile time,
13509 or a call where the callee has no prototype.
13515 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13519 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13521 aop = cUNOPx(entersubop)->op_first;
13522 if (!OpHAS_SIBLING(aop))
13523 aop = cUNOPx(aop)->op_first;
13524 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13525 /* skip the extra attributes->import() call implicitly added in
13526 * something like foo(my $x : bar)
13528 if ( aop->op_type == OP_ENTERSUB
13529 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13533 op_lvalue(aop, OP_ENTERSUB);
13539 =for apidoc ck_entersub_args_proto
13541 Performs the fixup of the arguments part of an C<entersub> op tree
13542 based on a subroutine prototype. This makes various modifications to
13543 the argument ops, from applying context up to inserting C<refgen> ops,
13544 and checking the number and syntactic types of arguments, as directed by
13545 the prototype. This is the standard treatment used on a subroutine call,
13546 not marked with C<&>, where the callee can be identified at compile time
13547 and has a prototype.
13549 C<protosv> supplies the subroutine prototype to be applied to the call.
13550 It may be a normal defined scalar, of which the string value will be used.
13551 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13552 that has been cast to C<SV*>) which has a prototype. The prototype
13553 supplied, in whichever form, does not need to match the actual callee
13554 referenced by the op tree.
13556 If the argument ops disagree with the prototype, for example by having
13557 an unacceptable number of arguments, a valid op tree is returned anyway.
13558 The error is reflected in the parser state, normally resulting in a single
13559 exception at the top level of parsing which covers all the compilation
13560 errors that occurred. In the error message, the callee is referred to
13561 by the name defined by the C<namegv> parameter.
13567 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13570 const char *proto, *proto_end;
13571 OP *aop, *prev, *cvop, *parent;
13574 I32 contextclass = 0;
13575 const char *e = NULL;
13576 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13577 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13578 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13579 "flags=%lx", (unsigned long) SvFLAGS(protosv));
13580 if (SvTYPE(protosv) == SVt_PVCV)
13581 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13582 else proto = SvPV(protosv, proto_len);
13583 proto = S_strip_spaces(aTHX_ proto, &proto_len);
13584 proto_end = proto + proto_len;
13585 parent = entersubop;
13586 aop = cUNOPx(entersubop)->op_first;
13587 if (!OpHAS_SIBLING(aop)) {
13589 aop = cUNOPx(aop)->op_first;
13592 aop = OpSIBLING(aop);
13593 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13594 while (aop != cvop) {
13597 if (proto >= proto_end)
13599 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13600 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13601 SVfARG(namesv)), SvUTF8(namesv));
13611 /* _ must be at the end */
13612 if (proto[1] && !strchr(";@%", proto[1]))
13628 if ( o3->op_type != OP_UNDEF
13629 && (o3->op_type != OP_SREFGEN
13630 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13632 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13634 bad_type_gv(arg, namegv, o3,
13635 arg == 1 ? "block or sub {}" : "sub {}");
13638 /* '*' allows any scalar type, including bareword */
13641 if (o3->op_type == OP_RV2GV)
13642 goto wrapref; /* autoconvert GLOB -> GLOBref */
13643 else if (o3->op_type == OP_CONST)
13644 o3->op_private &= ~OPpCONST_STRICT;
13650 if (o3->op_type == OP_RV2AV ||
13651 o3->op_type == OP_PADAV ||
13652 o3->op_type == OP_RV2HV ||
13653 o3->op_type == OP_PADHV
13659 case '[': case ']':
13666 switch (*proto++) {
13668 if (contextclass++ == 0) {
13669 e = (char *) memchr(proto, ']', proto_end - proto);
13670 if (!e || e == proto)
13678 if (contextclass) {
13679 const char *p = proto;
13680 const char *const end = proto;
13682 while (*--p != '[')
13683 /* \[$] accepts any scalar lvalue */
13685 && Perl_op_lvalue_flags(aTHX_
13687 OP_READ, /* not entersub */
13690 bad_type_gv(arg, namegv, o3,
13691 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13696 if (o3->op_type == OP_RV2GV)
13699 bad_type_gv(arg, namegv, o3, "symbol");
13702 if (o3->op_type == OP_ENTERSUB
13703 && !(o3->op_flags & OPf_STACKED))
13706 bad_type_gv(arg, namegv, o3, "subroutine");
13709 if (o3->op_type == OP_RV2SV ||
13710 o3->op_type == OP_PADSV ||
13711 o3->op_type == OP_HELEM ||
13712 o3->op_type == OP_AELEM)
13714 if (!contextclass) {
13715 /* \$ accepts any scalar lvalue */
13716 if (Perl_op_lvalue_flags(aTHX_
13718 OP_READ, /* not entersub */
13721 bad_type_gv(arg, namegv, o3, "scalar");
13725 if (o3->op_type == OP_RV2AV ||
13726 o3->op_type == OP_PADAV)
13728 o3->op_flags &=~ OPf_PARENS;
13732 bad_type_gv(arg, namegv, o3, "array");
13735 if (o3->op_type == OP_RV2HV ||
13736 o3->op_type == OP_PADHV)
13738 o3->op_flags &=~ OPf_PARENS;
13742 bad_type_gv(arg, namegv, o3, "hash");
13745 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13747 if (contextclass && e) {
13752 default: goto oops;
13762 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13763 SVfARG(cv_name((CV *)namegv, NULL, 0)),
13768 op_lvalue(aop, OP_ENTERSUB);
13770 aop = OpSIBLING(aop);
13772 if (aop == cvop && *proto == '_') {
13773 /* generate an access to $_ */
13774 op_sibling_splice(parent, prev, 0, newDEFSVOP());
13776 if (!optional && proto_end > proto &&
13777 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13779 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13780 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13781 SVfARG(namesv)), SvUTF8(namesv));
13787 =for apidoc ck_entersub_args_proto_or_list
13789 Performs the fixup of the arguments part of an C<entersub> op tree either
13790 based on a subroutine prototype or using default list-context processing.
13791 This is the standard treatment used on a subroutine call, not marked
13792 with C<&>, where the callee can be identified at compile time.
13794 C<protosv> supplies the subroutine prototype to be applied to the call,
13795 or indicates that there is no prototype. It may be a normal scalar,
13796 in which case if it is defined then the string value will be used
13797 as a prototype, and if it is undefined then there is no prototype.
13798 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13799 that has been cast to C<SV*>), of which the prototype will be used if it
13800 has one. The prototype (or lack thereof) supplied, in whichever form,
13801 does not need to match the actual callee referenced by the op tree.
13803 If the argument ops disagree with the prototype, for example by having
13804 an unacceptable number of arguments, a valid op tree is returned anyway.
13805 The error is reflected in the parser state, normally resulting in a single
13806 exception at the top level of parsing which covers all the compilation
13807 errors that occurred. In the error message, the callee is referred to
13808 by the name defined by the C<namegv> parameter.
13814 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13815 GV *namegv, SV *protosv)
13817 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13818 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13819 return ck_entersub_args_proto(entersubop, namegv, protosv);
13821 return ck_entersub_args_list(entersubop);
13825 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13827 IV cvflags = SvIVX(protosv);
13828 int opnum = cvflags & 0xffff;
13829 OP *aop = cUNOPx(entersubop)->op_first;
13831 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13835 if (!OpHAS_SIBLING(aop))
13836 aop = cUNOPx(aop)->op_first;
13837 aop = OpSIBLING(aop);
13838 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13840 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13841 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13842 SVfARG(namesv)), SvUTF8(namesv));
13845 op_free(entersubop);
13846 switch(cvflags >> 16) {
13847 case 'F': return newSVOP(OP_CONST, 0,
13848 newSVpv(CopFILE(PL_curcop),0));
13849 case 'L': return newSVOP(
13851 Perl_newSVpvf(aTHX_
13852 "%" IVdf, (IV)CopLINE(PL_curcop)
13855 case 'P': return newSVOP(OP_CONST, 0,
13857 ? newSVhek(HvNAME_HEK(PL_curstash))
13862 NOT_REACHED; /* NOTREACHED */
13865 OP *prev, *cvop, *first, *parent;
13868 parent = entersubop;
13869 if (!OpHAS_SIBLING(aop)) {
13871 aop = cUNOPx(aop)->op_first;
13874 first = prev = aop;
13875 aop = OpSIBLING(aop);
13876 /* find last sibling */
13878 OpHAS_SIBLING(cvop);
13879 prev = cvop, cvop = OpSIBLING(cvop))
13881 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13882 /* Usually, OPf_SPECIAL on an op with no args means that it had
13883 * parens, but these have their own meaning for that flag: */
13884 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13885 && opnum != OP_DELETE && opnum != OP_EXISTS)
13886 flags |= OPf_SPECIAL;
13887 /* excise cvop from end of sibling chain */
13888 op_sibling_splice(parent, prev, 1, NULL);
13890 if (aop == cvop) aop = NULL;
13892 /* detach remaining siblings from the first sibling, then
13893 * dispose of original optree */
13896 op_sibling_splice(parent, first, -1, NULL);
13897 op_free(entersubop);
13899 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13900 flags |= OPpEVAL_BYTES <<8;
13902 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13904 case OA_BASEOP_OR_UNOP:
13905 case OA_FILESTATOP:
13907 return newOP(opnum,flags); /* zero args */
13909 return newUNOP(opnum,flags,aop); /* one arg */
13910 /* too many args */
13917 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13918 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13919 SVfARG(namesv)), SvUTF8(namesv));
13921 nextop = OpSIBLING(aop);
13927 return opnum == OP_RUNCV
13928 ? newPVOP(OP_RUNCV,0,NULL)
13931 return op_convert_list(opnum,0,aop);
13934 NOT_REACHED; /* NOTREACHED */
13939 =for apidoc cv_get_call_checker_flags
13941 Retrieves the function that will be used to fix up a call to C<cv>.
13942 Specifically, the function is applied to an C<entersub> op tree for a
13943 subroutine call, not marked with C<&>, where the callee can be identified
13944 at compile time as C<cv>.
13946 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13947 for it is returned in C<*ckobj_p>, and control flags are returned in
13948 C<*ckflags_p>. The function is intended to be called in this manner:
13950 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13952 In this call, C<entersubop> is a pointer to the C<entersub> op,
13953 which may be replaced by the check function, and C<namegv> supplies
13954 the name that should be used by the check function to refer
13955 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13956 It is permitted to apply the check function in non-standard situations,
13957 such as to a call to a different subroutine or to a method call.
13959 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13960 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13961 instead, anything that can be used as the first argument to L</cv_name>.
13962 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13963 check function requires C<namegv> to be a genuine GV.
13965 By default, the check function is
13966 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13967 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13968 flag is clear. This implements standard prototype processing. It can
13969 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13971 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13972 indicates that the caller only knows about the genuine GV version of
13973 C<namegv>, and accordingly the corresponding bit will always be set in
13974 C<*ckflags_p>, regardless of the check function's recorded requirements.
13975 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13976 indicates the caller knows about the possibility of passing something
13977 other than a GV as C<namegv>, and accordingly the corresponding bit may
13978 be either set or clear in C<*ckflags_p>, indicating the check function's
13979 recorded requirements.
13981 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13982 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13983 (for which see above). All other bits should be clear.
13985 =for apidoc cv_get_call_checker
13987 The original form of L</cv_get_call_checker_flags>, which does not return
13988 checker flags. When using a checker function returned by this function,
13989 it is only safe to call it with a genuine GV as its C<namegv> argument.
13995 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13996 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13999 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14000 PERL_UNUSED_CONTEXT;
14001 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14003 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14004 *ckobj_p = callmg->mg_obj;
14005 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14007 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14008 *ckobj_p = (SV*)cv;
14009 *ckflags_p = gflags & MGf_REQUIRE_GV;
14014 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14017 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14018 PERL_UNUSED_CONTEXT;
14019 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14024 =for apidoc cv_set_call_checker_flags
14026 Sets the function that will be used to fix up a call to C<cv>.
14027 Specifically, the function is applied to an C<entersub> op tree for a
14028 subroutine call, not marked with C<&>, where the callee can be identified
14029 at compile time as C<cv>.
14031 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14032 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14033 The function should be defined like this:
14035 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14037 It is intended to be called in this manner:
14039 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14041 In this call, C<entersubop> is a pointer to the C<entersub> op,
14042 which may be replaced by the check function, and C<namegv> supplies
14043 the name that should be used by the check function to refer
14044 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14045 It is permitted to apply the check function in non-standard situations,
14046 such as to a call to a different subroutine or to a method call.
14048 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14049 CV or other SV instead. Whatever is passed can be used as the first
14050 argument to L</cv_name>. You can force perl to pass a GV by including
14051 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14053 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14054 bit currently has a defined meaning (for which see above). All other
14055 bits should be clear.
14057 The current setting for a particular CV can be retrieved by
14058 L</cv_get_call_checker_flags>.
14060 =for apidoc cv_set_call_checker
14062 The original form of L</cv_set_call_checker_flags>, which passes it the
14063 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14064 of that flag setting is that the check function is guaranteed to get a
14065 genuine GV as its C<namegv> argument.
14071 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14073 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14074 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14078 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14079 SV *ckobj, U32 ckflags)
14081 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14082 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14083 if (SvMAGICAL((SV*)cv))
14084 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14087 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14088 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14090 if (callmg->mg_flags & MGf_REFCOUNTED) {
14091 SvREFCNT_dec(callmg->mg_obj);
14092 callmg->mg_flags &= ~MGf_REFCOUNTED;
14094 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14095 callmg->mg_obj = ckobj;
14096 if (ckobj != (SV*)cv) {
14097 SvREFCNT_inc_simple_void_NN(ckobj);
14098 callmg->mg_flags |= MGf_REFCOUNTED;
14100 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14101 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14106 S_entersub_alloc_targ(pTHX_ OP * const o)
14108 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14109 o->op_private |= OPpENTERSUB_HASTARG;
14113 Perl_ck_subr(pTHX_ OP *o)
14118 SV **const_class = NULL;
14120 PERL_ARGS_ASSERT_CK_SUBR;
14122 aop = cUNOPx(o)->op_first;
14123 if (!OpHAS_SIBLING(aop))
14124 aop = cUNOPx(aop)->op_first;
14125 aop = OpSIBLING(aop);
14126 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14127 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14128 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14130 o->op_private &= ~1;
14131 o->op_private |= (PL_hints & HINT_STRICT_REFS);
14132 if (PERLDB_SUB && PL_curstash != PL_debstash)
14133 o->op_private |= OPpENTERSUB_DB;
14134 switch (cvop->op_type) {
14136 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14140 case OP_METHOD_NAMED:
14141 case OP_METHOD_SUPER:
14142 case OP_METHOD_REDIR:
14143 case OP_METHOD_REDIR_SUPER:
14144 o->op_flags |= OPf_REF;
14145 if (aop->op_type == OP_CONST) {
14146 aop->op_private &= ~OPpCONST_STRICT;
14147 const_class = &cSVOPx(aop)->op_sv;
14149 else if (aop->op_type == OP_LIST) {
14150 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
14151 if (sib && sib->op_type == OP_CONST) {
14152 sib->op_private &= ~OPpCONST_STRICT;
14153 const_class = &cSVOPx(sib)->op_sv;
14156 /* make class name a shared cow string to speedup method calls */
14157 /* constant string might be replaced with object, f.e. bigint */
14158 if (const_class && SvPOK(*const_class)) {
14160 const char* str = SvPV(*const_class, len);
14162 SV* const shared = newSVpvn_share(
14163 str, SvUTF8(*const_class)
14164 ? -(SSize_t)len : (SSize_t)len,
14167 if (SvREADONLY(*const_class))
14168 SvREADONLY_on(shared);
14169 SvREFCNT_dec(*const_class);
14170 *const_class = shared;
14177 S_entersub_alloc_targ(aTHX_ o);
14178 return ck_entersub_args_list(o);
14180 Perl_call_checker ckfun;
14183 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14184 if (CvISXSUB(cv) || !CvROOT(cv))
14185 S_entersub_alloc_targ(aTHX_ o);
14187 /* The original call checker API guarantees that a GV will be
14188 be provided with the right name. So, if the old API was
14189 used (or the REQUIRE_GV flag was passed), we have to reify
14190 the CV’s GV, unless this is an anonymous sub. This is not
14191 ideal for lexical subs, as its stringification will include
14192 the package. But it is the best we can do. */
14193 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14194 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14197 else namegv = MUTABLE_GV(cv);
14198 /* After a syntax error in a lexical sub, the cv that
14199 rv2cv_op_cv returns may be a nameless stub. */
14200 if (!namegv) return ck_entersub_args_list(o);
14203 return ckfun(aTHX_ o, namegv, ckobj);
14208 Perl_ck_svconst(pTHX_ OP *o)
14210 SV * const sv = cSVOPo->op_sv;
14211 PERL_ARGS_ASSERT_CK_SVCONST;
14212 PERL_UNUSED_CONTEXT;
14213 #ifdef PERL_COPY_ON_WRITE
14214 /* Since the read-only flag may be used to protect a string buffer, we
14215 cannot do copy-on-write with existing read-only scalars that are not
14216 already copy-on-write scalars. To allow $_ = "hello" to do COW with
14217 that constant, mark the constant as COWable here, if it is not
14218 already read-only. */
14219 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14222 # ifdef PERL_DEBUG_READONLY_COW
14232 Perl_ck_trunc(pTHX_ OP *o)
14234 PERL_ARGS_ASSERT_CK_TRUNC;
14236 if (o->op_flags & OPf_KIDS) {
14237 SVOP *kid = (SVOP*)cUNOPo->op_first;
14239 if (kid->op_type == OP_NULL)
14240 kid = (SVOP*)OpSIBLING(kid);
14241 if (kid && kid->op_type == OP_CONST &&
14242 (kid->op_private & OPpCONST_BARE) &&
14245 o->op_flags |= OPf_SPECIAL;
14246 kid->op_private &= ~OPpCONST_STRICT;
14253 Perl_ck_substr(pTHX_ OP *o)
14255 PERL_ARGS_ASSERT_CK_SUBSTR;
14258 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
14259 OP *kid = cLISTOPo->op_first;
14261 if (kid->op_type == OP_NULL)
14262 kid = OpSIBLING(kid);
14264 /* Historically, substr(delete $foo{bar},...) has been allowed
14265 with 4-arg substr. Keep it working by applying entersub
14267 op_lvalue(kid, OP_ENTERSUB);
14274 Perl_ck_tell(pTHX_ OP *o)
14276 PERL_ARGS_ASSERT_CK_TELL;
14278 if (o->op_flags & OPf_KIDS) {
14279 OP *kid = cLISTOPo->op_first;
14280 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
14281 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
14287 Perl_ck_each(pTHX_ OP *o)
14290 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
14291 const unsigned orig_type = o->op_type;
14293 PERL_ARGS_ASSERT_CK_EACH;
14296 switch (kid->op_type) {
14302 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
14303 : orig_type == OP_KEYS ? OP_AKEYS
14307 if (kid->op_private == OPpCONST_BARE
14308 || !SvROK(cSVOPx_sv(kid))
14309 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
14310 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
14315 qerror(Perl_mess(aTHX_
14316 "Experimental %s on scalar is now forbidden",
14317 PL_op_desc[orig_type]));
14319 bad_type_pv(1, "hash or array", o, kid);
14327 Perl_ck_length(pTHX_ OP *o)
14329 PERL_ARGS_ASSERT_CK_LENGTH;
14333 if (ckWARN(WARN_SYNTAX)) {
14334 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14338 const bool hash = kid->op_type == OP_PADHV
14339 || kid->op_type == OP_RV2HV;
14340 switch (kid->op_type) {
14345 name = S_op_varname(aTHX_ kid);
14351 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14352 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14354 SVfARG(name), hash ? "keys " : "", SVfARG(name)
14357 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14358 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14359 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14361 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14362 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14363 "length() used on @array (did you mean \"scalar(@array)\"?)");
14373 ---------------------------------------------------------
14375 Common vars in list assignment
14377 There now follows some enums and static functions for detecting
14378 common variables in list assignments. Here is a little essay I wrote
14379 for myself when trying to get my head around this. DAPM.
14383 First some random observations:
14385 * If a lexical var is an alias of something else, e.g.
14386 for my $x ($lex, $pkg, $a[0]) {...}
14387 then the act of aliasing will increase the reference count of the SV
14389 * If a package var is an alias of something else, it may still have a
14390 reference count of 1, depending on how the alias was created, e.g.
14391 in *a = *b, $a may have a refcount of 1 since the GP is shared
14392 with a single GvSV pointer to the SV. So If it's an alias of another
14393 package var, then RC may be 1; if it's an alias of another scalar, e.g.
14394 a lexical var or an array element, then it will have RC > 1.
14396 * There are many ways to create a package alias; ultimately, XS code
14397 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
14398 run-time tracing mechanisms are unlikely to be able to catch all cases.
14400 * When the LHS is all my declarations, the same vars can't appear directly
14401 on the RHS, but they can indirectly via closures, aliasing and lvalue
14402 subs. But those techniques all involve an increase in the lexical
14403 scalar's ref count.
14405 * When the LHS is all lexical vars (but not necessarily my declarations),
14406 it is possible for the same lexicals to appear directly on the RHS, and
14407 without an increased ref count, since the stack isn't refcounted.
14408 This case can be detected at compile time by scanning for common lex
14409 vars with PL_generation.
14411 * lvalue subs defeat common var detection, but they do at least
14412 return vars with a temporary ref count increment. Also, you can't
14413 tell at compile time whether a sub call is lvalue.
14418 A: There are a few circumstances where there definitely can't be any
14421 LHS empty: () = (...);
14422 RHS empty: (....) = ();
14423 RHS contains only constants or other 'can't possibly be shared'
14424 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
14425 i.e. they only contain ops not marked as dangerous, whose children
14426 are also not dangerous;
14428 LHS contains a single scalar element: e.g. ($x) = (....); because
14429 after $x has been modified, it won't be used again on the RHS;
14430 RHS contains a single element with no aggregate on LHS: e.g.
14431 ($a,$b,$c) = ($x); again, once $a has been modified, its value
14432 won't be used again.
14434 B: If LHS are all 'my' lexical var declarations (or safe ops, which
14437 my ($a, $b, @c) = ...;
14439 Due to closure and goto tricks, these vars may already have content.
14440 For the same reason, an element on the RHS may be a lexical or package
14441 alias of one of the vars on the left, or share common elements, for
14444 my ($x,$y) = f(); # $x and $y on both sides
14445 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14450 my @a = @$ra; # elements of @a on both sides
14451 sub f { @a = 1..4; \@a }
14454 First, just consider scalar vars on LHS:
14456 RHS is safe only if (A), or in addition,
14457 * contains only lexical *scalar* vars, where neither side's
14458 lexicals have been flagged as aliases
14460 If RHS is not safe, then it's always legal to check LHS vars for
14461 RC==1, since the only RHS aliases will always be associated
14464 Note that in particular, RHS is not safe if:
14466 * it contains package scalar vars; e.g.:
14469 my ($x, $y) = (2, $x_alias);
14470 sub f { $x = 1; *x_alias = \$x; }
14472 * It contains other general elements, such as flattened or
14473 * spliced or single array or hash elements, e.g.
14476 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14480 use feature 'refaliasing';
14481 \($a[0], $a[1]) = \($y,$x);
14484 It doesn't matter if the array/hash is lexical or package.
14486 * it contains a function call that happens to be an lvalue
14487 sub which returns one or more of the above, e.g.
14498 (so a sub call on the RHS should be treated the same
14499 as having a package var on the RHS).
14501 * any other "dangerous" thing, such an op or built-in that
14502 returns one of the above, e.g. pp_preinc
14505 If RHS is not safe, what we can do however is at compile time flag
14506 that the LHS are all my declarations, and at run time check whether
14507 all the LHS have RC == 1, and if so skip the full scan.
14509 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14511 Here the issue is whether there can be elements of @a on the RHS
14512 which will get prematurely freed when @a is cleared prior to
14513 assignment. This is only a problem if the aliasing mechanism
14514 is one which doesn't increase the refcount - only if RC == 1
14515 will the RHS element be prematurely freed.
14517 Because the array/hash is being INTROed, it or its elements
14518 can't directly appear on the RHS:
14520 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14522 but can indirectly, e.g.:
14526 sub f { @a = 1..3; \@a }
14528 So if the RHS isn't safe as defined by (A), we must always
14529 mortalise and bump the ref count of any remaining RHS elements
14530 when assigning to a non-empty LHS aggregate.
14532 Lexical scalars on the RHS aren't safe if they've been involved in
14535 use feature 'refaliasing';
14538 \(my $lex) = \$pkg;
14539 my @a = ($lex,3); # equivalent to ($a[0],3)
14546 Similarly with lexical arrays and hashes on the RHS:
14560 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14561 my $a; ($a, my $b) = (....);
14563 The difference between (B) and (C) is that it is now physically
14564 possible for the LHS vars to appear on the RHS too, where they
14565 are not reference counted; but in this case, the compile-time
14566 PL_generation sweep will detect such common vars.
14568 So the rules for (C) differ from (B) in that if common vars are
14569 detected, the runtime "test RC==1" optimisation can no longer be used,
14570 and a full mark and sweep is required
14572 D: As (C), but in addition the LHS may contain package vars.
14574 Since package vars can be aliased without a corresponding refcount
14575 increase, all bets are off. It's only safe if (A). E.g.
14577 my ($x, $y) = (1,2);
14579 for $x_alias ($x) {
14580 ($x_alias, $y) = (3, $x); # whoops
14583 Ditto for LHS aggregate package vars.
14585 E: Any other dangerous ops on LHS, e.g.
14586 (f(), $a[0], @$r) = (...);
14588 this is similar to (E) in that all bets are off. In addition, it's
14589 impossible to determine at compile time whether the LHS
14590 contains a scalar or an aggregate, e.g.
14592 sub f : lvalue { @a }
14595 * ---------------------------------------------------------
14599 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14600 * that at least one of the things flagged was seen.
14604 AAS_MY_SCALAR = 0x001, /* my $scalar */
14605 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
14606 AAS_LEX_SCALAR = 0x004, /* $lexical */
14607 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
14608 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14609 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
14610 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
14611 AAS_DANGEROUS = 0x080, /* an op (other than the above)
14612 that's flagged OA_DANGEROUS */
14613 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
14614 not in any of the categories above */
14615 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
14620 /* helper function for S_aassign_scan().
14621 * check a PAD-related op for commonality and/or set its generation number.
14622 * Returns a boolean indicating whether its shared */
14625 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14627 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14628 /* lexical used in aliasing */
14632 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14634 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14641 Helper function for OPpASSIGN_COMMON* detection in rpeep().
14642 It scans the left or right hand subtree of the aassign op, and returns a
14643 set of flags indicating what sorts of things it found there.
14644 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14645 set PL_generation on lexical vars; if the latter, we see if
14646 PL_generation matches.
14647 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14648 This fn will increment it by the number seen. It's not intended to
14649 be an accurate count (especially as many ops can push a variable
14650 number of SVs onto the stack); rather it's used as to test whether there
14651 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14655 S_aassign_scan(pTHX_ OP* o, bool rhs, int *scalars_p)
14658 OP *effective_top_op = o;
14662 bool top = o == effective_top_op;
14664 OP* next_kid = NULL;
14666 /* first, look for a solitary @_ on the RHS */
14669 && (o->op_flags & OPf_KIDS)
14670 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14672 OP *kid = cUNOPo->op_first;
14673 if ( ( kid->op_type == OP_PUSHMARK
14674 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14675 && ((kid = OpSIBLING(kid)))
14676 && !OpHAS_SIBLING(kid)
14677 && kid->op_type == OP_RV2AV
14678 && !(kid->op_flags & OPf_REF)
14679 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14680 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14681 && ((kid = cUNOPx(kid)->op_first))
14682 && kid->op_type == OP_GV
14683 && cGVOPx_gv(kid) == PL_defgv
14688 switch (o->op_type) {
14691 all_flags |= AAS_PKG_SCALAR;
14697 /* if !top, could be e.g. @a[0,1] */
14698 all_flags |= (top && (o->op_flags & OPf_REF))
14699 ? ((o->op_private & OPpLVAL_INTRO)
14700 ? AAS_MY_AGG : AAS_LEX_AGG)
14706 int comm = S_aassign_padcheck(aTHX_ o, rhs)
14707 ? AAS_LEX_SCALAR_COMM : 0;
14709 all_flags |= (o->op_private & OPpLVAL_INTRO)
14710 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14718 if (cUNOPx(o)->op_first->op_type != OP_GV)
14719 all_flags |= AAS_DANGEROUS; /* @{expr}, %{expr} */
14721 /* if !top, could be e.g. @a[0,1] */
14722 else if (top && (o->op_flags & OPf_REF))
14723 all_flags |= AAS_PKG_AGG;
14725 all_flags |= AAS_DANGEROUS;
14730 if (cUNOPx(o)->op_first->op_type != OP_GV) {
14732 all_flags |= AAS_DANGEROUS; /* ${expr} */
14735 all_flags |= AAS_PKG_SCALAR; /* $pkg */
14739 if (o->op_private & OPpSPLIT_ASSIGN) {
14740 /* the assign in @a = split() has been optimised away
14741 * and the @a attached directly to the split op
14742 * Treat the array as appearing on the RHS, i.e.
14743 * ... = (@a = split)
14748 if (o->op_flags & OPf_STACKED) {
14749 /* @{expr} = split() - the array expression is tacked
14750 * on as an extra child to split - process kid */
14751 next_kid = cLISTOPo->op_last;
14755 /* ... else array is directly attached to split op */
14757 all_flags |= (PL_op->op_private & OPpSPLIT_LEX)
14758 ? ((o->op_private & OPpLVAL_INTRO)
14759 ? AAS_MY_AGG : AAS_LEX_AGG)
14764 /* other args of split can't be returned */
14765 all_flags |= AAS_SAFE_SCALAR;
14769 /* undef counts as a scalar on the RHS:
14770 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
14771 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
14775 flags = AAS_SAFE_SCALAR;
14780 /* these are all no-ops; they don't push a potentially common SV
14781 * onto the stack, so they are neither AAS_DANGEROUS nor
14782 * AAS_SAFE_SCALAR */
14785 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14790 /* these do nothing, but may have children */
14794 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14796 flags = AAS_DANGEROUS;
14800 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
14801 && (o->op_private & OPpTARGET_MY))
14804 all_flags |= S_aassign_padcheck(aTHX_ o, rhs)
14805 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14809 /* if its an unrecognised, non-dangerous op, assume that it
14810 * it the cause of at least one safe scalar */
14812 flags = AAS_SAFE_SCALAR;
14816 all_flags |= flags;
14818 /* by default, process all kids next
14819 * XXX this assumes that all other ops are "transparent" - i.e. that
14820 * they can return some of their children. While this true for e.g.
14821 * sort and grep, it's not true for e.g. map. We really need a
14822 * 'transparent' flag added to regen/opcodes
14824 if (o->op_flags & OPf_KIDS) {
14825 next_kid = cUNOPo->op_first;
14826 /* these ops do nothing but may have children; but their
14827 * children should also be treated as top-level */
14828 if ( o == effective_top_op
14829 && (o->op_type == OP_NULL || o->op_type == OP_LIST)
14831 effective_top_op = next_kid;
14835 /* If next_kid is set, someone in the code above wanted us to process
14836 * that kid and all its remaining siblings. Otherwise, work our way
14837 * back up the tree */
14839 while (!next_kid) {
14841 return all_flags; /* at top; no parents/siblings to try */
14842 if (OpHAS_SIBLING(o)) {
14843 next_kid = o->op_sibparent;
14844 if (o == effective_top_op)
14845 effective_top_op = next_kid;
14848 if (o == effective_top_op)
14849 effective_top_op = o->op_sibparent;
14850 o = o->op_sibparent; /* try parent's next sibling */
14859 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14860 and modify the optree to make them work inplace */
14863 S_inplace_aassign(pTHX_ OP *o) {
14865 OP *modop, *modop_pushmark;
14867 OP *oleft, *oleft_pushmark;
14869 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14871 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14873 assert(cUNOPo->op_first->op_type == OP_NULL);
14874 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14875 assert(modop_pushmark->op_type == OP_PUSHMARK);
14876 modop = OpSIBLING(modop_pushmark);
14878 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14881 /* no other operation except sort/reverse */
14882 if (OpHAS_SIBLING(modop))
14885 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14886 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14888 if (modop->op_flags & OPf_STACKED) {
14889 /* skip sort subroutine/block */
14890 assert(oright->op_type == OP_NULL);
14891 oright = OpSIBLING(oright);
14894 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14895 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14896 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14897 oleft = OpSIBLING(oleft_pushmark);
14899 /* Check the lhs is an array */
14901 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14902 || OpHAS_SIBLING(oleft)
14903 || (oleft->op_private & OPpLVAL_INTRO)
14907 /* Only one thing on the rhs */
14908 if (OpHAS_SIBLING(oright))
14911 /* check the array is the same on both sides */
14912 if (oleft->op_type == OP_RV2AV) {
14913 if (oright->op_type != OP_RV2AV
14914 || !cUNOPx(oright)->op_first
14915 || cUNOPx(oright)->op_first->op_type != OP_GV
14916 || cUNOPx(oleft )->op_first->op_type != OP_GV
14917 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14918 cGVOPx_gv(cUNOPx(oright)->op_first)
14922 else if (oright->op_type != OP_PADAV
14923 || oright->op_targ != oleft->op_targ
14927 /* This actually is an inplace assignment */
14929 modop->op_private |= OPpSORT_INPLACE;
14931 /* transfer MODishness etc from LHS arg to RHS arg */
14932 oright->op_flags = oleft->op_flags;
14934 /* remove the aassign op and the lhs */
14936 op_null(oleft_pushmark);
14937 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14938 op_null(cUNOPx(oleft)->op_first);
14944 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14945 * that potentially represent a series of one or more aggregate derefs
14946 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14947 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14948 * additional ops left in too).
14950 * The caller will have already verified that the first few ops in the
14951 * chain following 'start' indicate a multideref candidate, and will have
14952 * set 'orig_o' to the point further on in the chain where the first index
14953 * expression (if any) begins. 'orig_action' specifies what type of
14954 * beginning has already been determined by the ops between start..orig_o
14955 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14957 * 'hints' contains any hints flags that need adding (currently just
14958 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14962 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14966 UNOP_AUX_item *arg_buf = NULL;
14967 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14968 int index_skip = -1; /* don't output index arg on this action */
14970 /* similar to regex compiling, do two passes; the first pass
14971 * determines whether the op chain is convertible and calculates the
14972 * buffer size; the second pass populates the buffer and makes any
14973 * changes necessary to ops (such as moving consts to the pad on
14974 * threaded builds).
14976 * NB: for things like Coverity, note that both passes take the same
14977 * path through the logic tree (except for 'if (pass)' bits), since
14978 * both passes are following the same op_next chain; and in
14979 * particular, if it would return early on the second pass, it would
14980 * already have returned early on the first pass.
14982 for (pass = 0; pass < 2; pass++) {
14984 UV action = orig_action;
14985 OP *first_elem_op = NULL; /* first seen aelem/helem */
14986 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14987 int action_count = 0; /* number of actions seen so far */
14988 int action_ix = 0; /* action_count % (actions per IV) */
14989 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14990 bool is_last = FALSE; /* no more derefs to follow */
14991 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14992 UNOP_AUX_item *arg = arg_buf;
14993 UNOP_AUX_item *action_ptr = arg_buf;
14996 action_ptr->uv = 0;
15000 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
15001 case MDEREF_HV_gvhv_helem:
15002 next_is_hash = TRUE;
15004 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
15005 case MDEREF_AV_gvav_aelem:
15007 #ifdef USE_ITHREADS
15008 arg->pad_offset = cPADOPx(start)->op_padix;
15009 /* stop it being swiped when nulled */
15010 cPADOPx(start)->op_padix = 0;
15012 arg->sv = cSVOPx(start)->op_sv;
15013 cSVOPx(start)->op_sv = NULL;
15019 case MDEREF_HV_padhv_helem:
15020 case MDEREF_HV_padsv_vivify_rv2hv_helem:
15021 next_is_hash = TRUE;
15023 case MDEREF_AV_padav_aelem:
15024 case MDEREF_AV_padsv_vivify_rv2av_aelem:
15026 arg->pad_offset = start->op_targ;
15027 /* we skip setting op_targ = 0 for now, since the intact
15028 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
15029 reset_start_targ = TRUE;
15034 case MDEREF_HV_pop_rv2hv_helem:
15035 next_is_hash = TRUE;
15037 case MDEREF_AV_pop_rv2av_aelem:
15041 NOT_REACHED; /* NOTREACHED */
15046 /* look for another (rv2av/hv; get index;
15047 * aelem/helem/exists/delele) sequence */
15052 UV index_type = MDEREF_INDEX_none;
15054 if (action_count) {
15055 /* if this is not the first lookup, consume the rv2av/hv */
15057 /* for N levels of aggregate lookup, we normally expect
15058 * that the first N-1 [ah]elem ops will be flagged as
15059 * /DEREF (so they autovivifiy if necessary), and the last
15060 * lookup op not to be.
15061 * For other things (like @{$h{k1}{k2}}) extra scope or
15062 * leave ops can appear, so abandon the effort in that
15064 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
15067 /* rv2av or rv2hv sKR/1 */
15069 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15070 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15071 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15074 /* at this point, we wouldn't expect any of these
15075 * possible private flags:
15076 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
15077 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
15079 ASSUME(!(o->op_private &
15080 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
15082 hints = (o->op_private & OPpHINT_STRICT_REFS);
15084 /* make sure the type of the previous /DEREF matches the
15085 * type of the next lookup */
15086 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
15089 action = next_is_hash
15090 ? MDEREF_HV_vivify_rv2hv_helem
15091 : MDEREF_AV_vivify_rv2av_aelem;
15095 /* if this is the second pass, and we're at the depth where
15096 * previously we encountered a non-simple index expression,
15097 * stop processing the index at this point */
15098 if (action_count != index_skip) {
15100 /* look for one or more simple ops that return an array
15101 * index or hash key */
15103 switch (o->op_type) {
15105 /* it may be a lexical var index */
15106 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
15107 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15108 ASSUME(!(o->op_private &
15109 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15111 if ( OP_GIMME(o,0) == G_SCALAR
15112 && !(o->op_flags & (OPf_REF|OPf_MOD))
15113 && o->op_private == 0)
15116 arg->pad_offset = o->op_targ;
15118 index_type = MDEREF_INDEX_padsv;
15124 if (next_is_hash) {
15125 /* it's a constant hash index */
15126 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
15127 /* "use constant foo => FOO; $h{+foo}" for
15128 * some weird FOO, can leave you with constants
15129 * that aren't simple strings. It's not worth
15130 * the extra hassle for those edge cases */
15135 OP * helem_op = o->op_next;
15137 ASSUME( helem_op->op_type == OP_HELEM
15138 || helem_op->op_type == OP_NULL
15140 if (helem_op->op_type == OP_HELEM) {
15141 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
15142 if ( helem_op->op_private & OPpLVAL_INTRO
15143 || rop->op_type != OP_RV2HV
15147 /* on first pass just check; on second pass
15149 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo,
15154 #ifdef USE_ITHREADS
15155 /* Relocate sv to the pad for thread safety */
15156 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
15157 arg->pad_offset = o->op_targ;
15160 arg->sv = cSVOPx_sv(o);
15165 /* it's a constant array index */
15167 SV *ix_sv = cSVOPo->op_sv;
15172 if ( action_count == 0
15175 && ( action == MDEREF_AV_padav_aelem
15176 || action == MDEREF_AV_gvav_aelem)
15178 maybe_aelemfast = TRUE;
15182 SvREFCNT_dec_NN(cSVOPo->op_sv);
15186 /* we've taken ownership of the SV */
15187 cSVOPo->op_sv = NULL;
15189 index_type = MDEREF_INDEX_const;
15194 /* it may be a package var index */
15196 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
15197 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
15198 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
15199 || o->op_private != 0
15204 if (kid->op_type != OP_RV2SV)
15207 ASSUME(!(kid->op_flags &
15208 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
15209 |OPf_SPECIAL|OPf_PARENS)));
15210 ASSUME(!(kid->op_private &
15212 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
15213 |OPpDEREF|OPpLVAL_INTRO)));
15214 if( (kid->op_flags &~ OPf_PARENS)
15215 != (OPf_WANT_SCALAR|OPf_KIDS)
15216 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
15221 #ifdef USE_ITHREADS
15222 arg->pad_offset = cPADOPx(o)->op_padix;
15223 /* stop it being swiped when nulled */
15224 cPADOPx(o)->op_padix = 0;
15226 arg->sv = cSVOPx(o)->op_sv;
15227 cSVOPo->op_sv = NULL;
15231 index_type = MDEREF_INDEX_gvsv;
15236 } /* action_count != index_skip */
15238 action |= index_type;
15241 /* at this point we have either:
15242 * * detected what looks like a simple index expression,
15243 * and expect the next op to be an [ah]elem, or
15244 * an nulled [ah]elem followed by a delete or exists;
15245 * * found a more complex expression, so something other
15246 * than the above follows.
15249 /* possibly an optimised away [ah]elem (where op_next is
15250 * exists or delete) */
15251 if (o->op_type == OP_NULL)
15254 /* at this point we're looking for an OP_AELEM, OP_HELEM,
15255 * OP_EXISTS or OP_DELETE */
15257 /* if a custom array/hash access checker is in scope,
15258 * abandon optimisation attempt */
15259 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
15260 && PL_check[o->op_type] != Perl_ck_null)
15262 /* similarly for customised exists and delete */
15263 if ( (o->op_type == OP_EXISTS)
15264 && PL_check[o->op_type] != Perl_ck_exists)
15266 if ( (o->op_type == OP_DELETE)
15267 && PL_check[o->op_type] != Perl_ck_delete)
15270 if ( o->op_type != OP_AELEM
15271 || (o->op_private &
15272 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
15274 maybe_aelemfast = FALSE;
15276 /* look for aelem/helem/exists/delete. If it's not the last elem
15277 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
15278 * flags; if it's the last, then it mustn't have
15279 * OPpDEREF_AV/HV, but may have lots of other flags, like
15280 * OPpLVAL_INTRO etc
15283 if ( index_type == MDEREF_INDEX_none
15284 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
15285 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
15289 /* we have aelem/helem/exists/delete with valid simple index */
15291 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
15292 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
15293 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
15295 /* This doesn't make much sense but is legal:
15296 * @{ local $x[0][0] } = 1
15297 * Since scope exit will undo the autovivification,
15298 * don't bother in the first place. The OP_LEAVE
15299 * assertion is in case there are other cases of both
15300 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
15301 * exit that would undo the local - in which case this
15302 * block of code would need rethinking.
15304 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
15306 OP *n = o->op_next;
15307 while (n && ( n->op_type == OP_NULL
15308 || n->op_type == OP_LIST
15309 || n->op_type == OP_SCALAR))
15311 assert(n && n->op_type == OP_LEAVE);
15313 o->op_private &= ~OPpDEREF;
15318 ASSUME(!(o->op_flags &
15319 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
15320 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
15322 ok = (o->op_flags &~ OPf_PARENS)
15323 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
15324 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
15326 else if (o->op_type == OP_EXISTS) {
15327 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15328 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15329 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
15330 ok = !(o->op_private & ~OPpARG1_MASK);
15332 else if (o->op_type == OP_DELETE) {
15333 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15334 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
15335 ASSUME(!(o->op_private &
15336 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
15337 /* don't handle slices or 'local delete'; the latter
15338 * is fairly rare, and has a complex runtime */
15339 ok = !(o->op_private & ~OPpARG1_MASK);
15340 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
15341 /* skip handling run-tome error */
15342 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
15345 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
15346 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
15347 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
15348 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
15349 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
15350 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
15355 if (!first_elem_op)
15359 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
15364 action |= MDEREF_FLAG_last;
15368 /* at this point we have something that started
15369 * promisingly enough (with rv2av or whatever), but failed
15370 * to find a simple index followed by an
15371 * aelem/helem/exists/delete. If this is the first action,
15372 * give up; but if we've already seen at least one
15373 * aelem/helem, then keep them and add a new action with
15374 * MDEREF_INDEX_none, which causes it to do the vivify
15375 * from the end of the previous lookup, and do the deref,
15376 * but stop at that point. So $a[0][expr] will do one
15377 * av_fetch, vivify and deref, then continue executing at
15382 index_skip = action_count;
15383 action |= MDEREF_FLAG_last;
15384 if (index_type != MDEREF_INDEX_none)
15389 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
15392 /* if there's no space for the next action, create a new slot
15393 * for it *before* we start adding args for that action */
15394 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
15401 } /* while !is_last */
15409 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
15410 if (index_skip == -1) {
15411 mderef->op_flags = o->op_flags
15412 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
15413 if (o->op_type == OP_EXISTS)
15414 mderef->op_private = OPpMULTIDEREF_EXISTS;
15415 else if (o->op_type == OP_DELETE)
15416 mderef->op_private = OPpMULTIDEREF_DELETE;
15418 mderef->op_private = o->op_private
15419 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
15421 /* accumulate strictness from every level (although I don't think
15422 * they can actually vary) */
15423 mderef->op_private |= hints;
15425 /* integrate the new multideref op into the optree and the
15428 * In general an op like aelem or helem has two child
15429 * sub-trees: the aggregate expression (a_expr) and the
15430 * index expression (i_expr):
15436 * The a_expr returns an AV or HV, while the i-expr returns an
15437 * index. In general a multideref replaces most or all of a
15438 * multi-level tree, e.g.
15454 * With multideref, all the i_exprs will be simple vars or
15455 * constants, except that i_expr1 may be arbitrary in the case
15456 * of MDEREF_INDEX_none.
15458 * The bottom-most a_expr will be either:
15459 * 1) a simple var (so padXv or gv+rv2Xv);
15460 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
15461 * so a simple var with an extra rv2Xv;
15462 * 3) or an arbitrary expression.
15464 * 'start', the first op in the execution chain, will point to
15465 * 1),2): the padXv or gv op;
15466 * 3): the rv2Xv which forms the last op in the a_expr
15467 * execution chain, and the top-most op in the a_expr
15470 * For all cases, the 'start' node is no longer required,
15471 * but we can't free it since one or more external nodes
15472 * may point to it. E.g. consider
15473 * $h{foo} = $a ? $b : $c
15474 * Here, both the op_next and op_other branches of the
15475 * cond_expr point to the gv[*h] of the hash expression, so
15476 * we can't free the 'start' op.
15478 * For expr->[...], we need to save the subtree containing the
15479 * expression; for the other cases, we just need to save the
15481 * So in all cases, we null the start op and keep it around by
15482 * making it the child of the multideref op; for the expr->
15483 * case, the expr will be a subtree of the start node.
15485 * So in the simple 1,2 case the optree above changes to
15491 * ex-gv (or ex-padxv)
15493 * with the op_next chain being
15495 * -> ex-gv -> multideref -> op-following-ex-exists ->
15497 * In the 3 case, we have
15510 * -> rest-of-a_expr subtree ->
15511 * ex-rv2xv -> multideref -> op-following-ex-exists ->
15514 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15515 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15516 * multideref attached as the child, e.g.
15522 * ex-rv2av - i_expr1
15530 /* if we free this op, don't free the pad entry */
15531 if (reset_start_targ)
15532 start->op_targ = 0;
15535 /* Cut the bit we need to save out of the tree and attach to
15536 * the multideref op, then free the rest of the tree */
15538 /* find parent of node to be detached (for use by splice) */
15540 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
15541 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15543 /* there is an arbitrary expression preceding us, e.g.
15544 * expr->[..]? so we need to save the 'expr' subtree */
15545 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15546 p = cUNOPx(p)->op_first;
15547 ASSUME( start->op_type == OP_RV2AV
15548 || start->op_type == OP_RV2HV);
15551 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15552 * above for exists/delete. */
15553 while ( (p->op_flags & OPf_KIDS)
15554 && cUNOPx(p)->op_first != start
15556 p = cUNOPx(p)->op_first;
15558 ASSUME(cUNOPx(p)->op_first == start);
15560 /* detach from main tree, and re-attach under the multideref */
15561 op_sibling_splice(mderef, NULL, 0,
15562 op_sibling_splice(p, NULL, 1, NULL));
15565 start->op_next = mderef;
15567 mderef->op_next = index_skip == -1 ? o->op_next : o;
15569 /* excise and free the original tree, and replace with
15570 * the multideref op */
15571 p = op_sibling_splice(top_op, NULL, -1, mderef);
15580 Size_t size = arg - arg_buf;
15582 if (maybe_aelemfast && action_count == 1)
15585 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15586 sizeof(UNOP_AUX_item) * (size + 1));
15587 /* for dumping etc: store the length in a hidden first slot;
15588 * we set the op_aux pointer to the second slot */
15589 arg_buf->uv = size;
15592 } /* for (pass = ...) */
15595 /* See if the ops following o are such that o will always be executed in
15596 * boolean context: that is, the SV which o pushes onto the stack will
15597 * only ever be consumed by later ops via SvTRUE(sv) or similar.
15598 * If so, set a suitable private flag on o. Normally this will be
15599 * bool_flag; but see below why maybe_flag is needed too.
15601 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15602 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15603 * already be taken, so you'll have to give that op two different flags.
15605 * More explanation of 'maybe_flag' and 'safe_and' parameters.
15606 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15607 * those underlying ops) short-circuit, which means that rather than
15608 * necessarily returning a truth value, they may return the LH argument,
15609 * which may not be boolean. For example in $x = (keys %h || -1), keys
15610 * should return a key count rather than a boolean, even though its
15611 * sort-of being used in boolean context.
15613 * So we only consider such logical ops to provide boolean context to
15614 * their LH argument if they themselves are in void or boolean context.
15615 * However, sometimes the context isn't known until run-time. In this
15616 * case the op is marked with the maybe_flag flag it.
15618 * Consider the following.
15620 * sub f { ....; if (%h) { .... } }
15622 * This is actually compiled as
15624 * sub f { ....; %h && do { .... } }
15626 * Here we won't know until runtime whether the final statement (and hence
15627 * the &&) is in void context and so is safe to return a boolean value.
15628 * So mark o with maybe_flag rather than the bool_flag.
15629 * Note that there is cost associated with determining context at runtime
15630 * (e.g. a call to block_gimme()), so it may not be worth setting (at
15631 * compile time) and testing (at runtime) maybe_flag if the scalar verses
15632 * boolean costs savings are marginal.
15634 * However, we can do slightly better with && (compared to || and //):
15635 * this op only returns its LH argument when that argument is false. In
15636 * this case, as long as the op promises to return a false value which is
15637 * valid in both boolean and scalar contexts, we can mark an op consumed
15638 * by && with bool_flag rather than maybe_flag.
15639 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15640 * than &PL_sv_no for a false result in boolean context, then it's safe. An
15641 * op which promises to handle this case is indicated by setting safe_and
15646 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15651 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15653 /* OPpTARGET_MY and boolean context probably don't mix well.
15654 * If someone finds a valid use case, maybe add an extra flag to this
15655 * function which indicates its safe to do so for this op? */
15656 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
15657 && (o->op_private & OPpTARGET_MY)));
15662 switch (lop->op_type) {
15667 /* these two consume the stack argument in the scalar case,
15668 * and treat it as a boolean in the non linenumber case */
15671 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15672 || (lop->op_private & OPpFLIP_LINENUM))
15678 /* these never leave the original value on the stack */
15687 /* OR DOR and AND evaluate their arg as a boolean, but then may
15688 * leave the original scalar value on the stack when following the
15689 * op_next route. If not in void context, we need to ensure
15690 * that whatever follows consumes the arg only in boolean context
15702 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15706 else if (!(lop->op_flags & OPf_WANT)) {
15707 /* unknown context - decide at runtime */
15719 lop = lop->op_next;
15722 o->op_private |= flag;
15727 /* mechanism for deferring recursion in rpeep() */
15729 #define MAX_DEFERRED 4
15733 if (defer_ix == (MAX_DEFERRED-1)) { \
15734 OP **defer = defer_queue[defer_base]; \
15735 CALL_RPEEP(*defer); \
15736 S_prune_chain_head(defer); \
15737 defer_base = (defer_base + 1) % MAX_DEFERRED; \
15740 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15743 #define IS_AND_OP(o) (o->op_type == OP_AND)
15744 #define IS_OR_OP(o) (o->op_type == OP_OR)
15747 /* A peephole optimizer. We visit the ops in the order they're to execute.
15748 * See the comments at the top of this file for more details about when
15749 * peep() is called */
15752 Perl_rpeep(pTHX_ OP *o)
15756 OP* oldoldop = NULL;
15757 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15758 int defer_base = 0;
15761 if (!o || o->op_opt)
15764 assert(o->op_type != OP_FREED);
15768 SAVEVPTR(PL_curcop);
15769 for (;; o = o->op_next) {
15770 if (o && o->op_opt)
15773 while (defer_ix >= 0) {
15775 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15776 CALL_RPEEP(*defer);
15777 S_prune_chain_head(defer);
15784 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15785 assert(!oldoldop || oldoldop->op_next == oldop);
15786 assert(!oldop || oldop->op_next == o);
15788 /* By default, this op has now been optimised. A couple of cases below
15789 clear this again. */
15793 /* look for a series of 1 or more aggregate derefs, e.g.
15794 * $a[1]{foo}[$i]{$k}
15795 * and replace with a single OP_MULTIDEREF op.
15796 * Each index must be either a const, or a simple variable,
15798 * First, look for likely combinations of starting ops,
15799 * corresponding to (global and lexical variants of)
15801 * $r->[...] $r->{...}
15802 * (preceding expression)->[...]
15803 * (preceding expression)->{...}
15804 * and if so, call maybe_multideref() to do a full inspection
15805 * of the op chain and if appropriate, replace with an
15813 switch (o2->op_type) {
15815 /* $pkg[..] : gv[*pkg]
15816 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
15818 /* Fail if there are new op flag combinations that we're
15819 * not aware of, rather than:
15820 * * silently failing to optimise, or
15821 * * silently optimising the flag away.
15822 * If this ASSUME starts failing, examine what new flag
15823 * has been added to the op, and decide whether the
15824 * optimisation should still occur with that flag, then
15825 * update the code accordingly. This applies to all the
15826 * other ASSUMEs in the block of code too.
15828 ASSUME(!(o2->op_flags &
15829 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15830 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15834 if (o2->op_type == OP_RV2AV) {
15835 action = MDEREF_AV_gvav_aelem;
15839 if (o2->op_type == OP_RV2HV) {
15840 action = MDEREF_HV_gvhv_helem;
15844 if (o2->op_type != OP_RV2SV)
15847 /* at this point we've seen gv,rv2sv, so the only valid
15848 * construct left is $pkg->[] or $pkg->{} */
15850 ASSUME(!(o2->op_flags & OPf_STACKED));
15851 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15852 != (OPf_WANT_SCALAR|OPf_MOD))
15855 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15856 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15857 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15859 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
15860 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15864 if (o2->op_type == OP_RV2AV) {
15865 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15868 if (o2->op_type == OP_RV2HV) {
15869 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15875 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15877 ASSUME(!(o2->op_flags &
15878 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15879 if ((o2->op_flags &
15880 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15881 != (OPf_WANT_SCALAR|OPf_MOD))
15884 ASSUME(!(o2->op_private &
15885 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15886 /* skip if state or intro, or not a deref */
15887 if ( o2->op_private != OPpDEREF_AV
15888 && o2->op_private != OPpDEREF_HV)
15892 if (o2->op_type == OP_RV2AV) {
15893 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15896 if (o2->op_type == OP_RV2HV) {
15897 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15904 /* $lex[..]: padav[@lex:1,2] sR *
15905 * or $lex{..}: padhv[%lex:1,2] sR */
15906 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15907 OPf_REF|OPf_SPECIAL)));
15908 if ((o2->op_flags &
15909 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15910 != (OPf_WANT_SCALAR|OPf_REF))
15912 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15914 /* OPf_PARENS isn't currently used in this case;
15915 * if that changes, let us know! */
15916 ASSUME(!(o2->op_flags & OPf_PARENS));
15918 /* at this point, we wouldn't expect any of the remaining
15919 * possible private flags:
15920 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15921 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15923 * OPpSLICEWARNING shouldn't affect runtime
15925 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15927 action = o2->op_type == OP_PADAV
15928 ? MDEREF_AV_padav_aelem
15929 : MDEREF_HV_padhv_helem;
15931 S_maybe_multideref(aTHX_ o, o2, action, 0);
15937 action = o2->op_type == OP_RV2AV
15938 ? MDEREF_AV_pop_rv2av_aelem
15939 : MDEREF_HV_pop_rv2hv_helem;
15942 /* (expr)->[...]: rv2av sKR/1;
15943 * (expr)->{...}: rv2hv sKR/1; */
15945 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15947 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15948 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15949 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15952 /* at this point, we wouldn't expect any of these
15953 * possible private flags:
15954 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15955 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15957 ASSUME(!(o2->op_private &
15958 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15960 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15964 S_maybe_multideref(aTHX_ o, o2, action, hints);
15973 switch (o->op_type) {
15975 PL_curcop = ((COP*)o); /* for warnings */
15978 PL_curcop = ((COP*)o); /* for warnings */
15980 /* Optimise a "return ..." at the end of a sub to just be "...".
15981 * This saves 2 ops. Before:
15982 * 1 <;> nextstate(main 1 -e:1) v ->2
15983 * 4 <@> return K ->5
15984 * 2 <0> pushmark s ->3
15985 * - <1> ex-rv2sv sK/1 ->4
15986 * 3 <#> gvsv[*cat] s ->4
15989 * - <@> return K ->-
15990 * - <0> pushmark s ->2
15991 * - <1> ex-rv2sv sK/1 ->-
15992 * 2 <$> gvsv(*cat) s ->3
15995 OP *next = o->op_next;
15996 OP *sibling = OpSIBLING(o);
15997 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15998 && OP_TYPE_IS(sibling, OP_RETURN)
15999 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
16000 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
16001 ||OP_TYPE_IS(sibling->op_next->op_next,
16003 && cUNOPx(sibling)->op_first == next
16004 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
16007 /* Look through the PUSHMARK's siblings for one that
16008 * points to the RETURN */
16009 OP *top = OpSIBLING(next);
16010 while (top && top->op_next) {
16011 if (top->op_next == sibling) {
16012 top->op_next = sibling->op_next;
16013 o->op_next = next->op_next;
16016 top = OpSIBLING(top);
16021 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
16023 * This latter form is then suitable for conversion into padrange
16024 * later on. Convert:
16026 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
16030 * nextstate1 -> listop -> nextstate3
16032 * pushmark -> padop1 -> padop2
16034 if (o->op_next && (
16035 o->op_next->op_type == OP_PADSV
16036 || o->op_next->op_type == OP_PADAV
16037 || o->op_next->op_type == OP_PADHV
16039 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
16040 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
16041 && o->op_next->op_next->op_next && (
16042 o->op_next->op_next->op_next->op_type == OP_PADSV
16043 || o->op_next->op_next->op_next->op_type == OP_PADAV
16044 || o->op_next->op_next->op_next->op_type == OP_PADHV
16046 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
16047 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
16048 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
16049 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
16051 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
16054 ns2 = pad1->op_next;
16055 pad2 = ns2->op_next;
16056 ns3 = pad2->op_next;
16058 /* we assume here that the op_next chain is the same as
16059 * the op_sibling chain */
16060 assert(OpSIBLING(o) == pad1);
16061 assert(OpSIBLING(pad1) == ns2);
16062 assert(OpSIBLING(ns2) == pad2);
16063 assert(OpSIBLING(pad2) == ns3);
16065 /* excise and delete ns2 */
16066 op_sibling_splice(NULL, pad1, 1, NULL);
16069 /* excise pad1 and pad2 */
16070 op_sibling_splice(NULL, o, 2, NULL);
16072 /* create new listop, with children consisting of:
16073 * a new pushmark, pad1, pad2. */
16074 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
16075 newop->op_flags |= OPf_PARENS;
16076 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16078 /* insert newop between o and ns3 */
16079 op_sibling_splice(NULL, o, 0, newop);
16081 /*fixup op_next chain */
16082 newpm = cUNOPx(newop)->op_first; /* pushmark */
16083 o ->op_next = newpm;
16084 newpm->op_next = pad1;
16085 pad1 ->op_next = pad2;
16086 pad2 ->op_next = newop; /* listop */
16087 newop->op_next = ns3;
16089 /* Ensure pushmark has this flag if padops do */
16090 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
16091 newpm->op_flags |= OPf_MOD;
16097 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
16098 to carry two labels. For now, take the easier option, and skip
16099 this optimisation if the first NEXTSTATE has a label. */
16100 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
16101 OP *nextop = o->op_next;
16103 switch (nextop->op_type) {
16108 nextop = nextop->op_next;
16114 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
16117 oldop->op_next = nextop;
16119 /* Skip (old)oldop assignment since the current oldop's
16120 op_next already points to the next op. */
16127 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
16128 if (o->op_next->op_private & OPpTARGET_MY) {
16129 if (o->op_flags & OPf_STACKED) /* chained concats */
16130 break; /* ignore_optimization */
16132 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
16133 o->op_targ = o->op_next->op_targ;
16134 o->op_next->op_targ = 0;
16135 o->op_private |= OPpTARGET_MY;
16138 op_null(o->op_next);
16142 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
16143 break; /* Scalar stub must produce undef. List stub is noop */
16147 if (o->op_targ == OP_NEXTSTATE
16148 || o->op_targ == OP_DBSTATE)
16150 PL_curcop = ((COP*)o);
16152 /* XXX: We avoid setting op_seq here to prevent later calls
16153 to rpeep() from mistakenly concluding that optimisation
16154 has already occurred. This doesn't fix the real problem,
16155 though (See 20010220.007 (#5874)). AMS 20010719 */
16156 /* op_seq functionality is now replaced by op_opt */
16164 oldop->op_next = o->op_next;
16178 convert repeat into a stub with no kids.
16180 if (o->op_next->op_type == OP_CONST
16181 || ( o->op_next->op_type == OP_PADSV
16182 && !(o->op_next->op_private & OPpLVAL_INTRO))
16183 || ( o->op_next->op_type == OP_GV
16184 && o->op_next->op_next->op_type == OP_RV2SV
16185 && !(o->op_next->op_next->op_private
16186 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
16188 const OP *kid = o->op_next->op_next;
16189 if (o->op_next->op_type == OP_GV)
16190 kid = kid->op_next;
16191 /* kid is now the ex-list. */
16192 if (kid->op_type == OP_NULL
16193 && (kid = kid->op_next)->op_type == OP_CONST
16194 /* kid is now the repeat count. */
16195 && kid->op_next->op_type == OP_REPEAT
16196 && kid->op_next->op_private & OPpREPEAT_DOLIST
16197 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
16198 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
16201 o = kid->op_next; /* repeat */
16202 oldop->op_next = o;
16203 op_free(cBINOPo->op_first);
16204 op_free(cBINOPo->op_last );
16205 o->op_flags &=~ OPf_KIDS;
16206 /* stub is a baseop; repeat is a binop */
16207 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
16208 OpTYPE_set(o, OP_STUB);
16214 /* Convert a series of PAD ops for my vars plus support into a
16215 * single padrange op. Basically
16217 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
16219 * becomes, depending on circumstances, one of
16221 * padrange ----------------------------------> (list) -> rest
16222 * padrange --------------------------------------------> rest
16224 * where all the pad indexes are sequential and of the same type
16226 * We convert the pushmark into a padrange op, then skip
16227 * any other pad ops, and possibly some trailing ops.
16228 * Note that we don't null() the skipped ops, to make it
16229 * easier for Deparse to undo this optimisation (and none of
16230 * the skipped ops are holding any resourses). It also makes
16231 * it easier for find_uninit_var(), as it can just ignore
16232 * padrange, and examine the original pad ops.
16236 OP *followop = NULL; /* the op that will follow the padrange op */
16239 PADOFFSET base = 0; /* init only to stop compiler whining */
16240 bool gvoid = 0; /* init only to stop compiler whining */
16241 bool defav = 0; /* seen (...) = @_ */
16242 bool reuse = 0; /* reuse an existing padrange op */
16244 /* look for a pushmark -> gv[_] -> rv2av */
16249 if ( p->op_type == OP_GV
16250 && cGVOPx_gv(p) == PL_defgv
16251 && (rv2av = p->op_next)
16252 && rv2av->op_type == OP_RV2AV
16253 && !(rv2av->op_flags & OPf_REF)
16254 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
16255 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
16257 q = rv2av->op_next;
16258 if (q->op_type == OP_NULL)
16260 if (q->op_type == OP_PUSHMARK) {
16270 /* scan for PAD ops */
16272 for (p = p->op_next; p; p = p->op_next) {
16273 if (p->op_type == OP_NULL)
16276 if (( p->op_type != OP_PADSV
16277 && p->op_type != OP_PADAV
16278 && p->op_type != OP_PADHV
16280 /* any private flag other than INTRO? e.g. STATE */
16281 || (p->op_private & ~OPpLVAL_INTRO)
16285 /* let $a[N] potentially be optimised into AELEMFAST_LEX
16287 if ( p->op_type == OP_PADAV
16289 && p->op_next->op_type == OP_CONST
16290 && p->op_next->op_next
16291 && p->op_next->op_next->op_type == OP_AELEM
16295 /* for 1st padop, note what type it is and the range
16296 * start; for the others, check that it's the same type
16297 * and that the targs are contiguous */
16299 intro = (p->op_private & OPpLVAL_INTRO);
16301 gvoid = OP_GIMME(p,0) == G_VOID;
16304 if ((p->op_private & OPpLVAL_INTRO) != intro)
16306 /* Note that you'd normally expect targs to be
16307 * contiguous in my($a,$b,$c), but that's not the case
16308 * when external modules start doing things, e.g.
16309 * Function::Parameters */
16310 if (p->op_targ != base + count)
16312 assert(p->op_targ == base + count);
16313 /* Either all the padops or none of the padops should
16314 be in void context. Since we only do the optimisa-
16315 tion for av/hv when the aggregate itself is pushed
16316 on to the stack (one item), there is no need to dis-
16317 tinguish list from scalar context. */
16318 if (gvoid != (OP_GIMME(p,0) == G_VOID))
16322 /* for AV, HV, only when we're not flattening */
16323 if ( p->op_type != OP_PADSV
16325 && !(p->op_flags & OPf_REF)
16329 if (count >= OPpPADRANGE_COUNTMASK)
16332 /* there's a biggest base we can fit into a
16333 * SAVEt_CLEARPADRANGE in pp_padrange.
16334 * (The sizeof() stuff will be constant-folded, and is
16335 * intended to avoid getting "comparison is always false"
16336 * compiler warnings. See the comments above
16337 * MEM_WRAP_CHECK for more explanation on why we do this
16338 * in a weird way to avoid compiler warnings.)
16341 && (8*sizeof(base) >
16342 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
16344 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
16346 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
16350 /* Success! We've got another valid pad op to optimise away */
16352 followop = p->op_next;
16355 if (count < 1 || (count == 1 && !defav))
16358 /* pp_padrange in specifically compile-time void context
16359 * skips pushing a mark and lexicals; in all other contexts
16360 * (including unknown till runtime) it pushes a mark and the
16361 * lexicals. We must be very careful then, that the ops we
16362 * optimise away would have exactly the same effect as the
16364 * In particular in void context, we can only optimise to
16365 * a padrange if we see the complete sequence
16366 * pushmark, pad*v, ...., list
16367 * which has the net effect of leaving the markstack as it
16368 * was. Not pushing onto the stack (whereas padsv does touch
16369 * the stack) makes no difference in void context.
16373 if (followop->op_type == OP_LIST
16374 && OP_GIMME(followop,0) == G_VOID
16377 followop = followop->op_next; /* skip OP_LIST */
16379 /* consolidate two successive my(...);'s */
16382 && oldoldop->op_type == OP_PADRANGE
16383 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
16384 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
16385 && !(oldoldop->op_flags & OPf_SPECIAL)
16388 assert(oldoldop->op_next == oldop);
16389 assert( oldop->op_type == OP_NEXTSTATE
16390 || oldop->op_type == OP_DBSTATE);
16391 assert(oldop->op_next == o);
16394 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
16396 /* Do not assume pad offsets for $c and $d are con-
16401 if ( oldoldop->op_targ + old_count == base
16402 && old_count < OPpPADRANGE_COUNTMASK - count) {
16403 base = oldoldop->op_targ;
16404 count += old_count;
16409 /* if there's any immediately following singleton
16410 * my var's; then swallow them and the associated
16412 * my ($a,$b); my $c; my $d;
16414 * my ($a,$b,$c,$d);
16417 while ( ((p = followop->op_next))
16418 && ( p->op_type == OP_PADSV
16419 || p->op_type == OP_PADAV
16420 || p->op_type == OP_PADHV)
16421 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
16422 && (p->op_private & OPpLVAL_INTRO) == intro
16423 && !(p->op_private & ~OPpLVAL_INTRO)
16425 && ( p->op_next->op_type == OP_NEXTSTATE
16426 || p->op_next->op_type == OP_DBSTATE)
16427 && count < OPpPADRANGE_COUNTMASK
16428 && base + count == p->op_targ
16431 followop = p->op_next;
16439 assert(oldoldop->op_type == OP_PADRANGE);
16440 oldoldop->op_next = followop;
16441 oldoldop->op_private = (intro | count);
16447 /* Convert the pushmark into a padrange.
16448 * To make Deparse easier, we guarantee that a padrange was
16449 * *always* formerly a pushmark */
16450 assert(o->op_type == OP_PUSHMARK);
16451 o->op_next = followop;
16452 OpTYPE_set(o, OP_PADRANGE);
16454 /* bit 7: INTRO; bit 6..0: count */
16455 o->op_private = (intro | count);
16456 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
16457 | gvoid * OPf_WANT_VOID
16458 | (defav ? OPf_SPECIAL : 0));
16464 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16465 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16470 /*'keys %h' in void or scalar context: skip the OP_KEYS
16471 * and perform the functionality directly in the RV2HV/PADHV
16474 if (o->op_flags & OPf_REF) {
16475 OP *k = o->op_next;
16476 U8 want = (k->op_flags & OPf_WANT);
16478 && k->op_type == OP_KEYS
16479 && ( want == OPf_WANT_VOID
16480 || want == OPf_WANT_SCALAR)
16481 && !(k->op_private & OPpMAYBE_LVSUB)
16482 && !(k->op_flags & OPf_MOD)
16484 o->op_next = k->op_next;
16485 o->op_flags &= ~(OPf_REF|OPf_WANT);
16486 o->op_flags |= want;
16487 o->op_private |= (o->op_type == OP_PADHV ?
16488 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
16489 /* for keys(%lex), hold onto the OP_KEYS's targ
16490 * since padhv doesn't have its own targ to return
16492 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16497 /* see if %h is used in boolean context */
16498 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16499 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16502 if (o->op_type != OP_PADHV)
16506 if ( o->op_type == OP_PADAV
16507 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16509 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16512 /* Skip over state($x) in void context. */
16513 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16514 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16516 oldop->op_next = o->op_next;
16517 goto redo_nextstate;
16519 if (o->op_type != OP_PADAV)
16523 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16524 OP* const pop = (o->op_type == OP_PADAV) ?
16525 o->op_next : o->op_next->op_next;
16527 if (pop && pop->op_type == OP_CONST &&
16528 ((PL_op = pop->op_next)) &&
16529 pop->op_next->op_type == OP_AELEM &&
16530 !(pop->op_next->op_private &
16531 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16532 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16535 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16536 no_bareword_allowed(pop);
16537 if (o->op_type == OP_GV)
16538 op_null(o->op_next);
16539 op_null(pop->op_next);
16541 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16542 o->op_next = pop->op_next->op_next;
16543 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16544 o->op_private = (U8)i;
16545 if (o->op_type == OP_GV) {
16548 o->op_type = OP_AELEMFAST;
16551 o->op_type = OP_AELEMFAST_LEX;
16553 if (o->op_type != OP_GV)
16557 /* Remove $foo from the op_next chain in void context. */
16559 && ( o->op_next->op_type == OP_RV2SV
16560 || o->op_next->op_type == OP_RV2AV
16561 || o->op_next->op_type == OP_RV2HV )
16562 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16563 && !(o->op_next->op_private & OPpLVAL_INTRO))
16565 oldop->op_next = o->op_next->op_next;
16566 /* Reprocess the previous op if it is a nextstate, to
16567 allow double-nextstate optimisation. */
16569 if (oldop->op_type == OP_NEXTSTATE) {
16576 o = oldop->op_next;
16579 else if (o->op_next->op_type == OP_RV2SV) {
16580 if (!(o->op_next->op_private & OPpDEREF)) {
16581 op_null(o->op_next);
16582 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16584 o->op_next = o->op_next->op_next;
16585 OpTYPE_set(o, OP_GVSV);
16588 else if (o->op_next->op_type == OP_READLINE
16589 && o->op_next->op_next->op_type == OP_CONCAT
16590 && (o->op_next->op_next->op_flags & OPf_STACKED))
16592 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16593 OpTYPE_set(o, OP_RCATLINE);
16594 o->op_flags |= OPf_STACKED;
16595 op_null(o->op_next->op_next);
16596 op_null(o->op_next);
16607 while (cLOGOP->op_other->op_type == OP_NULL)
16608 cLOGOP->op_other = cLOGOP->op_other->op_next;
16609 while (o->op_next && ( o->op_type == o->op_next->op_type
16610 || o->op_next->op_type == OP_NULL))
16611 o->op_next = o->op_next->op_next;
16613 /* If we're an OR and our next is an AND in void context, we'll
16614 follow its op_other on short circuit, same for reverse.
16615 We can't do this with OP_DOR since if it's true, its return
16616 value is the underlying value which must be evaluated
16620 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16621 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16623 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16625 o->op_next = ((LOGOP*)o->op_next)->op_other;
16627 DEFER(cLOGOP->op_other);
16632 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16633 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16642 case OP_ARGDEFELEM:
16643 while (cLOGOP->op_other->op_type == OP_NULL)
16644 cLOGOP->op_other = cLOGOP->op_other->op_next;
16645 DEFER(cLOGOP->op_other);
16650 while (cLOOP->op_redoop->op_type == OP_NULL)
16651 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16652 while (cLOOP->op_nextop->op_type == OP_NULL)
16653 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16654 while (cLOOP->op_lastop->op_type == OP_NULL)
16655 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16656 /* a while(1) loop doesn't have an op_next that escapes the
16657 * loop, so we have to explicitly follow the op_lastop to
16658 * process the rest of the code */
16659 DEFER(cLOOP->op_lastop);
16663 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16664 DEFER(cLOGOPo->op_other);
16668 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16669 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16670 assert(!(cPMOP->op_pmflags & PMf_ONCE));
16671 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16672 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16673 cPMOP->op_pmstashstartu.op_pmreplstart
16674 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16675 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16681 if (o->op_flags & OPf_SPECIAL) {
16682 /* first arg is a code block */
16683 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16684 OP * kid = cUNOPx(nullop)->op_first;
16686 assert(nullop->op_type == OP_NULL);
16687 assert(kid->op_type == OP_SCOPE
16688 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16689 /* since OP_SORT doesn't have a handy op_other-style
16690 * field that can point directly to the start of the code
16691 * block, store it in the otherwise-unused op_next field
16692 * of the top-level OP_NULL. This will be quicker at
16693 * run-time, and it will also allow us to remove leading
16694 * OP_NULLs by just messing with op_nexts without
16695 * altering the basic op_first/op_sibling layout. */
16696 kid = kLISTOP->op_first;
16698 (kid->op_type == OP_NULL
16699 && ( kid->op_targ == OP_NEXTSTATE
16700 || kid->op_targ == OP_DBSTATE ))
16701 || kid->op_type == OP_STUB
16702 || kid->op_type == OP_ENTER
16703 || (PL_parser && PL_parser->error_count));
16704 nullop->op_next = kid->op_next;
16705 DEFER(nullop->op_next);
16708 /* check that RHS of sort is a single plain array */
16709 oright = cUNOPo->op_first;
16710 if (!oright || oright->op_type != OP_PUSHMARK)
16713 if (o->op_private & OPpSORT_INPLACE)
16716 /* reverse sort ... can be optimised. */
16717 if (!OpHAS_SIBLING(cUNOPo)) {
16718 /* Nothing follows us on the list. */
16719 OP * const reverse = o->op_next;
16721 if (reverse->op_type == OP_REVERSE &&
16722 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16723 OP * const pushmark = cUNOPx(reverse)->op_first;
16724 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16725 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16726 /* reverse -> pushmark -> sort */
16727 o->op_private |= OPpSORT_REVERSE;
16729 pushmark->op_next = oright->op_next;
16739 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16741 LISTOP *enter, *exlist;
16743 if (o->op_private & OPpSORT_INPLACE)
16746 enter = (LISTOP *) o->op_next;
16749 if (enter->op_type == OP_NULL) {
16750 enter = (LISTOP *) enter->op_next;
16754 /* for $a (...) will have OP_GV then OP_RV2GV here.
16755 for (...) just has an OP_GV. */
16756 if (enter->op_type == OP_GV) {
16757 gvop = (OP *) enter;
16758 enter = (LISTOP *) enter->op_next;
16761 if (enter->op_type == OP_RV2GV) {
16762 enter = (LISTOP *) enter->op_next;
16768 if (enter->op_type != OP_ENTERITER)
16771 iter = enter->op_next;
16772 if (!iter || iter->op_type != OP_ITER)
16775 expushmark = enter->op_first;
16776 if (!expushmark || expushmark->op_type != OP_NULL
16777 || expushmark->op_targ != OP_PUSHMARK)
16780 exlist = (LISTOP *) OpSIBLING(expushmark);
16781 if (!exlist || exlist->op_type != OP_NULL
16782 || exlist->op_targ != OP_LIST)
16785 if (exlist->op_last != o) {
16786 /* Mmm. Was expecting to point back to this op. */
16789 theirmark = exlist->op_first;
16790 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16793 if (OpSIBLING(theirmark) != o) {
16794 /* There's something between the mark and the reverse, eg
16795 for (1, reverse (...))
16800 ourmark = ((LISTOP *)o)->op_first;
16801 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16804 ourlast = ((LISTOP *)o)->op_last;
16805 if (!ourlast || ourlast->op_next != o)
16808 rv2av = OpSIBLING(ourmark);
16809 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16810 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16811 /* We're just reversing a single array. */
16812 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16813 enter->op_flags |= OPf_STACKED;
16816 /* We don't have control over who points to theirmark, so sacrifice
16818 theirmark->op_next = ourmark->op_next;
16819 theirmark->op_flags = ourmark->op_flags;
16820 ourlast->op_next = gvop ? gvop : (OP *) enter;
16823 enter->op_private |= OPpITER_REVERSED;
16824 iter->op_private |= OPpITER_REVERSED;
16828 o = oldop->op_next;
16830 NOT_REACHED; /* NOTREACHED */
16836 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16837 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16842 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16843 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16846 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16848 sv = newRV((SV *)PL_compcv);
16852 OpTYPE_set(o, OP_CONST);
16853 o->op_flags |= OPf_SPECIAL;
16854 cSVOPo->op_sv = sv;
16859 if (OP_GIMME(o,0) == G_VOID
16860 || ( o->op_next->op_type == OP_LINESEQ
16861 && ( o->op_next->op_next->op_type == OP_LEAVESUB
16862 || ( o->op_next->op_next->op_type == OP_RETURN
16863 && !CvLVALUE(PL_compcv)))))
16865 OP *right = cBINOP->op_first;
16884 OP *left = OpSIBLING(right);
16885 if (left->op_type == OP_SUBSTR
16886 && (left->op_private & 7) < 4) {
16888 /* cut out right */
16889 op_sibling_splice(o, NULL, 1, NULL);
16890 /* and insert it as second child of OP_SUBSTR */
16891 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16893 left->op_private |= OPpSUBSTR_REPL_FIRST;
16895 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16902 int l, r, lr, lscalars, rscalars;
16904 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16905 Note that we do this now rather than in newASSIGNOP(),
16906 since only by now are aliased lexicals flagged as such
16908 See the essay "Common vars in list assignment" above for
16909 the full details of the rationale behind all the conditions
16912 PL_generation sorcery:
16913 To detect whether there are common vars, the global var
16914 PL_generation is incremented for each assign op we scan.
16915 Then we run through all the lexical variables on the LHS,
16916 of the assignment, setting a spare slot in each of them to
16917 PL_generation. Then we scan the RHS, and if any lexicals
16918 already have that value, we know we've got commonality.
16919 Also, if the generation number is already set to
16920 PERL_INT_MAX, then the variable is involved in aliasing, so
16921 we also have potential commonality in that case.
16927 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, &lscalars);
16930 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, &rscalars);
16934 /* After looking for things which are *always* safe, this main
16935 * if/else chain selects primarily based on the type of the
16936 * LHS, gradually working its way down from the more dangerous
16937 * to the more restrictive and thus safer cases */
16939 if ( !l /* () = ....; */
16940 || !r /* .... = (); */
16941 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16942 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16943 || (lscalars < 2) /* ($x, undef) = ... */
16945 NOOP; /* always safe */
16947 else if (l & AAS_DANGEROUS) {
16948 /* always dangerous */
16949 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16950 o->op_private |= OPpASSIGN_COMMON_AGG;
16952 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16953 /* package vars are always dangerous - too many
16954 * aliasing possibilities */
16955 if (l & AAS_PKG_SCALAR)
16956 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16957 if (l & AAS_PKG_AGG)
16958 o->op_private |= OPpASSIGN_COMMON_AGG;
16960 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16961 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16963 /* LHS contains only lexicals and safe ops */
16965 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16966 o->op_private |= OPpASSIGN_COMMON_AGG;
16968 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16969 if (lr & AAS_LEX_SCALAR_COMM)
16970 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16971 else if ( !(l & AAS_LEX_SCALAR)
16972 && (r & AAS_DEFAV))
16976 * as scalar-safe for performance reasons.
16977 * (it will still have been marked _AGG if necessary */
16980 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16981 /* if there are only lexicals on the LHS and no
16982 * common ones on the RHS, then we assume that the
16983 * only way those lexicals could also get
16984 * on the RHS is via some sort of dereffing or
16987 * ($lex, $x) = (1, $$r)
16988 * and in this case we assume the var must have
16989 * a bumped ref count. So if its ref count is 1,
16990 * it must only be on the LHS.
16992 o->op_private |= OPpASSIGN_COMMON_RC1;
16997 * may have to handle aggregate on LHS, but we can't
16998 * have common scalars. */
17001 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
17003 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17004 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
17009 /* see if ref() is used in boolean context */
17010 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17011 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
17015 /* see if the op is used in known boolean context,
17016 * but not if OA_TARGLEX optimisation is enabled */
17017 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
17018 && !(o->op_private & OPpTARGET_MY)
17020 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17024 /* see if the op is used in known boolean context */
17025 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
17026 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
17030 Perl_cpeep_t cpeep =
17031 XopENTRYCUSTOM(o, xop_peep);
17033 cpeep(aTHX_ o, oldop);
17038 /* did we just null the current op? If so, re-process it to handle
17039 * eliding "empty" ops from the chain */
17040 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
17053 Perl_peep(pTHX_ OP *o)
17059 =head1 Custom Operators
17061 =for apidoc Perl_custom_op_xop
17062 Return the XOP structure for a given custom op. This macro should be
17063 considered internal to C<OP_NAME> and the other access macros: use them instead.
17064 This macro does call a function. Prior
17065 to 5.19.6, this was implemented as a
17072 /* use PERL_MAGIC_ext to call a function to free the xop structure when
17073 * freeing PL_custom_ops */
17076 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
17080 PERL_UNUSED_ARG(mg);
17081 xop = INT2PTR(XOP *, SvIV(sv));
17082 Safefree(xop->xop_name);
17083 Safefree(xop->xop_desc);
17089 static const MGVTBL custom_op_register_vtbl = {
17094 custom_op_register_free, /* free */
17104 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
17110 static const XOP xop_null = { 0, 0, 0, 0, 0 };
17112 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
17113 assert(o->op_type == OP_CUSTOM);
17115 /* This is wrong. It assumes a function pointer can be cast to IV,
17116 * which isn't guaranteed, but this is what the old custom OP code
17117 * did. In principle it should be safer to Copy the bytes of the
17118 * pointer into a PV: since the new interface is hidden behind
17119 * functions, this can be changed later if necessary. */
17120 /* Change custom_op_xop if this ever happens */
17121 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
17124 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17126 /* See if the op isn't registered, but its name *is* registered.
17127 * That implies someone is using the pre-5.14 API,where only name and
17128 * description could be registered. If so, fake up a real
17130 * We only check for an existing name, and assume no one will have
17131 * just registered a desc */
17132 if (!he && PL_custom_op_names &&
17133 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
17138 /* XXX does all this need to be shared mem? */
17139 Newxz(xop, 1, XOP);
17140 pv = SvPV(HeVAL(he), l);
17141 XopENTRY_set(xop, xop_name, savepvn(pv, l));
17142 if (PL_custom_op_descs &&
17143 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
17145 pv = SvPV(HeVAL(he), l);
17146 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
17148 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
17149 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
17150 /* add magic to the SV so that the xop struct (pointed to by
17151 * SvIV(sv)) is freed. Normally a static xop is registered, but
17152 * for this backcompat hack, we've alloced one */
17153 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
17154 &custom_op_register_vtbl, NULL, 0);
17159 xop = (XOP *)&xop_null;
17161 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
17165 if(field == XOPe_xop_ptr) {
17168 const U32 flags = XopFLAGS(xop);
17169 if(flags & field) {
17171 case XOPe_xop_name:
17172 any.xop_name = xop->xop_name;
17174 case XOPe_xop_desc:
17175 any.xop_desc = xop->xop_desc;
17177 case XOPe_xop_class:
17178 any.xop_class = xop->xop_class;
17180 case XOPe_xop_peep:
17181 any.xop_peep = xop->xop_peep;
17184 NOT_REACHED; /* NOTREACHED */
17189 case XOPe_xop_name:
17190 any.xop_name = XOPd_xop_name;
17192 case XOPe_xop_desc:
17193 any.xop_desc = XOPd_xop_desc;
17195 case XOPe_xop_class:
17196 any.xop_class = XOPd_xop_class;
17198 case XOPe_xop_peep:
17199 any.xop_peep = XOPd_xop_peep;
17202 NOT_REACHED; /* NOTREACHED */
17207 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
17208 * op.c: In function 'Perl_custom_op_get_field':
17209 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
17210 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
17211 * expands to assert(0), which expands to ((0) ? (void)0 :
17212 * __assert(...)), and gcc doesn't know that __assert can never return. */
17218 =for apidoc custom_op_register
17219 Register a custom op. See L<perlguts/"Custom Operators">.
17225 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
17229 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
17231 /* see the comment in custom_op_xop */
17232 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
17234 if (!PL_custom_ops)
17235 PL_custom_ops = newHV();
17237 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
17238 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
17243 =for apidoc core_prototype
17245 This function assigns the prototype of the named core function to C<sv>, or
17246 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
17247 C<NULL> if the core function has no prototype. C<code> is a code as returned
17248 by C<keyword()>. It must not be equal to 0.
17254 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
17257 int i = 0, n = 0, seen_question = 0, defgv = 0;
17259 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
17260 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
17261 bool nullret = FALSE;
17263 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
17267 if (!sv) sv = sv_newmortal();
17269 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
17271 switch (code < 0 ? -code : code) {
17272 case KEY_and : case KEY_chop: case KEY_chomp:
17273 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
17274 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
17275 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
17276 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
17277 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
17278 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
17279 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
17280 case KEY_x : case KEY_xor :
17281 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
17282 case KEY_glob: retsetpvs("_;", OP_GLOB);
17283 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
17284 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
17285 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
17286 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
17287 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
17289 case KEY_evalbytes:
17290 name = "entereval"; break;
17298 while (i < MAXO) { /* The slow way. */
17299 if (strEQ(name, PL_op_name[i])
17300 || strEQ(name, PL_op_desc[i]))
17302 if (nullret) { assert(opnum); *opnum = i; return NULL; }
17309 defgv = PL_opargs[i] & OA_DEFGV;
17310 oa = PL_opargs[i] >> OASHIFT;
17312 if (oa & OA_OPTIONAL && !seen_question && (
17313 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
17318 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
17319 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
17320 /* But globs are already references (kinda) */
17321 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
17325 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
17326 && !scalar_mod_type(NULL, i)) {
17331 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
17335 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
17336 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
17337 str[n-1] = '_'; defgv = 0;
17341 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
17343 sv_setpvn(sv, str, n - 1);
17344 if (opnum) *opnum = i;
17349 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
17352 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
17353 newSVOP(OP_COREARGS,0,coreargssv);
17356 PERL_ARGS_ASSERT_CORESUB_OP;
17360 return op_append_elem(OP_LINESEQ,
17363 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
17370 o = newUNOP(OP_AVHVSWITCH,0,argop);
17371 o->op_private = opnum-OP_EACH;
17373 case OP_SELECT: /* which represents OP_SSELECT as well */
17378 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
17379 newSVOP(OP_CONST, 0, newSVuv(1))
17381 coresub_op(newSVuv((UV)OP_SSELECT), 0,
17383 coresub_op(coreargssv, 0, OP_SELECT)
17387 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
17389 return op_append_elem(
17392 opnum == OP_WANTARRAY || opnum == OP_RUNCV
17393 ? OPpOFFBYONE << 8 : 0)
17395 case OA_BASEOP_OR_UNOP:
17396 if (opnum == OP_ENTEREVAL) {
17397 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
17398 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
17400 else o = newUNOP(opnum,0,argop);
17401 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
17404 if (is_handle_constructor(o, 1))
17405 argop->op_private |= OPpCOREARGS_DEREF1;
17406 if (scalar_mod_type(NULL, opnum))
17407 argop->op_private |= OPpCOREARGS_SCALARMOD;
17411 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
17412 if (is_handle_constructor(o, 2))
17413 argop->op_private |= OPpCOREARGS_DEREF2;
17414 if (opnum == OP_SUBSTR) {
17415 o->op_private |= OPpMAYBE_LVSUB;
17424 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
17425 SV * const *new_const_svp)
17427 const char *hvname;
17428 bool is_const = !!CvCONST(old_cv);
17429 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
17431 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
17433 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
17435 /* They are 2 constant subroutines generated from
17436 the same constant. This probably means that
17437 they are really the "same" proxy subroutine
17438 instantiated in 2 places. Most likely this is
17439 when a constant is exported twice. Don't warn.
17442 (ckWARN(WARN_REDEFINE)
17444 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
17445 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
17446 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
17447 strEQ(hvname, "autouse"))
17451 && ckWARN_d(WARN_REDEFINE)
17452 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
17455 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
17457 ? "Constant subroutine %" SVf " redefined"
17458 : "Subroutine %" SVf " redefined",
17463 =head1 Hook manipulation
17465 These functions provide convenient and thread-safe means of manipulating
17472 =for apidoc wrap_op_checker
17474 Puts a C function into the chain of check functions for a specified op
17475 type. This is the preferred way to manipulate the L</PL_check> array.
17476 C<opcode> specifies which type of op is to be affected. C<new_checker>
17477 is a pointer to the C function that is to be added to that opcode's
17478 check chain, and C<old_checker_p> points to the storage location where a
17479 pointer to the next function in the chain will be stored. The value of
17480 C<new_checker> is written into the L</PL_check> array, while the value
17481 previously stored there is written to C<*old_checker_p>.
17483 L</PL_check> is global to an entire process, and a module wishing to
17484 hook op checking may find itself invoked more than once per process,
17485 typically in different threads. To handle that situation, this function
17486 is idempotent. The location C<*old_checker_p> must initially (once
17487 per process) contain a null pointer. A C variable of static duration
17488 (declared at file scope, typically also marked C<static> to give
17489 it internal linkage) will be implicitly initialised appropriately,
17490 if it does not have an explicit initialiser. This function will only
17491 actually modify the check chain if it finds C<*old_checker_p> to be null.
17492 This function is also thread safe on the small scale. It uses appropriate
17493 locking to avoid race conditions in accessing L</PL_check>.
17495 When this function is called, the function referenced by C<new_checker>
17496 must be ready to be called, except for C<*old_checker_p> being unfilled.
17497 In a threading situation, C<new_checker> may be called immediately,
17498 even before this function has returned. C<*old_checker_p> will always
17499 be appropriately set before C<new_checker> is called. If C<new_checker>
17500 decides not to do anything special with an op that it is given (which
17501 is the usual case for most uses of op check hooking), it must chain the
17502 check function referenced by C<*old_checker_p>.
17504 Taken all together, XS code to hook an op checker should typically look
17505 something like this:
17507 static Perl_check_t nxck_frob;
17508 static OP *myck_frob(pTHX_ OP *op) {
17510 op = nxck_frob(aTHX_ op);
17515 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
17517 If you want to influence compilation of calls to a specific subroutine,
17518 then use L</cv_set_call_checker_flags> rather than hooking checking of
17519 all C<entersub> ops.
17525 Perl_wrap_op_checker(pTHX_ Optype opcode,
17526 Perl_check_t new_checker, Perl_check_t *old_checker_p)
17530 PERL_UNUSED_CONTEXT;
17531 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
17532 if (*old_checker_p) return;
17533 OP_CHECK_MUTEX_LOCK;
17534 if (!*old_checker_p) {
17535 *old_checker_p = PL_check[opcode];
17536 PL_check[opcode] = new_checker;
17538 OP_CHECK_MUTEX_UNLOCK;
17543 /* Efficient sub that returns a constant scalar value. */
17545 const_sv_xsub(pTHX_ CV* cv)
17548 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17549 PERL_UNUSED_ARG(items);
17559 const_av_xsub(pTHX_ CV* cv)
17562 AV * const av = MUTABLE_AV(XSANY.any_ptr);
17570 if (SvRMAGICAL(av))
17571 Perl_croak(aTHX_ "Magical list constants are not supported");
17572 if (GIMME_V != G_ARRAY) {
17574 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17577 EXTEND(SP, AvFILLp(av)+1);
17578 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17579 XSRETURN(AvFILLp(av)+1);
17582 /* Copy an existing cop->cop_warnings field.
17583 * If it's one of the standard addresses, just re-use the address.
17584 * This is the e implementation for the DUP_WARNINGS() macro
17588 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17591 STRLEN *new_warnings;
17593 if (warnings == NULL || specialWARN(warnings))
17596 size = sizeof(*warnings) + *warnings;
17598 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17599 Copy(warnings, new_warnings, size, char);
17600 return new_warnings;
17604 * ex: set ts=8 sts=4 sw=4 et: