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 and manipulate the OP
23 * structures that hold a compiled perl program.
25 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
28 * A Perl program is compiled into a tree of OP nodes. Each op contains:
29 * * structural OP pointers to its children and siblings (op_sibling,
30 * op_first etc) that define the tree structure;
31 * * execution order OP pointers (op_next, plus sometimes op_other,
32 * op_lastop etc) that define the execution sequence plus variants;
33 * * a pointer to the C "pp" function that would execute the op;
34 * * any data specific to that op.
35 * For example, an OP_CONST op points to the pp_const() function and to an
36 * SV containing the constant value. When pp_const() is executed, its job
37 * is to push that SV onto the stack.
39 * OPs are mainly created by the newFOO() functions, which are mainly
40 * called from the parser (in perly.y) as the code is parsed. For example
41 * the Perl code $a + $b * $c would cause the equivalent of the following
42 * to be called (oversimplifying a bit):
44 * newBINOP(OP_ADD, flags,
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
49 * As the parser reduces low-level rules, it creates little op subtrees;
50 * as higher-level rules are resolved, these subtrees get joined together
51 * as branches on a bigger subtree, until eventually a top-level rule like
52 * a subroutine definition is reduced, at which point there is one large
55 * The execution order pointers (op_next) are generated as the subtrees
56 * are joined together. Consider this sub-expression: A*B + C/D: at the
57 * point when it's just been parsed, the op tree looks like:
65 * with the intended execution order being:
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
69 * At this point all the nodes' op_next pointers will have been set,
71 * * we don't know what the [NEXT] node will be yet;
72 * * we don't know what the [PREV] node will be yet, but when it gets
73 * created and needs its op_next set, it needs to be set to point to
74 * A, which is non-obvious.
75 * To handle both those cases, we temporarily set the top node's
76 * op_next to point to the first node to be executed in this subtree (A in
77 * this case). This means that initially a subtree's op_next chain,
78 * starting from the top node, will visit each node in execution sequence
79 * then point back at the top node.
80 * When we embed this subtree in a larger tree, its top op_next is used
81 * to get the start node, then is set to point to its new neighbour.
82 * For example the two separate [*],A,B and [/],C,D subtrees would
84 * [*] => A; A => B; B => [*]
86 * [/] => C; C => D; D => [/]
87 * When these two subtrees were joined together to make the [+] subtree,
88 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89 * set to point to [/]'s op_next, i.e. C.
91 * This op_next linking is done by the LINKLIST() macro and its underlying
92 * op_linklist() function. Given a top-level op, if its op_next is
93 * non-null, it's already been linked, so leave it. Otherwise link it with
94 * its children as described above, possibly recursively if any of the
95 * children have a null op_next.
97 * In summary: given a subtree, its top-level node's op_next will either
99 * NULL: the subtree hasn't been LINKLIST()ed yet;
100 * fake: points to the start op for this subtree;
101 * real: once the subtree has been embedded into a larger tree
106 Here's an older description from Larry.
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
112 An execution-order pass
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines. The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order. (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again). As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node. But
130 it's still not the real execution order.
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer. At that point, we can call
135 into peep() to do that code's portion of the 3rd pass. It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140 get the compile time state of %^H for that block. Storing %^H in every
141 block (or even COP) would be very expensive, so a different approach is
142 taken. The (running) state of %^H is serialised into a tree of HE-like
143 structs. Stores into %^H are chained onto the current leaf as a struct
144 refcounted_he * with the key and the value. Deletes from %^H are saved
145 with a value of PL_sv_placeholder. The state of %^H at any point can be
146 turned back into a regular HV by walking back up the tree from that point's
147 leaf, ignoring any key you've already seen (placeholder or not), storing
148 the rest into the HV structure, then removing the placeholders. Hence
149 memory is only used to store the %^H deltas from the enclosing COP, rather
150 than the entire %^H on each COP.
152 To cause actions on %^H to write out the serialisation records, it has
153 magic type 'H'. This magic (itself) does nothing, but its presence causes
154 the values to gain magic type 'h', which has entries for set and clear.
155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158 it will be correctly restored when any inner compiling scope is exited.
164 #include "keywords.h"
167 #include "invlist_inline.h"
169 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
170 #define CALL_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 Perl_op_prune_chain_head(OP** op_p)
182 PERL_ARGS_ASSERT_OP_PRUNE_CHAIN_HEAD;
185 && ( (*op_p)->op_type == OP_NULL
186 || (*op_p)->op_type == OP_SCOPE
187 || (*op_p)->op_type == OP_SCALAR
188 || (*op_p)->op_type == OP_LINESEQ)
190 *op_p = (*op_p)->op_next;
194 /* See the explanatory comments above struct opslab in op.h. */
196 #ifdef PERL_DEBUG_READONLY_OPS
197 # define PERL_SLAB_SIZE 128
198 # define PERL_MAX_SLAB_SIZE 4096
199 # include <sys/mman.h>
202 #ifndef PERL_SLAB_SIZE
203 # define PERL_SLAB_SIZE 64
205 #ifndef PERL_MAX_SLAB_SIZE
206 # define PERL_MAX_SLAB_SIZE 2048
209 /* rounds up to nearest pointer */
210 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
213 (assert(((char *)(p) - (char *)(o)) % sizeof(I32**) == 0), \
214 ((size_t)((I32 **)(p) - (I32**)(o))))
216 /* requires double parens and aTHX_ */
217 #define DEBUG_S_warn(args) \
219 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
222 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
223 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OPSLOT)))
225 /* the number of bytes to allocate for a slab with sz * sizeof(I32 **) space for op */
226 #define OpSLABSizeBytes(sz) \
227 ((sz) * sizeof(I32 *) + STRUCT_OFFSET(OPSLAB, opslab_slots))
229 /* malloc a new op slab (suitable for attaching to PL_compcv).
230 * sz is in units of pointers from the beginning of opslab_opslots */
233 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
236 size_t sz_bytes = OpSLABSizeBytes(sz);
238 /* opslot_offset is only U16 */
239 assert(sz < U16_MAX);
240 /* room for at least one op */
241 assert(sz >= OPSLOT_SIZE_BASE);
243 #ifdef PERL_DEBUG_READONLY_OPS
244 slab = (OPSLAB *) mmap(0, sz_bytes,
245 PROT_READ|PROT_WRITE,
246 MAP_ANON|MAP_PRIVATE, -1, 0);
247 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
248 (unsigned long) sz, slab));
249 if (slab == MAP_FAILED) {
250 perror("mmap failed");
254 slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes);
255 Zero(slab, sz_bytes, char);
257 slab->opslab_size = (U16)sz;
260 /* The context is unused in non-Windows */
263 slab->opslab_free_space = sz;
264 slab->opslab_head = head ? head : slab;
265 DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
266 (unsigned int)slab->opslab_size, (void*)slab,
267 (void*)(slab->opslab_head)));
271 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
273 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
275 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
276 U16 sz = OpSLOT(o)->opslot_size;
277 U16 index = OPSLOT_SIZE_TO_INDEX(sz);
279 assert(sz >= OPSLOT_SIZE_BASE);
280 /* make sure the array is large enough to include ops this large */
281 if (!slab->opslab_freed) {
282 /* we don't have a free list array yet, make a new one */
283 slab->opslab_freed_size = index+1;
284 slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
286 if (!slab->opslab_freed)
289 else if (index >= slab->opslab_freed_size) {
290 /* It's probably not worth doing exponential expansion here, the number of op sizes
293 /* We already have a list that isn't large enough, expand it */
294 size_t newsize = index+1;
295 OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
300 Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
302 slab->opslab_freed = p;
303 slab->opslab_freed_size = newsize;
306 o->op_next = slab->opslab_freed[index];
307 slab->opslab_freed[index] = o;
310 /* Returns a sz-sized block of memory (suitable for holding an op) from
311 * a free slot in the chain of op slabs attached to PL_compcv.
312 * Allocates a new slab if necessary.
313 * if PL_compcv isn't compiling, malloc() instead.
317 Perl_Slab_Alloc(pTHX_ size_t sz)
319 OPSLAB *head_slab; /* first slab in the chain */
323 size_t sz_in_p; /* size in pointer units, including the OPSLOT header */
325 /* We only allocate ops from the slab during subroutine compilation.
326 We find the slab via PL_compcv, hence that must be non-NULL. It could
327 also be pointing to a subroutine which is now fully set up (CvROOT()
328 pointing to the top of the optree for that sub), or a subroutine
329 which isn't using the slab allocator. If our sanity checks aren't met,
330 don't use a slab, but allocate the OP directly from the heap. */
331 if (!PL_compcv || CvROOT(PL_compcv)
332 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
334 o = (OP*)PerlMemShared_calloc(1, sz);
338 /* While the subroutine is under construction, the slabs are accessed via
339 CvSTART(), to avoid needing to expand PVCV by one pointer for something
340 unneeded at runtime. Once a subroutine is constructed, the slabs are
341 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
342 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
344 if (!CvSTART(PL_compcv)) {
346 (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
347 CvSLABBED_on(PL_compcv);
348 head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
350 else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
352 sz_in_p = SIZE_TO_PSIZE(sz + OPSLOT_HEADER);
354 /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
355 will free up OPs, so it makes sense to re-use them where possible. A
356 freed up slot is used in preference to a new allocation. */
357 if (head_slab->opslab_freed &&
358 OPSLOT_SIZE_TO_INDEX(sz_in_p) < head_slab->opslab_freed_size) {
361 /* look for a large enough size with any freed ops */
362 for (base_index = OPSLOT_SIZE_TO_INDEX(sz_in_p);
363 base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
367 if (base_index < head_slab->opslab_freed_size) {
368 /* found a freed op */
369 o = head_slab->opslab_freed[base_index];
371 DEBUG_S_warn((aTHX_ "realloced op at %p, slab %p, head slab %p",
372 (void *)o, (void *)OpMySLAB(o), (void *)head_slab));
373 head_slab->opslab_freed[base_index] = o->op_next;
380 #define INIT_OPSLOT(s) \
381 slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ; \
382 slot->opslot_size = s; \
383 slab2->opslab_free_space -= s; \
384 o = &slot->opslot_op; \
387 /* The partially-filled slab is next in the chain. */
388 slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
389 if (slab2->opslab_free_space < sz_in_p) {
390 /* Remaining space is too small. */
391 /* If we can fit a BASEOP, add it to the free chain, so as not
393 if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) {
394 slot = &slab2->opslab_slots;
395 INIT_OPSLOT(slab2->opslab_free_space);
396 o->op_type = OP_FREED;
397 DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p",
398 (void *)o, (void *)slab2, (void *)head_slab));
399 link_freed_op(head_slab, o);
402 /* Create a new slab. Make this one twice as big. */
403 slab2 = S_new_slab(aTHX_ head_slab,
404 slab2->opslab_size > PERL_MAX_SLAB_SIZE / 2
406 : slab2->opslab_size * 2);
407 slab2->opslab_next = head_slab->opslab_next;
408 head_slab->opslab_next = slab2;
410 assert(slab2->opslab_size >= sz_in_p);
412 /* Create a new op slot */
413 slot = OpSLOToff(slab2, slab2->opslab_free_space - sz_in_p);
414 assert(slot >= &slab2->opslab_slots);
415 INIT_OPSLOT(sz_in_p);
416 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
417 (void*)o, (void*)slab2, (void*)head_slab));
420 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
421 assert(!o->op_moresib);
422 assert(!o->op_sibparent);
429 #ifdef PERL_DEBUG_READONLY_OPS
431 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
433 PERL_ARGS_ASSERT_SLAB_TO_RO;
435 if (slab->opslab_readonly) return;
436 slab->opslab_readonly = 1;
437 for (; slab; slab = slab->opslab_next) {
438 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
439 (unsigned long) slab->opslab_size, (void *)slab));*/
440 if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ))
441 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab,
442 (unsigned long)slab->opslab_size, errno);
447 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
451 PERL_ARGS_ASSERT_SLAB_TO_RW;
453 if (!slab->opslab_readonly) return;
455 for (; slab2; slab2 = slab2->opslab_next) {
456 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
457 (unsigned long) size, (void *)slab2));*/
458 if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size),
459 PROT_READ|PROT_WRITE)) {
460 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab,
461 (unsigned long)slab2->opslab_size, errno);
464 slab->opslab_readonly = 0;
468 # define Slab_to_rw(op) NOOP
471 /* make freed ops die if they're inadvertently executed */
476 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
481 /* Return the block of memory used by an op to the free list of
482 * the OP slab associated with that op.
486 Perl_Slab_Free(pTHX_ void *op)
488 OP * const o = (OP *)op;
491 PERL_ARGS_ASSERT_SLAB_FREE;
494 o->op_ppaddr = S_pp_freed;
497 if (!o->op_slabbed) {
499 PerlMemShared_free(op);
504 /* If this op is already freed, our refcount will get screwy. */
505 assert(o->op_type != OP_FREED);
506 o->op_type = OP_FREED;
507 link_freed_op(slab, o);
508 DEBUG_S_warn((aTHX_ "freeing op at %p, slab %p, head slab %p",
509 (void*)o, (void *)OpMySLAB(o), (void*)slab));
510 OpslabREFCNT_dec_padok(slab);
514 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
516 const bool havepad = cBOOL(PL_comppad);
517 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
520 PAD_SAVE_SETNULLPAD();
526 /* Free a chain of OP slabs. Should only be called after all ops contained
527 * in it have been freed. At this point, its reference count should be 1,
528 * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
529 * and just directly calls opslab_free().
530 * (Note that the reference count which PL_compcv held on the slab should
531 * have been removed once compilation of the sub was complete).
537 Perl_opslab_free(pTHX_ OPSLAB *slab)
540 PERL_ARGS_ASSERT_OPSLAB_FREE;
542 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
543 assert(slab->opslab_refcnt == 1);
544 PerlMemShared_free(slab->opslab_freed);
546 slab2 = slab->opslab_next;
548 slab->opslab_refcnt = ~(size_t)0;
550 #ifdef PERL_DEBUG_READONLY_OPS
551 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
553 if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) {
554 perror("munmap failed");
558 PerlMemShared_free(slab);
564 /* like opslab_free(), but first calls op_free() on any ops in the slab
565 * not marked as OP_FREED
569 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
573 size_t savestack_count = 0;
575 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
578 OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space);
579 OPSLOT *end = OpSLOToff(slab2, slab2->opslab_size);
581 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
583 if (slot->opslot_op.op_type != OP_FREED
584 && !(slot->opslot_op.op_savefree
590 assert(slot->opslot_op.op_slabbed);
591 op_free(&slot->opslot_op);
592 if (slab->opslab_refcnt == 1) goto free;
595 } while ((slab2 = slab2->opslab_next));
596 /* > 1 because the CV still holds a reference count. */
597 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
599 assert(savestack_count == slab->opslab_refcnt-1);
601 /* Remove the CV’s reference count. */
602 slab->opslab_refcnt--;
609 #ifdef PERL_DEBUG_READONLY_OPS
611 Perl_op_refcnt_inc(pTHX_ OP *o)
614 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
615 if (slab && slab->opslab_readonly) {
628 Perl_op_refcnt_dec(pTHX_ OP *o)
631 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
633 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
635 if (slab && slab->opslab_readonly) {
637 result = --o->op_targ;
640 result = --o->op_targ;
646 * In the following definition, the ", (OP*)0" is just to make the compiler
647 * think the expression is of the right type: croak actually does a Siglongjmp.
649 #define CHECKOP(type,o) \
650 ((PL_op_mask && PL_op_mask[type]) \
651 ? ( op_free((OP*)o), \
652 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
654 : PL_check[type](aTHX_ (OP*)o))
656 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
659 S_no_fh_allowed(pTHX_ OP *o)
661 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
663 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
669 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
671 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
672 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
677 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
679 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
681 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
686 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
688 PERL_ARGS_ASSERT_BAD_TYPE_PV;
690 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
691 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
695 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
697 SV * const namesv = cv_name((CV *)gv, NULL, 0);
698 PERL_ARGS_ASSERT_BAD_TYPE_GV;
700 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
701 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
705 Perl_no_bareword_allowed(pTHX_ OP *o)
707 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
709 qerror(Perl_mess(aTHX_
710 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
712 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
716 Perl_no_bareword_filehandle(pTHX_ const char *fhname) {
717 PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE;
719 if (strNE(fhname, "STDERR")
720 && strNE(fhname, "STDOUT")
721 && strNE(fhname, "STDIN")
722 && strNE(fhname, "_")
723 && strNE(fhname, "ARGV")
724 && strNE(fhname, "ARGVOUT")
725 && strNE(fhname, "DATA")) {
726 qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname));
730 /* "register" allocation */
733 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
736 bool is_idfirst, is_default;
737 const bool is_our = (PL_parser->in_my == KEY_our);
739 PERL_ARGS_ASSERT_ALLOCMY;
741 if (flags & ~SVf_UTF8)
742 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
745 is_idfirst = flags & SVf_UTF8
746 ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
747 : isIDFIRST_A(name[1]);
750 is_default = len == 2 && name[1] == '_';
752 /* complain about "my $<special_var>" etc etc */
753 if (!is_our && (!is_idfirst || is_default)) {
754 const char * const type =
755 PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
756 PL_parser->in_my == KEY_state ? "\"state\"" : "\"my\"";
758 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
760 && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
761 /* diag_listed_as: Can't use global %s in %s */
762 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
763 name[0], toCTRL(name[1]),
764 (int)(len - 2), name + 2,
767 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
769 type), flags & SVf_UTF8);
773 /* allocate a spare slot and store the name in that slot */
777 addflags |= padadd_OUR;
778 else if(PL_parser->in_my == KEY_state)
779 addflags |= padadd_STATE;
780 else if(PL_parser->in_my == KEY_field)
781 addflags |= padadd_FIELD;
783 off = pad_add_name_pvn(name, len, addflags,
784 PL_parser->in_my_stash,
786 /* $_ is always in main::, even with our */
787 ? (PL_curstash && !memEQs(name,len,"$_")
793 /* anon sub prototypes contains state vars should always be cloned,
794 * otherwise the state var would be shared between anon subs */
796 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
797 CvCLONE_on(PL_compcv);
803 =for apidoc_section $optree_manipulation
805 =for apidoc alloccopstash
807 Available only under threaded builds, this function allocates an entry in
808 C<PL_stashpad> for the stash passed to it.
815 Perl_alloccopstash(pTHX_ HV *hv)
817 PADOFFSET off = 0, o = 1;
818 bool found_slot = FALSE;
820 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
822 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
824 for (; o < PL_stashpadmax; ++o) {
825 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
826 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
827 found_slot = TRUE, off = o;
830 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
831 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
832 off = PL_stashpadmax;
833 PL_stashpadmax += 10;
836 PL_stashpad[PL_stashpadix = off] = hv;
841 /* free the body of an op without examining its contents.
842 * Always use this rather than FreeOp directly */
845 S_op_destroy(pTHX_ OP *o)
855 Free an op and its children. Only use this when an op is no longer linked
858 Remember that any op with C<OPf_KIDS> set is expected to have a valid
859 C<op_first> pointer. If you are attempting to free an op but preserve its
860 child op, make sure to clear that flag before calling C<op_free()>. For
863 OP *kid = o->op_first; o->op_first = NULL;
864 o->op_flags &= ~OPf_KIDS;
871 Perl_op_free(pTHX_ OP *o)
876 bool went_up = FALSE; /* whether we reached the current node by
877 following the parent pointer from a child, and
878 so have already seen this node */
880 if (!o || o->op_type == OP_FREED)
883 if (o->op_private & OPpREFCOUNTED) {
884 /* if base of tree is refcounted, just decrement */
885 switch (o->op_type) {
895 refcnt = OpREFCNT_dec(o);
898 /* Need to find and remove any pattern match ops from
899 * the list we maintain for reset(). */
900 find_and_forget_pmops(o);
913 /* free child ops before ourself, (then free ourself "on the
916 /* Ensure the caller maintains the relationship between OPf_KIDS and
917 * op_first != NULL when restructuring the tree
918 * https://github.com/Perl/perl5/issues/20764
920 assert(!(o->op_flags & OPf_KIDS) || cUNOPo->op_first);
922 if (!went_up && o->op_flags & OPf_KIDS) {
923 next_op = cUNOPo->op_first;
927 /* find the next node to visit, *then* free the current node
928 * (can't rely on o->op_* fields being valid after o has been
931 /* The next node to visit will be either the sibling, or the
932 * parent if no siblings left, or NULL if we've worked our way
933 * back up to the top node in the tree */
934 next_op = (o == top_op) ? NULL : o->op_sibparent;
935 went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
937 /* Now process the current node */
939 /* Though ops may be freed twice, freeing the op after its slab is a
941 assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
942 /* During the forced freeing of ops after compilation failure, kidops
943 may be freed before their parents. */
944 if (!o || o->op_type == OP_FREED)
949 /* an op should only ever acquire op_private flags that we know about.
950 * If this fails, you may need to fix something in regen/op_private.
951 * Don't bother testing if:
952 * * the op_ppaddr doesn't match the op; someone may have
953 * overridden the op and be doing strange things with it;
954 * * we've errored, as op flags are often left in an
955 * inconsistent state then. Note that an error when
956 * compiling the main program leaves PL_parser NULL, so
957 * we can't spot faults in the main code, only
958 * evaled/required code;
959 * * it's a banned op - we may be croaking before the op is
960 * fully formed. - see CHECKOP. */
962 if ( o->op_ppaddr == PL_ppaddr[type]
964 && !PL_parser->error_count
965 && !(PL_op_mask && PL_op_mask[type])
968 assert(!(o->op_private & ~PL_op_private_valid[type]));
973 /* Call the op_free hook if it has been set. Do it now so that it's called
974 * at the right time for refcounted ops, but still before all of the kids
979 type = (OPCODE)o->op_targ;
982 Slab_to_rw(OpSLAB(o));
984 /* COP* is not cleared by op_clear() so that we may track line
985 * numbers etc even after null() */
986 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
998 /* S_op_clear_gv(): free a GV attached to an OP */
1002 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
1004 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
1008 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
1009 || o->op_type == OP_MULTIDEREF)
1012 ? ((GV*)PAD_SVl(*ixp)) : NULL;
1014 ? (GV*)(*svp) : NULL;
1016 /* It's possible during global destruction that the GV is freed
1017 before the optree. Whilst the SvREFCNT_inc is happy to bump from
1018 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
1019 will trigger an assertion failure, because the entry to sv_clear
1020 checks that the scalar is not already freed. A check of for
1021 !SvIS_FREED(gv) turns out to be invalid, because during global
1022 destruction the reference count can be forced down to zero
1023 (with SVf_BREAK set). In which case raising to 1 and then
1024 dropping to 0 triggers cleanup before it should happen. I
1025 *think* that this might actually be a general, systematic,
1026 weakness of the whole idea of SVf_BREAK, in that code *is*
1027 allowed to raise and lower references during global destruction,
1028 so any *valid* code that happens to do this during global
1029 destruction might well trigger premature cleanup. */
1030 bool still_valid = gv && SvREFCNT(gv);
1033 SvREFCNT_inc_simple_void(gv);
1036 pad_swipe(*ixp, TRUE);
1044 int try_downgrade = SvREFCNT(gv) == 2;
1045 SvREFCNT_dec_NN(gv);
1047 gv_try_downgrade(gv);
1053 Perl_op_clear(pTHX_ OP *o)
1057 PERL_ARGS_ASSERT_OP_CLEAR;
1059 switch (o->op_type) {
1060 case OP_NULL: /* Was holding old type, if any. */
1063 case OP_ENTEREVAL: /* Was holding hints. */
1064 case OP_ARGDEFELEM: /* Was holding signature index. */
1068 if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1075 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1077 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1080 case OP_METHOD_REDIR:
1081 case OP_METHOD_REDIR_SUPER:
1083 if (cMETHOPo->op_rclass_targ) {
1084 pad_swipe(cMETHOPo->op_rclass_targ, 1);
1085 cMETHOPo->op_rclass_targ = 0;
1088 SvREFCNT_dec(cMETHOPo->op_rclass_sv);
1089 cMETHOPo->op_rclass_sv = NULL;
1092 case OP_METHOD_NAMED:
1093 case OP_METHOD_SUPER:
1094 SvREFCNT_dec(cMETHOPo->op_u.op_meth_sv);
1095 cMETHOPo->op_u.op_meth_sv = NULL;
1098 pad_swipe(o->op_targ, 1);
1105 SvREFCNT_dec(cSVOPo->op_sv);
1106 cSVOPo->op_sv = NULL;
1109 Even if op_clear does a pad_free for the target of the op,
1110 pad_free doesn't actually remove the sv that exists in the pad;
1111 instead it lives on. This results in that it could be reused as
1112 a target later on when the pad was reallocated.
1115 pad_swipe(o->op_targ,1);
1125 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1130 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1131 && (o->op_private & OPpTRANS_USE_SVOP))
1134 if (cPADOPo->op_padix > 0) {
1135 pad_swipe(cPADOPo->op_padix, TRUE);
1136 cPADOPo->op_padix = 0;
1139 SvREFCNT_dec(cSVOPo->op_sv);
1140 cSVOPo->op_sv = NULL;
1144 PerlMemShared_free(cPVOPo->op_pv);
1145 cPVOPo->op_pv = NULL;
1149 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1153 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1154 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1156 if (o->op_private & OPpSPLIT_LEX)
1157 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1160 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1162 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1169 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1170 op_free(cPMOPo->op_code_list);
1171 cPMOPo->op_code_list = NULL;
1172 forget_pmop(cPMOPo);
1173 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1174 /* we use the same protection as the "SAFE" version of the PM_ macros
1175 * here since sv_clean_all might release some PMOPs
1176 * after PL_regex_padav has been cleared
1177 * and the clearing of PL_regex_padav needs to
1178 * happen before sv_clean_all
1181 if(PL_regex_pad) { /* We could be in destruction */
1182 const IV offset = (cPMOPo)->op_pmoffset;
1183 ReREFCNT_dec(PM_GETRE(cPMOPo));
1184 PL_regex_pad[offset] = &PL_sv_undef;
1185 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1189 ReREFCNT_dec(PM_GETRE(cPMOPo));
1190 PM_SETRE(cPMOPo, NULL);
1196 PerlMemShared_free(cUNOP_AUXo->op_aux);
1199 case OP_MULTICONCAT:
1201 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1202 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1203 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1204 * utf8 shared strings */
1205 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1206 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1208 PerlMemShared_free(p1);
1210 PerlMemShared_free(p2);
1211 PerlMemShared_free(aux);
1217 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1218 UV actions = items->uv;
1220 bool is_hash = FALSE;
1223 switch (actions & MDEREF_ACTION_MASK) {
1226 actions = (++items)->uv;
1229 case MDEREF_HV_padhv_helem:
1232 case MDEREF_AV_padav_aelem:
1233 pad_free((++items)->pad_offset);
1236 case MDEREF_HV_gvhv_helem:
1239 case MDEREF_AV_gvav_aelem:
1241 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1243 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1247 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1250 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1252 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1254 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1256 goto do_vivify_rv2xv_elem;
1258 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1261 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1262 pad_free((++items)->pad_offset);
1263 goto do_vivify_rv2xv_elem;
1265 case MDEREF_HV_pop_rv2hv_helem:
1266 case MDEREF_HV_vivify_rv2hv_helem:
1269 do_vivify_rv2xv_elem:
1270 case MDEREF_AV_pop_rv2av_aelem:
1271 case MDEREF_AV_vivify_rv2av_aelem:
1273 switch (actions & MDEREF_INDEX_MASK) {
1274 case MDEREF_INDEX_none:
1277 case MDEREF_INDEX_const:
1281 pad_swipe((++items)->pad_offset, 1);
1283 SvREFCNT_dec((++items)->sv);
1289 case MDEREF_INDEX_padsv:
1290 pad_free((++items)->pad_offset);
1292 case MDEREF_INDEX_gvsv:
1294 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1296 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1301 if (actions & MDEREF_FLAG_last)
1314 actions >>= MDEREF_SHIFT;
1317 /* start of malloc is at op_aux[-1], where the length is
1319 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1325 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1326 /* Every item in aux is a UV, so nothing in it to free */
1333 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1334 /* Every item in aux is a UV, so nothing in it to free */
1340 if (o->op_targ > 0) {
1341 pad_free(o->op_targ);
1347 S_cop_free(pTHX_ COP* cop)
1349 PERL_ARGS_ASSERT_COP_FREE;
1351 /* If called during global destruction PL_defstash might be NULL and there
1352 shouldn't be any code running that will trip over the bad cop address.
1353 This also avoids uselessly creating the AV after it's been destroyed.
1355 if (cop->op_type == OP_DBSTATE && PL_phase != PERL_PHASE_DESTRUCT) {
1356 /* Remove the now invalid op from the line number information.
1357 This could cause a freed memory overwrite if the debugger tried to
1358 set a breakpoint on this line.
1360 AV *av = CopFILEAVn(cop);
1362 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
1363 if (svp && *svp != &PL_sv_undef && SvIVX(*svp) == PTR2IV(cop) ) {
1364 (void)SvIOK_off(*svp);
1370 if (! specialWARN(cop->cop_warnings))
1371 cop->cop_warnings = rcpv_free(cop->cop_warnings);
1373 cophh_free(CopHINTHASH_get(cop));
1374 if (PL_curcop == cop)
1379 S_forget_pmop(pTHX_ PMOP *const o)
1381 HV * const pmstash = PmopSTASH(o);
1383 PERL_ARGS_ASSERT_FORGET_PMOP;
1385 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1386 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1388 PMOP **const array = (PMOP**) mg->mg_ptr;
1389 U32 count = mg->mg_len / sizeof(PMOP**);
1393 if (array[i] == o) {
1394 /* Found it. Move the entry at the end to overwrite it. */
1395 array[i] = array[--count];
1396 mg->mg_len = count * sizeof(PMOP**);
1397 /* Could realloc smaller at this point always, but probably
1398 not worth it. Probably worth free()ing if we're the
1401 Safefree(mg->mg_ptr);
1415 S_find_and_forget_pmops(pTHX_ OP *o)
1419 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1422 switch (o->op_type) {
1427 forget_pmop(cPMOPo);
1430 if (o->op_flags & OPf_KIDS) {
1431 o = cUNOPo->op_first;
1437 return; /* at top; no parents/siblings to try */
1438 if (OpHAS_SIBLING(o)) {
1439 o = o->op_sibparent; /* process next sibling */
1442 o = o->op_sibparent; /*try parent's next sibling */
1451 Neutralizes an op when it is no longer needed, but is still linked to from
1458 Perl_op_null(pTHX_ OP *o)
1461 PERL_ARGS_ASSERT_OP_NULL;
1463 if (o->op_type == OP_NULL)
1466 o->op_targ = o->op_type;
1467 OpTYPE_set(o, OP_NULL);
1471 =for apidoc op_refcnt_lock
1473 Implements the C<OP_REFCNT_LOCK> macro which you should use instead.
1479 Perl_op_refcnt_lock(pTHX)
1480 PERL_TSA_ACQUIRE(PL_op_mutex)
1482 PERL_UNUSED_CONTEXT;
1487 =for apidoc op_refcnt_unlock
1489 Implements the C<OP_REFCNT_UNLOCK> macro which you should use instead.
1495 Perl_op_refcnt_unlock(pTHX)
1496 PERL_TSA_RELEASE(PL_op_mutex)
1498 PERL_UNUSED_CONTEXT;
1504 =for apidoc op_sibling_splice
1506 A general function for editing the structure of an existing chain of
1507 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1508 you to delete zero or more sequential nodes, replacing them with zero or
1509 more different nodes. Performs the necessary op_first/op_last
1510 housekeeping on the parent node and op_sibling manipulation on the
1511 children. The last deleted node will be marked as the last node by
1512 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1514 Note that op_next is not manipulated, and nodes are not freed; that is the
1515 responsibility of the caller. It also won't create a new list op for an
1516 empty list etc; use higher-level functions like op_append_elem() for that.
1518 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1519 the splicing doesn't affect the first or last op in the chain.
1521 C<start> is the node preceding the first node to be spliced. Node(s)
1522 following it will be deleted, and ops will be inserted after it. If it is
1523 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1526 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1527 If -1 or greater than or equal to the number of remaining kids, all
1528 remaining kids are deleted.
1530 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1531 If C<NULL>, no nodes are inserted.
1533 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1538 action before after returns
1539 ------ ----- ----- -------
1542 splice(P, A, 2, X-Y-Z) | | B-C
1546 splice(P, NULL, 1, X-Y) | | A
1550 splice(P, NULL, 3, NULL) | | A-B-C
1554 splice(P, B, 0, X-Y) | | NULL
1558 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1559 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1565 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1569 OP *last_del = NULL;
1570 OP *last_ins = NULL;
1573 first = OpSIBLING(start);
1577 first = cLISTOPx(parent)->op_first;
1579 assert(del_count >= -1);
1581 if (del_count && first) {
1583 while (--del_count && OpHAS_SIBLING(last_del))
1584 last_del = OpSIBLING(last_del);
1585 rest = OpSIBLING(last_del);
1586 OpLASTSIB_set(last_del, NULL);
1593 while (OpHAS_SIBLING(last_ins))
1594 last_ins = OpSIBLING(last_ins);
1595 OpMAYBESIB_set(last_ins, rest, NULL);
1601 OpMAYBESIB_set(start, insert, NULL);
1605 cLISTOPx(parent)->op_first = insert;
1607 parent->op_flags |= OPf_KIDS;
1609 parent->op_flags &= ~OPf_KIDS;
1613 /* update op_last etc */
1620 /* ought to use OP_CLASS(parent) here, but that can't handle
1621 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1623 type = parent->op_type;
1624 if (type == OP_CUSTOM) {
1626 type = XopENTRYCUSTOM(parent, xop_class);
1629 if (type == OP_NULL)
1630 type = parent->op_targ;
1631 type = PL_opargs[type] & OA_CLASS_MASK;
1634 lastop = last_ins ? last_ins : start ? start : NULL;
1635 if ( type == OA_BINOP
1636 || type == OA_LISTOP
1640 cLISTOPx(parent)->op_last = lastop;
1643 OpLASTSIB_set(lastop, parent);
1645 return last_del ? first : NULL;
1648 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1652 =for apidoc op_parent
1654 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1660 Perl_op_parent(OP *o)
1662 PERL_ARGS_ASSERT_OP_PARENT;
1663 while (OpHAS_SIBLING(o))
1665 return o->op_sibparent;
1668 /* replace the sibling following start with a new UNOP, which becomes
1669 * the parent of the original sibling; e.g.
1671 * op_sibling_newUNOP(P, A, unop-args...)
1679 * where U is the new UNOP.
1681 * parent and start args are the same as for op_sibling_splice();
1682 * type and flags args are as newUNOP().
1684 * Returns the new UNOP.
1688 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1692 kid = op_sibling_splice(parent, start, 1, NULL);
1693 newop = newUNOP(type, flags, kid);
1694 op_sibling_splice(parent, start, 0, newop);
1699 /* lowest-level newLOGOP-style function - just allocates and populates
1700 * the struct. Higher-level stuff should be done by S_new_logop() /
1701 * newLOGOP(). This function exists mainly to avoid op_first assignment
1702 * being spread throughout this file.
1706 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1710 NewOp(1101, logop, 1, LOGOP);
1711 OpTYPE_set(logop, type);
1712 logop->op_first = first;
1713 logop->op_other = other;
1715 logop->op_flags = OPf_KIDS;
1716 while (kid && OpHAS_SIBLING(kid))
1717 kid = OpSIBLING(kid);
1719 OpLASTSIB_set(kid, (OP*)logop);
1724 /* Contextualizers */
1727 =for apidoc op_contextualize
1729 Applies a syntactic context to an op tree representing an expression.
1730 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_LIST>,
1731 or C<G_VOID> to specify the context to apply. The modified op tree
1738 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1740 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1742 case G_SCALAR: return scalar(o);
1743 case G_LIST: return list(o);
1744 case G_VOID: return scalarvoid(o);
1746 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1753 =for apidoc op_linklist
1754 This function is the implementation of the L</LINKLIST> macro. It should
1755 not be called directly.
1762 Perl_op_linklist(pTHX_ OP *o)
1769 PERL_ARGS_ASSERT_OP_LINKLIST;
1772 /* Descend down the tree looking for any unprocessed subtrees to
1775 if (o->op_flags & OPf_KIDS) {
1776 o = cUNOPo->op_first;
1779 o->op_next = o; /* leaf node; link to self initially */
1782 /* if we're at the top level, there either weren't any children
1783 * to process, or we've worked our way back to the top. */
1787 /* o is now processed. Next, process any sibling subtrees */
1789 if (OpHAS_SIBLING(o)) {
1794 /* Done all the subtrees at this level. Go back up a level and
1795 * link the parent in with all its (processed) children.
1798 o = o->op_sibparent;
1799 assert(!o->op_next);
1800 prevp = &(o->op_next);
1801 kid = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1803 *prevp = kid->op_next;
1804 prevp = &(kid->op_next);
1805 kid = OpSIBLING(kid);
1813 S_scalarkids(pTHX_ OP *o)
1815 if (o && o->op_flags & OPf_KIDS) {
1817 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1824 S_scalarboolean(pTHX_ OP *o)
1826 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1828 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1829 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1830 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1831 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1832 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1833 if (ckWARN(WARN_SYNTAX)) {
1834 const line_t oldline = CopLINE(PL_curcop);
1836 if (PL_parser && PL_parser->copline != NOLINE) {
1837 /* This ensures that warnings are reported at the first line
1838 of the conditional, not the last. */
1839 CopLINE_set(PL_curcop, PL_parser->copline);
1841 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1842 CopLINE_set(PL_curcop, oldline);
1849 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1852 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1853 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1855 const char funny = o->op_type == OP_PADAV
1856 || o->op_type == OP_RV2AV ? '@' : '%';
1857 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1859 if (cUNOPo->op_first->op_type != OP_GV
1860 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1862 return varname(gv, funny, 0, NULL, 0, subscript_type);
1865 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1870 Perl_op_varname(pTHX_ const OP *o)
1872 PERL_ARGS_ASSERT_OP_VARNAME;
1874 return S_op_varname_subscript(aTHX_ o, 1);
1879 Warns that an access of a single element from a named container variable in
1880 scalar context might not be what the programmer wanted. The container
1881 variable's (sigiled, full) name is given by C<name>, and the key to access
1882 it is given by the C<SVOP_sv> of the C<OP_CONST> op given by C<o>.
1883 C<is_hash> selects whether it prints using {KEY} or [KEY] brackets.
1885 C<is_slice> selects between two different messages used in different places.
1888 Perl_warn_elem_scalar_context(pTHX_ const OP *o, SV *name, bool is_hash, bool is_slice)
1890 PERL_ARGS_ASSERT_WARN_ELEM_SCALAR_CONTEXT;
1893 const char *keypv = NULL;
1895 const char lbrack = is_hash ? '{' : '[';
1896 const char rbrack = is_hash ? '}' : ']';
1898 if (o->op_type == OP_CONST) {
1902 keysv = sv_newmortal();
1903 pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1904 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1906 else if (!SvOK(keysv))
1911 assert(SvPOK(name));
1912 sv_chop(name,SvPVX(name)+1);
1918 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1919 PERL_DIAG_WARN_SYNTAX(
1920 "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c") :
1921 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1922 PERL_DIAG_WARN_SYNTAX(
1923 "%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c");
1925 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1926 SVfARG(name), lbrack, keypv, rbrack,
1927 SVfARG(name), lbrack, keypv, rbrack);
1931 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1932 PERL_DIAG_WARN_SYNTAX(
1933 "Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c") :
1934 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1935 PERL_DIAG_WARN_SYNTAX(
1936 "%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c");
1938 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1939 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1940 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1945 /* apply scalar context to the o subtree */
1948 Perl_scalar(pTHX_ OP *o)
1953 OP *next_kid = NULL; /* what op (if any) to process next */
1956 /* assumes no premature commitment */
1957 if (!o || (PL_parser && PL_parser->error_count)
1958 || (o->op_flags & OPf_WANT)
1959 || o->op_type == OP_RETURN)
1964 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1966 switch (o->op_type) {
1968 scalar(cBINOPo->op_first);
1969 /* convert what initially looked like a list repeat into a
1970 * scalar repeat, e.g. $s = (1) x $n
1972 if (o->op_private & OPpREPEAT_DOLIST) {
1973 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1974 assert(kid->op_type == OP_PUSHMARK);
1975 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1976 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1977 o->op_private &=~ OPpREPEAT_DOLIST;
1985 /* impose scalar context on everything except the condition */
1986 next_kid = OpSIBLING(cUNOPo->op_first);
1990 if (o->op_flags & OPf_KIDS)
1991 next_kid = cUNOPo->op_first; /* do all kids */
1994 /* the children of these ops are usually a list of statements,
1995 * except the leaves, whose first child is a corresponding enter
2000 kid = cLISTOPo->op_first;
2004 kid = cLISTOPo->op_first;
2006 kid = OpSIBLING(kid);
2009 OP *sib = OpSIBLING(kid);
2010 /* Apply void context to all kids except the last, which
2011 * is scalar (ignoring a trailing ex-nextstate in determining
2012 * if it's the last kid). E.g.
2013 * $scalar = do { void; void; scalar }
2014 * Except that 'when's are always scalar, e.g.
2015 * $scalar = do { given(..) {
2016 * when (..) { scalar }
2017 * when (..) { scalar }
2022 || ( !OpHAS_SIBLING(sib)
2023 && sib->op_type == OP_NULL
2024 && ( sib->op_targ == OP_NEXTSTATE
2025 || sib->op_targ == OP_DBSTATE )
2029 /* tail call optimise calling scalar() on the last kid */
2033 else if (kid->op_type == OP_LEAVEWHEN)
2039 NOT_REACHED; /* NOTREACHED */
2043 Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), "Useless use of %s in scalar context", "sort");
2049 /* Warn about scalar context */
2052 /* This warning can be nonsensical when there is a syntax error. */
2053 if (PL_parser && PL_parser->error_count)
2056 if (!ckWARN(WARN_SYNTAX)) break;
2058 kid = cLISTOPo->op_first;
2059 kid = OpSIBLING(kid); /* get past pushmark */
2060 assert(OpSIBLING(kid));
2061 name = op_varname(OpSIBLING(kid));
2062 if (!name) /* XS module fiddling with the op tree */
2064 warn_elem_scalar_context(kid, name, o->op_type == OP_KVHSLICE, false);
2068 /* If next_kid is set, someone in the code above wanted us to process
2069 * that kid and all its remaining siblings. Otherwise, work our way
2070 * back up the tree */
2074 return top_op; /* at top; no parents/siblings to try */
2075 if (OpHAS_SIBLING(o))
2076 next_kid = o->op_sibparent;
2078 o = o->op_sibparent; /*try parent's next sibling */
2079 switch (o->op_type) {
2085 /* should really restore PL_curcop to its old value, but
2086 * setting it to PL_compiling is better than do nothing */
2087 PL_curcop = &PL_compiling;
2096 /* apply void context to the optree arg */
2099 Perl_scalarvoid(pTHX_ OP *arg)
2105 PERL_ARGS_ASSERT_SCALARVOID;
2109 SV *useless_sv = NULL;
2110 const char* useless = NULL;
2111 OP * next_kid = NULL;
2113 if (o->op_type == OP_NEXTSTATE
2114 || o->op_type == OP_DBSTATE
2115 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2116 || o->op_targ == OP_DBSTATE)))
2117 PL_curcop = (COP*)o; /* for warning below */
2119 /* assumes no premature commitment */
2120 want = o->op_flags & OPf_WANT;
2121 if ((want && want != OPf_WANT_SCALAR)
2122 || (PL_parser && PL_parser->error_count)
2123 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2128 if ((o->op_private & OPpTARGET_MY)
2129 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2131 /* newASSIGNOP has already applied scalar context, which we
2132 leave, as if this op is inside SASSIGN. */
2136 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2138 switch (o->op_type) {
2140 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2144 if (o->op_flags & OPf_STACKED)
2146 if (o->op_type == OP_REPEAT)
2147 scalar(cBINOPo->op_first);
2150 if ((o->op_flags & OPf_STACKED) &&
2151 !(o->op_private & OPpCONCAT_NESTED))
2155 if (o->op_private == 4)
2191 case OP_GETSOCKNAME:
2192 case OP_GETPEERNAME:
2197 case OP_GETPRIORITY:
2222 useless = OP_DESC(o);
2232 case OP_AELEMFAST_LEX:
2236 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2237 /* Otherwise it's "Useless use of grep iterator" */
2238 useless = OP_DESC(o);
2242 if (!(o->op_private & OPpSPLIT_ASSIGN))
2243 useless = OP_DESC(o);
2247 kid = cUNOPo->op_first;
2248 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2249 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2252 useless = "negative pattern binding (!~)";
2256 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2257 useless = "non-destructive substitution (s///r)";
2261 useless = "non-destructive transliteration (tr///r)";
2268 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2269 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2270 useless = "a variable";
2275 if (cSVOPo->op_private & OPpCONST_STRICT)
2276 no_bareword_allowed(o);
2278 if (ckWARN(WARN_VOID)) {
2280 /* don't warn on optimised away booleans, eg
2281 * use constant Foo, 5; Foo || print; */
2282 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2284 /* the constants 0 and 1 are permitted as they are
2285 conventionally used as dummies in constructs like
2286 1 while some_condition_with_side_effects; */
2287 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2289 else if (SvPOK(sv)) {
2290 SV * const dsv = newSVpvs("");
2292 = Perl_newSVpvf(aTHX_
2294 pv_pretty(dsv, SvPVX_const(sv),
2295 SvCUR(sv), 32, NULL, NULL,
2297 | PERL_PV_ESCAPE_NOCLEAR
2298 | PERL_PV_ESCAPE_UNI_DETECT));
2299 SvREFCNT_dec_NN(dsv);
2301 else if (SvOK(sv)) {
2302 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2305 useless = "a constant (undef)";
2308 op_null(o); /* don't execute or even remember it */
2312 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2316 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2320 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2324 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2329 UNOP *refgen, *rv2cv;
2332 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2335 rv2gv = cBINOPo->op_last;
2336 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2339 refgen = cUNOPx(cBINOPo->op_first);
2341 if (!refgen || (refgen->op_type != OP_REFGEN
2342 && refgen->op_type != OP_SREFGEN))
2345 exlist = cLISTOPx(refgen->op_first);
2346 if (!exlist || exlist->op_type != OP_NULL
2347 || exlist->op_targ != OP_LIST)
2350 if (exlist->op_first->op_type != OP_PUSHMARK
2351 && exlist->op_first != exlist->op_last)
2354 rv2cv = cUNOPx(exlist->op_last);
2356 if (rv2cv->op_type != OP_RV2CV)
2359 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2360 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2361 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2363 o->op_private |= OPpASSIGN_CV_TO_GV;
2364 rv2gv->op_private |= OPpDONT_INIT_GV;
2365 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2377 kid = cLOGOPo->op_first;
2378 if (kid->op_type == OP_NOT
2379 && (kid->op_flags & OPf_KIDS)) {
2380 if (o->op_type == OP_AND) {
2381 OpTYPE_set(o, OP_OR);
2383 OpTYPE_set(o, OP_AND);
2393 next_kid = OpSIBLING(cUNOPo->op_first);
2397 if (o->op_flags & OPf_STACKED)
2404 if (!(o->op_flags & OPf_KIDS))
2415 next_kid = cLISTOPo->op_first;
2418 /* If the first kid after pushmark is something that the padrange
2419 optimisation would reject, then null the list and the pushmark.
2421 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2422 && ( !(kid = OpSIBLING(kid))
2423 || ( kid->op_type != OP_PADSV
2424 && kid->op_type != OP_PADAV
2425 && kid->op_type != OP_PADHV)
2426 || kid->op_private & ~OPpLVAL_INTRO
2427 || !(kid = OpSIBLING(kid))
2428 || ( kid->op_type != OP_PADSV
2429 && kid->op_type != OP_PADAV
2430 && kid->op_type != OP_PADHV)
2431 || kid->op_private & ~OPpLVAL_INTRO)
2433 op_null(cUNOPo->op_first); /* NULL the pushmark */
2434 op_null(o); /* NULL the list */
2446 /* mortalise it, in case warnings are fatal. */
2447 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2448 "Useless use of %" SVf " in void context",
2449 SVfARG(sv_2mortal(useless_sv)));
2452 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2453 "Useless use of %s in void context",
2458 /* if a kid hasn't been nominated to process, continue with the
2459 * next sibling, or if no siblings left, go back to the parent's
2460 * siblings and so on
2464 return arg; /* at top; no parents/siblings to try */
2465 if (OpHAS_SIBLING(o))
2466 next_kid = o->op_sibparent;
2468 o = o->op_sibparent; /*try parent's next sibling */
2477 S_listkids(pTHX_ OP *o)
2479 if (o && o->op_flags & OPf_KIDS) {
2481 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2488 /* apply list context to the o subtree */
2491 Perl_list(pTHX_ OP *o)
2496 OP *next_kid = NULL; /* what op (if any) to process next */
2500 /* assumes no premature commitment */
2501 if (!o || (o->op_flags & OPf_WANT)
2502 || (PL_parser && PL_parser->error_count)
2503 || o->op_type == OP_RETURN)
2508 if ((o->op_private & OPpTARGET_MY)
2509 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2511 goto do_next; /* As if inside SASSIGN */
2514 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2516 switch (o->op_type) {
2518 if (o->op_private & OPpREPEAT_DOLIST
2519 && !(o->op_flags & OPf_STACKED))
2521 list(cBINOPo->op_first);
2522 kid = cBINOPo->op_last;
2523 /* optimise away (.....) x 1 */
2524 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2525 && SvIVX(kSVOP_sv) == 1)
2527 op_null(o); /* repeat */
2528 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2530 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2538 /* impose list context on everything except the condition */
2539 next_kid = OpSIBLING(cUNOPo->op_first);
2543 if (!(o->op_flags & OPf_KIDS))
2545 /* possibly flatten 1..10 into a constant array */
2546 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2547 list(cBINOPo->op_first);
2548 gen_constant_list(o);
2551 next_kid = cUNOPo->op_first; /* do all kids */
2555 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2556 op_null(cUNOPo->op_first); /* NULL the pushmark */
2557 op_null(o); /* NULL the list */
2559 if (o->op_flags & OPf_KIDS)
2560 next_kid = cUNOPo->op_first; /* do all kids */
2563 /* the children of these ops are usually a list of statements,
2564 * except the leaves, whose first child is a corresponding enter
2568 kid = cLISTOPo->op_first;
2572 kid = cLISTOPo->op_first;
2574 kid = OpSIBLING(kid);
2577 OP *sib = OpSIBLING(kid);
2578 /* Apply void context to all kids except the last, which
2580 * @a = do { void; void; list }
2581 * Except that 'when's are always list context, e.g.
2582 * @a = do { given(..) {
2583 * when (..) { list }
2584 * when (..) { list }
2589 /* tail call optimise calling list() on the last kid */
2593 else if (kid->op_type == OP_LEAVEWHEN)
2599 NOT_REACHED; /* NOTREACHED */
2604 /* If next_kid is set, someone in the code above wanted us to process
2605 * that kid and all its remaining siblings. Otherwise, work our way
2606 * back up the tree */
2610 return top_op; /* at top; no parents/siblings to try */
2611 if (OpHAS_SIBLING(o))
2612 next_kid = o->op_sibparent;
2614 o = o->op_sibparent; /*try parent's next sibling */
2615 switch (o->op_type) {
2621 /* should really restore PL_curcop to its old value, but
2622 * setting it to PL_compiling is better than do nothing */
2623 PL_curcop = &PL_compiling;
2633 /* apply void context to non-final ops of a sequence */
2636 S_voidnonfinal(pTHX_ OP *o)
2639 const OPCODE type = o->op_type;
2641 if (type == OP_LINESEQ || type == OP_SCOPE ||
2642 type == OP_LEAVE || type == OP_LEAVETRY)
2644 OP *kid = cLISTOPo->op_first, *sib;
2645 if(type == OP_LEAVE) {
2646 /* Don't put the OP_ENTER in void context */
2647 assert(kid->op_type == OP_ENTER);
2648 kid = OpSIBLING(kid);
2650 for (; kid; kid = sib) {
2651 if ((sib = OpSIBLING(kid))
2652 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2653 || ( sib->op_targ != OP_NEXTSTATE
2654 && sib->op_targ != OP_DBSTATE )))
2659 PL_curcop = &PL_compiling;
2661 o->op_flags &= ~OPf_PARENS;
2662 if (PL_hints & HINT_BLOCK_SCOPE)
2663 o->op_flags |= OPf_PARENS;
2666 o = newOP(OP_STUB, 0);
2671 S_modkids(pTHX_ OP *o, I32 type)
2673 if (o && o->op_flags & OPf_KIDS) {
2675 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2676 op_lvalue(kid, type);
2682 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2683 * const fields. Also, convert CONST keys to HEK-in-SVs.
2684 * rop is the op that retrieves the hash;
2685 * key_op is the first key
2686 * real if false, only check (and possibly croak); don't update op
2690 Perl_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2696 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2698 if (rop->op_first->op_type == OP_PADSV)
2699 /* @$hash{qw(keys here)} */
2700 rop = cUNOPx(rop->op_first);
2702 /* @{$hash}{qw(keys here)} */
2703 if (rop->op_first->op_type == OP_SCOPE
2704 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2706 rop = cUNOPx(cLISTOPx(rop->op_first)->op_last);
2713 lexname = NULL; /* just to silence compiler warnings */
2714 fields = NULL; /* just to silence compiler warnings */
2718 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2719 PadnameHasTYPE(lexname))
2720 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2721 && isGV(*fields) && GvHV(*fields);
2723 for (; key_op; key_op = cSVOPx(OpSIBLING(key_op))) {
2725 if (key_op->op_type != OP_CONST)
2727 svp = cSVOPx_svp(key_op);
2729 /* make sure it's not a bareword under strict subs */
2730 if (key_op->op_private & OPpCONST_BARE &&
2731 key_op->op_private & OPpCONST_STRICT)
2733 no_bareword_allowed((OP*)key_op);
2736 /* Make the CONST have a shared SV */
2737 if ( !SvIsCOW_shared_hash(sv = *svp)
2738 && SvTYPE(sv) < SVt_PVMG
2744 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2745 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2746 SvREFCNT_dec_NN(sv);
2751 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2753 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2754 "in variable %" PNf " of type %" HEKf,
2755 SVfARG(*svp), PNfARG(lexname),
2756 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2762 /* do all the final processing on an optree (e.g. running the peephole
2763 * optimiser on it), then attach it to cv (if cv is non-null)
2767 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2771 /* XXX for some reason, evals, require and main optrees are
2772 * never attached to their CV; instead they just hang off
2773 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2774 * and get manually freed when appropriate */
2776 startp = &CvSTART(cv);
2778 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2781 optree->op_private |= OPpREFCOUNTED;
2782 OpREFCNT_set(optree, 1);
2783 optimize_optree(optree);
2785 finalize_optree(optree);
2786 op_prune_chain_head(startp);
2789 /* now that optimizer has done its work, adjust pad values */
2790 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2791 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2796 /* Relocate sv to the pad for thread safety.
2797 * Despite being a "constant", the SV is written to,
2798 * for reference counts, sv_upgrade() etc. */
2800 Perl_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2803 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2805 ix = pad_alloc(OP_CONST, SVf_READONLY);
2806 SvREFCNT_dec(PAD_SVl(ix));
2807 PAD_SETSV(ix, *svp);
2808 /* XXX I don't know how this isn't readonly already. */
2809 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2816 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2819 PadnameLVALUE_on(pn);
2820 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2822 /* RT #127786: cv can be NULL due to an eval within the DB package
2823 * called from an anon sub - anon subs don't have CvOUTSIDE() set
2824 * unless they contain an eval, but calling eval within DB
2825 * pretends the eval was done in the caller's scope.
2829 assert(CvPADLIST(cv));
2831 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2832 assert(PadnameLEN(pn));
2833 PadnameLVALUE_on(pn);
2838 S_vivifies(const OPCODE type)
2841 case OP_RV2AV: case OP_ASLICE:
2842 case OP_RV2HV: case OP_KVASLICE:
2843 case OP_RV2SV: case OP_HSLICE:
2844 case OP_AELEMFAST: case OP_KVHSLICE:
2853 /* apply lvalue reference (aliasing) context to the optree o.
2856 * o would be the list ($x,$y) and type would be OP_AASSIGN.
2857 * It may descend and apply this to children too, for example in
2858 * \( $cond ? $x, $y) = (...)
2862 S_lvref(pTHX_ OP *o, I32 type)
2868 switch (o->op_type) {
2870 o = OpSIBLING(cUNOPo->op_first);
2877 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2878 o->op_flags |= OPf_STACKED;
2879 if (o->op_flags & OPf_PARENS) {
2880 if (o->op_private & OPpLVAL_INTRO) {
2881 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2882 "localized parenthesized array in list assignment"));
2886 OpTYPE_set(o, OP_LVAVREF);
2887 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2888 o->op_flags |= OPf_MOD|OPf_REF;
2891 o->op_private |= OPpLVREF_AV;
2895 kid = cUNOPo->op_first;
2896 if (kid->op_type == OP_NULL)
2897 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2899 o->op_private = OPpLVREF_CV;
2900 if (kid->op_type == OP_GV)
2901 o->op_flags |= OPf_STACKED;
2902 else if (kid->op_type == OP_PADCV) {
2903 o->op_targ = kid->op_targ;
2905 op_free(cUNOPo->op_first);
2906 cUNOPo->op_first = NULL;
2907 o->op_flags &=~ OPf_KIDS;
2913 if (o->op_flags & OPf_PARENS) {
2915 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2916 "parenthesized hash in list assignment"));
2919 o->op_private |= OPpLVREF_HV;
2923 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2924 o->op_flags |= OPf_STACKED;
2928 if (o->op_flags & OPf_PARENS) goto parenhash;
2929 o->op_private |= OPpLVREF_HV;
2932 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2936 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2937 if (o->op_flags & OPf_PARENS) goto slurpy;
2938 o->op_private |= OPpLVREF_AV;
2943 o->op_private |= OPpLVREF_ELEM;
2944 o->op_flags |= OPf_STACKED;
2949 OpTYPE_set(o, OP_LVREFSLICE);
2950 o->op_private &= OPpLVAL_INTRO;
2954 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2956 else if (!(o->op_flags & OPf_KIDS))
2959 /* the code formerly only recursed into the first child of
2960 * a non ex-list OP_NULL. if we ever encounter such a null op with
2961 * more than one child, need to decide whether its ok to process
2962 * *all* its kids or not */
2963 assert(o->op_targ == OP_LIST
2964 || !(OpHAS_SIBLING(cBINOPo->op_first)));
2967 o = cLISTOPo->op_first;
2971 if (o->op_flags & OPf_PARENS)
2976 /* diag_listed_as: Can't modify reference to %s in %s assignment */
2977 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2978 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2985 OpTYPE_set(o, OP_LVREF);
2987 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2988 if (type == OP_ENTERLOOP)
2989 o->op_private |= OPpLVREF_ITER;
2994 return; /* at top; no parents/siblings to try */
2995 if (OpHAS_SIBLING(o)) {
2996 o = o->op_sibparent;
2999 o = o->op_sibparent; /*try parent's next sibling */
3005 PERL_STATIC_INLINE bool
3006 S_potential_mod_type(I32 type)
3008 /* Types that only potentially result in modification. */
3009 return type == OP_GREPSTART || type == OP_ENTERSUB
3010 || type == OP_REFGEN || type == OP_LEAVESUBLV;
3015 =for apidoc op_lvalue
3017 Propagate lvalue ("modifiable") context to an op and its children.
3018 C<type> represents the context type, roughly based on the type of op that
3019 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3020 because it has no op type of its own (it is signalled by a flag on
3023 This function detects things that can't be modified, such as C<$x+1>, and
3024 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3025 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3027 It also flags things that need to behave specially in an lvalue context,
3028 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3032 Perl_op_lvalue_flags() is a non-API lower-level interface to
3033 op_lvalue(). The flags param has these bits:
3034 OP_LVALUE_NO_CROAK: return rather than croaking on error
3039 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3043 if (!o || (PL_parser && PL_parser->error_count))
3048 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3050 OP *next_kid = NULL;
3052 if ((o->op_private & OPpTARGET_MY)
3053 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3058 /* elements of a list might be in void context because the list is
3059 in scalar context or because they are attribute sub calls */
3060 if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
3063 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3065 switch (o->op_type) {
3067 if (type == OP_SASSIGN)
3073 if ((o->op_flags & OPf_PARENS))
3078 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3079 !(o->op_flags & OPf_STACKED)) {
3080 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3081 assert(cUNOPo->op_first->op_type == OP_NULL);
3082 op_null(cLISTOPx(cUNOPo->op_first)->op_first);/* disable pushmark */
3085 else { /* lvalue subroutine call */
3086 o->op_private |= OPpLVAL_INTRO;
3087 PL_modcount = RETURN_UNLIMITED_NUMBER;
3088 if (S_potential_mod_type(type)) {
3089 o->op_private |= OPpENTERSUB_INARGS;
3092 else { /* Compile-time error message: */
3093 OP *kid = cUNOPo->op_first;
3098 if (kid->op_type != OP_PUSHMARK) {
3099 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3101 "panic: unexpected lvalue entersub "
3102 "args: type/targ %ld:%" UVuf,
3103 (long)kid->op_type, (UV)kid->op_targ);
3104 kid = kLISTOP->op_first;
3106 while (OpHAS_SIBLING(kid))
3107 kid = OpSIBLING(kid);
3108 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3109 break; /* Postpone until runtime */
3112 kid = kUNOP->op_first;
3113 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3114 kid = kUNOP->op_first;
3115 if (kid->op_type == OP_NULL)
3117 "panic: unexpected constant lvalue entersub "
3118 "entry via type/targ %ld:%" UVuf,
3119 (long)kid->op_type, (UV)kid->op_targ);
3120 if (kid->op_type != OP_GV) {
3127 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3128 ? MUTABLE_CV(SvRV(gv))
3134 if (flags & OP_LVALUE_NO_CROAK)
3137 namesv = cv_name(cv, NULL, 0);
3138 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
3139 "subroutine call of &%" SVf " in %s",
3140 SVfARG(namesv), PL_op_desc[type]),
3148 if (flags & OP_LVALUE_NO_CROAK) return NULL;
3149 /* grep, foreach, subcalls, refgen */
3150 if (S_potential_mod_type(type))
3152 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
3153 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3156 type ? PL_op_desc[type] : "local"));
3169 case OP_RIGHT_SHIFT:
3178 if (!(o->op_flags & OPf_STACKED))
3184 if (o->op_flags & OPf_STACKED) {
3188 if (!(o->op_private & OPpREPEAT_DOLIST))
3191 const I32 mods = PL_modcount;
3192 /* we recurse rather than iterate here because we need to
3193 * calculate and use the delta applied to PL_modcount by the
3194 * first child. So in something like
3195 * ($x, ($y) x 3) = split;
3196 * split knows that 4 elements are wanted
3198 modkids(cBINOPo->op_first, type);
3199 if (type != OP_AASSIGN)
3201 kid = cBINOPo->op_last;
3202 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3203 const IV iv = SvIV(kSVOP_sv);
3204 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3206 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3209 PL_modcount = RETURN_UNLIMITED_NUMBER;
3215 next_kid = OpSIBLING(cUNOPo->op_first);
3220 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3221 PL_modcount = RETURN_UNLIMITED_NUMBER;
3222 /* Treat \(@foo) like ordinary list, but still mark it as modi-
3223 fiable since some contexts need to know. */
3224 o->op_flags |= OPf_MOD;
3229 if (scalar_mod_type(o, type))
3231 ref(cUNOPo->op_first, o->op_type);
3238 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
3239 if (type == OP_LEAVESUBLV && (
3240 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3241 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3243 o->op_private |= OPpMAYBE_LVSUB;
3247 PL_modcount = RETURN_UNLIMITED_NUMBER;
3253 if (type == OP_LEAVESUBLV)
3254 o->op_private |= OPpMAYBE_LVSUB;
3258 if (type == OP_LEAVESUBLV
3259 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
3260 o->op_private |= OPpMAYBE_LVSUB;
3264 PL_hints |= HINT_BLOCK_SCOPE;
3265 if (type == OP_LEAVESUBLV)
3266 o->op_private |= OPpMAYBE_LVSUB;
3271 ref(cUNOPo->op_first, o->op_type);
3275 PL_hints |= HINT_BLOCK_SCOPE;
3285 case OP_AELEMFAST_LEX:
3292 PL_modcount = RETURN_UNLIMITED_NUMBER;
3293 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3295 /* Treat \(@foo) like ordinary list, but still mark it as modi-
3296 fiable since some contexts need to know. */
3297 o->op_flags |= OPf_MOD;
3300 if (scalar_mod_type(o, type))
3302 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3303 && type == OP_LEAVESUBLV)
3304 o->op_private |= OPpMAYBE_LVSUB;
3308 if (!type) /* local() */
3309 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3310 PNfARG(PAD_COMPNAME(o->op_targ)));
3311 if (!(o->op_private & OPpLVAL_INTRO)
3312 || ( type != OP_SASSIGN && type != OP_AASSIGN
3313 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
3314 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3322 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3326 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3332 if (type == OP_LEAVESUBLV)
3333 o->op_private |= OPpMAYBE_LVSUB;
3334 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3335 /* we recurse rather than iterate here because the child
3336 * needs to be processed with a different 'type' parameter */
3338 /* substr and vec */
3339 /* If this op is in merely potential (non-fatal) modifiable
3340 context, then apply OP_ENTERSUB context to
3341 the kid op (to avoid croaking). Other-
3342 wise pass this op’s own type so the correct op is mentioned
3343 in error messages. */
3344 op_lvalue(OpSIBLING(cBINOPo->op_first),
3345 S_potential_mod_type(type)
3353 ref(cBINOPo->op_first, o->op_type);
3354 if (type == OP_ENTERSUB &&
3355 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3356 o->op_private |= OPpLVAL_DEFER;
3357 if (type == OP_LEAVESUBLV)
3358 o->op_private |= OPpMAYBE_LVSUB;
3365 o->op_private |= OPpLVALUE;
3371 if (o->op_flags & OPf_KIDS)
3372 next_kid = cLISTOPo->op_last;
3377 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3379 else if (!(o->op_flags & OPf_KIDS))
3382 if (o->op_targ != OP_LIST) {
3383 OP *sib = OpSIBLING(cLISTOPo->op_first);
3384 /* OP_TRANS and OP_TRANSR with argument have a weird optree
3391 * compared with things like OP_MATCH which have the argument
3397 * so handle specially to correctly get "Can't modify" croaks etc
3400 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3402 /* this should trigger a "Can't modify transliteration" err */
3403 op_lvalue(sib, type);
3405 next_kid = cBINOPo->op_first;
3406 /* we assume OP_NULLs which aren't ex-list have no more than 2
3407 * children. If this assumption is wrong, increase the scan
3409 assert( !OpHAS_SIBLING(next_kid)
3410 || !OpHAS_SIBLING(OpSIBLING(next_kid)));
3416 next_kid = cLISTOPo->op_first;
3424 if (type == OP_LEAVESUBLV
3425 || !S_vivifies(cLOGOPo->op_first->op_type))
3426 next_kid = cLOGOPo->op_first;
3427 else if (type == OP_LEAVESUBLV
3428 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3429 next_kid = OpSIBLING(cLOGOPo->op_first);
3433 if (type == OP_NULL) { /* local */
3435 if (!FEATURE_MYREF_IS_ENABLED)
3436 Perl_croak(aTHX_ "The experimental declared_refs "
3437 "feature is not enabled");
3438 Perl_ck_warner_d(aTHX_
3439 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3440 "Declaring references is experimental");
3441 next_kid = cUNOPo->op_first;
3444 if (type != OP_AASSIGN && type != OP_SASSIGN
3445 && type != OP_ENTERLOOP)
3447 /* Don’t bother applying lvalue context to the ex-list. */
3448 kid = cUNOPx(cUNOPo->op_first)->op_first;
3449 assert (!OpHAS_SIBLING(kid));
3452 if (type == OP_NULL) /* local */
3454 if (type != OP_AASSIGN) goto nomod;
3455 kid = cUNOPo->op_first;
3458 const U8 ec = PL_parser ? PL_parser->error_count : 0;
3459 S_lvref(aTHX_ kid, type);
3460 if (!PL_parser || PL_parser->error_count == ec) {
3461 if (!FEATURE_REFALIASING_IS_ENABLED)
3463 "Experimental aliasing via reference not enabled");
3464 Perl_ck_warner_d(aTHX_
3465 packWARN(WARN_EXPERIMENTAL__REFALIASING),
3466 "Aliasing via reference is experimental");
3469 if (o->op_type == OP_REFGEN)
3470 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3475 if ((o->op_private & OPpSPLIT_ASSIGN)) {
3476 /* This is actually @array = split. */
3477 PL_modcount = RETURN_UNLIMITED_NUMBER;
3483 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3487 /* If we were to set OPf_REF on this and it was constructed by XS
3488 * code as a child of an OP_REFGEN then we'd end up generating a
3489 * double-ref when executed. We don't want to do that, so don't
3491 * See also https://github.com/Perl/perl5/issues/20384
3494 // Perl always sets OPf_REF as of 5.37.5.
3496 if (LIKELY(o->op_flags & OPf_REF)) goto nomod;
3498 // If we got here, then our op came from an XS module that predates
3499 // 5.37.5’s change to the op tree, which we have to handle a bit
3500 // diffrently to preserve backward compatibility.
3505 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3506 their argument is a filehandle; thus \stat(".") should not set
3508 if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
3511 if (type != OP_LEAVESUBLV)
3512 o->op_flags |= OPf_MOD;
3514 if (type == OP_AASSIGN || type == OP_SASSIGN)
3515 o->op_flags |= o->op_type == OP_ENTERSUB ? 0 : OPf_SPECIAL|OPf_REF;
3516 else if (!type) { /* local() */
3519 o->op_private |= OPpLVAL_INTRO;
3520 o->op_flags &= ~OPf_SPECIAL;
3521 PL_hints |= HINT_BLOCK_SCOPE;
3526 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3527 "Useless localization of %s", OP_DESC(o));
3530 else if (type != OP_GREPSTART && type != OP_ENTERSUB
3531 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3532 o->op_flags |= OPf_REF;
3537 return top_op; /* at top; no parents/siblings to try */
3538 if (OpHAS_SIBLING(o)) {
3539 next_kid = o->op_sibparent;
3540 if (!OpHAS_SIBLING(next_kid)) {
3541 /* a few node types don't recurse into their second child */
3542 OP *parent = next_kid->op_sibparent;
3543 I32 ptype = parent->op_type;
3544 if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
3545 || ( (ptype == OP_AND || ptype == OP_OR)
3546 && (type != OP_LEAVESUBLV
3547 && S_vivifies(next_kid->op_type))
3550 /*try parent's next sibling */
3557 o = o->op_sibparent; /*try parent's next sibling */
3568 S_scalar_mod_type(const OP *o, I32 type)
3573 if (o && o->op_type == OP_RV2GV)
3597 case OP_RIGHT_SHIFT:
3626 S_is_handle_constructor(const OP *o, I32 numargs)
3628 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3630 switch (o->op_type) {
3638 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
3651 S_refkids(pTHX_ OP *o, I32 type)
3653 if (o && o->op_flags & OPf_KIDS) {
3655 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3662 /* Apply reference (autovivification) context to the subtree at o.
3664 * push @{expression}, ....;
3665 * o will be the head of 'expression' and type will be OP_RV2AV.
3666 * It marks the op o (or a suitable child) as autovivifying, e.g. by
3668 * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
3669 * set_op_ref is true.
3671 * Also calls scalar(o).
3675 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3679 PERL_ARGS_ASSERT_DOREF;
3681 if (PL_parser && PL_parser->error_count)
3685 switch (o->op_type) {
3687 if ((type == OP_EXISTS || type == OP_DEFINED) &&
3688 !(o->op_flags & OPf_STACKED)) {
3689 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3690 assert(cUNOPo->op_first->op_type == OP_NULL);
3691 /* disable pushmark */
3692 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
3693 o->op_flags |= OPf_SPECIAL;
3695 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3696 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3697 : type == OP_RV2HV ? OPpDEREF_HV
3699 o->op_flags |= OPf_MOD;
3705 o = OpSIBLING(cUNOPo->op_first);
3709 if (type == OP_DEFINED)
3710 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3713 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3714 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3715 : type == OP_RV2HV ? OPpDEREF_HV
3717 o->op_flags |= OPf_MOD;
3719 if (o->op_flags & OPf_KIDS) {
3721 o = cUNOPo->op_first;
3729 o->op_flags |= OPf_REF;
3732 if (type == OP_DEFINED)
3733 o->op_flags |= OPf_SPECIAL; /* don't create GV */
3735 o = cUNOPo->op_first;
3741 o->op_flags |= OPf_REF;
3746 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3748 o = cBINOPo->op_first;
3753 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3754 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3755 : type == OP_RV2HV ? OPpDEREF_HV
3757 o->op_flags |= OPf_MOD;
3760 o = cBINOPo->op_first;
3769 if (!(o->op_flags & OPf_KIDS))
3771 o = cLISTOPo->op_last;
3780 return scalar(top_op); /* at top; no parents/siblings to try */
3781 if (OpHAS_SIBLING(o)) {
3782 o = o->op_sibparent;
3783 /* Normally skip all siblings and go straight to the parent;
3784 * the only op that requires two children to be processed
3785 * is OP_COND_EXPR */
3786 if (!OpHAS_SIBLING(o)
3787 && o->op_sibparent->op_type == OP_COND_EXPR)
3791 o = o->op_sibparent; /*try parent's next sibling */
3798 S_dup_attrlist(pTHX_ OP *o)
3802 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3804 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3805 * where the first kid is OP_PUSHMARK and the remaining ones
3806 * are OP_CONST. We need to push the OP_CONST values.
3808 if (o->op_type == OP_CONST)
3809 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3811 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3813 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3814 if (o->op_type == OP_CONST)
3815 rop = op_append_elem(OP_LIST, rop,
3816 newSVOP(OP_CONST, o->op_flags,
3817 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3824 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3826 PERL_ARGS_ASSERT_APPLY_ATTRS;
3828 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3830 /* fake up C<use attributes $pkg,$rv,@attrs> */
3832 #define ATTRSMODULE "attributes"
3833 #define ATTRSMODULE_PM "attributes.pm"
3836 aTHX_ PERL_LOADMOD_IMPORT_OPS,
3837 newSVpvs(ATTRSMODULE),
3839 op_prepend_elem(OP_LIST,
3840 newSVOP(OP_CONST, 0, stashsv),
3841 op_prepend_elem(OP_LIST,
3842 newSVOP(OP_CONST, 0,
3844 dup_attrlist(attrs))));
3849 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3851 OP *pack, *imop, *arg;
3852 SV *meth, *stashsv, **svp;
3854 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3859 assert(target->op_type == OP_PADSV ||
3860 target->op_type == OP_PADHV ||
3861 target->op_type == OP_PADAV);
3863 /* Ensure that attributes.pm is loaded. */
3864 /* Don't force the C<use> if we don't need it. */
3865 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3866 if (svp && *svp != &PL_sv_undef)
3867 NOOP; /* already in %INC */
3869 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3870 newSVpvs(ATTRSMODULE), NULL);
3872 /* Need package name for method call. */
3873 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3875 /* Build up the real arg-list. */
3876 stashsv = newSVhek(HvNAME_HEK(stash));
3878 arg = newPADxVOP(OP_PADSV, 0, target->op_targ);
3879 arg = op_prepend_elem(OP_LIST,
3880 newSVOP(OP_CONST, 0, stashsv),
3881 op_prepend_elem(OP_LIST,
3882 newUNOP(OP_REFGEN, 0,
3884 dup_attrlist(attrs)));
3886 /* Fake up a method call to import */
3887 meth = newSVpvs_share("import");
3888 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_WANT_VOID,
3889 op_append_elem(OP_LIST,
3890 op_prepend_elem(OP_LIST, pack, arg),
3891 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3893 /* Combine the ops. */
3894 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3898 =notfor apidoc apply_attrs_string
3900 Attempts to apply a list of attributes specified by the C<attrstr> and
3901 C<len> arguments to the subroutine identified by the C<cv> argument which
3902 is expected to be associated with the package identified by the C<stashpv>
3903 argument (see L<attributes>). It gets this wrong, though, in that it
3904 does not correctly identify the boundaries of the individual attribute
3905 specifications within C<attrstr>. This is not really intended for the
3906 public API, but has to be listed here for systems such as AIX which
3907 need an explicit export list for symbols. (It's called from XS code
3908 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3909 to respect attribute syntax properly would be welcome.
3915 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3916 const char *attrstr, STRLEN len)
3920 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3923 len = strlen(attrstr);
3927 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3929 const char * const sstr = attrstr;
3930 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3931 attrs = op_append_elem(OP_LIST, attrs,
3932 newSVOP(OP_CONST, 0,
3933 newSVpvn(sstr, attrstr-sstr)));
3937 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3938 newSVpvs(ATTRSMODULE),
3939 NULL, op_prepend_elem(OP_LIST,
3940 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3941 op_prepend_elem(OP_LIST,
3942 newSVOP(OP_CONST, 0,
3943 newRV(MUTABLE_SV(cv))),
3948 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
3951 OP *new_proto = NULL;
3956 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3962 if (o->op_type == OP_CONST) {
3963 pv = SvPV(cSVOPo_sv, pvlen);
3964 if (memBEGINs(pv, pvlen, "prototype(")) {
3965 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3966 SV ** const tmpo = cSVOPx_svp(o);
3967 SvREFCNT_dec(cSVOPo_sv);
3972 } else if (o->op_type == OP_LIST) {
3974 assert(o->op_flags & OPf_KIDS);
3975 lasto = cLISTOPo->op_first;
3976 assert(lasto->op_type == OP_PUSHMARK);
3977 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3978 if (o->op_type == OP_CONST) {
3979 pv = SvPV(cSVOPo_sv, pvlen);
3980 if (memBEGINs(pv, pvlen, "prototype(")) {
3981 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3982 SV ** const tmpo = cSVOPx_svp(o);
3983 SvREFCNT_dec(cSVOPo_sv);
3985 if (new_proto && ckWARN(WARN_MISC)) {
3987 const char * newp = SvPV(cSVOPo_sv, new_len);
3988 Perl_warner(aTHX_ packWARN(WARN_MISC),
3989 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3990 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3996 /* excise new_proto from the list */
3997 op_sibling_splice(*attrs, lasto, 1, NULL);
4004 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4005 would get pulled in with no real need */
4006 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4015 svname = sv_newmortal();
4016 gv_efullname3(svname, name, NULL);
4018 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4019 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4021 svname = (SV *)name;
4022 if (ckWARN(WARN_ILLEGALPROTO))
4023 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4025 if (*proto && ckWARN(WARN_PROTOTYPE)) {
4026 STRLEN old_len, new_len;
4027 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4028 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4030 if (curstash && svname == (SV *)name
4031 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4032 svname = sv_2mortal(newSVsv(PL_curstname));
4033 sv_catpvs(svname, "::");
4034 sv_catsv(svname, (SV *)name);
4037 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4038 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4040 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4041 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4051 S_cant_declare(pTHX_ OP *o)
4053 if (o->op_type == OP_NULL
4054 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4055 o = cUNOPo->op_first;
4056 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4057 o->op_type == OP_NULL
4058 && o->op_flags & OPf_SPECIAL
4061 PL_parser->in_my == KEY_our ? "our" :
4062 PL_parser->in_my == KEY_state ? "state" :
4067 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4070 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4072 PERL_ARGS_ASSERT_MY_KID;
4074 if (!o || (PL_parser && PL_parser->error_count))
4079 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4081 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4082 my_kid(kid, attrs, imopsp);
4084 } else if (type == OP_UNDEF || type == OP_STUB) {
4086 } else if (type == OP_RV2SV || /* "our" declaration */
4089 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4090 S_cant_declare(aTHX_ o);
4092 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4094 PL_parser->in_my = FALSE;
4095 PL_parser->in_my_stash = NULL;
4096 apply_attrs(GvSTASH(gv),
4097 (type == OP_RV2SV ? GvSVn(gv) :
4098 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4099 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4102 o->op_private |= OPpOUR_INTRO;
4105 else if (type == OP_REFGEN || type == OP_SREFGEN) {
4106 if (!FEATURE_MYREF_IS_ENABLED)
4107 Perl_croak(aTHX_ "The experimental declared_refs "
4108 "feature is not enabled");
4109 Perl_ck_warner_d(aTHX_
4110 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4111 "Declaring references is experimental");
4112 /* Kid is a nulled OP_LIST, handled above. */
4113 my_kid(cUNOPo->op_first, attrs, imopsp);
4116 else if (type != OP_PADSV &&
4119 type != OP_PUSHMARK)
4121 S_cant_declare(aTHX_ o);
4124 else if (attrs && type != OP_PUSHMARK) {
4128 PL_parser->in_my = FALSE;
4129 PL_parser->in_my_stash = NULL;
4131 /* check for C<my Dog $spot> when deciding package */
4132 stash = PAD_COMPNAME_TYPE(o->op_targ);
4134 stash = PL_curstash;
4135 apply_attrs_my(stash, o, attrs, imopsp);
4137 o->op_flags |= OPf_MOD;
4138 o->op_private |= OPpLVAL_INTRO;
4140 o->op_private |= OPpPAD_STATE;
4145 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4148 int maybe_scalar = 0;
4150 PERL_ARGS_ASSERT_MY_ATTRS;
4152 /* [perl #17376]: this appears to be premature, and results in code such as
4153 C< our(%x); > executing in list mode rather than void mode */
4155 if (o->op_flags & OPf_PARENS)
4165 o = my_kid(o, attrs, &rops);
4167 if (maybe_scalar && o->op_type == OP_PADSV) {
4168 o = scalar(op_append_list(OP_LIST, rops, o));
4169 o->op_private |= OPpLVAL_INTRO;
4172 /* The listop in rops might have a pushmark at the beginning,
4173 which will mess up list assignment. */
4174 LISTOP * const lrops = cLISTOPx(rops); /* for brevity */
4175 if (rops->op_type == OP_LIST &&
4176 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4178 OP * const pushmark = lrops->op_first;
4179 /* excise pushmark */
4180 op_sibling_splice(rops, NULL, 1, NULL);
4183 o = op_append_list(OP_LIST, o, rops);
4186 PL_parser->in_my = FALSE;
4187 PL_parser->in_my_stash = NULL;
4192 Perl_sawparens(pTHX_ OP *o)
4194 PERL_UNUSED_CONTEXT;
4196 o->op_flags |= OPf_PARENS;
4201 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4205 const OPCODE ltype = left->op_type;
4206 const OPCODE rtype = right->op_type;
4208 PERL_ARGS_ASSERT_BIND_MATCH;
4210 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4211 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4213 const char * const desc
4215 rtype == OP_SUBST || rtype == OP_TRANS
4216 || rtype == OP_TRANSR
4218 ? (int)rtype : OP_MATCH];
4219 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4220 SV * const name = op_varname(left);
4222 Perl_warner(aTHX_ packWARN(WARN_MISC),
4223 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4224 desc, SVfARG(name), SVfARG(name));
4226 const char * const sample = (isary
4227 ? "@array" : "%hash");
4228 Perl_warner(aTHX_ packWARN(WARN_MISC),
4229 "Applying %s to %s will act on scalar(%s)",
4230 desc, sample, sample);
4234 if (rtype == OP_CONST &&
4235 cSVOPx(right)->op_private & OPpCONST_BARE &&
4236 cSVOPx(right)->op_private & OPpCONST_STRICT)
4238 no_bareword_allowed(right);
4241 /* !~ doesn't make sense with /r, so error on it for now */
4242 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
4244 /* diag_listed_as: Using !~ with %s doesn't make sense */
4245 yyerror("Using !~ with s///r doesn't make sense");
4246 if (rtype == OP_TRANSR && type == OP_NOT)
4247 /* diag_listed_as: Using !~ with %s doesn't make sense */
4248 yyerror("Using !~ with tr///r doesn't make sense");
4250 ismatchop = (rtype == OP_MATCH ||
4251 rtype == OP_SUBST ||
4252 rtype == OP_TRANS || rtype == OP_TRANSR)
4253 && !(right->op_flags & OPf_SPECIAL);
4254 if (ismatchop && right->op_private & OPpTARGET_MY) {
4256 right->op_private &= ~OPpTARGET_MY;
4258 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
4259 if (left->op_type == OP_PADSV
4260 && !(left->op_private & OPpLVAL_INTRO))
4262 right->op_targ = left->op_targ;
4267 right->op_flags |= OPf_STACKED;
4268 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4269 ! (rtype == OP_TRANS &&
4270 right->op_private & OPpTRANS_IDENTICAL) &&
4271 ! (rtype == OP_SUBST &&
4272 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4273 left = op_lvalue(left, rtype);
4274 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4275 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4277 o = op_prepend_elem(rtype, scalar(left), right);
4280 return newUNOP(OP_NOT, 0, scalar(o));
4284 return bind_match(type, left,
4285 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4289 Perl_invert(pTHX_ OP *o)
4293 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4297 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
4303 left = newOP(OP_NULL, 0);
4305 right = newOP(OP_NULL, 0);
4308 NewOp(0, bop, 1, BINOP);
4310 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4311 OpTYPE_set(op, type);
4312 cBINOPx(op)->op_flags = OPf_KIDS;
4313 cBINOPx(op)->op_private = 2;
4314 cBINOPx(op)->op_first = left;
4315 cBINOPx(op)->op_last = right;
4316 OpMORESIB_set(left, right);
4317 OpLASTSIB_set(right, op);
4322 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
4327 PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
4329 right = newOP(OP_NULL, 0);
4331 NewOp(0, bop, 1, BINOP);
4333 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4334 OpTYPE_set(op, type);
4335 if (ch->op_type != OP_NULL) {
4337 OP *nch, *cleft, *cright;
4338 NewOp(0, lch, 1, UNOP);
4340 OpTYPE_set(nch, OP_NULL);
4341 nch->op_flags = OPf_KIDS;
4342 cleft = cBINOPx(ch)->op_first;
4343 cright = cBINOPx(ch)->op_last;
4344 cBINOPx(ch)->op_first = NULL;
4345 cBINOPx(ch)->op_last = NULL;
4346 cBINOPx(ch)->op_private = 0;
4347 cBINOPx(ch)->op_flags = 0;
4348 cUNOPx(nch)->op_first = cright;
4349 OpMORESIB_set(cright, ch);
4350 OpMORESIB_set(ch, cleft);
4351 OpLASTSIB_set(cleft, nch);
4354 OpMORESIB_set(right, op);
4355 OpMORESIB_set(op, cUNOPx(ch)->op_first);
4356 cUNOPx(ch)->op_first = right;
4361 Perl_cmpchain_finish(pTHX_ OP *ch)
4364 PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
4365 if (ch->op_type != OP_NULL) {
4366 OPCODE cmpoptype = ch->op_type;
4367 ch = CHECKOP(cmpoptype, ch);
4368 if(!ch->op_next && ch->op_type == cmpoptype)
4369 ch = fold_constants(op_integerize(op_std_init(ch)));
4373 OP *rightarg = cUNOPx(ch)->op_first;
4374 cUNOPx(ch)->op_first = OpSIBLING(rightarg);
4375 OpLASTSIB_set(rightarg, NULL);
4377 OP *cmpop = cUNOPx(ch)->op_first;
4378 OP *leftarg = OpSIBLING(cmpop);
4379 OPCODE cmpoptype = cmpop->op_type;
4382 is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
4383 OpLASTSIB_set(cmpop, NULL);
4384 OpLASTSIB_set(leftarg, NULL);
4388 nextrightarg = NULL;
4390 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
4391 leftarg = newOP(OP_NULL, 0);
4393 cBINOPx(cmpop)->op_first = leftarg;
4394 cBINOPx(cmpop)->op_last = rightarg;
4395 OpMORESIB_set(leftarg, rightarg);
4396 OpLASTSIB_set(rightarg, cmpop);
4397 cmpop->op_flags = OPf_KIDS;
4398 cmpop->op_private = 2;
4399 cmpop = CHECKOP(cmpoptype, cmpop);
4400 if(!cmpop->op_next && cmpop->op_type == cmpoptype)
4401 cmpop = op_integerize(op_std_init(cmpop));
4402 condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
4406 rightarg = nextrightarg;
4412 =for apidoc op_scope
4414 Wraps up an op tree with some additional ops so that at runtime a dynamic
4415 scope will be created. The original ops run in the new dynamic scope,
4416 and then, provided that they exit normally, the scope will be unwound.
4417 The additional ops used to create and unwind the dynamic scope will
4418 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4419 instead if the ops are simple enough to not need the full dynamic scope
4426 Perl_op_scope(pTHX_ OP *o)
4429 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4430 o = op_prepend_elem(OP_LINESEQ,
4431 newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
4432 OpTYPE_set(o, OP_LEAVE);
4434 else if (o->op_type == OP_LINESEQ) {
4436 OpTYPE_set(o, OP_SCOPE);
4437 kid = cLISTOPo->op_first;
4438 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4441 /* The following deals with things like 'do {1 for 1}' */
4442 kid = OpSIBLING(kid);
4444 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4449 o = newLISTOP(OP_SCOPE, 0, o, NULL);
4455 Perl_op_unscope(pTHX_ OP *o)
4457 if (o && o->op_type == OP_LINESEQ) {
4458 OP *kid = cLISTOPo->op_first;
4459 for(; kid; kid = OpSIBLING(kid))
4460 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4467 =for apidoc block_start
4469 Handles compile-time scope entry.
4470 Arranges for hints to be restored on block
4471 exit and also handles pad sequence numbers to make lexical variables scope
4472 right. Returns a savestack index for use with C<block_end>.
4478 Perl_block_start(pTHX_ int full)
4480 const int retval = PL_savestack_ix;
4482 PL_compiling.cop_seq = PL_cop_seqmax;
4484 pad_block_start(full);
4486 PL_hints &= ~HINT_BLOCK_SCOPE;
4487 SAVECOMPILEWARNINGS();
4488 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4489 SAVEI32(PL_compiling.cop_seq);
4490 PL_compiling.cop_seq = 0;
4492 CALL_BLOCK_HOOKS(bhk_start, full);
4498 =for apidoc block_end
4500 Handles compile-time scope exit. C<floor>
4501 is the savestack index returned by
4502 C<block_start>, and C<seq> is the body of the block. Returns the block,
4509 Perl_block_end(pTHX_ I32 floor, OP *seq)
4511 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4512 OP* retval = voidnonfinal(seq);
4515 /* XXX Is the null PL_parser check necessary here? */
4516 assert(PL_parser); /* Let’s find out under debugging builds. */
4517 if (PL_parser && PL_parser->parsed_sub) {
4518 o = newSTATEOP(0, NULL, NULL);
4520 retval = op_append_elem(OP_LINESEQ, retval, o);
4523 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4527 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4531 /* pad_leavemy has created a sequence of introcv ops for all my
4532 subs declared in the block. We have to replicate that list with
4533 clonecv ops, to deal with this situation:
4538 sub s1 { state sub foo { \&s2 } }
4541 Originally, I was going to have introcv clone the CV and turn
4542 off the stale flag. Since &s1 is declared before &s2, the
4543 introcv op for &s1 is executed (on sub entry) before the one for
4544 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
4545 cloned, since it is a state sub) closes over &s2 and expects
4546 to see it in its outer CV’s pad. If the introcv op clones &s1,
4547 then &s2 is still marked stale. Since &s1 is not active, and
4548 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4549 ble will not stay shared’ warning. Because it is the same stub
4550 that will be used when the introcv op for &s2 is executed, clos-
4551 ing over it is safe. Hence, we have to turn off the stale flag
4552 on all lexical subs in the block before we clone any of them.
4553 Hence, having introcv clone the sub cannot work. So we create a
4554 list of ops like this:
4578 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4579 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4580 for (;; kid = OpSIBLING(kid)) {
4581 OP *newkid = newOP(OP_CLONECV, 0);
4582 newkid->op_targ = kid->op_targ;
4583 o = op_append_elem(OP_LINESEQ, o, newkid);
4584 if (kid == last) break;
4586 retval = op_prepend_elem(OP_LINESEQ, o, retval);
4589 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4595 =for apidoc_section $scope
4597 =for apidoc blockhook_register
4599 Register a set of hooks to be called when the Perl lexical scope changes
4600 at compile time. See L<perlguts/"Compile-time scope hooks">.
4606 Perl_blockhook_register(pTHX_ BHK *hk)
4608 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4610 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4614 Perl_newPROG(pTHX_ OP *o)
4618 PERL_ARGS_ASSERT_NEWPROG;
4625 PL_eval_root = newUNOP(OP_LEAVEEVAL,
4626 ((PL_in_eval & EVAL_KEEPERR)
4627 ? OPf_SPECIAL : 0), o);
4630 assert(CxTYPE(cx) == CXt_EVAL);
4632 if ((cx->blk_gimme & G_WANT) == G_VOID)
4633 scalarvoid(PL_eval_root);
4634 else if ((cx->blk_gimme & G_WANT) == G_LIST)
4637 scalar(PL_eval_root);
4639 start = op_linklist(PL_eval_root);
4640 PL_eval_root->op_next = 0;
4641 i = PL_savestack_ix;
4644 S_process_optree(aTHX_ NULL, PL_eval_root, start);
4646 PL_savestack_ix = i;
4649 if (o->op_type == OP_STUB) {
4650 /* This block is entered if nothing is compiled for the main
4651 program. This will be the case for an genuinely empty main
4652 program, or one which only has BEGIN blocks etc, so already
4655 Historically (5.000) the guard above was !o. However, commit
4656 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4657 c71fccf11fde0068, changed perly.y so that newPROG() is now
4658 called with the output of block_end(), which returns a new
4659 OP_STUB for the case of an empty optree. ByteLoader (and
4660 maybe other things) also take this path, because they set up
4661 PL_main_start and PL_main_root directly, without generating an
4664 If the parsing the main program aborts (due to parse errors,
4665 or due to BEGIN or similar calling exit), then newPROG()
4666 isn't even called, and hence this code path and its cleanups
4667 are skipped. This shouldn't make a make a difference:
4668 * a non-zero return from perl_parse is a failure, and
4669 perl_destruct() should be called immediately.
4670 * however, if exit(0) is called during the parse, then
4671 perl_parse() returns 0, and perl_run() is called. As
4672 PL_main_start will be NULL, perl_run() will return
4673 promptly, and the exit code will remain 0.
4676 PL_comppad_name = 0;
4678 S_op_destroy(aTHX_ o);
4681 PL_main_root = op_scope(sawparens(scalarvoid(o)));
4682 PL_curcop = &PL_compiling;
4683 start = LINKLIST(PL_main_root);
4684 PL_main_root->op_next = 0;
4685 S_process_optree(aTHX_ NULL, PL_main_root, start);
4686 if (!PL_parser->error_count)
4687 /* on error, leave CV slabbed so that ops left lying around
4688 * will eb cleaned up. Else unslab */
4689 cv_forget_slab(PL_compcv);
4692 /* Register with debugger */
4694 CV * const cv = get_cvs("DB::postponed", 0);
4698 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4700 call_sv(MUTABLE_SV(cv), G_DISCARD);
4707 Perl_localize(pTHX_ OP *o, I32 lex)
4709 PERL_ARGS_ASSERT_LOCALIZE;
4711 if (o->op_flags & OPf_PARENS)
4712 /* [perl #17376]: this appears to be premature, and results in code such as
4713 C< our(%x); > executing in list mode rather than void mode */
4720 if ( PL_parser->bufptr > PL_parser->oldbufptr
4721 && PL_parser->bufptr[-1] == ','
4722 && ckWARN(WARN_PARENTHESIS))
4724 char *s = PL_parser->bufptr;
4727 /* some heuristics to detect a potential error */
4728 while (*s && (memCHRs(", \t\n", *s)))
4732 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
4734 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4737 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4739 while (*s && (memCHRs(", \t\n", *s)))
4745 if (sigil && (*s == ';' || *s == '=')) {
4746 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4747 "Parentheses missing around \"%s\" list",
4749 ? (PL_parser->in_my == KEY_our
4751 : PL_parser->in_my == KEY_state
4761 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
4762 PL_parser->in_my = FALSE;
4763 PL_parser->in_my_stash = NULL;
4768 Perl_jmaybe(pTHX_ OP *o)
4770 PERL_ARGS_ASSERT_JMAYBE;
4772 if (o->op_type == OP_LIST) {
4773 if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
4775 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4776 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4779 /* If the user disables this, then a warning might not be enough to alert
4780 them to a possible change of behaviour here, so throw an exception.
4782 yyerror("Multidimensional hash lookup is disabled");
4788 PERL_STATIC_INLINE OP *
4789 S_op_std_init(pTHX_ OP *o)
4791 I32 type = o->op_type;
4793 PERL_ARGS_ASSERT_OP_STD_INIT;
4795 if (PL_opargs[type] & OA_RETSCALAR)
4797 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4798 o->op_targ = pad_alloc(type, SVs_PADTMP);
4803 PERL_STATIC_INLINE OP *
4804 S_op_integerize(pTHX_ OP *o)
4806 I32 type = o->op_type;
4808 PERL_ARGS_ASSERT_OP_INTEGERIZE;
4810 /* integerize op. */
4811 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4813 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4816 if (type == OP_NEGATE)
4817 /* XXX might want a ck_negate() for this */
4818 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4823 /* This function exists solely to provide a scope to limit
4824 setjmp/longjmp() messing with auto variables. It cannot be inlined because
4828 S_fold_constants_eval(pTHX) {
4844 S_fold_constants(pTHX_ OP *const o)
4848 I32 type = o->op_type;
4853 SV * const oldwarnhook = PL_warnhook;
4854 SV * const olddiehook = PL_diehook;
4856 U8 oldwarn = PL_dowarn;
4859 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4861 if (!(PL_opargs[type] & OA_FOLDCONST))
4870 #ifdef USE_LOCALE_CTYPE
4871 if (IN_LC_COMPILETIME(LC_CTYPE))
4880 #ifdef USE_LOCALE_COLLATE
4881 if (IN_LC_COMPILETIME(LC_COLLATE))
4886 /* XXX what about the numeric ops? */
4887 #ifdef USE_LOCALE_NUMERIC
4888 if (IN_LC_COMPILETIME(LC_NUMERIC))
4893 if (!OpHAS_SIBLING(cLISTOPo->op_first)
4894 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4897 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4898 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4900 const char *s = SvPVX_const(sv);
4901 while (s < SvEND(sv)) {
4902 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4909 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4912 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4913 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4917 if (PL_parser && PL_parser->error_count)
4918 goto nope; /* Don't try to run w/ errors */
4920 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4921 switch (curop->op_type) {
4923 if ( (curop->op_private & OPpCONST_BARE)
4924 && (curop->op_private & OPpCONST_STRICT)) {
4925 no_bareword_allowed(curop);
4933 /* Foldable; move to next op in list */
4937 /* No other op types are considered foldable */
4942 curop = LINKLIST(o);
4943 old_next = o->op_next;
4947 old_cxix = cxstack_ix;
4948 create_eval_scope(NULL, G_FAKINGEVAL);
4950 /* Verify that we don't need to save it: */
4951 assert(PL_curcop == &PL_compiling);
4952 StructCopy(&PL_compiling, ¬_compiling, COP);
4953 PL_curcop = ¬_compiling;
4954 /* The above ensures that we run with all the correct hints of the
4955 currently compiling COP, but that IN_PERL_RUNTIME is true. */
4956 assert(IN_PERL_RUNTIME);
4957 PL_warnhook = PERL_WARNHOOK_FATAL;
4960 /* Effective $^W=1. */
4961 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4962 PL_dowarn |= G_WARN_ON;
4964 ret = S_fold_constants_eval(aTHX);
4968 sv = *(PL_stack_sp--);
4969 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
4970 pad_swipe(o->op_targ, FALSE);
4972 else if (SvTEMP(sv)) { /* grab mortal temp? */
4973 SvREFCNT_inc_simple_void(sv);
4976 else { assert(SvIMMORTAL(sv)); }
4979 /* Something tried to die. Abandon constant folding. */
4980 /* Pretend the error never happened. */
4982 o->op_next = old_next;
4985 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4986 PL_warnhook = oldwarnhook;
4987 PL_diehook = olddiehook;
4988 /* XXX note that this croak may fail as we've already blown away
4989 * the stack - eg any nested evals */
4990 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4992 PL_dowarn = oldwarn;
4993 PL_warnhook = oldwarnhook;
4994 PL_diehook = olddiehook;
4995 PL_curcop = &PL_compiling;
4997 /* if we croaked, depending on how we croaked the eval scope
4998 * may or may not have already been popped */
4999 if (cxstack_ix > old_cxix) {
5000 assert(cxstack_ix == old_cxix + 1);
5001 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5002 delete_eval_scope();
5007 /* OP_STRINGIFY and constant folding are used to implement qq.
5008 Here the constant folding is an implementation detail that we
5009 want to hide. If the stringify op is itself already marked
5010 folded, however, then it is actually a folded join. */
5011 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5016 else if (!SvIMMORTAL(sv)) {
5020 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5021 if (!is_stringify) newop->op_folded = 1;
5028 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
5029 * the constant value being an AV holding the flattened range.
5033 S_gen_constant_list(pTHX_ OP *o)
5035 OP *curop, *old_next;
5036 SV * const oldwarnhook = PL_warnhook;
5037 SV * const olddiehook = PL_diehook;
5039 U8 oldwarn = PL_dowarn;
5049 if (PL_parser && PL_parser->error_count)
5050 return; /* Don't attempt to run with errors */
5052 curop = LINKLIST(o);
5053 old_next = o->op_next;
5055 op_was_null = o->op_type == OP_NULL;
5056 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5057 o->op_type = OP_CUSTOM;
5060 o->op_type = OP_NULL;
5061 op_prune_chain_head(&curop);
5064 old_cxix = cxstack_ix;
5065 create_eval_scope(NULL, G_FAKINGEVAL);
5067 old_curcop = PL_curcop;
5068 StructCopy(old_curcop, ¬_compiling, COP);
5069 PL_curcop = ¬_compiling;
5070 /* The above ensures that we run with all the correct hints of the
5071 current COP, but that IN_PERL_RUNTIME is true. */
5072 assert(IN_PERL_RUNTIME);
5073 PL_warnhook = PERL_WARNHOOK_FATAL;
5077 /* Effective $^W=1. */
5078 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5079 PL_dowarn |= G_WARN_ON;
5083 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5084 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5086 Perl_pp_pushmark(aTHX);
5089 assert (!(curop->op_flags & OPf_SPECIAL));
5090 assert(curop->op_type == OP_RANGE);
5091 Perl_pp_anonlist(aTHX);
5095 o->op_next = old_next;
5099 PL_warnhook = oldwarnhook;
5100 PL_diehook = olddiehook;
5101 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5106 PL_dowarn = oldwarn;
5107 PL_warnhook = oldwarnhook;
5108 PL_diehook = olddiehook;
5109 PL_curcop = old_curcop;
5111 if (cxstack_ix > old_cxix) {
5112 assert(cxstack_ix == old_cxix + 1);
5113 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5114 delete_eval_scope();
5119 OpTYPE_set(o, OP_RV2AV);
5120 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
5121 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
5122 o->op_opt = 0; /* needs to be revisited in rpeep() */
5123 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5125 /* replace subtree with an OP_CONST */
5126 curop = cUNOPo->op_first;
5127 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5130 if (AvFILLp(av) != -1)
5131 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5134 SvREADONLY_on(*svp);
5142 =for apidoc_section $optree_manipulation
5146 FORBID_LOOPEX_DEFAULT = (1<<0),
5149 static void walk_ops_find_labels(pTHX_ OP *o, HV *gotolabels)
5151 switch(o->op_type) {
5157 const char *label_pv = CopLABEL_len_flags((COP *)o, &label_len, &label_flags);
5161 SV *labelsv = newSVpvn_flags(label_pv, label_len, label_flags);
5162 SAVEFREESV(labelsv);
5164 sv_inc(HeVAL(hv_fetch_ent(gotolabels, labelsv, TRUE, 0)));
5169 if(!(o->op_flags & OPf_KIDS))
5172 OP *kid = cUNOPo->op_first;
5174 walk_ops_find_labels(aTHX_ kid, gotolabels);
5175 kid = OpSIBLING(kid);
5179 static void walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, HV *permittedgotos, const char *blockname)
5181 bool is_loop = FALSE;
5184 switch(o->op_type) {
5187 PL_curcop = (COP *)o;
5195 /* OPf_STACKED means either dynamically computed label or `goto &sub` */
5196 if(o->op_flags & OPf_STACKED)
5199 SV *target = newSVpvn_utf8(cPVOPo->op_pv, strlen(cPVOPo->op_pv),
5200 cPVOPo->op_private & OPpPV_IS_UTF8);
5203 if(hv_fetch_ent(permittedgotos, target, FALSE, 0))
5213 /* OPf_SPECIAL means this is a default loopex */
5214 if(o->op_flags & OPf_SPECIAL) {
5215 if(flags & FORBID_LOOPEX_DEFAULT)
5220 /* OPf_STACKED means it's a dynamically computed label */
5221 if(o->op_flags & OPf_STACKED)
5224 SV *target = newSVpv(cPVOPo->op_pv, strlen(cPVOPo->op_pv));
5225 if(cPVOPo->op_private & OPpPV_IS_UTF8)
5229 if(hv_fetch_ent(permittedloops, target, FALSE, 0))
5239 const char *label_pv = CopLABEL_len_flags(PL_curcop, &label_len, &label_flags);
5242 labelsv = newSVpvn(label_pv, label_len);
5243 if(label_flags & SVf_UTF8)
5245 SAVEFREESV(labelsv);
5247 sv_inc(HeVAL(hv_fetch_ent(permittedloops, labelsv, TRUE, 0)));
5255 /* diag_listed_as: Can't "%s" out of a "defer" block */
5256 /* diag_listed_as: Can't "%s" out of a "finally" block */
5257 croak("Can't \"%s\" out of %s", PL_op_name[o->op_type], blockname);
5263 if(!(o->op_flags & OPf_KIDS))
5266 OP *kid = cUNOPo->op_first;
5268 walk_ops_forbid(aTHX_ kid, flags, permittedloops, permittedgotos, blockname);
5269 kid = OpSIBLING(kid);
5272 /* Now in the body of the loop; we can permit loopex default */
5273 flags &= ~FORBID_LOOPEX_DEFAULT;
5277 if(is_loop && labelsv) {
5278 HE *he = hv_fetch_ent(permittedloops, labelsv, FALSE, 0);
5279 if(SvIV(HeVAL(he)) > 1)
5282 hv_delete_ent(permittedloops, labelsv, 0, 0);
5287 =for apidoc forbid_outofblock_ops
5289 Checks an optree that implements a block, to ensure there are no control-flow
5290 ops that attempt to leave the block. Any C<OP_RETURN> is forbidden, as is any
5291 C<OP_GOTO>. Loops are analysed, so any LOOPEX op (C<OP_NEXT>, C<OP_LAST> or
5292 C<OP_REDO>) that affects a loop that contains it within the block are
5293 permitted, but those that do not are forbidden.
5295 If any of these forbidden constructions are detected, an exception is thrown
5296 by using the op name and the blockname argument to construct a suitable
5299 This function alone is not sufficient to ensure the optree does not perform
5300 any of these forbidden activities during runtime, as it might call a different
5301 function that performs a non-local LOOPEX, or a string-eval() that performs a
5302 C<goto>, or various other things. It is intended purely as a compile-time
5303 check for those that could be detected statically. Additional runtime checks
5304 may be required depending on the circumstance it is used for.
5306 Note currently that I<all> C<OP_GOTO> ops are forbidden, even in cases where
5307 they might otherwise be safe to execute. This may be permitted in a later
5314 Perl_forbid_outofblock_ops(pTHX_ OP *o, const char *blockname)
5316 PERL_ARGS_ASSERT_FORBID_OUTOFBLOCK_OPS;
5319 SAVEVPTR(PL_curcop);
5321 HV *looplabels = newHV();
5322 SAVEFREESV((SV *)looplabels);
5324 HV *gotolabels = newHV();
5325 SAVEFREESV((SV *)gotolabels);
5327 walk_ops_find_labels(aTHX_ o, gotolabels);
5329 walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, gotolabels, blockname);
5334 /* List constructors */
5337 =for apidoc op_append_elem
5339 Append an item to the list of ops contained directly within a list-type
5340 op, returning the lengthened list. C<first> is the list-type op,
5341 and C<last> is the op to append to the list. C<optype> specifies the
5342 intended opcode for the list. If C<first> is not already a list of the
5343 right type, it will be upgraded into one. If either C<first> or C<last>
5344 is null, the other is returned unchanged.
5350 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5358 if (first->op_type != (unsigned)type
5359 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5361 return newLISTOP(type, 0, first, last);
5364 op_sibling_splice(first, cLISTOPx(first)->op_last, 0, last);
5365 first->op_flags |= OPf_KIDS;
5370 =for apidoc op_append_list
5372 Concatenate the lists of ops contained directly within two list-type ops,
5373 returning the combined list. C<first> and C<last> are the list-type ops
5374 to concatenate. C<optype> specifies the intended opcode for the list.
5375 If either C<first> or C<last> is not already a list of the right type,
5376 it will be upgraded into one. If either C<first> or C<last> is null,
5377 the other is returned unchanged.
5383 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5391 if (first->op_type != (unsigned)type)
5392 return op_prepend_elem(type, first, last);
5394 if (last->op_type != (unsigned)type)
5395 return op_append_elem(type, first, last);
5397 OpMORESIB_set(cLISTOPx(first)->op_last, cLISTOPx(last)->op_first);
5398 cLISTOPx(first)->op_last = cLISTOPx(last)->op_last;
5399 OpLASTSIB_set(cLISTOPx(first)->op_last, first);
5400 first->op_flags |= (last->op_flags & OPf_KIDS);
5402 S_op_destroy(aTHX_ last);
5408 =for apidoc op_prepend_elem
5410 Prepend an item to the list of ops contained directly within a list-type
5411 op, returning the lengthened list. C<first> is the op to prepend to the
5412 list, and C<last> is the list-type op. C<optype> specifies the intended
5413 opcode for the list. If C<last> is not already a list of the right type,
5414 it will be upgraded into one. If either C<first> or C<last> is null,
5415 the other is returned unchanged.
5421 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5429 if (last->op_type == (unsigned)type) {
5430 if (type == OP_LIST) { /* already a PUSHMARK there */
5431 /* insert 'first' after pushmark */
5432 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5433 if (!(first->op_flags & OPf_PARENS))
5434 last->op_flags &= ~OPf_PARENS;
5437 op_sibling_splice(last, NULL, 0, first);
5438 last->op_flags |= OPf_KIDS;
5442 return newLISTOP(type, 0, first, last);
5446 =for apidoc op_convert_list
5448 Converts C<o> into a list op if it is not one already, and then converts it
5449 into the specified C<type>, calling its check function, allocating a target if
5450 it needs one, and folding constants.
5452 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5453 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
5454 C<op_convert_list> to make it the right type.
5460 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5462 if (type < 0) type = -type, flags |= OPf_SPECIAL;
5463 if (type == OP_RETURN) {
5464 if (FEATURE_MODULE_TRUE_IS_ENABLED)
5465 flags |= OPf_SPECIAL;
5467 if (!o || o->op_type != OP_LIST)
5468 o = force_list(o, FALSE);
5471 o->op_flags &= ~OPf_WANT;
5472 o->op_private &= ~OPpLVAL_INTRO;
5475 if (!(PL_opargs[type] & OA_MARK))
5476 op_null(cLISTOPo->op_first);
5478 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5479 if (kid2 && kid2->op_type == OP_COREARGS) {
5480 op_null(cLISTOPo->op_first);
5481 kid2->op_private |= OPpCOREARGS_PUSHMARK;
5485 if (type != OP_SPLIT)
5486 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5487 * ck_split() create a real PMOP and leave the op's type as listop
5488 * for now. Otherwise op_free() etc will crash.
5490 OpTYPE_set(o, type);
5492 o->op_flags |= flags;
5493 if (flags & OPf_FOLDED)
5496 o = CHECKOP(type, o);
5497 if (o->op_type != (unsigned)type)
5500 return fold_constants(op_integerize(op_std_init(o)));
5507 =for apidoc_section $optree_construction
5509 =for apidoc newNULLLIST
5511 Constructs, checks, and returns a new C<stub> op, which represents an
5512 empty list expression.
5518 Perl_newNULLLIST(pTHX)
5520 return newOP(OP_STUB, 0);
5523 /* promote o and any siblings to be a list if its not already; i.e.
5531 * pushmark - o - A - B
5533 * If nullit it true, the list op is nulled.
5537 S_force_list(pTHX_ OP *o, bool nullit)
5539 if (!o || o->op_type != OP_LIST) {
5542 /* manually detach any siblings then add them back later */
5543 rest = OpSIBLING(o);
5544 OpLASTSIB_set(o, NULL);
5546 o = newLISTOP(OP_LIST, 0, o, NULL);
5548 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5556 =for apidoc op_force_list
5558 Promotes o and any siblings to be an C<OP_LIST> if it is not already. If
5559 a new C<OP_LIST> op was created, its first child will be C<OP_PUSHMARK>.
5560 The returned node itself will be nulled, leaving only its children.
5562 This is often what you want to do before putting the optree into list
5565 o = op_contextualize(op_force_list(o), G_LIST);
5571 Perl_op_force_list(pTHX_ OP *o)
5573 return force_list(o, TRUE);
5577 =for apidoc newLISTOP
5579 Constructs, checks, and returns an op of any list type. C<type> is
5580 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5581 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
5582 supply up to two ops to be direct children of the list op; they are
5583 consumed by this function and become part of the constructed op tree.
5585 For most list operators, the check function expects all the kid ops to be
5586 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5587 appropriate. What you want to do in that case is create an op of type
5588 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5589 See L</op_convert_list> for more information.
5595 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5598 /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
5599 * pushmark is banned. So do it now while existing ops are in a
5600 * consistent state, in case they suddenly get freed */
5601 OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
5603 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
5604 || type == OP_CUSTOM);
5606 NewOp(1101, listop, 1, LISTOP);
5607 OpTYPE_set(listop, type);
5610 listop->op_flags = (U8)flags;
5614 else if (!first && last)
5617 OpMORESIB_set(first, last);
5618 listop->op_first = first;
5619 listop->op_last = last;
5622 OpMORESIB_set(pushop, first);
5623 listop->op_first = pushop;
5624 listop->op_flags |= OPf_KIDS;
5626 listop->op_last = pushop;
5628 if (listop->op_last)
5629 OpLASTSIB_set(listop->op_last, (OP*)listop);
5631 return CHECKOP(type, listop);
5637 Constructs, checks, and returns an op of any base type (any type that
5638 has no extra fields). C<type> is the opcode. C<flags> gives the
5639 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5646 Perl_newOP(pTHX_ I32 type, I32 flags)
5650 if (type == -OP_ENTEREVAL) {
5651 type = OP_ENTEREVAL;
5652 flags |= OPpEVAL_BYTES<<8;
5655 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5656 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5657 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5658 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5660 NewOp(1101, o, 1, OP);
5661 OpTYPE_set(o, type);
5662 o->op_flags = (U8)flags;
5665 o->op_private = (U8)(0 | (flags >> 8));
5666 if (PL_opargs[type] & OA_RETSCALAR)
5668 if (PL_opargs[type] & OA_TARGET)
5669 o->op_targ = pad_alloc(type, SVs_PADTMP);
5670 return CHECKOP(type, o);
5676 Constructs, checks, and returns an op of any unary type. C<type> is
5677 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
5678 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5679 bits, the eight bits of C<op_private>, except that the bit with value 1
5680 is automatically set. C<first> supplies an optional op to be the direct
5681 child of the unary op; it is consumed by this function and become part
5682 of the constructed op tree.
5684 =for apidoc Amnh||OPf_KIDS
5690 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5694 if (type == -OP_ENTEREVAL) {
5695 type = OP_ENTEREVAL;
5696 flags |= OPpEVAL_BYTES<<8;
5699 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5700 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5701 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5702 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5703 || type == OP_SASSIGN
5704 || type == OP_ENTERTRY
5705 || type == OP_ENTERTRYCATCH
5706 || type == OP_CUSTOM
5707 || type == OP_NULL );
5710 first = newOP(OP_STUB, 0);
5711 if (PL_opargs[type] & OA_MARK)
5712 first = op_force_list(first);
5714 NewOp(1101, unop, 1, UNOP);
5715 OpTYPE_set(unop, type);
5716 unop->op_first = first;
5717 unop->op_flags = (U8)(flags | OPf_KIDS);
5718 unop->op_private = (U8)(1 | (flags >> 8));
5720 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5721 OpLASTSIB_set(first, (OP*)unop);
5723 unop = (UNOP*) CHECKOP(type, unop);
5727 return fold_constants(op_integerize(op_std_init((OP *) unop)));
5731 =for apidoc newUNOP_AUX
5733 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5734 initialised to C<aux>
5740 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5744 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5745 || type == OP_CUSTOM);
5747 NewOp(1101, unop, 1, UNOP_AUX);
5748 unop->op_type = (OPCODE)type;
5749 unop->op_ppaddr = PL_ppaddr[type];
5750 unop->op_first = first;
5751 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5752 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5755 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5756 OpLASTSIB_set(first, (OP*)unop);
5758 unop = (UNOP_AUX*) CHECKOP(type, unop);
5760 return op_std_init((OP *) unop);
5764 =for apidoc newMETHOP
5766 Constructs, checks, and returns an op of method type with a method name
5767 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
5768 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5769 and, shifted up eight bits, the eight bits of C<op_private>, except that
5770 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
5771 op which evaluates method name; it is consumed by this function and
5772 become part of the constructed op tree.
5773 Supported optypes: C<OP_METHOD>.
5779 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5782 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5783 || type == OP_CUSTOM);
5785 NewOp(1101, methop, 1, METHOP);
5787 if (PL_opargs[type] & OA_MARK) dynamic_meth = op_force_list(dynamic_meth);
5788 methop->op_flags = (U8)(flags | OPf_KIDS);
5789 methop->op_u.op_first = dynamic_meth;
5790 methop->op_private = (U8)(1 | (flags >> 8));
5792 if (!OpHAS_SIBLING(dynamic_meth))
5793 OpLASTSIB_set(dynamic_meth, (OP*)methop);
5797 methop->op_flags = (U8)(flags & ~OPf_KIDS);
5798 methop->op_u.op_meth_sv = const_meth;
5799 methop->op_private = (U8)(0 | (flags >> 8));
5800 methop->op_next = (OP*)methop;
5804 methop->op_rclass_targ = 0;
5806 methop->op_rclass_sv = NULL;
5809 OpTYPE_set(methop, type);
5810 return CHECKOP(type, methop);
5814 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5815 PERL_ARGS_ASSERT_NEWMETHOP;
5816 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5820 =for apidoc newMETHOP_named
5822 Constructs, checks, and returns an op of method type with a constant
5823 method name. C<type> is the opcode. C<flags> gives the eight bits of
5824 C<op_flags>, and, shifted up eight bits, the eight bits of
5825 C<op_private>. C<const_meth> supplies a constant method name;
5826 it must be a shared COW string.
5827 Supported optypes: C<OP_METHOD_NAMED>.
5833 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5834 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5835 return newMETHOP_internal(type, flags, NULL, const_meth);
5839 =for apidoc newBINOP
5841 Constructs, checks, and returns an op of any binary type. C<type>
5842 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
5843 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5844 the eight bits of C<op_private>, except that the bit with value 1 or
5845 2 is automatically set as required. C<first> and C<last> supply up to
5846 two ops to be the direct children of the binary op; they are consumed
5847 by this function and become part of the constructed op tree.
5853 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5857 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5858 || type == OP_NULL || type == OP_CUSTOM);
5860 NewOp(1101, binop, 1, BINOP);
5863 first = newOP(OP_NULL, 0);
5865 OpTYPE_set(binop, type);
5866 binop->op_first = first;
5867 binop->op_flags = (U8)(flags | OPf_KIDS);
5870 binop->op_private = (U8)(1 | (flags >> 8));
5873 binop->op_private = (U8)(2 | (flags >> 8));
5874 OpMORESIB_set(first, last);
5877 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5878 OpLASTSIB_set(last, (OP*)binop);
5880 binop->op_last = OpSIBLING(binop->op_first);
5882 OpLASTSIB_set(binop->op_last, (OP*)binop);
5884 binop = (BINOP*) CHECKOP(type, binop);
5885 if (binop->op_next || binop->op_type != (OPCODE)type)
5888 return fold_constants(op_integerize(op_std_init((OP *)binop)));
5892 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
5894 const char indent[] = " ";
5896 UV len = _invlist_len(invlist);
5897 UV * array = invlist_array(invlist);
5900 PERL_ARGS_ASSERT_INVMAP_DUMP;
5902 for (i = 0; i < len; i++) {
5903 UV start = array[i];
5904 UV end = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
5906 PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
5907 if (end == IV_MAX) {
5908 PerlIO_printf(Perl_debug_log, " .. INFTY");
5910 else if (end != start) {
5911 PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
5914 PerlIO_printf(Perl_debug_log, " ");
5917 PerlIO_printf(Perl_debug_log, "\t");
5919 if (map[i] == TR_UNLISTED) {
5920 PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
5922 else if (map[i] == TR_SPECIAL_HANDLING) {
5923 PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
5926 PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
5931 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
5932 * containing the search and replacement strings, assemble into
5933 * a translation table attached as o->op_pv.
5934 * Free expr and repl.
5935 * It expects the toker to have already set the
5936 * OPpTRANS_COMPLEMENT
5939 * flags as appropriate; this function may add
5941 * OPpTRANS_CAN_FORCE_UTF8
5942 * OPpTRANS_IDENTICAL
5948 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5950 /* This function compiles a tr///, from data gathered from toke.c, into a
5951 * form suitable for use by do_trans() in doop.c at runtime.
5953 * It first normalizes the data, while discarding extraneous inputs; then
5954 * writes out the compiled data. The normalization allows for complete
5955 * analysis, and avoids some false negatives and positives earlier versions
5958 * The normalization form is an inversion map (described below in detail).
5959 * This is essentially the compiled form for tr///'s that require UTF-8,
5960 * and its easy to use it to write the 257-byte table for tr///'s that
5961 * don't need UTF-8. That table is identical to what's been in use for
5962 * many perl versions, except that it doesn't handle some edge cases that
5963 * it used to, involving code points above 255. The UTF-8 form now handles
5964 * these. (This could be changed with extra coding should it shown to be
5967 * If the complement (/c) option is specified, the lhs string (tstr) is
5968 * parsed into an inversion list. Complementing these is trivial. Then a
5969 * complemented tstr is built from that, and used thenceforth. This hides
5970 * the fact that it was complemented from almost all successive code.
5972 * One of the important characteristics to know about the input is whether
5973 * the transliteration may be done in place, or does a temporary need to be
5974 * allocated, then copied. If the replacement for every character in every
5975 * possible string takes up no more bytes than the character it
5976 * replaces, then it can be edited in place. Otherwise the replacement
5977 * could overwrite a byte we are about to read, depending on the strings
5978 * being processed. The comments and variable names here refer to this as
5979 * "growing". Some inputs won't grow, and might even shrink under /d, but
5980 * some inputs could grow, so we have to assume any given one might grow.
5981 * On very long inputs, the temporary could eat up a lot of memory, so we
5982 * want to avoid it if possible. For non-UTF-8 inputs, everything is
5983 * single-byte, so can be edited in place, unless there is something in the
5984 * pattern that could force it into UTF-8. The inversion map makes it
5985 * feasible to determine this. Previous versions of this code pretty much
5986 * punted on determining if UTF-8 could be edited in place. Now, this code
5987 * is rigorous in making that determination.
5989 * Another characteristic we need to know is whether the lhs and rhs are
5990 * identical. If so, and no other flags are present, the only effect of
5991 * the tr/// is to count the characters present in the input that are
5992 * mentioned in the lhs string. The implementation of that is easier and
5993 * runs faster than the more general case. Normalizing here allows for
5994 * accurate determination of this. Previously there were false negatives
5997 * Instead of 'transliterated', the comments here use 'unmapped' for the
5998 * characters that are left unchanged by the operation; otherwise they are
6001 * The lhs of the tr/// is here referred to as the t side.
6002 * The rhs of the tr/// is here referred to as the r side.
6005 SV * const tstr = cSVOPx(expr)->op_sv;
6006 SV * const rstr = cSVOPx(repl)->op_sv;
6009 const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
6010 const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
6013 UV t_count = 0, r_count = 0; /* Number of characters in search and
6014 replacement lists */
6016 /* khw thinks some of the private flags for this op are quaintly named.
6017 * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
6018 * character when represented in UTF-8 is longer than the original
6019 * character's UTF-8 representation */
6020 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6021 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6022 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6024 /* Set to true if there is some character < 256 in the lhs that maps to
6025 * above 255. If so, a non-UTF-8 match string can be forced into being in
6026 * UTF-8 by a tr/// operation. */
6027 bool can_force_utf8 = FALSE;
6029 /* What is the maximum expansion factor in UTF-8 transliterations. If a
6030 * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
6031 * expansion factor is 1.5. This number is used at runtime to calculate
6032 * how much space to allocate for non-inplace transliterations. Without
6033 * this number, the worst case is 14, which is extremely unlikely to happen
6034 * in real life, and could require significant memory overhead. */
6035 NV max_expansion = 1.;
6037 UV t_range_count, r_range_count, min_range_count;
6041 UV r_cp = 0, t_cp = 0;
6042 UV t_cp_end = (UV) -1;
6046 UV final_map = TR_UNLISTED; /* The final character in the replacement
6047 list, updated as we go along. Initialize
6048 to something illegal */
6050 bool rstr_utf8 = cBOOL(SvUTF8(rstr));
6051 bool tstr_utf8 = cBOOL(SvUTF8(tstr));
6053 const U8* tend = t + tlen;
6054 const U8* rend = r + rlen;
6056 SV * inverted_tstr = NULL;
6061 /* This routine implements detection of a transliteration having a longer
6062 * UTF-8 representation than its source, by partitioning all the possible
6063 * code points of the platform into equivalence classes of the same UTF-8
6064 * byte length in the first pass. As it constructs the mappings, it carves
6065 * these up into smaller chunks, but doesn't merge any together. This
6066 * makes it easy to find the instances it's looking for. A second pass is
6067 * done after this has been determined which merges things together to
6068 * shrink the table for runtime. The table below is used for both ASCII
6069 * and EBCDIC platforms. On EBCDIC, the byte length is not monotonically
6070 * increasing for code points below 256. To correct for that, the macro
6071 * CP_ADJUST defined below converts those code points to ASCII in the first
6072 * pass, and we use the ASCII partition values. That works because the
6073 * growth factor will be unaffected, which is all that is calculated during
6074 * the first pass. */
6075 UV PL_partition_by_byte_length[] = {
6077 0x80, /* Below this is 1 byte representations */
6078 (32 * (1UL << ( UTF_ACCUMULATION_SHIFT))), /* 2 bytes below this */
6079 (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))), /* 3 bytes below this */
6080 ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))), /* 4 bytes below this */
6081 ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))), /* 5 bytes below this */
6082 ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT))) /* 6 bytes below this */
6086 ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT))) /* 7 bytes below this */
6091 PERL_ARGS_ASSERT_PMTRANS;
6093 PL_hints |= HINT_BLOCK_SCOPE;
6095 /* If /c, the search list is sorted and complemented. This is now done by
6096 * creating an inversion list from it, and then trivially inverting that.
6097 * The previous implementation used qsort, but creating the list
6098 * automatically keeps it sorted as we go along */
6101 SV * inverted_tlist = _new_invlist(tlen);
6104 DEBUG_y(PerlIO_printf(Perl_debug_log,
6105 "%s: %d: tstr before inversion=\n%s\n",
6106 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6110 /* Non-utf8 strings don't have ranges, so each character is listed
6113 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
6116 else { /* But UTF-8 strings have been parsed in toke.c to have
6117 * ranges if appropriate. */
6121 /* Get the first character */
6122 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
6125 /* If the next byte indicates that this wasn't the first
6126 * element of a range, the range is just this one */
6127 if (t >= tend || *t != RANGE_INDICATOR) {
6128 inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
6130 else { /* Otherwise, ignore the indicator byte, and get the
6131 final element, and add the whole range */
6133 t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
6136 inverted_tlist = _add_range_to_invlist(inverted_tlist,
6140 } /* End of parse through tstr */
6142 /* The inversion list is done; now invert it */
6143 _invlist_invert(inverted_tlist);
6145 /* Now go through the inverted list and create a new tstr for the rest
6146 * of the routine to use. Since the UTF-8 version can have ranges, and
6147 * can be much more compact than the non-UTF-8 version, we create the
6148 * string in UTF-8 even if not necessary. (This is just an intermediate
6149 * value that gets thrown away anyway.) */
6150 invlist_iterinit(inverted_tlist);
6151 inverted_tstr = newSVpvs("");
6152 while (invlist_iternext(inverted_tlist, &start, &end)) {
6153 U8 temp[UTF8_MAXBYTES];
6156 /* IV_MAX keeps things from going out of bounds */
6157 start = MIN(IV_MAX, start);
6158 end = MIN(IV_MAX, end);
6160 temp_end_pos = uvchr_to_utf8(temp, start);
6161 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6164 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
6165 temp_end_pos = uvchr_to_utf8(temp, end);
6166 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6170 /* Set up so the remainder of the routine uses this complement, instead
6171 * of the actual input */
6172 t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
6173 tend = t0 + temp_len;
6176 SvREFCNT_dec_NN(inverted_tlist);
6179 /* For non-/d, an empty rhs means to use the lhs */
6180 if (rlen == 0 && ! del) {
6183 rstr_utf8 = tstr_utf8;
6186 t_invlist = _new_invlist(1);
6188 /* Initialize to a single range */
6189 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
6191 /* Below, we parse the (potentially adjusted) input, creating the inversion
6192 * map. This is done in two passes. The first pass is just to determine
6193 * if the transliteration can be done in-place. It can be done in place if
6194 * no possible inputs result in the replacement taking up more bytes than
6195 * the input. To figure that out, in the first pass we start with all the
6196 * possible code points partitioned into ranges so that every code point in
6197 * a range occupies the same number of UTF-8 bytes as every other code
6198 * point in the range. Constructing the inversion map doesn't merge ranges
6199 * together, but can split them into multiple ones. Given the starting
6200 * partition, the ending state will also have the same characteristic,
6201 * namely that each code point in each partition requires the same number
6202 * of UTF-8 bytes to represent as every other code point in the same
6205 * This partitioning has been pre-compiled. Copy it to initialize */
6206 len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
6207 invlist_extend(t_invlist, len);
6208 t_array = invlist_array(t_invlist);
6209 Copy(PL_partition_by_byte_length, t_array, len, UV);
6210 invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
6211 Newx(r_map, len + 1, UV);
6213 /* The inversion map the first pass creates could be used as-is, but
6214 * generally would be larger and slower to run than the output of the
6217 for (pass2 = 0; pass2 < 2; pass2++) {
6219 /* In the second pass, we start with a single range */
6220 t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
6222 t_array = invlist_array(t_invlist);
6225 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
6226 * so as to get the well-behaved length 1 vs length 2 boundary. Only code
6227 * points below 256 differ between the two character sets in this regard. For
6228 * these, we also can't have any ranges, as they have to be individually
6231 # define CP_ADJUST(x) ((pass2) ? (x) : NATIVE_TO_UNI(x))
6232 # define FORCE_RANGE_LEN_1(x) ((pass2) ? 0 : ((x) < 256))
6233 # define CP_SKIP(x) ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
6235 # define CP_ADJUST(x) (x)
6236 # define FORCE_RANGE_LEN_1(x) 0
6237 # define CP_SKIP(x) UVCHR_SKIP(x)
6240 /* And the mapping of each of the ranges is initialized. Initially,
6241 * everything is TR_UNLISTED. */
6242 for (i = 0; i < len; i++) {
6243 r_map[i] = TR_UNLISTED;
6250 t_range_count = r_range_count = 0;
6252 DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
6253 __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6254 DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
6255 _byte_dump_string(r, rend - r, 0)));
6256 DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
6257 complement, squash, del));
6258 DEBUG_y(invmap_dump(t_invlist, r_map));
6260 /* Now go through the search list constructing an inversion map. The
6261 * input is not necessarily in any particular order. Making it an
6262 * inversion map orders it, potentially simplifying, and makes it easy
6263 * to deal with at run time. This is the only place in core that
6264 * generates an inversion map; if others were introduced, it might be
6265 * better to create general purpose routines to handle them.
6266 * (Inversion maps are created in perl in other places.)
6268 * An inversion map consists of two parallel arrays. One is
6269 * essentially an inversion list: an ordered list of code points such
6270 * that each element gives the first code point of a range of
6271 * consecutive code points that map to the element in the other array
6272 * that has the same index as this one (in other words, the
6273 * corresponding element). Thus the range extends up to (but not
6274 * including) the code point given by the next higher element. In a
6275 * true inversion map, the corresponding element in the other array
6276 * gives the mapping of the first code point in the range, with the
6277 * understanding that the next higher code point in the inversion
6278 * list's range will map to the next higher code point in the map.
6280 * So if at element [i], let's say we have:
6285 * This means that A => a, B => b, C => c.... Let's say that the
6286 * situation is such that:
6290 * This means the sequence that started at [i] stops at K => k. This
6291 * illustrates that you need to look at the next element to find where
6292 * a sequence stops. Except, the highest element in the inversion list
6293 * begins a range that is understood to extend to the platform's
6296 * This routine modifies traditional inversion maps to reserve two
6299 * TR_UNLISTED (or -1) indicates that no code point in the range
6300 * is listed in the tr/// searchlist. At runtime, these are
6301 * always passed through unchanged. In the inversion map, all
6302 * points in the range are mapped to -1, instead of increasing,
6303 * like the 'L' in the example above.
6305 * We start the parse with every code point mapped to this, and as
6306 * we parse and find ones that are listed in the search list, we
6307 * carve out ranges as we go along that override that.
6309 * TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
6310 * range needs special handling. Again, all code points in the
6311 * range are mapped to -2, instead of increasing.
6313 * Under /d this value means the code point should be deleted from
6314 * the transliteration when encountered.
6316 * Otherwise, it marks that every code point in the range is to
6317 * map to the final character in the replacement list. This
6318 * happens only when the replacement list is shorter than the
6319 * search one, so there are things in the search list that have no
6320 * correspondence in the replacement list. For example, in
6321 * tr/a-z/A/, 'A' is the final value, and the inversion map
6322 * generated for this would be like this:
6327 * 'A' appears once, then the remainder of the range maps to -2.
6328 * The use of -2 isn't strictly necessary, as an inversion map is
6329 * capable of representing this situation, but not nearly so
6330 * compactly, and this is actually quite commonly encountered.
6331 * Indeed, the original design of this code used a full inversion
6332 * map for this. But things like
6334 * generated huge data structures, slowly, and the execution was
6335 * also slow. So the current scheme was implemented.
6337 * So, if the next element in our example is:
6341 * Then all of L, M, N, O, and P map to TR_UNLISTED. If the next
6345 * [i+4] S TR_UNLISTED
6347 * Then Q => q; R => z; and S => TR_UNLISTED. If [i+4] (the 'S') is
6348 * the final element in the arrays, every code point from S to infinity
6349 * maps to TR_UNLISTED.
6352 /* Finish up range started in what otherwise would
6353 * have been the final iteration */
6354 while (t < tend || t_range_count > 0) {
6355 bool adjacent_to_range_above = FALSE;
6356 bool adjacent_to_range_below = FALSE;
6358 bool merge_with_range_above = FALSE;
6359 bool merge_with_range_below = FALSE;
6361 UV span, invmap_range_length_remaining;
6365 /* If we are in the middle of processing a range in the 'target'
6366 * side, the previous iteration has set us up. Otherwise, look at
6367 * the next character in the search list */
6368 if (t_range_count <= 0) {
6371 /* Here, not in the middle of a range, and not UTF-8. The
6372 * next code point is the single byte where we're at */
6373 t_cp = CP_ADJUST(*t);
6380 /* Here, not in the middle of a range, and is UTF-8. The
6381 * next code point is the next UTF-8 char in the input. We
6382 * know the input is valid, because the toker constructed
6384 t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
6387 /* UTF-8 strings (only) have been parsed in toke.c to have
6388 * ranges. See if the next byte indicates that this was
6389 * the first element of a range. If so, get the final
6390 * element and calculate the range size. If not, the range
6392 if ( t < tend && *t == RANGE_INDICATOR
6393 && ! FORCE_RANGE_LEN_1(t_cp))
6396 t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
6405 /* Count the total number of listed code points * */
6406 t_count += t_range_count;
6409 /* Similarly, get the next character in the replacement list */
6410 if (r_range_count <= 0) {
6413 /* But if we've exhausted the rhs, there is nothing to map
6414 * to, except the special handling one, and we make the
6415 * range the same size as the lhs one. */
6416 r_cp = TR_SPECIAL_HANDLING;
6417 r_range_count = t_range_count;
6420 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6421 "final_map =%" UVXf "\n", final_map));
6426 r_cp = CP_ADJUST(*r);
6433 r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
6435 if ( r < rend && *r == RANGE_INDICATOR
6436 && ! FORCE_RANGE_LEN_1(r_cp))
6439 r_range_count = valid_utf8_to_uvchr(r,
6440 &r_char_len) - r_cp + 1;
6448 if (r_cp == TR_SPECIAL_HANDLING) {
6449 r_range_count = t_range_count;
6452 /* This is the final character so far */
6453 final_map = r_cp + r_range_count - 1;
6455 r_count += r_range_count;
6459 /* Here, we have the next things ready in both sides. They are
6460 * potentially ranges. We try to process as big a chunk as
6461 * possible at once, but the lhs and rhs must be synchronized, so
6462 * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
6464 min_range_count = MIN(t_range_count, r_range_count);
6466 /* Search the inversion list for the entry that contains the input
6467 * code point <cp>. The inversion map was initialized to cover the
6468 * entire range of possible inputs, so this should not fail. So
6469 * the return value is the index into the list's array of the range
6470 * that contains <cp>, that is, 'i' such that array[i] <= cp <
6472 j = _invlist_search(t_invlist, t_cp);
6476 /* Here, the data structure might look like:
6479 * [i-1] J j # J-L => j-l
6480 * [i] M -1 # M => default; as do N, O, P, Q
6481 * [i+1] R x # R => x, S => x+1, T => x+2
6482 * [i+2] U y # U => y, V => y+1, ...
6484 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6486 * where 'x' and 'y' above are not to be taken literally.
6488 * The maximum chunk we can handle in this loop iteration, is the
6489 * smallest of the three components: the lhs 't_', the rhs 'r_',
6490 * and the remainder of the range in element [i]. (In pass 1, that
6491 * range will have everything in it be of the same class; we can't
6492 * cross into another class.) 'min_range_count' already contains
6493 * the smallest of the first two values. The final one is
6494 * irrelevant if the map is to the special indicator */
6496 invmap_range_length_remaining = (i + 1 < len)
6497 ? t_array[i+1] - t_cp
6499 span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
6501 /* The end point of this chunk is where we are, plus the span, but
6502 * never larger than the platform's infinity */
6503 t_cp_end = MIN(IV_MAX, t_cp + span - 1);
6505 if (r_cp == TR_SPECIAL_HANDLING) {
6507 /* If unmatched lhs code points map to the final map, use that
6508 * value. This being set to TR_SPECIAL_HANDLING indicates that
6509 * we don't have a final map: unmatched lhs code points are
6511 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
6514 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
6516 /* If something on the lhs is below 256, and something on the
6517 * rhs is above, there is a potential mapping here across that
6518 * boundary. Indeed the only way there isn't is if both sides
6519 * start at the same point. That means they both cross at the
6520 * same time. But otherwise one crosses before the other */
6521 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
6522 can_force_utf8 = TRUE;
6526 /* If a character appears in the search list more than once, the
6527 * 2nd and succeeding occurrences are ignored, so only do this
6528 * range if haven't already processed this character. (The range
6529 * has been set up so that all members in it will be of the same
6531 if (r_map[i] == TR_UNLISTED) {
6532 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6533 "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
6534 t_cp, t_cp_end, r_cp, r_cp_end));
6536 /* This is the first definition for this chunk, hence is valid
6537 * and needs to be processed. Here and in the comments below,
6538 * we use the above sample data. The t_cp chunk must be any
6539 * contiguous subset of M, N, O, P, and/or Q.
6541 * In the first pass, calculate if there is any possible input
6542 * string that has a character whose transliteration will be
6543 * longer than it. If none, the transliteration may be done
6544 * in-place, as it can't write over a so-far unread byte.
6545 * Otherwise, a copy must first be made. This could be
6546 * expensive for long inputs.
6548 * In the first pass, the t_invlist has been partitioned so
6549 * that all elements in any single range have the same number
6550 * of bytes in their UTF-8 representations. And the r space is
6551 * either a single byte, or a range of strictly monotonically
6552 * increasing code points. So the final element in the range
6553 * will be represented by no fewer bytes than the initial one.
6554 * That means that if the final code point in the t range has
6555 * at least as many bytes as the final code point in the r,
6556 * then all code points in the t range have at least as many
6557 * bytes as their corresponding r range element. But if that's
6558 * not true, the transliteration of at least the final code
6559 * point grows in length. As an example, suppose we had
6560 * tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
6561 * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
6562 * platforms. We have deliberately set up the data structure
6563 * so that any range in the lhs gets split into chunks for
6564 * processing, such that every code point in a chunk has the
6565 * same number of UTF-8 bytes. We only have to check the final
6566 * code point in the rhs against any code point in the lhs. */
6568 && r_cp_end != TR_SPECIAL_HANDLING
6569 && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
6571 /* Here, we will need to make a copy of the input string
6572 * before doing the transliteration. The worst possible
6573 * case is an expansion ratio of 14:1. This is rare, and
6574 * we'd rather allocate only the necessary amount of extra
6575 * memory for that copy. We can calculate the worst case
6576 * for this particular transliteration is by keeping track
6577 * of the expansion factor for each range.
6579 * Consider tr/\xCB/\X{E000}/. The maximum expansion
6580 * factor is 1 byte going to 3 if the target string is not
6581 * UTF-8, but 2 bytes going to 3 if it is in UTF-8. We
6582 * could pass two different values so doop could choose
6583 * based on the UTF-8ness of the target. But khw thinks
6584 * (perhaps wrongly) that is overkill. It is used only to
6585 * make sure we malloc enough space.
6587 * If no target string can force the result to be UTF-8,
6588 * then we don't have to worry about the case of the target
6589 * string not being UTF-8 */
6590 NV t_size = (can_force_utf8 && t_cp < 256)
6592 : CP_SKIP(t_cp_end);
6593 NV ratio = CP_SKIP(r_cp_end) / t_size;
6595 o->op_private |= OPpTRANS_GROWS;
6597 /* Now that we know it grows, we can keep track of the
6599 if (ratio > max_expansion) {
6600 max_expansion = ratio;
6601 DEBUG_y(PerlIO_printf(Perl_debug_log,
6602 "New expansion factor: %" NVgf "\n",
6607 /* The very first range is marked as adjacent to the
6608 * non-existent range below it, as it causes things to "just
6611 * If the lowest code point in this chunk is M, it adjoins the
6613 if (t_cp == t_array[i]) {
6614 adjacent_to_range_below = TRUE;
6616 /* And if the map has the same offset from the beginning of
6617 * the range as does this new code point (or both are for
6618 * TR_SPECIAL_HANDLING), this chunk can be completely
6619 * merged with the range below. EXCEPT, in the first pass,
6620 * we don't merge ranges whose UTF-8 byte representations
6621 * have different lengths, so that we can more easily
6622 * detect if a replacement is longer than the source, that
6623 * is if it 'grows'. But in the 2nd pass, there's no
6624 * reason to not merge */
6625 if ( (i > 0 && ( pass2
6626 || CP_SKIP(t_array[i-1])
6628 && ( ( r_cp == TR_SPECIAL_HANDLING
6629 && r_map[i-1] == TR_SPECIAL_HANDLING)
6630 || ( r_cp != TR_SPECIAL_HANDLING
6631 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
6633 merge_with_range_below = TRUE;
6637 /* Similarly, if the highest code point in this chunk is 'Q',
6638 * it adjoins the range above, and if the map is suitable, can
6639 * be merged with it */
6640 if ( t_cp_end >= IV_MAX - 1
6642 && t_cp_end + 1 == t_array[i+1]))
6644 adjacent_to_range_above = TRUE;
6647 || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
6648 && ( ( r_cp == TR_SPECIAL_HANDLING
6649 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
6650 || ( r_cp != TR_SPECIAL_HANDLING
6651 && r_cp_end == r_map[i+1] - 1)))
6653 merge_with_range_above = TRUE;
6657 if (merge_with_range_below && merge_with_range_above) {
6659 /* Here the new chunk looks like M => m, ... Q => q; and
6660 * the range above is like R => r, .... Thus, the [i-1]
6661 * and [i+1] ranges should be seamlessly melded so the
6664 * [i-1] J j # J-T => j-t
6665 * [i] U y # U => y, V => y+1, ...
6667 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6669 Move(t_array + i + 2, t_array + i, len - i - 2, UV);
6670 Move(r_map + i + 2, r_map + i, len - i - 2, UV);
6672 invlist_set_len(t_invlist,
6674 *(get_invlist_offset_addr(t_invlist)));
6676 else if (merge_with_range_below) {
6678 /* Here the new chunk looks like M => m, .... But either
6679 * (or both) it doesn't extend all the way up through Q; or
6680 * the range above doesn't start with R => r. */
6681 if (! adjacent_to_range_above) {
6683 /* In the first case, let's say the new chunk extends
6684 * through O. We then want:
6686 * [i-1] J j # J-O => j-o
6687 * [i] P -1 # P => -1, Q => -1
6688 * [i+1] R x # R => x, S => x+1, T => x+2
6689 * [i+2] U y # U => y, V => y+1, ...
6691 * [-1] Z -1 # Z => default; as do Z+1, ...
6694 t_array[i] = t_cp_end + 1;
6695 r_map[i] = TR_UNLISTED;
6697 else { /* Adjoins the range above, but can't merge with it
6698 (because 'x' is not the next map after q) */
6700 * [i-1] J j # J-Q => j-q
6701 * [i] R x # R => x, S => x+1, T => x+2
6702 * [i+1] U y # U => y, V => y+1, ...
6704 * [-1] Z -1 # Z => default; as do Z+1, ...
6708 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6709 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
6711 invlist_set_len(t_invlist, len,
6712 *(get_invlist_offset_addr(t_invlist)));
6715 else if (merge_with_range_above) {
6717 /* Here the new chunk ends with Q => q, and the range above
6718 * must start with R => r, so the two can be merged. But
6719 * either (or both) the new chunk doesn't extend all the
6720 * way down to M; or the mapping of the final code point
6721 * range below isn't m */
6722 if (! adjacent_to_range_below) {
6724 /* In the first case, let's assume the new chunk starts
6725 * with P => p. Then, because it's merge-able with the
6726 * range above, that range must be R => r. We want:
6728 * [i-1] J j # J-L => j-l
6729 * [i] M -1 # M => -1, N => -1
6730 * [i+1] P p # P-T => p-t
6731 * [i+2] U y # U => y, V => y+1, ...
6733 * [-1] Z -1 # Z => default; as do Z+1, ...
6736 t_array[i+1] = t_cp;
6739 else { /* Adjoins the range below, but can't merge with it
6742 * [i-1] J j # J-L => j-l
6743 * [i] M x # M-T => x-5 .. x+2
6744 * [i+1] U y # U => y, V => y+1, ...
6746 * [-1] Z -1 # Z => default; as do Z+1, ...
6749 Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6750 Move(r_map + i + 1, r_map + i, len - i - 1, UV);
6754 invlist_set_len(t_invlist, len,
6755 *(get_invlist_offset_addr(t_invlist)));
6758 else if (adjacent_to_range_below && adjacent_to_range_above) {
6759 /* The new chunk completely fills the gap between the
6760 * ranges on either side, but can't merge with either of
6763 * [i-1] J j # J-L => j-l
6764 * [i] M z # M => z, N => z+1 ... Q => z+4
6765 * [i+1] R x # R => x, S => x+1, T => x+2
6766 * [i+2] U y # U => y, V => y+1, ...
6768 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6772 else if (adjacent_to_range_below) {
6773 /* The new chunk adjoins the range below, but not the range
6774 * above, and can't merge. Let's assume the chunk ends at
6777 * [i-1] J j # J-L => j-l
6778 * [i] M z # M => z, N => z+1, O => z+2
6779 * [i+1] P -1 # P => -1, Q => -1
6780 * [i+2] R x # R => x, S => x+1, T => x+2
6781 * [i+3] U y # U => y, V => y+1, ...
6783 * [-w] Z -1 # Z => default; as do Z+1, ... infinity
6785 invlist_extend(t_invlist, len + 1);
6786 t_array = invlist_array(t_invlist);
6787 Renew(r_map, len + 1, UV);
6789 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6790 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
6792 t_array[i+1] = t_cp_end + 1;
6793 r_map[i+1] = TR_UNLISTED;
6795 invlist_set_len(t_invlist, len,
6796 *(get_invlist_offset_addr(t_invlist)));
6798 else if (adjacent_to_range_above) {
6799 /* The new chunk adjoins the range above, but not the range
6800 * below, and can't merge. Let's assume the new chunk
6803 * [i-1] J j # J-L => j-l
6804 * [i] M -1 # M => default, N => default
6805 * [i+1] O z # O => z, P => z+1, Q => z+2
6806 * [i+2] R x # R => x, S => x+1, T => x+2
6807 * [i+3] U y # U => y, V => y+1, ...
6809 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6811 invlist_extend(t_invlist, len + 1);
6812 t_array = invlist_array(t_invlist);
6813 Renew(r_map, len + 1, UV);
6815 Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6816 Move(r_map + i + 1, r_map + i + 2, len - i - 1, UV);
6817 t_array[i+1] = t_cp;
6820 invlist_set_len(t_invlist, len,
6821 *(get_invlist_offset_addr(t_invlist)));
6824 /* The new chunk adjoins neither the range above, nor the
6825 * range below. Lets assume it is N..P => n..p
6827 * [i-1] J j # J-L => j-l
6828 * [i] M -1 # M => default
6829 * [i+1] N n # N..P => n..p
6830 * [i+2] Q -1 # Q => default
6831 * [i+3] R x # R => x, S => x+1, T => x+2
6832 * [i+4] U y # U => y, V => y+1, ...
6834 * [-1] Z -1 # Z => default; as do Z+1, ... infinity
6837 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6838 "Before fixing up: len=%d, i=%d\n",
6839 (int) len, (int) i));
6840 DEBUG_yv(invmap_dump(t_invlist, r_map));
6842 invlist_extend(t_invlist, len + 2);
6843 t_array = invlist_array(t_invlist);
6844 Renew(r_map, len + 2, UV);
6846 Move(t_array + i + 1,
6847 t_array + i + 2 + 1, len - i - (2 - 1), UV);
6849 r_map + i + 2 + 1, len - i - (2 - 1), UV);
6852 invlist_set_len(t_invlist, len,
6853 *(get_invlist_offset_addr(t_invlist)));
6855 t_array[i+1] = t_cp;
6858 t_array[i+2] = t_cp_end + 1;
6859 r_map[i+2] = TR_UNLISTED;
6861 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6862 "After iteration: span=%" UVuf ", t_range_count=%"
6863 UVuf " r_range_count=%" UVuf "\n",
6864 span, t_range_count, r_range_count));
6865 DEBUG_yv(invmap_dump(t_invlist, r_map));
6866 } /* End of this chunk needs to be processed */
6868 /* Done with this chunk. */
6870 if (t_cp >= IV_MAX) {
6873 t_range_count -= span;
6874 if (r_cp != TR_SPECIAL_HANDLING) {
6876 r_range_count -= span;
6882 } /* End of loop through the search list */
6884 /* We don't need an exact count, but we do need to know if there is
6885 * anything left over in the replacement list. So, just assume it's
6886 * one byte per character */
6890 } /* End of passes */
6892 SvREFCNT_dec(inverted_tstr);
6894 DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
6895 DEBUG_y(invmap_dump(t_invlist, r_map));
6897 /* We now have normalized the input into an inversion map.
6899 * See if the lhs and rhs are equivalent. If so, this tr/// is a no-op
6900 * except for the count, and streamlined runtime code can be used */
6901 if (!del && !squash) {
6903 /* They are identical if they point to the same address, or if
6904 * everything maps to UNLISTED or to itself. This catches things that
6905 * not looking at the normalized inversion map doesn't catch, like
6906 * tr/aa/ab/ or tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104} */
6908 for (i = 0; i < len; i++) {
6909 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
6910 goto done_identical_check;
6915 /* Here have gone through entire list, and didn't find any
6916 * non-identical mappings */
6917 o->op_private |= OPpTRANS_IDENTICAL;
6919 done_identical_check: ;
6922 t_array = invlist_array(t_invlist);
6924 /* If has components above 255, we generally need to use the inversion map
6928 && t_array[len-1] > 255
6929 /* If the final range is 0x100-INFINITY and is a special
6930 * mapping, the table implementation can handle it */
6931 && ! ( t_array[len-1] == 256
6932 && ( r_map[len-1] == TR_UNLISTED
6933 || r_map[len-1] == TR_SPECIAL_HANDLING))))
6938 /* A UTF-8 op is generated, indicated by this flag. This op is an
6940 o->op_private |= OPpTRANS_USE_SVOP;
6942 if (can_force_utf8) {
6943 o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
6946 /* The inversion map is pushed; first the list. */
6947 invmap = MUTABLE_AV(newAV());
6949 SvREADONLY_on(t_invlist);
6950 av_push(invmap, t_invlist);
6952 /* 2nd is the mapping */
6953 r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
6954 SvREADONLY_on(r_map_sv);
6955 av_push(invmap, r_map_sv);
6957 /* 3rd is the max possible expansion factor */
6958 temp_sv = newSVnv(max_expansion);
6959 SvREADONLY_on(temp_sv);
6960 av_push(invmap, temp_sv);
6962 /* Characters that are in the search list, but not in the replacement
6963 * list are mapped to the final character in the replacement list */
6964 if (! del && r_count < t_count) {
6965 temp_sv = newSVuv(final_map);
6966 SvREADONLY_on(temp_sv);
6967 av_push(invmap, temp_sv);
6971 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6972 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6973 PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
6974 SvPADTMP_on(invmap);
6975 SvREADONLY_on(invmap);
6977 cSVOPo->op_sv = (SV *) invmap;
6985 /* The OPtrans_map struct already contains one slot; hence the -1. */
6986 SSize_t struct_size = sizeof(OPtrans_map)
6987 + (256 - 1 + 1)*sizeof(short);
6989 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6990 * table. Entries with the value TR_UNMAPPED indicate chars not to be
6991 * translated, while TR_DELETE indicates a search char without a
6992 * corresponding replacement char under /d.
6994 * In addition, an extra slot at the end is used to store the final
6995 * repeating char, or TR_R_EMPTY under an empty replacement list, or
6996 * TR_DELETE under /d; which makes the runtime code easier. */
6998 /* Indicate this is an op_pv */
6999 o->op_private &= ~OPpTRANS_USE_SVOP;
7001 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7003 cPVOPo->op_pv = (char*)tbl;
7005 for (i = 0; i < len; i++) {
7006 STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7007 short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7008 short to = (short) r_map[i];
7010 bool do_increment = TRUE;
7012 /* Any code points above our limit should be irrelevant */
7013 if (t_array[i] >= tbl->size) break;
7015 /* Set up the map */
7016 if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7017 to = (short) final_map;
7018 do_increment = FALSE;
7021 do_increment = FALSE;
7024 /* Create a map for everything in this range. The value increases
7025 * except for the special cases */
7026 for (j = (short) t_array[i]; j < upper; j++) {
7028 if (do_increment) to++;
7032 tbl->map[tbl->size] = del
7036 : (short) TR_R_EMPTY;
7037 DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
7038 for (i = 0; i < tbl->size; i++) {
7039 if (tbl->map[i] < 0) {
7040 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
7041 (unsigned) i, tbl->map[i]));
7044 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
7045 (unsigned) i, tbl->map[i]));
7047 if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
7048 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
7051 DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
7052 (unsigned) tbl->size, tbl->map[tbl->size]));
7054 SvREFCNT_dec(t_invlist);
7056 #if 0 /* code that added excess above-255 chars at the end of the table, in
7057 case we ever want to not use the inversion map implementation for
7064 /* More replacement chars than search chars:
7065 * store excess replacement chars at end of main table.
7068 struct_size += excess;
7069 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
7070 struct_size + excess * sizeof(short));
7071 tbl->size += excess;
7072 cPVOPo->op_pv = (char*)tbl;
7074 for (i = 0; i < excess; i++)
7075 tbl->map[i + 256] = r[j+i];
7078 /* no more replacement chars than search chars */
7084 DEBUG_y(PerlIO_printf(Perl_debug_log,
7085 "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
7086 " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
7087 del, squash, complement,
7088 cBOOL(o->op_private & OPpTRANS_IDENTICAL),
7089 cBOOL(o->op_private & OPpTRANS_USE_SVOP),
7090 cBOOL(o->op_private & OPpTRANS_GROWS),
7091 cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
7096 if(del && rlen != 0 && r_count == t_count) {
7097 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7098 } else if(r_count > t_count) {
7099 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7112 Constructs, checks, and returns an op of any pattern matching type.
7113 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
7114 and, shifted up eight bits, the eight bits of C<op_private>.
7120 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7124 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7125 || type == OP_CUSTOM);
7127 NewOp(1101, pmop, 1, PMOP);
7128 OpTYPE_set(pmop, type);
7129 pmop->op_flags = (U8)flags;
7130 pmop->op_private = (U8)(0 | (flags >> 8));
7131 if (PL_opargs[type] & OA_RETSCALAR)
7134 if (PL_hints & HINT_RE_TAINT)
7135 pmop->op_pmflags |= PMf_RETAINT;
7136 #ifdef USE_LOCALE_CTYPE
7137 if (IN_LC_COMPILETIME(LC_CTYPE)) {
7138 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7143 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7145 if (PL_hints & HINT_RE_FLAGS) {
7146 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7147 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7149 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7150 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7151 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7153 if (reflags && SvOK(reflags)) {
7154 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7160 assert(SvPOK(PL_regex_pad[0]));
7161 if (SvCUR(PL_regex_pad[0])) {
7162 /* Pop off the "packed" IV from the end. */
7163 SV *const repointer_list = PL_regex_pad[0];
7164 const char *p = SvEND(repointer_list) - sizeof(IV);
7165 const IV offset = *((IV*)p);
7167 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7169 SvEND_set(repointer_list, p);
7171 pmop->op_pmoffset = offset;
7172 /* This slot should be free, so assert this: */
7173 assert(PL_regex_pad[offset] == &PL_sv_undef);
7175 SV * const repointer = &PL_sv_undef;
7176 av_push(PL_regex_padav, repointer);
7177 pmop->op_pmoffset = av_top_index(PL_regex_padav);
7178 PL_regex_pad = AvARRAY(PL_regex_padav);
7182 return CHECKOP(type, pmop);
7190 /* Any pad names in scope are potentially lvalues. */
7191 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7192 PADNAME *pn = PAD_COMPNAME_SV(i);
7193 if (!pn || !PadnameLEN(pn))
7195 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7196 S_mark_padname_lvalue(aTHX_ pn);
7200 /* Given some sort of match op o, and an expression expr containing a
7201 * pattern, either compile expr into a regex and attach it to o (if it's
7202 * constant), or convert expr into a runtime regcomp op sequence (if it's
7205 * Flags currently has 2 bits of meaning:
7206 * 1: isreg indicates that the pattern is part of a regex construct, eg
7207 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7208 * split "pattern", which aren't. In the former case, expr will be a list
7209 * if the pattern contains more than one term (eg /a$b/).
7210 * 2: The pattern is for a split.
7212 * When the pattern has been compiled within a new anon CV (for
7213 * qr/(?{...})/ ), then floor indicates the savestack level just before
7214 * the new sub was created
7216 * tr/// is also handled.
7220 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
7224 I32 repl_has_vars = 0;
7225 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
7226 bool is_compiletime;
7228 bool isreg = cBOOL(flags & 1);
7229 bool is_split = cBOOL(flags & 2);
7231 PERL_ARGS_ASSERT_PMRUNTIME;
7234 return pmtrans(o, expr, repl);
7237 /* find whether we have any runtime or code elements;
7238 * at the same time, temporarily set the op_next of each DO block;
7239 * then when we LINKLIST, this will cause the DO blocks to be excluded
7240 * from the op_next chain (and from having LINKLIST recursively
7241 * applied to them). We fix up the DOs specially later */
7245 if (expr->op_type == OP_LIST) {
7247 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7248 if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
7250 assert(!child->op_next);
7251 if (UNLIKELY(!OpHAS_SIBLING(child))) {
7252 assert(PL_parser && PL_parser->error_count);
7253 /* This can happen with qr/ (?{(^{})/. Just fake up
7254 the op we were expecting to see, to avoid crashing
7256 op_sibling_splice(expr, child, 0,
7257 newSVOP(OP_CONST, 0, &PL_sv_no));
7259 child->op_next = OpSIBLING(child);
7261 else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
7265 else if (expr->op_type != OP_CONST)
7270 /* fix up DO blocks; treat each one as a separate little sub;
7271 * also, mark any arrays as LIST/REF */
7273 if (expr->op_type == OP_LIST) {
7275 for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7277 if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
7278 assert( !(child->op_flags & OPf_WANT));
7279 /* push the array rather than its contents. The regex
7280 * engine will retrieve and join the elements later */
7281 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
7285 if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
7287 child->op_next = NULL; /* undo temporary hack from above */
7290 if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
7291 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
7293 assert(leaveop->op_first->op_type == OP_ENTER);
7294 assert(OpHAS_SIBLING(leaveop->op_first));
7295 child->op_next = OpSIBLING(leaveop->op_first);
7297 assert(leaveop->op_flags & OPf_KIDS);
7298 assert(leaveop->op_last->op_next == (OP*)leaveop);
7299 leaveop->op_next = NULL; /* stop on last op */
7300 op_null((OP*)leaveop);
7304 OP *scope = cLISTOPx(child)->op_first;
7305 assert(scope->op_type == OP_SCOPE);
7306 assert(scope->op_flags & OPf_KIDS);
7307 scope->op_next = NULL; /* stop on last op */
7311 /* XXX optimize_optree() must be called on o before
7312 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7313 * currently cope with a peephole-optimised optree.
7314 * Calling optimize_optree() here ensures that condition
7315 * is met, but may mean optimize_optree() is applied
7316 * to the same optree later (where hopefully it won't do any
7317 * harm as it can't convert an op to multiconcat if it's
7318 * already been converted */
7319 optimize_optree(child);
7321 /* have to peep the DOs individually as we've removed it from
7322 * the op_next chain */
7324 op_prune_chain_head(&(child->op_next));
7326 /* runtime finalizes as part of finalizing whole tree */
7327 finalize_optree(child);
7330 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7331 assert( !(expr->op_flags & OPf_WANT));
7332 /* push the array rather than its contents. The regex
7333 * engine will retrieve and join the elements later */
7334 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7337 PL_hints |= HINT_BLOCK_SCOPE;
7339 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7341 if (is_compiletime) {
7342 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7343 regexp_engine const *eng = current_re_engine();
7346 /* make engine handle split ' ' specially */
7347 pm->op_pmflags |= PMf_SPLIT;
7348 rx_flags |= RXf_SPLIT;
7351 if (!has_code || !eng->op_comp) {
7352 /* compile-time simple constant pattern */
7354 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7355 /* whoops! we guessed that a qr// had a code block, but we
7356 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7357 * that isn't required now. Note that we have to be pretty
7358 * confident that nothing used that CV's pad while the
7359 * regex was parsed, except maybe op targets for \Q etc.
7360 * If there were any op targets, though, they should have
7361 * been stolen by constant folding.
7365 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7366 while (++i <= AvFILLp(PL_comppad)) {
7367 # ifdef USE_PAD_RESET
7368 /* under USE_PAD_RESET, pad swipe replaces a swiped
7369 * folded constant with a fresh padtmp */
7370 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7372 assert(!PL_curpad[i]);
7376 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7377 * outer CV (the one whose slab holds the pm op). The
7378 * inner CV (which holds expr) will be freed later, once
7379 * all the entries on the parse stack have been popped on
7380 * return from this function. Which is why its safe to
7381 * call op_free(expr) below.
7384 pm->op_pmflags &= ~PMf_HAS_CV;
7387 /* Skip compiling if parser found an error for this pattern */
7388 if (pm->op_pmflags & PMf_HAS_ERROR) {
7394 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7395 rx_flags, pm->op_pmflags)
7396 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7397 rx_flags, pm->op_pmflags)
7402 /* compile-time pattern that includes literal code blocks */
7406 /* Skip compiling if parser found an error for this pattern */
7407 if (pm->op_pmflags & PMf_HAS_ERROR) {
7411 re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7414 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7417 if (pm->op_pmflags & PMf_HAS_CV) {
7419 /* this QR op (and the anon sub we embed it in) is never
7420 * actually executed. It's just a placeholder where we can
7421 * squirrel away expr in op_code_list without the peephole
7422 * optimiser etc processing it for a second time */
7423 OP *qr = newPMOP(OP_QR, 0);
7424 cPMOPx(qr)->op_code_list = expr;
7426 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7427 SvREFCNT_inc_simple_void(PL_compcv);
7428 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7429 ReANY(re)->qr_anoncv = cv;
7431 /* attach the anon CV to the pad so that
7432 * pad_fixup_inner_anons() can find it */
7433 (void)pad_add_anon(cv, o->op_type);
7434 SvREFCNT_inc_simple_void(cv);
7437 pm->op_code_list = expr;
7442 /* runtime pattern: build chain of regcomp etc ops */
7444 PADOFFSET cv_targ = 0;
7446 reglist = isreg && expr->op_type == OP_LIST;
7451 pm->op_code_list = expr;
7452 /* don't free op_code_list; its ops are embedded elsewhere too */
7453 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7457 /* make engine handle split ' ' specially */
7458 pm->op_pmflags |= PMf_SPLIT;
7460 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7461 * to allow its op_next to be pointed past the regcomp and
7462 * preceding stacking ops;
7463 * OP_REGCRESET is there to reset taint before executing the
7465 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7466 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7468 if (pm->op_pmflags & PMf_HAS_CV) {
7469 /* we have a runtime qr with literal code. This means
7470 * that the qr// has been wrapped in a new CV, which
7471 * means that runtime consts, vars etc will have been compiled
7472 * against a new pad. So... we need to execute those ops
7473 * within the environment of the new CV. So wrap them in a call
7474 * to a new anon sub. i.e. for
7478 * we build an anon sub that looks like
7480 * sub { "a", $b, '(?{...})' }
7482 * and call it, passing the returned list to regcomp.
7483 * Or to put it another way, the list of ops that get executed
7487 * ------ -------------------
7488 * pushmark (for regcomp)
7489 * pushmark (for entersub)
7492 * regcreset regcreset
7494 * const("a") const("a")
7496 * const("(?{...})") const("(?{...})")
7501 SvREFCNT_inc_simple_void(PL_compcv);
7502 CvLVALUE_on(PL_compcv);
7503 /* these lines are just an unrolled newANONATTRSUB */
7504 expr = newSVOP(OP_ANONCODE, OPf_REF,
7505 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7506 cv_targ = expr->op_targ;
7508 expr = list(op_force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
7511 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7512 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7513 | (reglist ? OPf_STACKED : 0);
7514 rcop->op_targ = cv_targ;
7516 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7517 if (PL_hints & HINT_RE_EVAL)
7518 S_set_haseval(aTHX);
7520 /* establish postfix order */
7521 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7523 rcop->op_next = expr;
7524 cUNOPx(expr)->op_first->op_next = (OP*)rcop;
7527 rcop->op_next = LINKLIST(expr);
7528 expr->op_next = (OP*)rcop;
7531 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7537 /* If we are looking at s//.../e with a single statement, get past
7538 the implicit do{}. */
7539 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7540 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7541 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7544 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7545 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7546 && !OpHAS_SIBLING(sib))
7549 if (curop->op_type == OP_CONST)
7551 else if (( (curop->op_type == OP_RV2SV ||
7552 curop->op_type == OP_RV2AV ||
7553 curop->op_type == OP_RV2HV ||
7554 curop->op_type == OP_RV2GV)
7555 && cUNOPx(curop)->op_first
7556 && cUNOPx(curop)->op_first->op_type == OP_GV )
7557 || curop->op_type == OP_PADSV
7558 || curop->op_type == OP_PADAV
7559 || curop->op_type == OP_PADHV
7560 || curop->op_type == OP_PADANY) {
7568 || !RX_PRELEN(PM_GETRE(pm))
7569 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7571 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7572 op_prepend_elem(o->op_type, scalar(repl), o);
7575 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7576 rcop->op_private = 1;
7578 /* establish postfix order */
7579 rcop->op_next = LINKLIST(repl);
7580 repl->op_next = (OP*)rcop;
7582 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7583 assert(!(pm->op_pmflags & PMf_ONCE));
7584 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7595 Constructs, checks, and returns an op of any type that involves an
7596 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7597 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7598 takes ownership of one reference to it.
7604 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7608 PERL_ARGS_ASSERT_NEWSVOP;
7610 /* OP_RUNCV is allowed specially so rpeep has room to convert it into an
7612 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7613 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7614 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7616 || type == OP_CUSTOM);
7618 NewOp(1101, svop, 1, SVOP);
7619 OpTYPE_set(svop, type);
7621 svop->op_next = (OP*)svop;
7622 svop->op_flags = (U8)flags;
7623 svop->op_private = (U8)(0 | (flags >> 8));
7624 if (PL_opargs[type] & OA_RETSCALAR)
7626 if (PL_opargs[type] & OA_TARGET)
7627 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7628 return CHECKOP(type, svop);
7632 =for apidoc newDEFSVOP
7634 Constructs and returns an op to access C<$_>.
7640 Perl_newDEFSVOP(pTHX)
7642 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7648 =for apidoc newPADOP
7650 Constructs, checks, and returns an op of any type that involves a
7651 reference to a pad element. C<type> is the opcode. C<flags> gives the
7652 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7653 is populated with C<sv>; this function takes ownership of one reference
7656 This function only exists if Perl has been compiled to use ithreads.
7662 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7666 PERL_ARGS_ASSERT_NEWPADOP;
7668 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7669 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7670 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7671 || type == OP_CUSTOM);
7673 NewOp(1101, padop, 1, PADOP);
7674 OpTYPE_set(padop, type);
7676 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7677 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7678 PAD_SETSV(padop->op_padix, sv);
7680 padop->op_next = (OP*)padop;
7681 padop->op_flags = (U8)flags;
7682 if (PL_opargs[type] & OA_RETSCALAR)
7684 if (PL_opargs[type] & OA_TARGET)
7685 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7686 return CHECKOP(type, padop);
7689 #endif /* USE_ITHREADS */
7694 Constructs, checks, and returns an op of any type that involves an
7695 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7696 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7697 reference; calling this function does not transfer ownership of any
7704 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7706 PERL_ARGS_ASSERT_NEWGVOP;
7709 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7711 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7718 Constructs, checks, and returns an op of any type that involves an
7719 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7720 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7721 Depending on the op type, the memory referenced by C<pv> may be freed
7722 when the op is destroyed. If the op is of a freeing type, C<pv> must
7723 have been allocated using C<PerlMemShared_malloc>.
7729 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7731 const bool utf8 = cBOOL(flags & SVf_UTF8);
7736 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7737 || type == OP_CUSTOM
7738 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7740 NewOp(1101, pvop, 1, PVOP);
7741 OpTYPE_set(pvop, type);
7743 pvop->op_next = (OP*)pvop;
7744 pvop->op_flags = (U8)flags;
7745 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7746 if (PL_opargs[type] & OA_RETSCALAR)
7748 if (PL_opargs[type] & OA_TARGET)
7749 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7750 return CHECKOP(type, pvop);
7754 Perl_package(pTHX_ OP *o)
7756 SV *const sv = cSVOPo->op_sv;
7758 PERL_ARGS_ASSERT_PACKAGE;
7760 SAVEGENERICSV(PL_curstash);
7761 save_item(PL_curstname);
7763 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7765 sv_setsv(PL_curstname, sv);
7767 PL_hints |= HINT_BLOCK_SCOPE;
7768 PL_parser->copline = NOLINE;
7774 Perl_package_version( pTHX_ OP *v )
7776 U32 savehints = PL_hints;
7777 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7778 PL_hints &= ~HINT_STRICT_VARS;
7779 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7780 PL_hints = savehints;
7784 /* Extract the first two components of a "version" object as two 8bit integers
7785 * and return them packed into a single U16 in the format of PL_prevailing_version.
7786 * This function only ever has to cope with version objects already known
7787 * bounded by the current perl version, so we know its components will fit
7788 * (Up until we reach perl version 5.256 anyway) */
7789 static U16 S_extract_shortver(pTHX_ SV *sv)
7792 if(!SvRV(sv) || !SvOBJECT(rv = SvRV(sv)) || !sv_derived_from(sv, "version"))
7795 AV *av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rv), "version", 0)));
7799 IV major = av_count(av) > 0 ? SvIV(*av_fetch(av, 0, false)) : 0;
7801 shortver |= 255 << 8;
7803 shortver |= major << 8;
7805 IV minor = av_count(av) > 1 ? SvIV(*av_fetch(av, 1, false)) : 0;
7813 #define SHORTVER(maj,min) ((maj << 8) | min)
7816 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7821 SV *use_version = NULL;
7823 PERL_ARGS_ASSERT_UTILIZE;
7825 if (idop->op_type != OP_CONST)
7826 Perl_croak(aTHX_ "Module name must be constant");
7831 SV * const vesv = cSVOPx(version)->op_sv;
7833 if (!arg && !SvNIOKp(vesv)) {
7840 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7841 Perl_croak(aTHX_ "Version number must be a constant number");
7843 /* Make copy of idop so we don't free it twice */
7844 pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7846 /* Fake up a method call to VERSION */
7847 meth = newSVpvs_share("VERSION");
7848 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7849 op_append_elem(OP_LIST,
7850 op_prepend_elem(OP_LIST, pack, version),
7851 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7855 /* Fake up an import/unimport */
7856 if (arg && arg->op_type == OP_STUB) {
7857 imop = arg; /* no import on explicit () */
7859 else if (SvNIOKp(cSVOPx(idop)->op_sv)) {
7860 imop = NULL; /* use 5.0; */
7862 use_version = cSVOPx(idop)->op_sv;
7864 idop->op_private |= OPpCONST_NOVER;
7869 /* Make copy of idop so we don't free it twice */
7870 pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7872 /* Fake up a method call to import/unimport */
7874 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7875 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7876 op_append_elem(OP_LIST,
7877 op_prepend_elem(OP_LIST, pack, arg),
7878 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7882 /* Fake up the BEGIN {}, which does its thing immediately. */
7884 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7887 op_append_elem(OP_LINESEQ,
7888 op_append_elem(OP_LINESEQ,
7889 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7890 newSTATEOP(0, NULL, veop)),
7891 newSTATEOP(0, NULL, imop) ));
7895 * feature bundle that corresponds to the required version. */
7896 use_version = sv_2mortal(new_version(use_version));
7897 S_enable_feature_bundle(aTHX_ use_version);
7899 U16 shortver = S_extract_shortver(aTHX_ use_version);
7901 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7902 if (shortver >= SHORTVER(5, 11)) {
7903 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7904 PL_hints |= HINT_STRICT_REFS;
7905 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7906 PL_hints |= HINT_STRICT_SUBS;
7907 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7908 PL_hints |= HINT_STRICT_VARS;
7910 if (shortver >= SHORTVER(5, 35))
7911 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
7913 /* otherwise they are off */
7915 if(PL_prevailing_version >= SHORTVER(5, 11))
7916 deprecate_fatal_in(WARN_DEPRECATED__VERSION_DOWNGRADE, "5.40",
7917 "Downgrading a use VERSION declaration to below v5.11");
7919 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7920 PL_hints &= ~HINT_STRICT_REFS;
7921 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7922 PL_hints &= ~HINT_STRICT_SUBS;
7923 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7924 PL_hints &= ~HINT_STRICT_VARS;
7927 PL_prevailing_version = shortver;
7930 /* The "did you use incorrect case?" warning used to be here.
7931 * The problem is that on case-insensitive filesystems one
7932 * might get false positives for "use" (and "require"):
7933 * "use Strict" or "require CARP" will work. This causes
7934 * portability problems for the script: in case-strict
7935 * filesystems the script will stop working.
7937 * The "incorrect case" warning checked whether "use Foo"
7938 * imported "Foo" to your namespace, but that is wrong, too:
7939 * there is no requirement nor promise in the language that
7940 * a Foo.pm should or would contain anything in package "Foo".
7942 * There is very little Configure-wise that can be done, either:
7943 * the case-sensitivity of the build filesystem of Perl does not
7944 * help in guessing the case-sensitivity of the runtime environment.
7947 PL_hints |= HINT_BLOCK_SCOPE;
7948 PL_parser->copline = NOLINE;
7949 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7953 =for apidoc_section $embedding
7955 =for apidoc load_module
7956 =for apidoc_item load_module_nocontext
7958 These load the module whose name is pointed to by the string part of C<name>.
7959 Note that the actual module name, not its filename, should be given.
7960 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7961 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7962 trailing arguments can be used to specify arguments to the module's C<import()>
7963 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7964 on the flags. The flags argument is a bitwise-ORed collection of any of
7965 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7966 (or 0 for no flags).
7968 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7969 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7970 the trailing optional arguments may be omitted entirely. Otherwise, if
7971 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7972 exactly one C<OP*>, containing the op tree that produces the relevant import
7973 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7974 will be used as import arguments; and the list must be terminated with C<(SV*)
7975 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7976 set, the trailing C<NULL> pointer is needed even if no import arguments are
7977 desired. The reference count for each specified C<SV*> argument is
7978 decremented. In addition, the C<name> argument is modified.
7980 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7983 C<load_module> and C<load_module_nocontext> have the same apparent signature,
7984 but the former hides the fact that it is accessing a thread context parameter.
7985 So use the latter when you get a compilation error about C<pTHX>.
7987 =for apidoc Amnh||PERL_LOADMOD_DENY
7988 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
7989 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
7991 =for apidoc vload_module
7992 Like C<L</load_module>> but the arguments are an encapsulated argument list.
7997 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
8001 PERL_ARGS_ASSERT_LOAD_MODULE;
8003 va_start(args, ver);
8004 vload_module(flags, name, ver, &args);
8010 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8014 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8015 va_start(args, ver);
8016 vload_module(flags, name, ver, &args);
8022 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8028 PERL_ARGS_ASSERT_VLOAD_MODULE;
8030 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8031 * that it has a PL_parser to play with while doing that, and also
8032 * that it doesn't mess with any existing parser, by creating a tmp
8033 * new parser with lex_start(). This won't actually be used for much,
8034 * since pp_require() will create another parser for the real work.
8035 * The ENTER/LEAVE pair protect callers from any side effects of use.
8037 * start_subparse() creates a new PL_compcv. This means that any ops
8038 * allocated below will be allocated from that CV's op slab, and so
8039 * will be automatically freed if the utilise() fails
8043 SAVEVPTR(PL_curcop);
8044 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8045 floor = start_subparse(FALSE, 0);
8047 modname = newSVOP(OP_CONST, 0, name);
8048 modname->op_private |= OPpCONST_BARE;
8050 veop = newSVOP(OP_CONST, 0, ver);
8054 if (flags & PERL_LOADMOD_NOIMPORT) {
8055 imop = sawparens(newNULLLIST());
8057 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8058 imop = va_arg(*args, OP*);
8063 sv = va_arg(*args, SV*);
8065 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8066 sv = va_arg(*args, SV*);
8070 utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8074 PERL_STATIC_INLINE OP *
8075 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8077 return newUNOP(OP_ENTERSUB, OPf_STACKED,
8078 newLISTOP(OP_LIST, 0, arg,
8079 newUNOP(OP_RV2CV, 0,
8080 newGVOP(OP_GV, 0, gv))));
8084 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8089 PERL_ARGS_ASSERT_DOFILE;
8091 if (!force_builtin && (gv = gv_override("do", 2))) {
8092 doop = S_new_entersubop(aTHX_ gv, term);
8095 doop = newUNOP(OP_DOFILE, 0, scalar(term));
8101 =for apidoc_section $optree_construction
8103 =for apidoc newSLICEOP
8105 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
8106 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8107 be set automatically, and, shifted up eight bits, the eight bits of
8108 C<op_private>, except that the bit with value 1 or 2 is automatically
8109 set as required. C<listval> and C<subscript> supply the parameters of
8110 the slice; they are consumed by this function and become part of the
8111 constructed op tree.
8117 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8119 return newBINOP(OP_LSLICE, flags,
8120 list(op_force_list(subscript)),
8121 list(op_force_list(listval)));
8124 #define ASSIGN_SCALAR 0
8125 #define ASSIGN_LIST 1
8126 #define ASSIGN_REF 2
8128 /* given the optree o on the LHS of an assignment, determine whether its:
8129 * ASSIGN_SCALAR $x = ...
8130 * ASSIGN_LIST ($x) = ...
8131 * ASSIGN_REF \$x = ...
8135 S_assignment_type(pTHX_ const OP *o)
8144 if (o->op_type == OP_SREFGEN)
8146 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8147 type = kid->op_type;
8148 flags = o->op_flags | kid->op_flags;
8149 if (!(flags & OPf_PARENS)
8150 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8151 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8155 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8156 o = cUNOPo->op_first;
8157 flags = o->op_flags;
8159 ret = ASSIGN_SCALAR;
8162 if (type == OP_COND_EXPR) {
8163 OP * const sib = OpSIBLING(cLOGOPo->op_first);
8164 const I32 t = assignment_type(sib);
8165 const I32 f = assignment_type(OpSIBLING(sib));
8167 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8169 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8170 yyerror("Assignment to both a list and a scalar");
8171 return ASSIGN_SCALAR;
8174 if (type == OP_LIST &&
8175 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8176 o->op_private & OPpLVAL_INTRO)
8179 if (type == OP_LIST || flags & OPf_PARENS ||
8180 type == OP_RV2AV || type == OP_RV2HV ||
8181 type == OP_ASLICE || type == OP_HSLICE ||
8182 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8185 if (type == OP_PADAV || type == OP_PADHV)
8188 if (type == OP_RV2SV)
8195 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8197 const PADOFFSET target = padop->op_targ;
8198 OP *const other = newOP(OP_PADSV,
8200 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8201 OP *const first = newOP(OP_NULL, 0);
8202 OP *const nullop = newCONDOP(0, first, initop, other);
8203 /* XXX targlex disabled for now; see ticket #124160
8204 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8206 OP *const condop = first->op_next;
8208 OpTYPE_set(condop, OP_ONCE);
8209 other->op_targ = target;
8210 nullop->op_flags |= OPf_WANT_SCALAR;
8212 /* Store the initializedness of state vars in a separate
8215 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8216 /* hijacking PADSTALE for uninitialized state variables */
8217 SvPADSTALE_on(PAD_SVl(condop->op_targ));
8223 =for apidoc newARGDEFELEMOP
8225 Constructs and returns a new C<OP_ARGDEFELEM> op which provides a defaulting
8226 expression given by C<expr> for the signature parameter at the index given
8227 by C<argindex>. The expression optree is consumed by this function and
8228 becomes part of the returned optree.
8234 Perl_newARGDEFELEMOP(pTHX_ I32 flags, OP *expr, I32 argindex)
8236 PERL_ARGS_ASSERT_NEWARGDEFELEMOP;
8238 OP *o = (OP *)alloc_LOGOP(OP_ARGDEFELEM, expr, LINKLIST(expr));
8239 o->op_flags |= (U8)(flags);
8240 o->op_private = 1 | (U8)(flags >> 8);
8242 /* re-purpose op_targ to hold @_ index */
8243 o->op_targ = (PADOFFSET)(argindex);
8249 =for apidoc newASSIGNOP
8251 Constructs, checks, and returns an assignment op. C<left> and C<right>
8252 supply the parameters of the assignment; they are consumed by this
8253 function and become part of the constructed op tree.
8255 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8256 a suitable conditional optree is constructed. If C<optype> is the opcode
8257 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8258 performs the binary operation and assigns the result to the left argument.
8259 Either way, if C<optype> is non-zero then C<flags> has no effect.
8261 If C<optype> is zero, then a plain scalar or list assignment is
8262 constructed. Which type of assignment it is is automatically determined.
8263 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8264 will be set automatically, and, shifted up eight bits, the eight bits
8265 of C<op_private>, except that the bit with value 1 or 2 is automatically
8272 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8282 right = scalar(right);
8283 return newLOGOP(optype, 0,
8284 op_lvalue(scalar(left), optype),
8285 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8287 return newBINOP(optype, OPf_STACKED,
8288 op_lvalue(scalar(left), optype), scalar(right));
8291 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8292 OP *state_var_op = NULL;
8293 static const char no_list_state[] = "Initialization of state variables"
8294 " in list currently forbidden";
8297 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8298 left->op_private &= ~ OPpSLICEWARNING;
8301 left = op_lvalue(left, OP_AASSIGN);
8302 curop = list(op_force_list(left));
8303 o = newBINOP(OP_AASSIGN, flags, list(op_force_list(right)), curop);
8304 o->op_private = (U8)(0 | (flags >> 8));
8306 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8308 OP *lop = cLISTOPx(left)->op_first, *vop, *eop;
8309 if (!(left->op_flags & OPf_PARENS) &&
8310 lop->op_type == OP_PUSHMARK &&
8311 (vop = OpSIBLING(lop)) &&
8312 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8313 !(vop->op_flags & OPf_PARENS) &&
8314 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8315 (OPpLVAL_INTRO|OPpPAD_STATE) &&
8316 (eop = OpSIBLING(vop)) &&
8317 eop->op_type == OP_ENTERSUB &&
8318 !OpHAS_SIBLING(eop)) {
8322 if ((lop->op_type == OP_PADSV ||
8323 lop->op_type == OP_PADAV ||
8324 lop->op_type == OP_PADHV ||
8325 lop->op_type == OP_PADANY)
8326 && (lop->op_private & OPpPAD_STATE)
8328 yyerror(no_list_state);
8329 lop = OpSIBLING(lop);
8333 else if ( (left->op_private & OPpLVAL_INTRO)
8334 && (left->op_private & OPpPAD_STATE)
8335 && ( left->op_type == OP_PADSV
8336 || left->op_type == OP_PADAV
8337 || left->op_type == OP_PADHV
8338 || left->op_type == OP_PADANY)
8340 /* All single variable list context state assignments, hence
8350 if (left->op_flags & OPf_PARENS)
8351 yyerror(no_list_state);
8353 state_var_op = left;
8356 /* optimise @a = split(...) into:
8357 * @{expr}: split(..., @{expr}) (where @a is not flattened)
8358 * @a, my @a, local @a: split(...) (where @a is attached to
8359 * the split op itself)
8363 && right->op_type == OP_SPLIT
8364 /* don't do twice, e.g. @b = (@a = split) */
8365 && !(right->op_private & OPpSPLIT_ASSIGN))
8369 if ( ( left->op_type == OP_RV2AV
8370 && (gvop=cUNOPx(left)->op_first)->op_type==OP_GV)
8371 || left->op_type == OP_PADAV)
8373 /* @pkg or @lex or local @pkg' or 'my @lex' */
8377 cPMOPx(right)->op_pmreplrootu.op_pmtargetoff
8378 = cPADOPx(gvop)->op_padix;
8379 cPADOPx(gvop)->op_padix = 0; /* steal it */
8381 cPMOPx(right)->op_pmreplrootu.op_pmtargetgv
8382 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8383 cSVOPx(gvop)->op_sv = NULL; /* steal it */
8385 right->op_private |=
8386 left->op_private & OPpOUR_INTRO;
8389 cPMOPx(right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8390 left->op_targ = 0; /* steal it */
8391 right->op_private |= OPpSPLIT_LEX;
8393 right->op_private |= left->op_private & OPpLVAL_INTRO;
8396 tmpop = cUNOPo->op_first; /* to list (nulled) */
8397 tmpop = cUNOPx(tmpop)->op_first; /* to pushmark */
8398 assert(OpSIBLING(tmpop) == right);
8399 assert(!OpHAS_SIBLING(right));
8400 /* detach the split subtreee from the o tree,
8401 * then free the residual o tree */
8402 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8403 op_free(o); /* blow off assign */
8404 right->op_private |= OPpSPLIT_ASSIGN;
8405 right->op_flags &= ~OPf_WANT;
8406 /* "I don't know and I don't care." */
8409 else if (left->op_type == OP_RV2AV) {
8412 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8413 assert(OpSIBLING(pushop) == left);
8414 /* Detach the array ... */
8415 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8416 /* ... and attach it to the split. */
8417 op_sibling_splice(right, cLISTOPx(right)->op_last,
8419 right->op_flags |= OPf_STACKED;
8420 /* Detach split and expunge aassign as above. */
8423 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8424 cLISTOPx(right)->op_last->op_type == OP_CONST)
8426 /* convert split(...,0) to split(..., PL_modcount+1) */
8428 &cSVOPx(cLISTOPx(right)->op_last)->op_sv;
8429 SV * const sv = *svp;
8430 if (SvIOK(sv) && SvIVX(sv) == 0)
8432 if (right->op_private & OPpSPLIT_IMPLIM) {
8433 /* our own SV, created in ck_split */
8435 sv_setiv(sv, PL_modcount+1);
8438 /* SV may belong to someone else */
8440 *svp = newSViv(PL_modcount+1);
8447 o = S_newONCEOP(aTHX_ o, state_var_op);
8450 if (assign_type == ASSIGN_REF)
8451 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8453 right = newOP(OP_UNDEF, 0);
8454 if (right->op_type == OP_READLINE) {
8455 right->op_flags |= OPf_STACKED;
8456 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8460 o = newBINOP(OP_SASSIGN, flags,
8461 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8467 =for apidoc newSTATEOP
8469 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8470 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8471 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8472 If C<label> is non-null, it supplies the name of a label to attach to
8473 the state op; this function takes ownership of the memory pointed at by
8474 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8477 If C<o> is null, the state op is returned. Otherwise the state op is
8478 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8479 is consumed by this function and becomes part of the returned op tree.
8485 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8487 const U32 seq = intro_my();
8488 const U32 utf8 = flags & SVf_UTF8;
8492 PL_parser->parsed_sub = 0;
8496 NewOp(1101, cop, 1, COP);
8497 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8498 OpTYPE_set(cop, OP_DBSTATE);
8501 OpTYPE_set(cop, OP_NEXTSTATE);
8503 cop->op_flags = (U8)flags;
8504 CopHINTS_set(cop, PL_hints);
8506 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8508 cop->op_next = (OP*)cop;
8511 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8512 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8513 CopFEATURES_setfrom(cop, PL_curcop);
8515 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8517 PL_hints |= HINT_BLOCK_SCOPE;
8518 /* It seems that we need to defer freeing this pointer, as other parts
8519 of the grammar end up wanting to copy it after this op has been
8524 if (PL_parser->preambling != NOLINE) {
8525 CopLINE_set(cop, PL_parser->preambling);
8526 PL_parser->copline = NOLINE;
8528 else if (PL_parser->copline == NOLINE)
8529 CopLINE_set(cop, CopLINE(PL_curcop));
8531 CopLINE_set(cop, PL_parser->copline);
8532 PL_parser->copline = NOLINE;
8535 CopFILE_copy(cop, PL_curcop);
8537 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8539 CopSTASH_set(cop, PL_curstash);
8541 if (cop->op_type == OP_DBSTATE) {
8542 /* this line can have a breakpoint - store the cop in IV */
8543 AV *av = CopFILEAVx(PL_curcop);
8545 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8546 if (svp && *svp != &PL_sv_undef ) {
8547 (void)SvIOK_on(*svp);
8548 SvIV_set(*svp, PTR2IV(cop));
8553 if (flags & OPf_SPECIAL)
8555 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8559 =for apidoc newLOGOP
8561 Constructs, checks, and returns a logical (flow control) op. C<type>
8562 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8563 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8564 the eight bits of C<op_private>, except that the bit with value 1 is
8565 automatically set. C<first> supplies the expression controlling the
8566 flow, and C<other> supplies the side (alternate) chain of ops; they are
8567 consumed by this function and become part of the constructed op tree.
8573 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8575 PERL_ARGS_ASSERT_NEWLOGOP;
8577 return new_logop(type, flags, &first, &other);
8581 /* See if the optree o contains a single OP_CONST (plus possibly
8582 * surrounding enter/nextstate/null etc). If so, return it, else return
8587 S_search_const(pTHX_ OP *o)
8589 PERL_ARGS_ASSERT_SEARCH_CONST;
8592 switch (o->op_type) {
8596 if (o->op_flags & OPf_KIDS) {
8597 o = cUNOPo->op_first;
8606 if (!(o->op_flags & OPf_KIDS))
8608 kid = cLISTOPo->op_first;
8611 switch (kid->op_type) {
8615 kid = OpSIBLING(kid);
8618 if (kid != cLISTOPo->op_last)
8625 kid = cLISTOPo->op_last;
8637 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8644 int prepend_not = 0;
8646 PERL_ARGS_ASSERT_NEW_LOGOP;
8651 /* [perl #59802]: Warn about things like "return $a or $b", which
8652 is parsed as "(return $a) or $b" rather than "return ($a or
8653 $b)". NB: This also applies to xor, which is why we do it
8656 switch (first->op_type) {
8660 /* XXX: Perhaps we should emit a stronger warning for these.
8661 Even with the high-precedence operator they don't seem to do
8664 But until we do, fall through here.
8670 /* XXX: Currently we allow people to "shoot themselves in the
8671 foot" by explicitly writing "(return $a) or $b".
8673 Warn unless we are looking at the result from folding or if
8674 the programmer explicitly grouped the operators like this.
8675 The former can occur with e.g.
8677 use constant FEATURE => ( $] >= ... );
8678 sub { not FEATURE and return or do_stuff(); }
8680 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8681 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8682 "Possible precedence issue with control flow operator");
8683 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8689 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8690 return newBINOP(type, flags, scalar(first), scalar(other));
8692 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8693 || type == OP_CUSTOM);
8695 scalarboolean(first);
8697 /* search for a constant op that could let us fold the test */
8698 if ((cstop = search_const(first))) {
8699 if (cstop->op_private & OPpCONST_STRICT)
8700 no_bareword_allowed(cstop);
8701 else if ((cstop->op_private & OPpCONST_BARE))
8702 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8703 if ((type == OP_AND && SvTRUE(cSVOPx(cstop)->op_sv)) ||
8704 (type == OP_OR && !SvTRUE(cSVOPx(cstop)->op_sv)) ||
8705 (type == OP_DOR && !SvOK(cSVOPx(cstop)->op_sv))) {
8706 /* Elide the (constant) lhs, since it can't affect the outcome */
8708 if (other->op_type == OP_CONST)
8709 other->op_private |= OPpCONST_SHORTCIRCUIT;
8711 if (other->op_type == OP_LEAVE)
8712 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8713 else if (other->op_type == OP_MATCH
8714 || other->op_type == OP_SUBST
8715 || other->op_type == OP_TRANSR
8716 || other->op_type == OP_TRANS)
8717 /* Mark the op as being unbindable with =~ */
8718 other->op_flags |= OPf_SPECIAL;
8720 other->op_folded = 1;
8724 /* Elide the rhs, since the outcome is entirely determined by
8725 * the (constant) lhs */
8727 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8728 const OP *o2 = other;
8729 if ( ! (o2->op_type == OP_LIST
8730 && (( o2 = cUNOPx(o2)->op_first))
8731 && o2->op_type == OP_PUSHMARK
8732 && (( o2 = OpSIBLING(o2))) )
8735 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8736 || o2->op_type == OP_PADHV)
8737 && o2->op_private & OPpLVAL_INTRO
8738 && !(o2->op_private & OPpPAD_STATE))
8740 Perl_croak(aTHX_ "This use of my() in false conditional is "
8741 "no longer allowed");
8745 if (cstop->op_type == OP_CONST)
8746 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8751 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8752 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8754 const OP * const k1 = cUNOPx(first)->op_first;
8755 const OP * const k2 = OpSIBLING(k1);
8757 switch (first->op_type)
8760 if (k2 && k2->op_type == OP_READLINE
8761 && (k2->op_flags & OPf_STACKED)
8762 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8764 warnop = k2->op_type;
8769 if (k1->op_type == OP_READDIR
8770 || k1->op_type == OP_GLOB
8771 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8772 || k1->op_type == OP_EACH
8773 || k1->op_type == OP_AEACH)
8775 warnop = ((k1->op_type == OP_NULL)
8776 ? (OPCODE)k1->op_targ : k1->op_type);
8781 const line_t oldline = CopLINE(PL_curcop);
8782 /* This ensures that warnings are reported at the first line
8783 of the construction, not the last. */
8784 CopLINE_set(PL_curcop, PL_parser->copline);
8785 Perl_warner(aTHX_ packWARN(WARN_MISC),
8786 "Value of %s%s can be \"0\"; test with defined()",
8788 ((warnop == OP_READLINE || warnop == OP_GLOB)
8789 ? " construct" : "() operator"));
8790 CopLINE_set(PL_curcop, oldline);
8794 /* optimize AND and OR ops that have NOTs as children */
8795 if (first->op_type == OP_NOT
8796 && (first->op_flags & OPf_KIDS)
8797 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8798 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8800 if (type == OP_AND || type == OP_OR) {
8806 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8808 prepend_not = 1; /* prepend a NOT op later */
8813 logop = alloc_LOGOP(type, first, LINKLIST(other));
8814 logop->op_flags |= (U8)flags;
8815 logop->op_private = (U8)(1 | (flags >> 8));
8817 /* establish postfix order */
8818 logop->op_next = LINKLIST(first);
8819 first->op_next = (OP*)logop;
8820 assert(!OpHAS_SIBLING(first));
8821 op_sibling_splice((OP*)logop, first, 0, other);
8823 CHECKOP(type,logop);
8825 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8826 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8834 =for apidoc newCONDOP
8836 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8837 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8838 will be set automatically, and, shifted up eight bits, the eight bits of
8839 C<op_private>, except that the bit with value 1 is automatically set.
8840 C<first> supplies the expression selecting between the two branches,
8841 and C<trueop> and C<falseop> supply the branches; they are consumed by
8842 this function and become part of the constructed op tree.
8848 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8855 PERL_ARGS_ASSERT_NEWCONDOP;
8858 return newLOGOP(OP_AND, 0, first, trueop);
8860 return newLOGOP(OP_OR, 0, first, falseop);
8862 scalarboolean(first);
8863 if ((cstop = search_const(first))) {
8864 /* Left or right arm of the conditional? */
8865 const bool left = SvTRUE(cSVOPx(cstop)->op_sv);
8866 OP *live = left ? trueop : falseop;
8867 OP *const dead = left ? falseop : trueop;
8868 if (cstop->op_private & OPpCONST_BARE &&
8869 cstop->op_private & OPpCONST_STRICT) {
8870 no_bareword_allowed(cstop);
8874 if (live->op_type == OP_LEAVE)
8875 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8876 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8877 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8878 /* Mark the op as being unbindable with =~ */
8879 live->op_flags |= OPf_SPECIAL;
8880 live->op_folded = 1;
8883 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8884 logop->op_flags |= (U8)flags;
8885 logop->op_private = (U8)(1 | (flags >> 8));
8886 logop->op_next = LINKLIST(falseop);
8888 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8891 /* establish postfix order */
8892 start = LINKLIST(first);
8893 first->op_next = (OP*)logop;
8895 /* make first, trueop, falseop siblings */
8896 op_sibling_splice((OP*)logop, first, 0, trueop);
8897 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8899 o = newUNOP(OP_NULL, 0, (OP*)logop);
8901 trueop->op_next = falseop->op_next = o;
8908 =for apidoc newTRYCATCHOP
8910 Constructs and returns a conditional execution statement that implements
8911 the C<try>/C<catch> semantics. First the op tree in C<tryblock> is executed,
8912 inside a context that traps exceptions. If an exception occurs then the
8913 optree in C<catchblock> is executed, with the trapped exception set into the
8914 lexical variable given by C<catchvar> (which must be an op of type
8915 C<OP_PADSV>). All the optrees are consumed by this function and become part
8916 of the returned op tree.
8918 The C<flags> argument is currently ignored.
8924 Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
8928 PERL_ARGS_ASSERT_NEWTRYCATCHOP;
8929 assert(catchvar->op_type == OP_PADSV);
8931 PERL_UNUSED_ARG(flags);
8933 /* The returned optree is shaped as:
8934 * LISTOP leavetrycatch
8935 * LOGOP entertrycatch
8942 if(tryblock->op_type != OP_LINESEQ)
8943 tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
8944 OpTYPE_set(tryblock, OP_POPTRY);
8946 /* Manually construct a naked LOGOP.
8947 * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
8948 * containing the LOGOP we wanted as its op_first */
8949 catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
8950 OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
8951 OpLASTSIB_set(catchblock, catchop);
8953 /* Inject the catchvar's pad offset into the OP_CATCH targ */
8954 cLOGOPx(catchop)->op_targ = catchvar->op_targ;
8957 /* Build the optree structure */
8958 o = newLISTOP(OP_LIST, 0, tryblock, catchop);
8959 o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
8965 =for apidoc newRANGE
8967 Constructs and returns a C<range> op, with subordinate C<flip> and
8968 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8969 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8970 for both the C<flip> and C<range> ops, except that the bit with value
8971 1 is automatically set. C<left> and C<right> supply the expressions
8972 controlling the endpoints of the range; they are consumed by this function
8973 and become part of the constructed op tree.
8979 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8987 PERL_ARGS_ASSERT_NEWRANGE;
8989 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8990 range->op_flags = OPf_KIDS;
8991 leftstart = LINKLIST(left);
8992 range->op_private = (U8)(1 | (flags >> 8));
8994 /* make left and right siblings */
8995 op_sibling_splice((OP*)range, left, 0, right);
8997 range->op_next = (OP*)range;
8998 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8999 flop = newUNOP(OP_FLOP, 0, flip);
9000 o = newUNOP(OP_NULL, 0, flop);
9002 range->op_next = leftstart;
9004 left->op_next = flip;
9005 right->op_next = flop;
9008 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9009 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9011 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9012 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9013 SvPADTMP_on(PAD_SV(flip->op_targ));
9015 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9016 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9018 /* check barewords before they might be optimized away */
9019 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9020 no_bareword_allowed(left);
9021 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9022 no_bareword_allowed(right);
9025 if (!flip->op_private || !flop->op_private)
9026 LINKLIST(o); /* blow off optimizer unless constant */
9032 =for apidoc newLOOPOP
9034 Constructs, checks, and returns an op tree expressing a loop. This is
9035 only a loop in the control flow through the op tree; it does not have
9036 the heavyweight loop structure that allows exiting the loop by C<last>
9037 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
9038 top-level op, except that some bits will be set automatically as required.
9039 C<expr> supplies the expression controlling loop iteration, and C<block>
9040 supplies the body of the loop; they are consumed by this function and
9041 become part of the constructed op tree. C<debuggable> is currently
9042 unused and should always be 1.
9048 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9050 PERL_ARGS_ASSERT_NEWLOOPOP;
9054 const bool once = block && block->op_flags & OPf_SPECIAL &&
9055 block->op_type == OP_NULL;
9057 PERL_UNUSED_ARG(debuggable);
9060 (expr->op_type == OP_CONST && !SvTRUE(cSVOPx(expr)->op_sv))
9061 || ( expr->op_type == OP_NOT
9062 && cUNOPx(expr)->op_first->op_type == OP_CONST
9063 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9066 /* Return the block now, so that S_new_logop does not try to
9070 return block; /* do {} while 0 does once */
9073 if (expr->op_type == OP_READLINE
9074 || expr->op_type == OP_READDIR
9075 || expr->op_type == OP_GLOB
9076 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9077 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9078 expr = newUNOP(OP_DEFINED, 0,
9079 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9080 } else if (expr->op_flags & OPf_KIDS) {
9081 const OP * const k1 = cUNOPx(expr)->op_first;
9082 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9083 switch (expr->op_type) {
9085 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9086 && (k2->op_flags & OPf_STACKED)
9087 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9088 expr = newUNOP(OP_DEFINED, 0, expr);
9092 if (k1 && (k1->op_type == OP_READDIR
9093 || k1->op_type == OP_GLOB
9094 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9095 || k1->op_type == OP_EACH
9096 || k1->op_type == OP_AEACH))
9097 expr = newUNOP(OP_DEFINED, 0, expr);
9102 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9103 * op, in listop. This is wrong. [perl #27024] */
9105 block = newOP(OP_NULL, 0);
9106 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9107 o = new_logop(OP_AND, 0, &expr, &listop);
9114 cLISTOPx(listop)->op_last->op_next = LINKLIST(o);
9116 if (once && o != listop)
9118 assert(cUNOPo->op_first->op_type == OP_AND
9119 || cUNOPo->op_first->op_type == OP_OR);
9120 o->op_next = cLOGOPx(cUNOPo->op_first)->op_other;
9124 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
9126 o->op_flags |= flags;
9128 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
9133 =for apidoc newWHILEOP
9135 Constructs, checks, and returns an op tree expressing a C<while> loop.
9136 This is a heavyweight loop, with structure that allows exiting the loop
9137 by C<last> and suchlike.
9139 C<loop> is an optional preconstructed C<enterloop> op to use in the
9140 loop; if it is null then a suitable op will be constructed automatically.
9141 C<expr> supplies the loop's controlling expression. C<block> supplies the
9142 main body of the loop, and C<cont> optionally supplies a C<continue> block
9143 that operates as a second half of the body. All of these optree inputs
9144 are consumed by this function and become part of the constructed op tree.
9146 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9147 op and, shifted up eight bits, the eight bits of C<op_private> for
9148 the C<leaveloop> op, except that (in both cases) some bits will be set
9149 automatically. C<debuggable> is currently unused and should always be 1.
9150 C<has_my> can be supplied as true to force the
9151 loop body to be enclosed in its own scope.
9157 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9158 OP *expr, OP *block, OP *cont, I32 has_my)
9166 PERL_UNUSED_ARG(debuggable);
9169 if (expr->op_type == OP_READLINE
9170 || expr->op_type == OP_READDIR
9171 || expr->op_type == OP_GLOB
9172 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9173 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9174 expr = newUNOP(OP_DEFINED, 0,
9175 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9176 } else if (expr->op_flags & OPf_KIDS) {
9177 const OP * const k1 = cUNOPx(expr)->op_first;
9178 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9179 switch (expr->op_type) {
9181 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9182 && (k2->op_flags & OPf_STACKED)
9183 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9184 expr = newUNOP(OP_DEFINED, 0, expr);
9188 if (k1 && (k1->op_type == OP_READDIR
9189 || k1->op_type == OP_GLOB
9190 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9191 || k1->op_type == OP_EACH
9192 || k1->op_type == OP_AEACH))
9193 expr = newUNOP(OP_DEFINED, 0, expr);
9200 block = newOP(OP_NULL, 0);
9201 else if (cont || has_my) {
9202 block = op_scope(block);
9206 next = LINKLIST(cont);
9209 OP * const unstack = newOP(OP_UNSTACK, 0);
9212 cont = op_append_elem(OP_LINESEQ, cont, unstack);
9216 listop = op_append_list(OP_LINESEQ, block, cont);
9218 redo = LINKLIST(listop);
9222 o = new_logop(OP_AND, 0, &expr, &listop);
9223 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9225 return expr; /* listop already freed by new_logop */
9228 cLISTOPx(listop)->op_last->op_next =
9229 (o == listop ? redo : LINKLIST(o));
9235 NewOp(1101,loop,1,LOOP);
9236 OpTYPE_set(loop, OP_ENTERLOOP);
9237 loop->op_private = 0;
9238 loop->op_next = (OP*)loop;
9241 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9243 loop->op_redoop = redo;
9244 loop->op_lastop = o;
9245 o->op_private |= loopflags;
9248 loop->op_nextop = next;
9250 loop->op_nextop = o;
9252 o->op_flags |= flags;
9253 o->op_private |= (flags >> 8);
9258 =for apidoc newFOROP
9260 Constructs, checks, and returns an op tree expressing a C<foreach>
9261 loop (iteration through a list of values). This is a heavyweight loop,
9262 with structure that allows exiting the loop by C<last> and suchlike.
9264 C<sv> optionally supplies the variable(s) that will be aliased to each
9265 item in turn; if null, it defaults to C<$_>.
9266 C<expr> supplies the list of values to iterate over. C<block> supplies
9267 the main body of the loop, and C<cont> optionally supplies a C<continue>
9268 block that operates as a second half of the body. All of these optree
9269 inputs are consumed by this function and become part of the constructed
9272 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9273 op and, shifted up eight bits, the eight bits of C<op_private> for
9274 the C<leaveloop> op, except that (in both cases) some bits will be set
9281 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9285 PADOFFSET padoff = 0;
9286 PADOFFSET how_many_more = 0;
9291 PERL_ARGS_ASSERT_NEWFOROP;
9294 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
9295 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9296 OpTYPE_set(sv, OP_RV2GV);
9298 /* The op_type check is needed to prevent a possible segfault
9299 * if the loop variable is undeclared and 'strict vars' is in
9300 * effect. This is illegal but is nonetheless parsed, so we
9301 * may reach this point with an OP_CONST where we're expecting
9304 if (cUNOPx(sv)->op_first->op_type == OP_GV
9305 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9306 iterpflags |= OPpITER_DEF;
9308 else if (sv->op_type == OP_PADSV) { /* private variable */
9309 if (sv->op_flags & OPf_PARENS) {
9310 /* handle degenerate 1-var form of "for my ($x, ...)" */
9311 sv->op_private |= OPpLVAL_INTRO;
9314 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9315 padoff = sv->op_targ;
9319 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9321 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9323 else if (sv->op_type == OP_LIST) {
9324 LISTOP *list = cLISTOPx(sv);
9325 OP *pushmark = list->op_first;
9330 iterpflags = OPpLVAL_INTRO; /* for my ($k, $v) () */
9333 if (!pushmark || pushmark->op_type != OP_PUSHMARK) {
9334 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting pushmark",
9335 pushmark ? PL_op_desc[pushmark->op_type] : "NULL");
9337 first_padsv = OpSIBLING(pushmark);
9338 if (!first_padsv || first_padsv->op_type != OP_PADSV) {
9339 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting padsv",
9340 first_padsv ? PL_op_desc[first_padsv->op_type] : "NULL");
9342 padoff = first_padsv->op_targ;
9344 /* There should be at least one more PADSV to find, and the ops
9345 should have consecutive values in targ: */
9346 padsv = cUNOPx(OpSIBLING(first_padsv));
9348 if (!padsv || padsv->op_type != OP_PADSV) {
9349 Perl_croak(aTHX_ "panic: newFORLOOP, found %s at %zd, expecting padsv",
9350 padsv ? PL_op_desc[padsv->op_type] : "NULL",
9354 if (padsv->op_targ != padoff + how_many_more) {
9355 Perl_croak(aTHX_ "panic: newFORLOOP, padsv at %zd targ is %zd, not %zd",
9356 how_many_more, padsv->op_targ, padoff + how_many_more);
9359 padsv = cUNOPx(OpSIBLING(padsv));
9362 /* OK, this optree has the shape that we expected. So now *we*
9363 "claim" the Pad slots: */
9364 first_padsv->op_targ = 0;
9365 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9369 padsv = cUNOPx(OpSIBLING(first_padsv));
9373 PAD_COMPNAME_GEN_set(i, PERL_INT_MAX);
9375 padsv = cUNOPx(OpSIBLING(padsv));
9382 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9384 PADNAME * const pn = PAD_COMPNAME(padoff);
9385 const char * const name = PadnamePV(pn);
9387 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9388 iterpflags |= OPpITER_DEF;
9392 sv = newGVOP(OP_GV, 0, PL_defgv);
9393 iterpflags |= OPpITER_DEF;
9396 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9397 expr = op_lvalue(op_force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
9398 iterflags |= OPf_STACKED;
9400 else if (expr->op_type == OP_NULL &&
9401 (expr->op_flags & OPf_KIDS) &&
9402 cBINOPx(expr)->op_first->op_type == OP_FLOP)
9404 /* Basically turn for($x..$y) into the same as for($x,$y), but we
9405 * set the STACKED flag to indicate that these values are to be
9406 * treated as min/max values by 'pp_enteriter'.
9408 const UNOP* const flip = cUNOPx(cUNOPx(cBINOPx(expr)->op_first)->op_first);
9409 LOGOP* const range = cLOGOPx(flip->op_first);
9410 OP* const left = range->op_first;
9411 OP* const right = OpSIBLING(left);
9414 range->op_flags &= ~OPf_KIDS;
9415 /* detach range's children */
9416 op_sibling_splice((OP*)range, NULL, -1, NULL);
9418 listop = cLISTOPx(newLISTOP(OP_LIST, 0, left, right));
9419 listop->op_first->op_next = range->op_next;
9420 left->op_next = range->op_other;
9421 right->op_next = (OP*)listop;
9422 listop->op_next = listop->op_first;
9425 expr = (OP*)(listop);
9427 iterflags |= OPf_STACKED;
9430 expr = op_lvalue(op_force_list(expr), OP_GREPSTART);
9433 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9434 op_append_elem(OP_LIST, list(expr),
9436 assert(!loop->op_next);
9437 /* for my $x () sets OPpLVAL_INTRO;
9438 * for our $x () sets OPpOUR_INTRO */
9439 loop->op_private = (U8)iterpflags;
9441 /* upgrade loop from a LISTOP to a LOOPOP;
9442 * keep it in-place if there's space */
9443 if (loop->op_slabbed
9444 && OpSLOT(loop)->opslot_size
9445 < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
9447 /* no space; allocate new op */
9449 NewOp(1234,tmp,1,LOOP);
9450 Copy(loop,tmp,1,LISTOP);
9451 assert(loop->op_last->op_sibparent == (OP*)loop);
9452 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9453 S_op_destroy(aTHX_ (OP*)loop);
9456 else if (!loop->op_slabbed)
9458 /* loop was malloc()ed */
9459 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9460 OpLASTSIB_set(loop->op_last, (OP*)loop);
9462 loop->op_targ = padoff;
9464 /* hint to deparser that this: for my (...) ... */
9465 loop->op_flags |= OPf_PARENS;
9466 iter = newOP(OP_ITER, 0);
9467 iter->op_targ = how_many_more;
9468 return newWHILEOP(flags, 1, loop, iter, block, cont, 0);
9472 =for apidoc newLOOPEX
9474 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9475 or C<last>). C<type> is the opcode. C<label> supplies the parameter
9476 determining the target of the op; it is consumed by this function and
9477 becomes part of the constructed op tree.
9483 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9487 PERL_ARGS_ASSERT_NEWLOOPEX;
9489 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9490 || type == OP_CUSTOM);
9492 if (type != OP_GOTO) {
9493 /* "last()" means "last" */
9494 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9495 o = newOP(type, OPf_SPECIAL);
9499 /* Check whether it's going to be a goto &function */
9500 if (label->op_type == OP_ENTERSUB
9501 && !(label->op_flags & OPf_STACKED))
9502 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9505 /* Check for a constant argument */
9506 if (label->op_type == OP_CONST) {
9507 SV * const sv = cSVOPx(label)->op_sv;
9509 const char *s = SvPV_const(sv,l);
9510 if (l == strlen(s)) {
9512 SvUTF8(cSVOPx(label)->op_sv),
9514 SvPV_nolen_const(cSVOPx(label)->op_sv)));
9518 /* If we have already created an op, we do not need the label. */
9521 else o = newUNOP(type, OPf_STACKED, label);
9523 PL_hints |= HINT_BLOCK_SCOPE;
9527 /* if the condition is a literal array or hash
9528 (or @{ ... } etc), make a reference to it.
9531 S_ref_array_or_hash(pTHX_ OP *cond)
9534 && (cond->op_type == OP_RV2AV
9535 || cond->op_type == OP_PADAV
9536 || cond->op_type == OP_RV2HV
9537 || cond->op_type == OP_PADHV))
9539 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9542 && (cond->op_type == OP_ASLICE
9543 || cond->op_type == OP_KVASLICE
9544 || cond->op_type == OP_HSLICE
9545 || cond->op_type == OP_KVHSLICE)) {
9547 /* anonlist now needs a list from this op, was previously used in
9549 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9550 cond->op_flags |= OPf_WANT_LIST;
9552 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9559 /* These construct the optree fragments representing given()
9562 entergiven and enterwhen are LOGOPs; the op_other pointer
9563 points up to the associated leave op. We need this so we
9564 can put it in the context and make break/continue work.
9565 (Also, of course, pp_enterwhen will jump straight to
9566 op_other if the match fails.)
9570 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9571 I32 enter_opcode, I32 leave_opcode,
9572 PADOFFSET entertarg)
9577 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9578 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9580 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9581 enterop->op_targ = 0;
9582 enterop->op_private = 0;
9584 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9587 /* prepend cond if we have one */
9588 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9590 o->op_next = LINKLIST(cond);
9591 cond->op_next = (OP *) enterop;
9594 /* This is a default {} block */
9595 enterop->op_flags |= OPf_SPECIAL;
9596 o ->op_flags |= OPf_SPECIAL;
9598 o->op_next = (OP *) enterop;
9601 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9602 entergiven and enterwhen both
9605 enterop->op_next = LINKLIST(block);
9606 block->op_next = enterop->op_other = o;
9612 /* For the purposes of 'when(implied_smartmatch)'
9613 * versus 'when(boolean_expression)',
9614 * does this look like a boolean operation? For these purposes
9615 a boolean operation is:
9616 - a subroutine call [*]
9617 - a logical connective
9618 - a comparison operator
9619 - a filetest operator, with the exception of -s -M -A -C
9620 - defined(), exists() or eof()
9621 - /$re/ or $foo =~ /$re/
9623 [*] possibly surprising
9626 S_looks_like_bool(pTHX_ const OP *o)
9628 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9630 switch(o->op_type) {
9633 return looks_like_bool(cLOGOPo->op_first);
9637 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9640 looks_like_bool(cLOGOPo->op_first)
9641 && looks_like_bool(sibl));
9647 o->op_flags & OPf_KIDS
9648 && looks_like_bool(cUNOPo->op_first));
9652 case OP_NOT: case OP_XOR:
9654 case OP_EQ: case OP_NE: case OP_LT:
9655 case OP_GT: case OP_LE: case OP_GE:
9657 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9658 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9660 case OP_SEQ: case OP_SNE: case OP_SLT:
9661 case OP_SGT: case OP_SLE: case OP_SGE:
9665 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9666 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9667 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9668 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9669 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9670 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9671 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9672 case OP_FTTEXT: case OP_FTBINARY:
9674 case OP_DEFINED: case OP_EXISTS:
9675 case OP_MATCH: case OP_EOF:
9683 /* optimised-away (index() != -1) or similar comparison */
9684 if (o->op_private & OPpTRUEBOOL)
9689 /* Detect comparisons that have been optimized away */
9690 if (cSVOPo->op_sv == &PL_sv_yes
9691 || cSVOPo->op_sv == &PL_sv_no)
9704 =for apidoc newGIVENOP
9706 Constructs, checks, and returns an op tree expressing a C<given> block.
9707 C<cond> supplies the expression to whose value C<$_> will be locally
9708 aliased, and C<block> supplies the body of the C<given> construct; they
9709 are consumed by this function and become part of the constructed op tree.
9710 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9716 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9718 PERL_ARGS_ASSERT_NEWGIVENOP;
9719 PERL_UNUSED_ARG(defsv_off);
9722 return newGIVWHENOP(
9723 ref_array_or_hash(cond),
9725 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9730 =for apidoc newWHENOP
9732 Constructs, checks, and returns an op tree expressing a C<when> block.
9733 C<cond> supplies the test expression, and C<block> supplies the block
9734 that will be executed if the test evaluates to true; they are consumed
9735 by this function and become part of the constructed op tree. C<cond>
9736 will be interpreted DWIMically, often as a comparison against C<$_>,
9737 and may be null to generate a C<default> block.
9743 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9745 const bool cond_llb = (!cond || looks_like_bool(cond));
9748 PERL_ARGS_ASSERT_NEWWHENOP;
9753 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9755 scalar(ref_array_or_hash(cond)));
9758 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9762 =for apidoc newDEFEROP
9764 Constructs and returns a deferred-block statement that implements the
9765 C<defer> semantics. The C<block> optree is consumed by this function and
9766 becomes part of the returned optree.
9768 The C<flags> argument carries additional flags to set on the returned op,
9769 including the C<op_private> field.
9775 Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
9777 OP *o, *start, *blockfirst;
9779 PERL_ARGS_ASSERT_NEWDEFEROP;
9781 forbid_outofblock_ops(block,
9782 (flags & (OPpDEFER_FINALLY << 8)) ? "a \"finally\" block" : "a \"defer\" block");
9784 start = LINKLIST(block);
9786 /* Hide the block inside an OP_NULL with no execution */
9787 block = newUNOP(OP_NULL, 0, block);
9788 block->op_next = block;
9790 o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
9791 o->op_flags |= OPf_WANT_VOID | (U8)(flags);
9792 o->op_private = (U8)(flags >> 8);
9794 /* Terminate the block */
9795 blockfirst = cUNOPx(block)->op_first;
9796 assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE);
9797 blockfirst->op_next = NULL;
9803 =for apidoc op_wrap_finally
9805 Wraps the given C<block> optree fragment in its own scoped block, arranging
9806 for the C<finally> optree fragment to be invoked when leaving that block for
9807 any reason. Both optree fragments are consumed and the combined result is
9814 Perl_op_wrap_finally(pTHX_ OP *block, OP *finally)
9816 PERL_ARGS_ASSERT_OP_WRAP_FINALLY;
9818 /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can
9819 * just splice the DEFEROP in at the top, for efficiency.
9822 OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block);
9823 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
9824 OpTYPE_set(o, OP_LEAVE);
9829 /* must not conflict with SVf_UTF8 */
9830 #define CV_CKPROTO_CURSTASH 0x1
9833 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9834 const STRLEN len, const U32 flags)
9836 SV *name = NULL, *msg;
9837 const char * cvp = SvROK(cv)
9838 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9839 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9842 STRLEN clen = CvPROTOLEN(cv), plen = len;
9844 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9846 if (p == NULL && cvp == NULL)
9849 if (!ckWARN_d(WARN_PROTOTYPE))
9853 p = S_strip_spaces(aTHX_ p, &plen);
9854 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9855 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9856 if (plen == clen && memEQ(cvp, p, plen))
9859 if (flags & SVf_UTF8) {
9860 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9864 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9870 msg = sv_newmortal();
9875 gv_efullname3(name = sv_newmortal(), gv, NULL);
9876 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9877 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9878 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9879 name = newSVhek_mortal(HvNAME_HEK(PL_curstash));
9880 sv_catpvs(name, "::");
9882 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9883 assert (CvNAMED(SvRV_const(gv)));
9884 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9886 else sv_catsv(name, (SV *)gv);
9888 else name = (SV *)gv;
9890 sv_setpvs(msg, "Prototype mismatch:");
9892 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9894 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9895 UTF8fARG(SvUTF8(cv),clen,cvp)
9898 sv_catpvs(msg, ": none");
9899 sv_catpvs(msg, " vs ");
9901 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9903 sv_catpvs(msg, "none");
9904 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9907 static void const_sv_xsub(pTHX_ CV* cv);
9908 static void const_av_xsub(pTHX_ CV* cv);
9912 =for apidoc_section $optree_manipulation
9914 =for apidoc cv_const_sv
9916 If C<cv> is a constant sub eligible for inlining, returns the constant
9917 value returned by the sub. Otherwise, returns C<NULL>.
9919 Constant subs can be created with C<newCONSTSUB> or as described in
9920 L<perlsub/"Constant Functions">.
9925 Perl_cv_const_sv(const CV *const cv)
9930 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9932 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9933 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9938 Perl_cv_const_sv_or_av(const CV * const cv)
9942 if (SvROK(cv)) return SvRV((SV *)cv);
9943 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9944 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9947 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9948 * Can be called in 2 ways:
9951 * look for a single OP_CONST with attached value: return the value
9953 * allow_lex && !CvCONST(cv);
9955 * examine the clone prototype, and if contains only a single
9956 * OP_CONST, return the value; or if it contains a single PADSV ref-
9957 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9958 * a candidate for "constizing" at clone time, and return NULL.
9962 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9970 for (; o; o = o->op_next) {
9971 const OPCODE type = o->op_type;
9973 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9975 || type == OP_PUSHMARK)
9977 if (type == OP_DBSTATE)
9979 if (type == OP_LEAVESUB)
9983 if (type == OP_CONST && cSVOPo->op_sv)
9985 else if (type == OP_UNDEF && !o->op_private) {
9986 sv = newSV_type(SVt_NULL);
9989 else if (allow_lex && type == OP_PADSV) {
9990 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEf_OUTER)
9992 sv = &PL_sv_undef; /* an arbitrary non-null value */
10010 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10011 PADNAME * const name, SV ** const const_svp)
10014 assert (o || name);
10015 assert (const_svp);
10017 if (CvFLAGS(PL_compcv)) {
10018 /* might have had built-in attrs applied */
10019 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10020 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10021 && ckWARN(WARN_MISC))
10023 /* protect against fatal warnings leaking compcv */
10024 SAVEFREESV(PL_compcv);
10025 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10026 SvREFCNT_inc_simple_void_NN(PL_compcv);
10029 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10030 & ~(CVf_LVALUE * pureperl));
10035 /* redundant check for speed: */
10036 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10037 const line_t oldline = CopLINE(PL_curcop);
10040 : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1,
10041 (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP
10043 if (PL_parser && PL_parser->copline != NOLINE)
10044 /* This ensures that warnings are reported at the first
10045 line of a redefinition, not the last. */
10046 CopLINE_set(PL_curcop, PL_parser->copline);
10047 /* protect against fatal warnings leaking compcv */
10048 SAVEFREESV(PL_compcv);
10049 report_redefined_cv(namesv, cv, const_svp);
10050 SvREFCNT_inc_simple_void_NN(PL_compcv);
10051 CopLINE_set(PL_curcop, oldline);
10058 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10063 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10066 CV *compcv = PL_compcv;
10069 PADOFFSET pax = o->op_targ;
10070 CV *outcv = CvOUTSIDE(PL_compcv);
10073 bool reusable = FALSE;
10075 #ifdef PERL_DEBUG_READONLY_OPS
10076 OPSLAB *slab = NULL;
10079 PERL_ARGS_ASSERT_NEWMYSUB;
10081 PL_hints |= HINT_BLOCK_SCOPE;
10083 /* Find the pad slot for storing the new sub.
10084 We cannot use PL_comppad, as it is the pad owned by the new sub. We
10085 need to look in CvOUTSIDE and find the pad belonging to the enclos-
10086 ing sub. And then we need to dig deeper if this is a lexical from
10088 my sub foo; sub { sub foo { } }
10091 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10092 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10093 pax = PARENT_PAD_INDEX(name);
10094 outcv = CvOUTSIDE(outcv);
10099 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10100 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10101 spot = (CV **)svspot;
10103 if (!(PL_parser && PL_parser->error_count))
10104 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10107 assert(proto->op_type == OP_CONST);
10108 ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10109 ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10119 if (PL_parser && PL_parser->error_count) {
10121 SvREFCNT_dec(PL_compcv);
10126 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10128 svspot = (SV **)(spot = &clonee);
10130 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10133 assert (SvTYPE(*spot) == SVt_PVCV);
10134 if (CvNAMED(*spot))
10135 hek = CvNAME_HEK(*spot);
10138 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10139 CvNAME_HEK_set(*spot, hek =
10142 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10146 CvLEXICAL_on(*spot);
10148 cv = PadnamePROTOCV(name);
10149 svspot = (SV **)(spot = &PadnamePROTOCV(name));
10153 /* This makes sub {}; work as expected. */
10154 if (block->op_type == OP_STUB) {
10155 const line_t l = PL_parser->copline;
10157 block = newSTATEOP(0, NULL, 0);
10158 PL_parser->copline = l;
10160 block = CvLVALUE(compcv)
10161 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10162 ? newUNOP(OP_LEAVESUBLV, 0,
10163 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10164 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10165 start = LINKLIST(block);
10166 block->op_next = 0;
10167 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10168 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10176 const bool exists = CvROOT(cv) || CvXSUB(cv);
10178 /* if the subroutine doesn't exist and wasn't pre-declared
10179 * with a prototype, assume it will be AUTOLOADed,
10180 * skipping the prototype check
10182 if (exists || SvPOK(cv))
10183 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10185 /* already defined? */
10187 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10193 /* just a "sub foo;" when &foo is already defined */
10194 SAVEFREESV(compcv);
10198 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10205 SvREFCNT_inc_simple_void_NN(const_sv);
10206 SvFLAGS(const_sv) |= SVs_PADTMP;
10208 assert(!CvROOT(cv) && !CvCONST(cv));
10209 cv_forget_slab(cv);
10212 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10213 CvFILE_set_from_cop(cv, PL_curcop);
10214 CvSTASH_set(cv, PL_curstash);
10217 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10218 CvXSUBANY(cv).any_ptr = const_sv;
10219 CvXSUB(cv) = const_sv_xsub;
10223 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(compcv);
10225 SvREFCNT_dec(compcv);
10230 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10231 determine whether this sub definition is in the same scope as its
10232 declaration. If this sub definition is inside an inner named pack-
10233 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10234 the package sub. So check PadnameOUTER(name) too.
10236 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10237 assert(!CvWEAKOUTSIDE(compcv));
10238 SvREFCNT_dec(CvOUTSIDE(compcv));
10239 CvWEAKOUTSIDE_on(compcv);
10241 /* XXX else do we have a circular reference? */
10243 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
10244 /* transfer PL_compcv to cv */
10246 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10247 cv_flags_t preserved_flags =
10248 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10249 PADLIST *const temp_padl = CvPADLIST(cv);
10250 CV *const temp_cv = CvOUTSIDE(cv);
10251 const cv_flags_t other_flags =
10252 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10253 OP * const cvstart = CvSTART(cv);
10257 CvFLAGS(compcv) | preserved_flags;
10258 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10259 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10260 CvPADLIST_set(cv, CvPADLIST(compcv));
10261 CvOUTSIDE(compcv) = temp_cv;
10262 CvPADLIST_set(compcv, temp_padl);
10263 CvSTART(cv) = CvSTART(compcv);
10264 CvSTART(compcv) = cvstart;
10265 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10266 CvFLAGS(compcv) |= other_flags;
10269 Safefree(CvFILE(cv));
10273 /* inner references to compcv must be fixed up ... */
10274 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10275 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10276 ++PL_sub_generation;
10279 /* Might have had built-in attributes applied -- propagate them. */
10280 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10282 /* ... before we throw it away */
10283 SvREFCNT_dec(compcv);
10284 PL_compcv = compcv = cv;
10293 if (!CvNAME_HEK(cv)) {
10294 if (hek) (void)share_hek_hek(hek);
10297 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10298 hek = share_hek(PadnamePV(name)+1,
10299 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10302 CvNAME_HEK_set(cv, hek);
10308 if (CvFILE(cv) && CvDYNFILE(cv))
10309 Safefree(CvFILE(cv));
10310 CvFILE_set_from_cop(cv, PL_curcop);
10311 CvSTASH_set(cv, PL_curstash);
10314 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10316 SvUTF8_on(MUTABLE_SV(cv));
10320 /* If we assign an optree to a PVCV, then we've defined a
10321 * subroutine that the debugger could be able to set a breakpoint
10322 * in, so signal to pp_entereval that it should not throw away any
10323 * saved lines at scope exit. */
10325 PL_breakable_sub_gen++;
10326 CvROOT(cv) = block;
10327 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10328 itself has a refcount. */
10330 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10331 #ifdef PERL_DEBUG_READONLY_OPS
10332 slab = (OPSLAB *)CvSTART(cv);
10334 S_process_optree(aTHX_ cv, block, start);
10339 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10340 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10344 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10345 SV * const tmpstr = sv_newmortal();
10346 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10347 GV_ADDMULTI, SVt_PVHV);
10349 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf "-%" LINE_Tf,
10350 CopFILE(PL_curcop),
10351 (line_t)PL_subline,
10352 CopLINE(PL_curcop));
10353 if (HvNAME_HEK(PL_curstash)) {
10354 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10355 sv_catpvs(tmpstr, "::");
10358 sv_setpvs(tmpstr, "__ANON__::");
10360 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10361 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10362 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10363 hv = GvHVn(db_postponed);
10364 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10365 CV * const pcv = GvCV(db_postponed);
10371 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10379 assert(CvDEPTH(outcv));
10381 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10383 cv_clone_into(clonee, *spot);
10384 else *spot = cv_clone(clonee);
10385 SvREFCNT_dec_NN(clonee);
10389 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10390 PADOFFSET depth = CvDEPTH(outcv);
10393 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10395 *svspot = SvREFCNT_inc_simple_NN(cv);
10396 SvREFCNT_dec(oldcv);
10402 PL_parser->copline = NOLINE;
10403 LEAVE_SCOPE(floor);
10404 #ifdef PERL_DEBUG_READONLY_OPS
10413 =for apidoc newATTRSUB_x
10415 Construct a Perl subroutine, also performing some surrounding jobs.
10417 This function is expected to be called in a Perl compilation context,
10418 and some aspects of the subroutine are taken from global variables
10419 associated with compilation. In particular, C<PL_compcv> represents
10420 the subroutine that is currently being compiled. It must be non-null
10421 when this function is called, and some aspects of the subroutine being
10422 constructed are taken from it. The constructed subroutine may actually
10423 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10425 If C<block> is null then the subroutine will have no body, and for the
10426 time being it will be an error to call it. This represents a forward
10427 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
10428 non-null then it provides the Perl code of the subroutine body, which
10429 will be executed when the subroutine is called. This body includes
10430 any argument unwrapping code resulting from a subroutine signature or
10431 similar. The pad use of the code must correspond to the pad attached
10432 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
10433 C<leavesublv> op; this function will add such an op. C<block> is consumed
10434 by this function and will become part of the constructed subroutine.
10436 C<proto> specifies the subroutine's prototype, unless one is supplied
10437 as an attribute (see below). If C<proto> is null, then the subroutine
10438 will not have a prototype. If C<proto> is non-null, it must point to a
10439 C<const> op whose value is a string, and the subroutine will have that
10440 string as its prototype. If a prototype is supplied as an attribute, the
10441 attribute takes precedence over C<proto>, but in that case C<proto> should
10442 preferably be null. In any case, C<proto> is consumed by this function.
10444 C<attrs> supplies attributes to be applied the subroutine. A handful of
10445 attributes take effect by built-in means, being applied to C<PL_compcv>
10446 immediately when seen. Other attributes are collected up and attached
10447 to the subroutine by this route. C<attrs> may be null to supply no
10448 attributes, or point to a C<const> op for a single attribute, or point
10449 to a C<list> op whose children apart from the C<pushmark> are C<const>
10450 ops for one or more attributes. Each C<const> op must be a string,
10451 giving the attribute name optionally followed by parenthesised arguments,
10452 in the manner in which attributes appear in Perl source. The attributes
10453 will be applied to the sub by this function. C<attrs> is consumed by
10456 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10457 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
10458 must point to a C<const> OP, which will be consumed by this function,
10459 and its string value supplies a name for the subroutine. The name may
10460 be qualified or unqualified, and if it is unqualified then a default
10461 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
10462 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10463 by which the subroutine will be named.
10465 If there is already a subroutine of the specified name, then the new
10466 sub will either replace the existing one in the glob or be merged with
10467 the existing one. A warning may be generated about redefinition.
10469 If the subroutine has one of a few special names, such as C<BEGIN> or
10470 C<END>, then it will be claimed by the appropriate queue for automatic
10471 running of phase-related subroutines. In this case the relevant glob will
10472 be left not containing any subroutine, even if it did contain one before.
10473 In the case of C<BEGIN>, the subroutine will be executed and the reference
10474 to it disposed of before this function returns.
10476 The function returns a pointer to the constructed subroutine. If the sub
10477 is anonymous then ownership of one counted reference to the subroutine
10478 is transferred to the caller. If the sub is named then the caller does
10479 not get ownership of a reference. In most such cases, where the sub
10480 has a non-phase name, the sub will be alive at the point it is returned
10481 by virtue of being contained in the glob that names it. A phase-named
10482 subroutine will usually be alive by virtue of the reference owned by the
10483 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10484 been executed, will quite likely have been destroyed already by the
10485 time this function returns, making it erroneous for the caller to make
10486 any use of the returned pointer. It is the caller's responsibility to
10487 ensure that it knows which of these situations applies.
10489 =for apidoc newATTRSUB
10490 Construct a Perl subroutine, also performing some surrounding jobs.
10492 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
10493 FALSE. This means that if C<o> is null, the new sub will be anonymous; otherwise
10494 the name will be derived from C<o> in the way described (as with all other
10495 details) in L<perlintern/C<newATTRSUB_x>>.
10498 Like C<L</newATTRSUB>>, but without attributes.
10503 /* _x = extended */
10505 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10506 OP *block, bool o_is_gv)
10510 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10512 CV *cv = NULL; /* the previous CV with this name, if any */
10514 const bool ec = PL_parser && PL_parser->error_count;
10515 /* If the subroutine has no body, no attributes, and no builtin attributes
10516 then it's just a sub declaration, and we may be able to get away with
10517 storing with a placeholder scalar in the symbol table, rather than a
10518 full CV. If anything is present then it will take a full CV to
10520 const I32 gv_fetch_flags
10521 = ec ? GV_NOADD_NOINIT :
10522 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10523 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10525 const char * const name =
10526 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10528 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10529 bool evanescent = FALSE;
10530 bool isBEGIN = FALSE;
10532 #ifdef PERL_DEBUG_READONLY_OPS
10533 OPSLAB *slab = NULL;
10541 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
10542 hek and CvSTASH pointer together can imply the GV. If the name
10543 contains a package name, then GvSTASH(CvGV(cv)) may differ from
10544 CvSTASH, so forego the optimisation if we find any.
10545 Also, we may be called from load_module at run time, so
10546 PL_curstash (which sets CvSTASH) may not point to the stash the
10547 sub is stored in. */
10548 /* XXX This optimization is currently disabled for packages other
10549 than main, since there was too much CPAN breakage. */
10551 ec ? GV_NOADD_NOINIT
10552 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10553 || PL_curstash != PL_defstash
10554 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10556 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10557 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10559 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10560 SV * const sv = sv_newmortal();
10561 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" LINE_Tf "]",
10562 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10563 CopFILE(PL_curcop), CopLINE(PL_curcop));
10564 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10566 } else if (PL_curstash) {
10567 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10570 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10576 move_proto_attr(&proto, &attrs, gv, 0);
10579 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10590 /* we need this in two places later on, so set it up here */
10591 if (name && block) {
10592 const char *s = (char *) my_memrchr(name, ':', namlen);
10593 s = s ? s+1 : name;
10594 isBEGIN = strEQ(s,"BEGIN");
10598 /* Make sure that we do not have any prototypes or
10599 * attributes associated with this BEGIN block, as the block
10600 * is already done and dusted, and we will assert or worse
10601 * if we try to attach the prototype to the now essentially
10602 * nonexistent sub. */
10604 /* diag_listed_as: %s on BEGIN block ignored */
10605 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Prototype on BEGIN block ignored");
10607 /* diag_listed_as: %s on BEGIN block ignored */
10608 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Attribute on BEGIN block ignored");
10614 assert(proto->op_type == OP_CONST);
10615 ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10616 ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10625 SvREFCNT_dec(PL_compcv);
10631 if (PL_in_eval & EVAL_KEEPERR)
10632 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10634 SV * const errsv = ERRSV;
10635 /* force display of errors found but not reported */
10636 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10637 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10643 if (!block && SvTYPE(gv) != SVt_PVGV) {
10644 /* If we are not defining a new sub and the existing one is not a
10646 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10647 /* We are applying attributes to an existing sub, so we need it
10648 upgraded if it is a constant. */
10649 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10650 gv_init_pvn(gv, PL_curstash, name, namlen,
10651 SVf_UTF8 * name_is_utf8);
10653 else { /* Maybe prototype now, and had at maximum
10654 a prototype or const/sub ref before. */
10655 if (SvTYPE(gv) > SVt_NULL) {
10656 cv_ckproto_len_flags((const CV *)gv,
10657 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10663 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10665 SvUTF8_on(MUTABLE_SV(gv));
10668 sv_setiv(MUTABLE_SV(gv), -1);
10671 SvREFCNT_dec(PL_compcv);
10672 cv = PL_compcv = NULL;
10677 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10681 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10687 if (CvIsMETHOD(PL_compcv))
10688 block = class_wrap_method_body(block);
10689 /* This makes sub {}; work as expected. */
10690 if (block->op_type == OP_STUB) {
10691 const line_t l = PL_parser->copline;
10693 block = newSTATEOP(0, NULL, 0);
10694 PL_parser->copline = l;
10696 block = CvLVALUE(PL_compcv)
10697 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10698 && (!isGV(gv) || !GvASSUMECV(gv)))
10699 ? newUNOP(OP_LEAVESUBLV, 0,
10700 op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10701 : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10702 start = LINKLIST(block);
10703 block->op_next = 0;
10704 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10706 S_op_const_sv(aTHX_ start, PL_compcv,
10707 cBOOL(CvCLONE(PL_compcv)));
10714 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10715 cv_ckproto_len_flags((const CV *)gv,
10716 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10717 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10719 /* All the other code for sub redefinition warnings expects the
10720 clobbered sub to be a CV. Instead of making all those code
10721 paths more complex, just inline the RV version here. */
10722 const line_t oldline = CopLINE(PL_curcop);
10723 assert(IN_PERL_COMPILETIME);
10724 if (PL_parser && PL_parser->copline != NOLINE)
10725 /* This ensures that warnings are reported at the first
10726 line of a redefinition, not the last. */
10727 CopLINE_set(PL_curcop, PL_parser->copline);
10728 /* protect against fatal warnings leaking compcv */
10729 SAVEFREESV(PL_compcv);
10731 if (ckWARN(WARN_REDEFINE)
10732 || ( ckWARN_d(WARN_REDEFINE)
10733 && ( !const_sv || SvRV(gv) == const_sv
10734 || SvTYPE(const_sv) == SVt_PVAV
10735 || SvTYPE(SvRV(gv)) == SVt_PVAV
10736 || sv_cmp(SvRV(gv), const_sv) ))) {
10738 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10739 "Constant subroutine %" SVf " redefined",
10740 SVfARG(cSVOPo->op_sv));
10743 SvREFCNT_inc_simple_void_NN(PL_compcv);
10744 CopLINE_set(PL_curcop, oldline);
10745 SvREFCNT_dec(SvRV(gv));
10750 const bool exists = CvROOT(cv) || CvXSUB(cv);
10752 /* if the subroutine doesn't exist and wasn't pre-declared
10753 * with a prototype, assume it will be AUTOLOADed,
10754 * skipping the prototype check
10756 if (exists || SvPOK(cv))
10757 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10758 /* already defined (or promised)? */
10759 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10760 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10766 /* just a "sub foo;" when &foo is already defined */
10767 SAVEFREESV(PL_compcv);
10774 SvREFCNT_inc_simple_void_NN(const_sv);
10775 SvFLAGS(const_sv) |= SVs_PADTMP;
10777 assert(!CvROOT(cv) && !CvCONST(cv));
10778 cv_forget_slab(cv);
10779 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10780 CvXSUBANY(cv).any_ptr = const_sv;
10781 CvXSUB(cv) = const_sv_xsub;
10785 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10788 if (isGV(gv) || CvNOWARN_AMBIGUOUS(PL_compcv)) {
10789 if (name && isGV(gv))
10790 GvCV_set(gv, NULL);
10791 cv = newCONSTSUB_flags(
10792 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10796 assert(SvREFCNT((SV*)cv) != 0);
10797 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10801 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10802 prepare_SV_for_RV((SV *)gv);
10803 SvOK_off((SV *)gv);
10806 SvRV_set(gv, const_sv);
10810 SvREFCNT_dec(PL_compcv);
10815 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10816 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10819 if (cv) { /* must reuse cv if autoloaded */
10820 /* transfer PL_compcv to cv */
10822 bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10823 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10824 PADLIST *const temp_av = CvPADLIST(cv);
10825 CV *const temp_cv = CvOUTSIDE(cv);
10826 const cv_flags_t other_flags =
10827 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10828 OP * const cvstart = CvSTART(cv);
10832 assert(!CvCVGV_RC(cv));
10833 assert(CvGV(cv) == gv);
10837 PERL_HASH(hash, name, namlen);
10847 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10849 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10850 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10851 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10852 CvOUTSIDE(PL_compcv) = temp_cv;
10853 CvPADLIST_set(PL_compcv, temp_av);
10854 CvSTART(cv) = CvSTART(PL_compcv);
10855 CvSTART(PL_compcv) = cvstart;
10856 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10857 CvFLAGS(PL_compcv) |= other_flags;
10860 Safefree(CvFILE(cv));
10862 CvFILE_set_from_cop(cv, PL_curcop);
10863 CvSTASH_set(cv, PL_curstash);
10865 /* inner references to PL_compcv must be fixed up ... */
10866 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10867 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10868 ++PL_sub_generation;
10871 /* Might have had built-in attributes applied -- propagate them. */
10872 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10874 /* ... before we throw it away */
10875 SvREFCNT_dec(PL_compcv);
10880 if (name && isGV(gv)) {
10883 if (HvENAME_HEK(GvSTASH(gv)))
10884 /* sub Foo::bar { (shift)+1 } */
10885 gv_method_changed(gv);
10889 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10890 prepare_SV_for_RV((SV *)gv);
10891 SvOK_off((SV *)gv);
10894 SvRV_set(gv, (SV *)cv);
10895 if (HvENAME_HEK(PL_curstash))
10896 mro_method_changed_in(PL_curstash);
10900 assert(SvREFCNT((SV*)cv) != 0);
10902 if (!CvHASGV(cv)) {
10907 PERL_HASH(hash, name, namlen);
10908 CvNAME_HEK_set(cv, share_hek(name,
10914 CvFILE_set_from_cop(cv, PL_curcop);
10915 CvSTASH_set(cv, PL_curstash);
10919 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10921 SvUTF8_on(MUTABLE_SV(cv));
10925 /* If we assign an optree to a PVCV, then we've defined a
10926 * subroutine that the debugger could be able to set a breakpoint
10927 * in, so signal to pp_entereval that it should not throw away any
10928 * saved lines at scope exit. */
10930 PL_breakable_sub_gen++;
10931 CvROOT(cv) = block;
10932 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10933 itself has a refcount. */
10935 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10936 #ifdef PERL_DEBUG_READONLY_OPS
10937 slab = (OPSLAB *)CvSTART(cv);
10939 S_process_optree(aTHX_ cv, block, start);
10944 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10945 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10946 ? GvSTASH(CvGV(cv))
10950 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10952 SvREFCNT_inc_simple_void_NN(cv);
10955 if (block && has_name) {
10956 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10957 SV * const tmpstr = cv_name(cv,NULL,0);
10958 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10959 GV_ADDMULTI, SVt_PVHV);
10961 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf "-%" LINE_Tf,
10962 CopFILE(PL_curcop),
10963 (line_t)PL_subline,
10964 CopLINE(PL_curcop));
10965 (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10966 hv = GvHVn(db_postponed);
10967 if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10968 CV * const pcv = GvCV(db_postponed);
10974 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10980 if (PL_parser && PL_parser->error_count)
10981 clear_special_blocks(name, gv, cv);
10984 process_special_blocks(floor, name, gv, cv);
10990 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10992 PL_parser->copline = NOLINE;
10993 LEAVE_SCOPE(floor);
10995 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10997 #ifdef PERL_DEBUG_READONLY_OPS
11001 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11002 pad_add_weakref(cv);
11008 S_clear_special_blocks(pTHX_ const char *const fullname,
11009 GV *const gv, CV *const cv) {
11013 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11015 colon = strrchr(fullname,':');
11016 name = colon ? colon + 1 : fullname;
11018 if ((*name == 'B' && strEQ(name, "BEGIN"))
11019 || (*name == 'E' && strEQ(name, "END"))
11020 || (*name == 'U' && strEQ(name, "UNITCHECK"))
11021 || (*name == 'C' && strEQ(name, "CHECK"))
11022 || (*name == 'I' && strEQ(name, "INIT"))) {
11027 GvCV_set(gv, NULL);
11028 SvREFCNT_dec_NN(MUTABLE_SV(cv));
11032 /* Returns true if the sub has been freed. */
11034 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11038 const char *const colon = strrchr(fullname,':');
11039 const char *const name = colon ? colon + 1 : fullname;
11041 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11043 if (*name == 'B') {
11044 if (strEQ(name, "BEGIN")) {
11045 /* can't goto a declaration, but a null statement is fine */
11046 module_install_hack: ;
11047 const I32 oldscope = PL_scopestack_ix;
11048 SV *max_nest_sv = NULL;
11052 if (floor) LEAVE_SCOPE(floor);
11055 /* Make sure we don't recurse too deeply into BEGIN blocks,
11056 * but let the user control it via the new control variable
11058 * ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}
11060 * Note that this code (when max_nest_iv is 1) *looks* like
11061 * it would block the following code:
11063 * BEGIN { $n |= 1; BEGIN { $n |= 2; BEGIN { $n |= 4 } } }
11065 * but it does *not*; this code will happily execute when
11066 * the nest limit is 1. The reason is revealed in the
11067 * execution order. If we could watch $n in this code, we
11068 * would see the following order of modifications:
11074 * This is because nested BEGIN blocks execute in FILO
11075 * order; this is because BEGIN blocks are defined to
11076 * execute immediately once they are closed. So the
11077 * innermost block is closed first, and it executes, which
11078 * increments the eval_begin_nest_depth by 1, and then it
11079 * finishes, which drops eval_begin_nest_depth back to its
11080 * previous value. This happens in turn as each BEGIN is
11083 * The *only* place these counts matter is when BEGIN is
11084 * inside of some kind of string eval, either a require or a
11085 * true eval. Only in that case would there be any nesting
11086 * and would perl try to execute a BEGIN before another had
11089 * Thus this logic puts an upper limit on module nesting.
11090 * Hence the reason we let the user control it, although it
11091 * is hard to imagine a 1000-level-deep module use
11092 * dependency even in a very large codebase. The real
11093 * objective is to prevent code like this:
11095 * perl -e'sub f { eval "BEGIN { f() }" } f()'
11097 * from segfaulting due to stack exhaustion.
11100 max_nest_sv = get_sv(PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS, GV_ADD);
11101 if (!SvOK(max_nest_sv))
11102 sv_setiv(max_nest_sv, PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT);
11103 max_nest_iv = SvIV(max_nest_sv);
11104 if (max_nest_iv < 0) {
11105 max_nest_iv = PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT;
11106 sv_setiv(max_nest_sv, max_nest_iv);
11109 /* (UV) below is just to silence a compiler warning, and should be
11110 * effectively a no-op, as max_nest_iv will never be negative here.
11112 if (PL_eval_begin_nest_depth >= (UV)max_nest_iv) {
11113 Perl_croak(aTHX_ "Too many nested BEGIN blocks, maximum of %" IVdf " allowed",
11116 SAVEINT(PL_eval_begin_nest_depth);
11117 PL_eval_begin_nest_depth++;
11119 SAVEVPTR(PL_curcop);
11120 if (PL_curcop == &PL_compiling) {
11121 /* Avoid pushing the "global" &PL_compiling onto the
11122 * context stack. For example, a stack trace inside
11123 * nested use's would show all calls coming from whoever
11124 * most recently updated PL_compiling.cop_file and
11125 * cop_line. So instead, temporarily set PL_curcop to a
11126 * private copy of &PL_compiling. PL_curcop will soon be
11127 * set to point back to &PL_compiling anyway but only
11128 * after the temp value has been pushed onto the context
11129 * stack as blk_oldcop.
11130 * This is slightly hacky, but necessary. Note also
11131 * that in the brief window before PL_curcop is set back
11132 * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
11133 * will give the wrong answer.
11135 PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
11136 CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
11137 SAVEFREEOP(PL_curcop);
11140 PUSHSTACKi(PERLSI_REQUIRE);
11141 SAVECOPFILE(&PL_compiling);
11142 SAVECOPLINE(&PL_compiling);
11144 DEBUG_x( dump_sub(gv) );
11145 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11146 GvCV_set(gv,0); /* cv has been hijacked */
11147 call_list(oldscope, PL_beginav);
11151 return !PL_savebegin;
11156 if (*name == 'E') {
11157 if (strEQ(name, "END")) {
11158 DEBUG_x( dump_sub(gv) );
11159 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11162 } else if (*name == 'U') {
11163 if (strEQ(name, "UNITCHECK")) {
11164 /* It's never too late to run a unitcheck block */
11165 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11169 } else if (*name == 'C') {
11170 if (strEQ(name, "CHECK")) {
11172 /* diag_listed_as: Too late to run %s block */
11173 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11174 "Too late to run CHECK block");
11175 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11179 } else if (*name == 'I') {
11180 if (strEQ(name, "INIT")) {
11181 #ifdef MI_INIT_WORKAROUND_PACK
11183 HV *hv = CvSTASH(cv);
11184 STRLEN len = hv ? HvNAMELEN(hv) : 0;
11185 char *pv = (len == sizeof(MI_INIT_WORKAROUND_PACK)-1)
11186 ? HvNAME_get(hv) : NULL;
11187 if ( pv && strEQ(pv, MI_INIT_WORKAROUND_PACK) ) {
11188 /* old versions of Module::Install::DSL contain code
11189 * that creates an INIT in eval, which expects to run
11190 * after an exit(0) in BEGIN. This unfortunately
11191 * breaks a lot of code in the CPAN river. So we magically
11192 * convert INIT blocks from Module::Install::DSL to
11193 * be BEGIN blocks. Which works out, since the INIT
11194 * blocks it creates are eval'ed and so are late.
11196 Perl_warn(aTHX_ "Treating %s::INIT block as BEGIN block as workaround",
11197 MI_INIT_WORKAROUND_PACK);
11198 goto module_install_hack;
11204 /* diag_listed_as: Too late to run %s block */
11205 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11206 "Too late to run INIT block");
11207 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11213 DEBUG_x( dump_sub(gv) );
11215 GvCV_set(gv,0); /* cv has been hijacked */
11221 =for apidoc newCONSTSUB
11223 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11224 rather than of counted length, and no flags are set. (This means that
11225 C<name> is always interpreted as Latin-1.)
11231 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11233 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11237 =for apidoc newCONSTSUB_flags
11239 Construct a constant subroutine, also performing some surrounding
11240 jobs. A scalar constant-valued subroutine is eligible for inlining
11241 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11242 123 }>>. Other kinds of constant subroutine have other treatment.
11244 The subroutine will have an empty prototype and will ignore any arguments
11245 when called. Its constant behaviour is determined by C<sv>. If C<sv>
11246 is null, the subroutine will yield an empty list. If C<sv> points to a
11247 scalar, the subroutine will always yield that scalar. If C<sv> points
11248 to an array, the subroutine will always yield a list of the elements of
11249 that array in list context, or the number of elements in the array in
11250 scalar context. This function takes ownership of one counted reference
11251 to the scalar or array, and will arrange for the object to live as long
11252 as the subroutine does. If C<sv> points to a scalar then the inlining
11253 assumes that the value of the scalar will never change, so the caller
11254 must ensure that the scalar is not subsequently written to. If C<sv>
11255 points to an array then no such assumption is made, so it is ostensibly
11256 safe to mutate the array or its elements, but whether this is really
11257 supported has not been determined.
11259 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11260 Other aspects of the subroutine will be left in their default state.
11261 The caller is free to mutate the subroutine beyond its initial state
11262 after this function has returned.
11264 If C<name> is null then the subroutine will be anonymous, with its
11265 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11266 subroutine will be named accordingly, referenced by the appropriate glob.
11267 C<name> is a string of length C<len> bytes giving a sigilless symbol
11268 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11269 otherwise. The name may be either qualified or unqualified. If the
11270 name is unqualified then it defaults to being in the stash specified by
11271 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11272 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11275 C<flags> should not have bits set other than C<SVf_UTF8>.
11277 If there is already a subroutine of the specified name, then the new sub
11278 will replace the existing one in the glob. A warning may be generated
11279 about the redefinition.
11281 If the subroutine has one of a few special names, such as C<BEGIN> or
11282 C<END>, then it will be claimed by the appropriate queue for automatic
11283 running of phase-related subroutines. In this case the relevant glob will
11284 be left not containing any subroutine, even if it did contain one before.
11285 Execution of the subroutine will likely be a no-op, unless C<sv> was
11286 a tied array or the caller modified the subroutine in some interesting
11287 way before it was executed. In the case of C<BEGIN>, the treatment is
11288 buggy: the sub will be executed when only half built, and may be deleted
11289 prematurely, possibly causing a crash.
11291 The function returns a pointer to the constructed subroutine. If the sub
11292 is anonymous then ownership of one counted reference to the subroutine
11293 is transferred to the caller. If the sub is named then the caller does
11294 not get ownership of a reference. In most such cases, where the sub
11295 has a non-phase name, the sub will be alive at the point it is returned
11296 by virtue of being contained in the glob that names it. A phase-named
11297 subroutine will usually be alive by virtue of the reference owned by
11298 the phase's automatic run queue. A C<BEGIN> subroutine may have been
11299 destroyed already by the time this function returns, but currently bugs
11300 occur in that case before the caller gets control. It is the caller's
11301 responsibility to ensure that it knows which of these situations applies.
11307 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11311 const char *const file = CopFILE(PL_curcop);
11315 if (IN_PERL_RUNTIME) {
11316 /* at runtime, it's not safe to manipulate PL_curcop: it may be
11317 * an op shared between threads. Use a non-shared COP for our
11319 SAVEVPTR(PL_curcop);
11320 SAVECOMPILEWARNINGS();
11321 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11322 PL_curcop = &PL_compiling;
11324 SAVECOPLINE(PL_curcop);
11325 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11328 PL_hints &= ~HINT_BLOCK_SCOPE;
11331 SAVEGENERICSV(PL_curstash);
11332 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11335 /* Protect sv against leakage caused by fatal warnings. */
11336 if (sv) SAVEFREESV(sv);
11338 /* file becomes the CvFILE. For an XS, it's usually static storage,
11339 and so doesn't get free()d. (It's expected to be from the C pre-
11340 processor __FILE__ directive). But we need a dynamically allocated one,
11341 and we need it to get freed. */
11342 cv = newXS_len_flags(name, len,
11343 sv && SvTYPE(sv) == SVt_PVAV
11346 file ? file : "", "",
11347 &sv, XS_DYNAMIC_FILENAME | flags);
11349 assert(SvREFCNT((SV*)cv) != 0);
11350 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11361 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
11362 static storage, as it is used directly as CvFILE(), without a copy being made.
11368 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11370 PERL_ARGS_ASSERT_NEWXS;
11371 return newXS_len_flags(
11372 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11377 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11378 const char *const filename, const char *const proto,
11381 PERL_ARGS_ASSERT_NEWXS_FLAGS;
11382 return newXS_len_flags(
11383 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11388 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11390 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11391 return newXS_len_flags(
11392 name, strlen(name), subaddr, NULL, NULL, NULL, 0
11397 =for apidoc newXS_len_flags
11399 Construct an XS subroutine, also performing some surrounding jobs.
11401 The subroutine will have the entry point C<subaddr>. It will have
11402 the prototype specified by the nul-terminated string C<proto>, or
11403 no prototype if C<proto> is null. The prototype string is copied;
11404 the caller can mutate the supplied string afterwards. If C<filename>
11405 is non-null, it must be a nul-terminated filename, and the subroutine
11406 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
11407 point directly to the supplied string, which must be static. If C<flags>
11408 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11411 Other aspects of the subroutine will be left in their default state.
11412 If anything else needs to be done to the subroutine for it to function
11413 correctly, it is the caller's responsibility to do that after this
11414 function has constructed it. However, beware of the subroutine
11415 potentially being destroyed before this function returns, as described
11418 If C<name> is null then the subroutine will be anonymous, with its
11419 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
11420 subroutine will be named accordingly, referenced by the appropriate glob.
11421 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11422 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11423 The name may be either qualified or unqualified, with the stash defaulting
11424 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
11425 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11426 they have there, such as C<GV_ADDWARN>. The symbol is always added to
11427 the stash if necessary, with C<GV_ADDMULTI> semantics.
11429 If there is already a subroutine of the specified name, then the new sub
11430 will replace the existing one in the glob. A warning may be generated
11431 about the redefinition. If the old subroutine was C<CvCONST> then the
11432 decision about whether to warn is influenced by an expectation about
11433 whether the new subroutine will become a constant of similar value.
11434 That expectation is determined by C<const_svp>. (Note that the call to
11435 this function doesn't make the new subroutine C<CvCONST> in any case;
11436 that is left to the caller.) If C<const_svp> is null then it indicates
11437 that the new subroutine will not become a constant. If C<const_svp>
11438 is non-null then it indicates that the new subroutine will become a
11439 constant, and it points to an C<SV*> that provides the constant value
11440 that the subroutine will have.
11442 If the subroutine has one of a few special names, such as C<BEGIN> or
11443 C<END>, then it will be claimed by the appropriate queue for automatic
11444 running of phase-related subroutines. In this case the relevant glob will
11445 be left not containing any subroutine, even if it did contain one before.
11446 In the case of C<BEGIN>, the subroutine will be executed and the reference
11447 to it disposed of before this function returns, and also before its
11448 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
11449 constructed by this function to be ready for execution then the caller
11450 must prevent this happening by giving the subroutine a different name.
11452 The function returns a pointer to the constructed subroutine. If the sub
11453 is anonymous then ownership of one counted reference to the subroutine
11454 is transferred to the caller. If the sub is named then the caller does
11455 not get ownership of a reference. In most such cases, where the sub
11456 has a non-phase name, the sub will be alive at the point it is returned
11457 by virtue of being contained in the glob that names it. A phase-named
11458 subroutine will usually be alive by virtue of the reference owned by the
11459 phase's automatic run queue. But a C<BEGIN> subroutine, having already
11460 been executed, will quite likely have been destroyed already by the
11461 time this function returns, making it erroneous for the caller to make
11462 any use of the returned pointer. It is the caller's responsibility to
11463 ensure that it knows which of these situations applies.
11469 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11470 XSUBADDR_t subaddr, const char *const filename,
11471 const char *const proto, SV **const_svp,
11475 bool interleave = FALSE;
11476 bool evanescent = FALSE;
11478 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11481 GV * const gv = gv_fetchpvn(
11482 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11483 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11484 sizeof("__ANON__::__ANON__") - 1,
11485 GV_ADDMULTI | flags, SVt_PVCV);
11487 if ((cv = (name ? GvCV(gv) : NULL))) {
11489 /* just a cached method */
11493 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11494 /* already defined (or promised) */
11495 /* Redundant check that allows us to avoid creating an SV
11496 most of the time: */
11497 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11498 report_redefined_cv(newSVpvn_flags(
11499 name,len,(flags&SVf_UTF8)|SVs_TEMP
11510 if (cv) /* must reuse cv if autoloaded */
11513 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11517 if (HvENAME_HEK(GvSTASH(gv)))
11518 gv_method_changed(gv); /* newXS */
11522 assert(SvREFCNT((SV*)cv) != 0);
11526 /* XSUBs can't be perl lang/perl5db.pl debugged
11527 if (PERLDB_LINE_OR_SAVESRC)
11528 (void)gv_fetchfile(filename); */
11529 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11530 if (flags & XS_DYNAMIC_FILENAME) {
11532 CvFILE(cv) = savepv(filename);
11534 /* NOTE: not copied, as it is expected to be an external constant string */
11535 CvFILE(cv) = (char *)filename;
11538 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11539 CvFILE(cv) = (char*)PL_xsubfilename;
11542 CvXSUB(cv) = subaddr;
11543 #ifndef MULTIPLICITY
11544 CvHSCXT(cv) = &PL_stack_sp;
11550 evanescent = process_special_blocks(0, name, gv, cv);
11553 } /* <- not a conditional branch */
11556 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11558 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11559 if (interleave) LEAVE;
11560 assert(evanescent || SvREFCNT((SV*)cv) != 0);
11564 /* Add a stub CV to a typeglob.
11565 * This is the implementation of a forward declaration, 'sub foo';'
11569 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11571 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11573 PERL_ARGS_ASSERT_NEWSTUB;
11574 assert(!GvCVu(gv));
11577 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11578 gv_method_changed(gv);
11580 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11584 CvGV_set(cv, cvgv);
11585 CvFILE_set_from_cop(cv, PL_curcop);
11586 CvSTASH_set(cv, PL_curstash);
11592 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11599 if (PL_parser && PL_parser->error_count) {
11605 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11606 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11609 if ((cv = GvFORM(gv))) {
11610 if (ckWARN(WARN_REDEFINE)) {
11611 const line_t oldline = CopLINE(PL_curcop);
11612 if (PL_parser && PL_parser->copline != NOLINE)
11613 CopLINE_set(PL_curcop, PL_parser->copline);
11615 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11616 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11618 /* diag_listed_as: Format %s redefined */
11619 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11620 "Format STDOUT redefined");
11622 CopLINE_set(PL_curcop, oldline);
11627 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11629 CvFILE_set_from_cop(cv, PL_curcop);
11632 root = newUNOP(OP_LEAVEWRITE, 0, voidnonfinal(block));
11634 start = LINKLIST(root);
11636 S_process_optree(aTHX_ cv, root, start);
11637 cv_forget_slab(cv);
11642 PL_parser->copline = NOLINE;
11643 LEAVE_SCOPE(floor);
11644 PL_compiling.cop_seq = 0;
11648 Perl_newANONLIST(pTHX_ OP *o)
11650 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
11654 Perl_newANONHASH(pTHX_ OP *o)
11656 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
11660 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11662 return newANONATTRSUB(floor, proto, NULL, block);
11666 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11668 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11670 bool is_const = CvANONCONST(cv);
11673 newSVOP(OP_ANONCODE, is_const ? 0 : OPf_REF,
11677 anoncode = newUNOP(OP_ANONCONST, OPf_REF,
11678 op_convert_list(OP_ENTERSUB,
11679 OPf_STACKED|OPf_WANT_SCALAR,
11687 Perl_oopsAV(pTHX_ OP *o)
11690 PERL_ARGS_ASSERT_OOPSAV;
11692 switch (o->op_type) {
11695 OpTYPE_set(o, OP_PADAV);
11696 return ref(o, OP_RV2AV);
11700 OpTYPE_set(o, OP_RV2AV);
11705 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11712 Perl_oopsHV(pTHX_ OP *o)
11715 PERL_ARGS_ASSERT_OOPSHV;
11717 switch (o->op_type) {
11720 OpTYPE_set(o, OP_PADHV);
11721 return ref(o, OP_RV2HV);
11725 OpTYPE_set(o, OP_RV2HV);
11726 /* rv2hv steals the bottom bit for its own uses */
11727 o->op_private &= ~OPpARG1_MASK;
11732 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11739 Perl_newAVREF(pTHX_ OP *o)
11742 PERL_ARGS_ASSERT_NEWAVREF;
11744 if (o->op_type == OP_PADANY) {
11745 OpTYPE_set(o, OP_PADAV);
11748 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11749 Perl_croak(aTHX_ "Can't use an array as a reference");
11751 return newUNOP(OP_RV2AV, 0, scalar(o));
11755 Perl_newGVREF(pTHX_ I32 type, OP *o)
11757 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11758 return newUNOP(OP_NULL, 0, o);
11760 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED &&
11761 ((PL_opargs[type] >> OASHIFT) & 7) == OA_FILEREF &&
11762 o->op_type == OP_CONST && (o->op_private & OPpCONST_BARE)) {
11763 no_bareword_filehandle(SvPVX(cSVOPo_sv));
11766 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11770 Perl_newHVREF(pTHX_ OP *o)
11773 PERL_ARGS_ASSERT_NEWHVREF;
11775 if (o->op_type == OP_PADANY) {
11776 OpTYPE_set(o, OP_PADHV);
11779 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11780 Perl_croak(aTHX_ "Can't use a hash as a reference");
11782 return newUNOP(OP_RV2HV, 0, scalar(o));
11786 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11788 if (o->op_type == OP_PADANY) {
11789 OpTYPE_set(o, OP_PADCV);
11791 return newUNOP(OP_RV2CV, flags, scalar(o));
11795 Perl_newSVREF(pTHX_ OP *o)
11798 PERL_ARGS_ASSERT_NEWSVREF;
11800 if (o->op_type == OP_PADANY) {
11801 OpTYPE_set(o, OP_PADSV);
11805 return newUNOP(OP_RV2SV, 0, scalar(o));
11808 /* Check routines. See the comments at the top of this file for details
11809 * on when these are called */
11812 Perl_ck_anoncode(pTHX_ OP *o)
11814 PERL_ARGS_ASSERT_CK_ANONCODE;
11816 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11817 cSVOPo->op_sv = NULL;
11822 S_io_hints(pTHX_ OP *o)
11824 #if O_BINARY != 0 || O_TEXT != 0
11826 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11828 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11831 const char *d = SvPV_const(*svp, len);
11832 const I32 mode = mode_from_discipline(d, len);
11833 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11835 if (mode & O_BINARY)
11836 o->op_private |= OPpOPEN_IN_RAW;
11840 o->op_private |= OPpOPEN_IN_CRLF;
11844 svp = hv_fetchs(table, "open_OUT", FALSE);
11847 const char *d = SvPV_const(*svp, len);
11848 const I32 mode = mode_from_discipline(d, len);
11849 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11851 if (mode & O_BINARY)
11852 o->op_private |= OPpOPEN_OUT_RAW;
11856 o->op_private |= OPpOPEN_OUT_CRLF;
11861 PERL_UNUSED_CONTEXT;
11862 PERL_UNUSED_ARG(o);
11867 Perl_ck_backtick(pTHX_ OP *o)
11872 PERL_ARGS_ASSERT_CK_BACKTICK;
11874 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11875 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11876 && (gv = gv_override("readpipe",8)))
11878 /* detach rest of siblings from o and its first child */
11879 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11880 newop = S_new_entersubop(aTHX_ gv, sibl);
11882 else if (!(o->op_flags & OPf_KIDS))
11883 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11888 S_io_hints(aTHX_ o);
11893 Perl_ck_bitop(pTHX_ OP *o)
11895 PERL_ARGS_ASSERT_CK_BITOP;
11897 /* get rid of arg count and indicate if in the scope of 'use integer' */
11898 o->op_private = (PL_hints & HINT_INTEGER) ? OPpUSEINT : 0;
11900 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11901 && OP_IS_INFIX_BIT(o->op_type))
11903 const OP * const left = cBINOPo->op_first;
11904 const OP * const right = OpSIBLING(left);
11905 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11906 (left->op_flags & OPf_PARENS) == 0) ||
11907 (OP_IS_NUMCOMPARE(right->op_type) &&
11908 (right->op_flags & OPf_PARENS) == 0))
11909 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11910 "Possible precedence problem on bitwise %s operator",
11911 o->op_type == OP_BIT_OR
11912 ||o->op_type == OP_NBIT_OR ? "|"
11913 : o->op_type == OP_BIT_AND
11914 ||o->op_type == OP_NBIT_AND ? "&"
11915 : o->op_type == OP_BIT_XOR
11916 ||o->op_type == OP_NBIT_XOR ? "^"
11917 : o->op_type == OP_SBIT_OR ? "|."
11918 : o->op_type == OP_SBIT_AND ? "&." : "^."
11924 PERL_STATIC_INLINE bool
11925 is_dollar_bracket(pTHX_ const OP * const o)
11928 PERL_UNUSED_CONTEXT;
11929 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11930 && (kid = cUNOPx(o)->op_first)
11931 && kid->op_type == OP_GV
11932 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11935 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11938 Perl_ck_cmp(pTHX_ OP *o)
11944 OP *indexop, *constop, *start;
11948 PERL_ARGS_ASSERT_CK_CMP;
11950 is_eq = ( o->op_type == OP_EQ
11951 || o->op_type == OP_NE
11952 || o->op_type == OP_I_EQ
11953 || o->op_type == OP_I_NE);
11955 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11956 const OP *kid = cUNOPo->op_first;
11959 ( is_dollar_bracket(aTHX_ kid)
11960 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11962 || ( kid->op_type == OP_CONST
11963 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11967 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11968 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11971 /* convert (index(...) == -1) and variations into
11972 * (r)index/BOOL(,NEG)
11977 indexop = cUNOPo->op_first;
11978 constop = OpSIBLING(indexop);
11980 if (indexop->op_type == OP_CONST) {
11982 indexop = OpSIBLING(constop);
11987 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11990 /* ($lex = index(....)) == -1 */
11991 if (indexop->op_private & OPpTARGET_MY)
11994 if (constop->op_type != OP_CONST)
11997 sv = cSVOPx_sv(constop);
11998 if (!(sv && SvIOK_notUV(sv)))
12002 if (iv != -1 && iv != 0)
12006 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12007 if (!(iv0 ^ reverse))
12011 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12016 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12017 if (!(iv0 ^ reverse))
12021 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12026 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12032 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12038 indexop->op_flags &= ~OPf_PARENS;
12039 indexop->op_flags |= (o->op_flags & OPf_PARENS);
12040 indexop->op_private |= OPpTRUEBOOL;
12042 indexop->op_private |= OPpINDEX_BOOLNEG;
12043 /* cut out the index op and free the eq,const ops */
12044 (void)op_sibling_splice(o, start, 1, NULL);
12052 Perl_ck_concat(pTHX_ OP *o)
12054 const OP * const kid = cUNOPo->op_first;
12056 PERL_ARGS_ASSERT_CK_CONCAT;
12057 PERL_UNUSED_CONTEXT;
12059 /* reuse the padtmp returned by the concat child */
12060 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12061 !(kUNOP->op_first->op_flags & OPf_MOD))
12063 o->op_flags |= OPf_STACKED;
12064 o->op_private |= OPpCONCAT_NESTED;
12070 Perl_ck_spair(pTHX_ OP *o)
12073 PERL_ARGS_ASSERT_CK_SPAIR;
12075 if (o->op_flags & OPf_KIDS) {
12079 const OPCODE type = o->op_type;
12080 o = modkids(ck_fun(o), type);
12081 kid = cUNOPo->op_first;
12082 kidkid = kUNOP->op_first;
12083 newop = OpSIBLING(kidkid);
12085 const OPCODE type = newop->op_type;
12086 if (OpHAS_SIBLING(newop))
12088 if (o->op_type == OP_REFGEN
12089 && ( type == OP_RV2CV
12090 || ( !(newop->op_flags & OPf_PARENS)
12091 && ( type == OP_RV2AV || type == OP_PADAV
12092 || type == OP_RV2HV || type == OP_PADHV))))
12093 NOOP; /* OK (allow srefgen for \@a and \%h) */
12094 else if (OP_GIMME(newop,0) != G_SCALAR)
12097 /* excise first sibling */
12098 op_sibling_splice(kid, NULL, 1, NULL);
12101 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12102 * and OP_CHOMP into OP_SCHOMP */
12103 o->op_ppaddr = PL_ppaddr[++o->op_type];
12108 Perl_ck_delete(pTHX_ OP *o)
12110 PERL_ARGS_ASSERT_CK_DELETE;
12114 if (o->op_flags & OPf_KIDS) {
12115 OP * const kid = cUNOPo->op_first;
12116 switch (kid->op_type) {
12118 o->op_flags |= OPf_SPECIAL;
12121 o->op_private |= OPpSLICE;
12124 o->op_flags |= OPf_SPECIAL;
12129 o->op_flags |= OPf_SPECIAL;
12132 o->op_private |= OPpKVSLICE;
12135 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12136 "element or slice");
12138 if (kid->op_private & OPpLVAL_INTRO)
12139 o->op_private |= OPpLVAL_INTRO;
12146 Perl_ck_eof(pTHX_ OP *o)
12148 PERL_ARGS_ASSERT_CK_EOF;
12150 if (o->op_flags & OPf_KIDS) {
12152 if (cLISTOPo->op_first->op_type == OP_STUB) {
12154 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12159 kid = cLISTOPo->op_first;
12160 if (kid->op_type == OP_RV2GV)
12161 kid->op_private |= OPpALLOW_FAKE;
12168 Perl_ck_eval(pTHX_ OP *o)
12171 PERL_ARGS_ASSERT_CK_EVAL;
12173 PL_hints |= HINT_BLOCK_SCOPE;
12174 if (o->op_flags & OPf_KIDS) {
12175 SVOP * const kid = cSVOPx(cUNOPo->op_first);
12178 if (o->op_type == OP_ENTERTRY) {
12181 /* cut whole sibling chain free from o */
12182 op_sibling_splice(o, NULL, -1, NULL);
12185 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12187 /* establish postfix order */
12188 enter->op_next = (OP*)enter;
12190 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12191 OpTYPE_set(o, OP_LEAVETRY);
12192 enter->op_other = o;
12197 S_set_haseval(aTHX);
12201 const U8 priv = o->op_private;
12203 /* the newUNOP will recursively call ck_eval(), which will handle
12204 * all the stuff at the end of this function, like adding
12207 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12209 o->op_targ = (PADOFFSET)PL_hints;
12210 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12211 if ((PL_hints & HINT_LOCALIZE_HH) != 0
12212 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12213 /* Store a copy of %^H that pp_entereval can pick up. */
12214 HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12216 STOREFEATUREBITSHH(hh);
12217 hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12218 /* append hhop to only child */
12219 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12221 o->op_private |= OPpEVAL_HAS_HH;
12223 if (!(o->op_private & OPpEVAL_BYTES)
12224 && FEATURE_UNIEVAL_IS_ENABLED)
12225 o->op_private |= OPpEVAL_UNICODE;
12230 Perl_ck_trycatch(pTHX_ OP *o)
12233 OP *to_free = NULL;
12234 OP *trykid, *catchkid;
12235 OP *catchroot, *catchstart;
12237 PERL_ARGS_ASSERT_CK_TRYCATCH;
12239 trykid = cUNOPo->op_first;
12240 if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
12242 trykid = OpSIBLING(trykid);
12244 catchkid = OpSIBLING(trykid);
12246 assert(trykid->op_type == OP_POPTRY);
12247 assert(catchkid->op_type == OP_CATCH);
12249 /* cut whole sibling chain free from o */
12250 op_sibling_splice(o, NULL, -1, NULL);
12255 enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
12257 /* establish postfix order */
12258 enter->op_next = (OP*)enter;
12260 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
12261 op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
12263 OpTYPE_set(o, OP_LEAVETRYCATCH);
12265 /* The returned optree is actually threaded up slightly nonobviously in
12266 * terms of its ->op_next pointers.
12268 * This way, if the tryblock dies, its retop points at the OP_CATCH, but
12269 * if it does not then its leavetry skips over that and continues
12270 * execution past it.
12273 /* First, link up the actual body of the catch block */
12274 catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
12275 catchstart = LINKLIST(catchroot);
12276 cLOGOPx(catchkid)->op_other = catchstart;
12278 o->op_next = LINKLIST(o);
12280 /* die within try block should jump to the catch */
12281 enter->op_other = catchkid;
12283 /* after try block that doesn't die, just skip straight to leavetrycatch */
12284 trykid->op_next = o;
12286 /* after catch block, skip back up to the leavetrycatch */
12287 catchroot->op_next = o;
12293 Perl_ck_exec(pTHX_ OP *o)
12295 PERL_ARGS_ASSERT_CK_EXEC;
12297 if (o->op_flags & OPf_STACKED) {
12300 kid = OpSIBLING(cUNOPo->op_first);
12301 if (kid->op_type == OP_RV2GV)
12310 Perl_ck_exists(pTHX_ OP *o)
12312 PERL_ARGS_ASSERT_CK_EXISTS;
12315 if (o->op_flags & OPf_KIDS) {
12316 OP * const kid = cUNOPo->op_first;
12317 if (kid->op_type == OP_ENTERSUB) {
12318 (void) ref(kid, o->op_type);
12319 if (kid->op_type != OP_RV2CV
12320 && !(PL_parser && PL_parser->error_count))
12322 "exists argument is not a subroutine name");
12323 o->op_private |= OPpEXISTS_SUB;
12325 else if (kid->op_type == OP_AELEM)
12326 o->op_flags |= OPf_SPECIAL;
12327 else if (kid->op_type != OP_HELEM)
12328 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12329 "element or a subroutine");
12336 Perl_ck_helemexistsor(pTHX_ OP *o)
12338 PERL_ARGS_ASSERT_CK_HELEMEXISTSOR;
12343 if(!(o->op_flags & OPf_KIDS) ||
12344 !(first = cLOGOPo->op_first) ||
12345 first->op_type != OP_HELEM)
12346 /* As this opcode isn't currently exposed to pure-perl, only core or XS
12347 * authors are ever going to see this message. We don't need to list it
12348 * in perldiag as to do so would require documenting OP_HELEMEXISTSOR
12351 /* diag_listed_as: SKIPME */
12352 croak("OP_HELEMEXISTSOR argument is not a HASH element");
12354 OP *hvop = cBINOPx(first)->op_first;
12355 OP *keyop = OpSIBLING(hvop);
12356 assert(!OpSIBLING(keyop));
12358 op_null(first); // null out the OP_HELEM
12360 keyop->op_next = o;
12366 Perl_ck_rvconst(pTHX_ OP *o)
12368 SVOP * const kid = cSVOPx(cUNOPo->op_first);
12370 PERL_ARGS_ASSERT_CK_RVCONST;
12372 if (o->op_type == OP_RV2HV)
12373 /* rv2hv steals the bottom bit for its own uses */
12374 o->op_private &= ~OPpARG1_MASK;
12376 o->op_private |= (PL_hints & HINT_STRICT_REFS);
12378 if (kid->op_type == OP_CONST) {
12381 SV * const kidsv = kid->op_sv;
12383 /* Is it a constant from cv_const_sv()? */
12384 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12387 if (SvTYPE(kidsv) == SVt_PVAV) return o;
12388 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12389 const char *badthing;
12390 switch (o->op_type) {
12392 badthing = "a SCALAR";
12395 badthing = "an ARRAY";
12398 badthing = "a HASH";
12406 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12407 SVfARG(kidsv), badthing);
12410 * This is a little tricky. We only want to add the symbol if we
12411 * didn't add it in the lexer. Otherwise we get duplicate strict
12412 * warnings. But if we didn't add it in the lexer, we must at
12413 * least pretend like we wanted to add it even if it existed before,
12414 * or we get possible typo warnings. OPpCONST_ENTERED says
12415 * whether the lexer already added THIS instance of this symbol.
12417 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12418 gv = gv_fetchsv(kidsv,
12419 o->op_type == OP_RV2CV
12420 && o->op_private & OPpMAY_RETURN_CONSTANT
12422 : iscv | !(kid->op_private & OPpCONST_ENTERED),
12425 : o->op_type == OP_RV2SV
12427 : o->op_type == OP_RV2AV
12429 : o->op_type == OP_RV2HV
12436 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12437 && SvTYPE(SvRV(gv)) != SVt_PVCV)
12438 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12440 OpTYPE_set(kid, OP_GV);
12441 SvREFCNT_dec(kid->op_sv);
12442 #ifdef USE_ITHREADS
12443 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12444 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12445 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12446 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12447 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12449 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12451 kid->op_private = 0;
12452 /* FAKE globs in the symbol table cause weird bugs (#77810) */
12460 Perl_ck_ftst(pTHX_ OP *o)
12462 const I32 type = o->op_type;
12464 PERL_ARGS_ASSERT_CK_FTST;
12466 if (o->op_flags & OPf_REF) {
12469 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12470 SVOP * const kid = cSVOPx(cUNOPo->op_first);
12471 const OPCODE kidtype = kid->op_type;
12473 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12474 && !kid->op_folded) {
12475 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12476 no_bareword_filehandle(SvPVX(kSVOP_sv));
12478 OP * const newop = newGVOP(type, OPf_REF,
12479 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12484 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12485 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12487 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12488 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12489 array_passed_to_stat, name);
12492 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12493 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12496 scalar((OP *) kid);
12497 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12498 o->op_private |= OPpFT_ACCESS;
12499 if (OP_IS_FILETEST(type)
12500 && OP_IS_FILETEST(kidtype)
12502 o->op_private |= OPpFT_STACKED;
12503 kid->op_private |= OPpFT_STACKING;
12504 if (kidtype == OP_FTTTY && (
12505 !(kid->op_private & OPpFT_STACKED)
12506 || kid->op_private & OPpFT_AFTER_t
12508 o->op_private |= OPpFT_AFTER_t;
12513 if (type == OP_FTTTY)
12514 o = newGVOP(type, OPf_REF, PL_stdingv);
12516 o = newUNOP(type, 0, newDEFSVOP());
12522 Perl_ck_fun(pTHX_ OP *o)
12524 const int type = o->op_type;
12525 I32 oa = PL_opargs[type] >> OASHIFT;
12527 PERL_ARGS_ASSERT_CK_FUN;
12529 if (o->op_flags & OPf_STACKED) {
12530 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12531 oa &= ~OA_OPTIONAL;
12533 return no_fh_allowed(o);
12536 if (o->op_flags & OPf_KIDS) {
12537 OP *prev_kid = NULL;
12538 OP *kid = cLISTOPo->op_first;
12540 bool seen_optional = FALSE;
12542 if (kid->op_type == OP_PUSHMARK ||
12543 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12546 kid = OpSIBLING(kid);
12548 if (kid && kid->op_type == OP_COREARGS) {
12549 bool optional = FALSE;
12552 if (oa & OA_OPTIONAL) optional = TRUE;
12555 if (optional) o->op_private |= numargs;
12560 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12561 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12562 kid = newDEFSVOP();
12563 /* append kid to chain */
12564 op_sibling_splice(o, prev_kid, 0, kid);
12566 seen_optional = TRUE;
12573 /* list seen where single (scalar) arg expected? */
12574 if (numargs == 1 && !(oa >> 4)
12575 && kid->op_type == OP_LIST && type != OP_SCALAR)
12577 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12579 if (type != OP_DELETE) scalar(kid);
12590 if ((type == OP_PUSH || type == OP_UNSHIFT)
12591 && !OpHAS_SIBLING(kid))
12592 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12593 "Useless use of %s with no values",
12596 if (kid->op_type == OP_CONST
12597 && ( !SvROK(cSVOPx_sv(kid))
12598 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
12600 bad_type_pv(numargs, "array", o, kid);
12601 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12602 || kid->op_type == OP_RV2GV) {
12603 bad_type_pv(1, "array", o, kid);
12605 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12606 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12607 PL_op_desc[type]), 0);
12610 op_lvalue(kid, type);
12614 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12615 bad_type_pv(numargs, "hash", o, kid);
12616 op_lvalue(kid, type);
12620 /* replace kid with newop in chain */
12622 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12623 newop->op_next = newop;
12628 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12629 if (kid->op_type == OP_CONST &&
12630 (kid->op_private & OPpCONST_BARE))
12632 OP * const newop = newGVOP(OP_GV, 0,
12633 gv_fetchsv(kSVOP->op_sv, GV_ADD, SVt_PVIO));
12634 /* a first argument is handled by toke.c, ideally we'd
12635 just check here but several ops don't use ck_fun() */
12636 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12637 no_bareword_filehandle(SvPVX(kSVOP_sv));
12639 /* replace kid with newop in chain */
12640 op_sibling_splice(o, prev_kid, 1, newop);
12644 else if (kid->op_type == OP_READLINE) {
12645 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12646 bad_type_pv(numargs, "HANDLE", o, kid);
12649 I32 flags = OPf_SPECIAL;
12651 PADOFFSET targ = 0;
12653 /* is this op a FH constructor? */
12654 if (is_handle_constructor(o,numargs)) {
12655 const char *name = NULL;
12658 bool want_dollar = TRUE;
12661 /* Set a flag to tell rv2gv to vivify
12662 * need to "prove" flag does not mean something
12663 * else already - NI-S 1999/05/07
12666 if (kid->op_type == OP_PADSV) {
12668 = PAD_COMPNAME_SV(kid->op_targ);
12669 name = PadnamePV (pn);
12670 len = PadnameLEN(pn);
12671 name_utf8 = PadnameUTF8(pn);
12673 else if (kid->op_type == OP_RV2SV
12674 && kUNOP->op_first->op_type == OP_GV)
12676 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12678 len = GvNAMELEN(gv);
12679 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12681 else if (kid->op_type == OP_AELEM
12682 || kid->op_type == OP_HELEM)
12685 OP *op = kBINOP->op_first;
12689 const char * const a =
12690 kid->op_type == OP_AELEM ?
12692 if (((op->op_type == OP_RV2AV) ||
12693 (op->op_type == OP_RV2HV)) &&
12694 (firstop = cUNOPx(op)->op_first) &&
12695 (firstop->op_type == OP_GV)) {
12696 /* packagevar $a[] or $h{} */
12697 GV * const gv = cGVOPx_gv(firstop);
12700 Perl_newSVpvf(aTHX_
12705 else if (op->op_type == OP_PADAV
12706 || op->op_type == OP_PADHV) {
12707 /* lexicalvar $a[] or $h{} */
12708 const char * const padname =
12709 PAD_COMPNAME_PV(op->op_targ);
12712 Perl_newSVpvf(aTHX_
12718 name = SvPV_const(tmpstr, len);
12719 name_utf8 = SvUTF8(tmpstr);
12720 sv_2mortal(tmpstr);
12724 name = "__ANONIO__";
12726 want_dollar = FALSE;
12728 op_lvalue(kid, type);
12732 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12733 namesv = PAD_SVl(targ);
12734 if (want_dollar && *name != '$')
12735 sv_setpvs(namesv, "$");
12738 sv_catpvn(namesv, name, len);
12739 if ( name_utf8 ) SvUTF8_on(namesv);
12743 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12745 kid->op_targ = targ;
12746 kid->op_private |= priv;
12752 if ((type == OP_UNDEF || type == OP_POS)
12753 && numargs == 1 && !(oa >> 4)
12754 && kid->op_type == OP_LIST)
12755 return too_many_arguments_pv(o,PL_op_desc[type], 0);
12756 op_lvalue(scalar(kid), type);
12761 kid = OpSIBLING(kid);
12763 /* FIXME - should the numargs or-ing move after the too many
12764 * arguments check? */
12765 o->op_private |= numargs;
12767 return too_many_arguments_pv(o,OP_DESC(o), 0);
12770 else if (PL_opargs[type] & OA_DEFGV) {
12771 /* Ordering of these two is important to keep f_map.t passing. */
12773 return newUNOP(type, 0, newDEFSVOP());
12777 while (oa & OA_OPTIONAL)
12779 if (oa && oa != OA_LIST)
12780 return too_few_arguments_pv(o,OP_DESC(o), 0);
12786 Perl_ck_glob(pTHX_ OP *o)
12790 PERL_ARGS_ASSERT_CK_GLOB;
12793 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12794 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12796 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12800 * \ null - const(wildcard)
12805 * \ mark - glob - rv2cv
12806 * | \ gv(CORE::GLOBAL::glob)
12808 * \ null - const(wildcard)
12810 o->op_flags |= OPf_SPECIAL;
12811 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12812 o = S_new_entersubop(aTHX_ gv, o);
12813 o = newUNOP(OP_NULL, 0, o);
12814 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12817 else o->op_flags &= ~OPf_SPECIAL;
12818 #if !defined(PERL_EXTERNAL_GLOB)
12819 if (!PL_globhook) {
12821 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12822 newSVpvs("File::Glob"), NULL, NULL, NULL);
12825 #endif /* !PERL_EXTERNAL_GLOB */
12826 gv = (GV *)newSV_type(SVt_NULL);
12827 gv_init(gv, 0, "", 0, 0);
12829 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12830 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12836 Perl_ck_grep(pTHX_ OP *o)
12840 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12842 PERL_ARGS_ASSERT_CK_GREP;
12844 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12846 if (o->op_flags & OPf_STACKED) {
12847 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12848 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12849 return no_fh_allowed(o);
12850 o->op_flags &= ~OPf_STACKED;
12852 kid = OpSIBLING(cLISTOPo->op_first);
12853 if (type == OP_MAPWHILE)
12858 if (PL_parser && PL_parser->error_count)
12860 kid = OpSIBLING(cLISTOPo->op_first);
12861 if (kid->op_type != OP_NULL)
12862 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12863 kid = kUNOP->op_first;
12865 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12866 kid->op_next = (OP*)gwop;
12867 o->op_private = gwop->op_private = 0;
12868 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12870 kid = OpSIBLING(cLISTOPo->op_first);
12871 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12872 op_lvalue(kid, OP_GREPSTART);
12878 Perl_ck_index(pTHX_ OP *o)
12880 PERL_ARGS_ASSERT_CK_INDEX;
12882 if (o->op_flags & OPf_KIDS) {
12883 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12885 kid = OpSIBLING(kid); /* get past "big" */
12886 if (kid && kid->op_type == OP_CONST) {
12887 const bool save_taint = TAINT_get;
12888 SV *sv = kSVOP->op_sv;
12889 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12890 && SvOK(sv) && !SvROK(sv))
12892 sv = newSV_type(SVt_NULL);
12893 sv_copypv(sv, kSVOP->op_sv);
12894 SvREFCNT_dec_NN(kSVOP->op_sv);
12897 if (SvOK(sv)) fbm_compile(sv, 0);
12898 TAINT_set(save_taint);
12899 #ifdef NO_TAINT_SUPPORT
12900 PERL_UNUSED_VAR(save_taint);
12908 Perl_ck_lfun(pTHX_ OP *o)
12910 const OPCODE type = o->op_type;
12912 PERL_ARGS_ASSERT_CK_LFUN;
12914 return modkids(ck_fun(o), type);
12918 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12920 PERL_ARGS_ASSERT_CK_DEFINED;
12922 if ((o->op_flags & OPf_KIDS)) {
12923 switch (cUNOPo->op_first->op_type) {
12926 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12927 " (Maybe you should just omit the defined()?)");
12928 NOT_REACHED; /* NOTREACHED */
12932 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12933 " (Maybe you should just omit the defined()?)");
12934 NOT_REACHED; /* NOTREACHED */
12945 Perl_ck_readline(pTHX_ OP *o)
12947 PERL_ARGS_ASSERT_CK_READLINE;
12949 if (o->op_flags & OPf_KIDS) {
12950 OP *kid = cLISTOPo->op_first;
12951 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED
12952 && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
12953 no_bareword_filehandle(SvPVX(kSVOP_sv));
12955 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12960 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12968 Perl_ck_rfun(pTHX_ OP *o)
12970 const OPCODE type = o->op_type;
12972 PERL_ARGS_ASSERT_CK_RFUN;
12974 return refkids(ck_fun(o), type);
12978 Perl_ck_listiob(pTHX_ OP *o)
12982 PERL_ARGS_ASSERT_CK_LISTIOB;
12984 kid = cLISTOPo->op_first;
12986 o = op_force_list(o);
12987 kid = cLISTOPo->op_first;
12989 if (kid->op_type == OP_PUSHMARK)
12990 kid = OpSIBLING(kid);
12991 if (kid && o->op_flags & OPf_STACKED)
12992 kid = OpSIBLING(kid);
12993 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12994 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12995 && !kid->op_folded) {
12996 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12997 no_bareword_filehandle(SvPVX(kSVOP_sv));
12999 o->op_flags |= OPf_STACKED; /* make it a filehandle */
13001 /* replace old const op with new OP_RV2GV parent */
13002 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13003 OP_RV2GV, OPf_REF);
13004 kid = OpSIBLING(kid);
13009 op_append_elem(o->op_type, o, newDEFSVOP());
13011 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13012 return listkids(o);
13016 Perl_ck_smartmatch(pTHX_ OP *o)
13018 PERL_ARGS_ASSERT_CK_SMARTMATCH;
13019 if (0 == (o->op_flags & OPf_SPECIAL)) {
13020 OP *first = cBINOPo->op_first;
13021 OP *second = OpSIBLING(first);
13023 /* Implicitly take a reference to an array or hash */
13025 /* remove the original two siblings, then add back the
13026 * (possibly different) first and second sibs.
13028 op_sibling_splice(o, NULL, 1, NULL);
13029 op_sibling_splice(o, NULL, 1, NULL);
13030 first = ref_array_or_hash(first);
13031 second = ref_array_or_hash(second);
13032 op_sibling_splice(o, NULL, 0, second);
13033 op_sibling_splice(o, NULL, 0, first);
13035 /* Implicitly take a reference to a regular expression */
13036 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13037 OpTYPE_set(first, OP_QR);
13039 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13040 OpTYPE_set(second, OP_QR);
13049 S_maybe_targlex(pTHX_ OP *o)
13051 OP * const kid = cLISTOPo->op_first;
13052 /* has a disposable target? */
13053 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13054 && !(kid->op_flags & OPf_STACKED)
13055 /* Cannot steal the second time! */
13056 && !(kid->op_private & OPpTARGET_MY)
13059 OP * const kkid = OpSIBLING(kid);
13061 /* Can just relocate the target. */
13062 if (kkid && kkid->op_type == OP_PADSV
13063 && (!(kkid->op_private & OPpLVAL_INTRO)
13064 || kkid->op_private & OPpPAD_STATE))
13066 kid->op_targ = kkid->op_targ;
13068 /* Now we do not need PADSV and SASSIGN.
13069 * Detach kid and free the rest. */
13070 op_sibling_splice(o, NULL, 1, NULL);
13072 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
13080 Perl_ck_sassign(pTHX_ OP *o)
13082 OP * const kid = cBINOPo->op_first;
13084 PERL_ARGS_ASSERT_CK_SASSIGN;
13086 if (OpHAS_SIBLING(kid)) {
13087 OP *kkid = OpSIBLING(kid);
13088 /* For state variable assignment with attributes, kkid is a list op
13089 whose op_last is a padsv. */
13090 if ((kkid->op_type == OP_PADSV ||
13091 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13092 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13095 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13096 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13097 return S_newONCEOP(aTHX_ o, kkid);
13100 return S_maybe_targlex(aTHX_ o);
13105 Perl_ck_match(pTHX_ OP *o)
13107 PERL_UNUSED_CONTEXT;
13108 PERL_ARGS_ASSERT_CK_MATCH;
13114 Perl_ck_method(pTHX_ OP *o)
13116 SV *sv, *methsv, *rclass;
13117 const char* method;
13120 STRLEN len, nsplit = 0, i;
13122 OP * const kid = cUNOPo->op_first;
13124 PERL_ARGS_ASSERT_CK_METHOD;
13125 if (kid->op_type != OP_CONST) return o;
13129 /* replace ' with :: */
13130 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13131 SvEND(sv) - SvPVX(sv) )))
13134 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13137 method = SvPVX_const(sv);
13139 utf8 = SvUTF8(sv) ? -1 : 1;
13141 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13146 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13148 if (!nsplit) { /* $proto->method() */
13150 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13153 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13155 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13158 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13159 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13160 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13161 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13163 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13164 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13166 #ifdef USE_ITHREADS
13167 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13169 cMETHOPx(new_op)->op_rclass_sv = rclass;
13176 Perl_ck_null(pTHX_ OP *o)
13178 PERL_ARGS_ASSERT_CK_NULL;
13179 PERL_UNUSED_CONTEXT;
13184 Perl_ck_open(pTHX_ OP *o)
13186 PERL_ARGS_ASSERT_CK_OPEN;
13188 S_io_hints(aTHX_ o);
13190 /* In case of three-arg dup open remove strictness
13191 * from the last arg if it is a bareword. */
13192 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13193 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
13197 if ((last->op_type == OP_CONST) && /* The bareword. */
13198 (last->op_private & OPpCONST_BARE) &&
13199 (last->op_private & OPpCONST_STRICT) &&
13200 (oa = OpSIBLING(first)) && /* The fh. */
13201 (oa = OpSIBLING(oa)) && /* The mode. */
13202 (oa->op_type == OP_CONST) &&
13203 SvPOK(cSVOPx(oa)->op_sv) &&
13204 (mode = SvPVX_const(cSVOPx(oa)->op_sv)) &&
13205 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
13206 (last == OpSIBLING(oa))) /* The bareword. */
13207 last->op_private &= ~OPpCONST_STRICT;
13213 Perl_ck_prototype(pTHX_ OP *o)
13215 PERL_ARGS_ASSERT_CK_PROTOTYPE;
13216 if (!(o->op_flags & OPf_KIDS)) {
13218 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13224 Perl_ck_refassign(pTHX_ OP *o)
13226 OP * const right = cLISTOPo->op_first;
13227 OP * const left = OpSIBLING(right);
13228 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13231 PERL_ARGS_ASSERT_CK_REFASSIGN;
13233 assert (left->op_type == OP_SREFGEN);
13236 /* we use OPpPAD_STATE in refassign to mean either of those things,
13237 * and the code assumes the two flags occupy the same bit position
13238 * in the various ops below */
13239 assert(OPpPAD_STATE == OPpOUR_INTRO);
13241 switch (varop->op_type) {
13243 o->op_private |= OPpLVREF_AV;
13246 o->op_private |= OPpLVREF_HV;
13250 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13251 o->op_targ = varop->op_targ;
13252 varop->op_targ = 0;
13253 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13257 o->op_private |= OPpLVREF_AV;
13259 NOT_REACHED; /* NOTREACHED */
13261 o->op_private |= OPpLVREF_HV;
13265 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13266 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13268 /* Point varop to its GV kid, detached. */
13269 varop = op_sibling_splice(varop, NULL, -1, NULL);
13273 OP * const kidparent =
13274 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13275 OP * const kid = cUNOPx(kidparent)->op_first;
13276 o->op_private |= OPpLVREF_CV;
13277 if (kid->op_type == OP_GV) {
13278 SV *sv = (SV*)cGVOPx_gv(kid);
13280 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13281 /* a CVREF here confuses pp_refassign, so make sure
13283 CV *const cv = (CV*)SvRV(sv);
13284 SV *name_sv = newSVhek_mortal(CvNAME_HEK(cv));
13285 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13286 assert(SvTYPE(sv) == SVt_PVGV);
13288 goto detach_and_stack;
13290 if (kid->op_type != OP_PADCV) goto bad;
13291 o->op_targ = kid->op_targ;
13297 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13298 o->op_private |= OPpLVREF_ELEM;
13301 /* Detach varop. */
13302 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13306 /* diag_listed_as: Can't modify reference to %s in %s assignment */
13307 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13312 if (!FEATURE_REFALIASING_IS_ENABLED)
13314 "Experimental aliasing via reference not enabled");
13315 Perl_ck_warner_d(aTHX_
13316 packWARN(WARN_EXPERIMENTAL__REFALIASING),
13317 "Aliasing via reference is experimental");
13319 o->op_flags |= OPf_STACKED;
13320 op_sibling_splice(o, right, 1, varop);
13323 o->op_flags &=~ OPf_STACKED;
13324 op_sibling_splice(o, right, 1, NULL);
13331 Perl_ck_repeat(pTHX_ OP *o)
13333 PERL_ARGS_ASSERT_CK_REPEAT;
13335 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13337 o->op_private |= OPpREPEAT_DOLIST;
13338 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13339 kids = op_force_list(kids); /* promote it to a list */
13340 op_sibling_splice(o, NULL, 0, kids); /* and add back */
13348 Perl_ck_require(pTHX_ OP *o)
13352 PERL_ARGS_ASSERT_CK_REQUIRE;
13354 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
13355 SVOP * const kid = cSVOPx(cUNOPo->op_first);
13359 if (kid->op_type == OP_CONST) {
13360 SV * const sv = kid->op_sv;
13361 U32 const was_readonly = SvREADONLY(sv);
13362 if (kid->op_private & OPpCONST_BARE) {
13366 if (was_readonly) {
13367 SvREADONLY_off(sv);
13370 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13375 /* treat ::foo::bar as foo::bar */
13376 if (len >= 2 && s[0] == ':' && s[1] == ':')
13377 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13379 DIE(aTHX_ "Bareword in require maps to empty filename");
13381 for (; s < end; s++) {
13382 if (*s == ':' && s[1] == ':') {
13384 Move(s+2, s+1, end - s - 1, char);
13388 SvEND_set(sv, end);
13389 sv_catpvs(sv, ".pm");
13390 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13391 hek = share_hek(SvPVX(sv),
13392 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13394 sv_sethek(sv, hek);
13396 SvFLAGS(sv) |= was_readonly;
13398 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13401 if (SvREFCNT(sv) > 1) {
13402 kid->op_sv = newSVpvn_share(
13403 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13404 SvREFCNT_dec_NN(sv);
13408 if (was_readonly) SvREADONLY_off(sv);
13409 PERL_HASH(hash, s, len);
13411 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13413 sv_sethek(sv, hek);
13415 SvFLAGS(sv) |= was_readonly;
13421 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13422 /* handle override, if any */
13423 && (gv = gv_override("require", 7))) {
13425 if (o->op_flags & OPf_KIDS) {
13426 kid = cUNOPo->op_first;
13427 op_sibling_splice(o, NULL, -1, NULL);
13430 kid = newDEFSVOP();
13433 newop = S_new_entersubop(aTHX_ gv, kid);
13441 Perl_ck_return(pTHX_ OP *o)
13445 PERL_ARGS_ASSERT_CK_RETURN;
13447 kid = OpSIBLING(cLISTOPo->op_first);
13448 if (PL_compcv && CvLVALUE(PL_compcv)) {
13449 for (; kid; kid = OpSIBLING(kid))
13450 op_lvalue(kid, OP_LEAVESUBLV);
13457 Perl_ck_select(pTHX_ OP *o)
13461 PERL_ARGS_ASSERT_CK_SELECT;
13463 if (o->op_flags & OPf_KIDS) {
13464 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13465 if (kid && OpHAS_SIBLING(kid)) {
13466 OpTYPE_set(o, OP_SSELECT);
13468 return fold_constants(op_integerize(op_std_init(o)));
13472 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13473 if (kid && kid->op_type == OP_RV2GV)
13474 kid->op_private &= ~HINT_STRICT_REFS;
13479 Perl_ck_shift(pTHX_ OP *o)
13481 const I32 type = o->op_type;
13483 PERL_ARGS_ASSERT_CK_SHIFT;
13485 if (!(o->op_flags & OPf_KIDS)) {
13488 if (!CvUNIQUE(PL_compcv)) {
13489 o->op_flags |= OPf_SPECIAL;
13493 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13495 return newUNOP(type, 0, scalar(argop));
13497 return scalar(ck_fun(o));
13501 Perl_ck_sort(pTHX_ OP *o)
13507 PERL_ARGS_ASSERT_CK_SORT;
13509 if (o->op_flags & OPf_STACKED)
13511 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13514 return too_few_arguments_pv(o,OP_DESC(o), 0);
13516 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
13517 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
13519 /* if the first arg is a code block, process it and mark sort as
13521 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13523 if (kid->op_type == OP_LEAVE)
13524 op_null(kid); /* wipe out leave */
13525 /* Prevent execution from escaping out of the sort block. */
13528 /* provide scalar context for comparison function/block */
13529 kid = scalar(firstkid);
13530 kid->op_next = kid;
13531 o->op_flags |= OPf_SPECIAL;
13533 else if (kid->op_type == OP_CONST
13534 && kid->op_private & OPpCONST_BARE) {
13538 const char * const name = SvPV(kSVOP_sv, len);
13540 assert (len < 256);
13541 Copy(name, tmpbuf+1, len, char);
13542 off = pad_findmy_pvn(tmpbuf, len+1, 0);
13543 if (off != NOT_IN_PAD) {
13544 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13546 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13547 sv_catpvs(fq, "::");
13548 sv_catsv(fq, kSVOP_sv);
13549 SvREFCNT_dec_NN(kSVOP_sv);
13553 /* replace the const op with the pad op */
13554 op_sibling_splice(firstkid, NULL, 1,
13555 newPADxVOP(OP_PADCV, 0, off));
13561 firstkid = OpSIBLING(firstkid);
13564 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13565 /* provide list context for arguments */
13568 op_lvalue(kid, OP_GREPSTART);
13574 /* for sort { X } ..., where X is one of
13575 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13576 * elide the second child of the sort (the one containing X),
13577 * and set these flags as appropriate
13581 * Also, check and warn on lexical $a, $b.
13585 S_simplify_sort(pTHX_ OP *o)
13587 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
13591 const char *gvname;
13594 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13596 kid = kUNOP->op_first; /* get past null */
13597 if (!(have_scopeop = kid->op_type == OP_SCOPE)
13598 && kid->op_type != OP_LEAVE)
13600 kid = kLISTOP->op_last; /* get past scope */
13601 switch(kid->op_type) {
13605 if (!have_scopeop) goto padkids;
13610 k = kid; /* remember this node*/
13611 if (kBINOP->op_first->op_type != OP_RV2SV
13612 || kBINOP->op_last ->op_type != OP_RV2SV)
13615 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13616 then used in a comparison. This catches most, but not
13617 all cases. For instance, it catches
13618 sort { my($a); $a <=> $b }
13620 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13621 (although why you'd do that is anyone's guess).
13625 if (!ckWARN(WARN_SYNTAX)) return;
13626 kid = kBINOP->op_first;
13628 if (kid->op_type == OP_PADSV) {
13629 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13630 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13631 && ( PadnamePV(name)[1] == 'a'
13632 || PadnamePV(name)[1] == 'b' ))
13633 /* diag_listed_as: "my %s" used in sort comparison */
13634 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13635 "\"%s %s\" used in sort comparison",
13636 PadnameIsSTATE(name)
13641 } while ((kid = OpSIBLING(kid)));
13644 kid = kBINOP->op_first; /* get past cmp */
13645 if (kUNOP->op_first->op_type != OP_GV)
13647 kid = kUNOP->op_first; /* get past rv2sv */
13649 if (GvSTASH(gv) != PL_curstash)
13651 gvname = GvNAME(gv);
13652 if (*gvname == 'a' && gvname[1] == '\0')
13654 else if (*gvname == 'b' && gvname[1] == '\0')
13659 kid = k; /* back to cmp */
13660 /* already checked above that it is rv2sv */
13661 kid = kBINOP->op_last; /* down to 2nd arg */
13662 if (kUNOP->op_first->op_type != OP_GV)
13664 kid = kUNOP->op_first; /* get past rv2sv */
13666 if (GvSTASH(gv) != PL_curstash)
13668 gvname = GvNAME(gv);
13670 ? !(*gvname == 'a' && gvname[1] == '\0')
13671 : !(*gvname == 'b' && gvname[1] == '\0'))
13673 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13675 o->op_private |= OPpSORT_DESCEND;
13676 if (k->op_type == OP_NCMP)
13677 o->op_private |= OPpSORT_NUMERIC;
13678 if (k->op_type == OP_I_NCMP)
13679 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13680 kid = OpSIBLING(cLISTOPo->op_first);
13681 /* cut out and delete old block (second sibling) */
13682 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13687 Perl_ck_split(pTHX_ OP *o)
13692 PERL_ARGS_ASSERT_CK_SPLIT;
13694 assert(o->op_type == OP_LIST);
13696 if (o->op_flags & OPf_STACKED)
13697 return no_fh_allowed(o);
13699 kid = cLISTOPo->op_first;
13700 /* delete leading NULL node, then add a CONST if no other nodes */
13701 assert(kid->op_type == OP_NULL);
13702 op_sibling_splice(o, NULL, 1,
13703 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13705 kid = cLISTOPo->op_first;
13707 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13708 /* remove match expression, and replace with new optree with
13709 * a match op at its head */
13710 op_sibling_splice(o, NULL, 1, NULL);
13711 /* pmruntime will handle split " " behavior with flag==2 */
13712 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13713 op_sibling_splice(o, NULL, 0, kid);
13716 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13718 if (kPMOP->op_pmflags & PMf_GLOBAL) {
13719 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13720 "Use of /g modifier is meaningless in split");
13723 /* eliminate the split op, and move the match op (plus any children)
13724 * into its place, then convert the match op into a split op. i.e.
13726 * SPLIT MATCH SPLIT(ex-MATCH)
13728 * MATCH - A - B - C => R - A - B - C => R - A - B - C
13734 * (R, if it exists, will be a regcomp op)
13737 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
13738 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
13739 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
13740 OpTYPE_set(kid, OP_SPLIT);
13741 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
13742 kid->op_private = o->op_private;
13745 kid = sibs; /* kid is now the string arg of the split */
13748 kid = newDEFSVOP();
13749 op_append_elem(OP_SPLIT, o, kid);
13753 kid = OpSIBLING(kid);
13755 kid = newSVOP(OP_CONST, 0, newSViv(0));
13756 op_append_elem(OP_SPLIT, o, kid);
13757 o->op_private |= OPpSPLIT_IMPLIM;
13761 if (OpHAS_SIBLING(kid))
13762 return too_many_arguments_pv(o,OP_DESC(o), 0);
13768 Perl_ck_stringify(pTHX_ OP *o)
13770 OP * const kid = OpSIBLING(cUNOPo->op_first);
13771 PERL_ARGS_ASSERT_CK_STRINGIFY;
13772 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13773 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
13774 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
13775 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13777 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13785 Perl_ck_join(pTHX_ OP *o)
13787 OP * const kid = OpSIBLING(cLISTOPo->op_first);
13789 PERL_ARGS_ASSERT_CK_JOIN;
13791 if (kid && kid->op_type == OP_MATCH) {
13792 if (ckWARN(WARN_SYNTAX)) {
13793 const REGEXP *re = PM_GETRE(kPMOP);
13795 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13796 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13797 : newSVpvs_flags( "STRING", SVs_TEMP );
13798 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13799 "/%" SVf "/ should probably be written as \"%" SVf "\"",
13800 SVfARG(msg), SVfARG(msg));
13804 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13805 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13806 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13807 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13809 const OP * const bairn = OpSIBLING(kid); /* the list */
13810 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13811 && OP_GIMME(bairn,0) == G_SCALAR)
13813 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13814 op_sibling_splice(o, kid, 1, NULL));
13824 =for apidoc rv2cv_op_cv
13826 Examines an op, which is expected to identify a subroutine at runtime,
13827 and attempts to determine at compile time which subroutine it identifies.
13828 This is normally used during Perl compilation to determine whether
13829 a prototype can be applied to a function call. C<cvop> is the op
13830 being considered, normally an C<rv2cv> op. A pointer to the identified
13831 subroutine is returned, if it could be determined statically, and a null
13832 pointer is returned if it was not possible to determine statically.
13834 Currently, the subroutine can be identified statically if the RV that the
13835 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13836 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
13837 suitable if the constant value must be an RV pointing to a CV. Details of
13838 this process may change in future versions of Perl. If the C<rv2cv> op
13839 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13840 the subroutine statically: this flag is used to suppress compile-time
13841 magic on a subroutine call, forcing it to use default runtime behaviour.
13843 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13844 of a GV reference is modified. If a GV was examined and its CV slot was
13845 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13846 If the op is not optimised away, and the CV slot is later populated with
13847 a subroutine having a prototype, that flag eventually triggers the warning
13848 "called too early to check prototype".
13850 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13851 of returning a pointer to the subroutine it returns a pointer to the
13852 GV giving the most appropriate name for the subroutine in this context.
13853 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13854 (C<CvANON>) subroutine that is referenced through a GV it will be the
13855 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
13856 A null pointer is returned as usual if there is no statically-determinable
13859 =for apidoc Amnh||OPpEARLY_CV
13860 =for apidoc Amnh||OPpENTERSUB_AMPER
13861 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
13862 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
13867 /* shared by toke.c:yylex */
13869 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13871 const PADNAME *name = PAD_COMPNAME(off);
13872 CV *compcv = PL_compcv;
13873 while (PadnameOUTER(name)) {
13874 compcv = CvOUTSIDE(compcv);
13875 if (LIKELY(PARENT_PAD_INDEX(name))) {
13876 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13877 [off = PARENT_PAD_INDEX(name)];
13880 /* In an eval() in an inner scope like a function, the
13881 intermediate pad in the sub might not be populated with the
13882 sub. So search harder.
13884 It is possible we won't find the name in this
13885 particular scope, but that's fine, if we don't we'll
13886 find it in some outer scope. Finding it here will let us
13887 go back to following the PARENT_PAD_INDEX() chain.
13889 const PADNAMELIST * const names = PadlistNAMES(CvPADLIST(compcv));
13890 PADNAME * const * const name_p = PadnamelistARRAY(names);
13892 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
13893 const PADNAME * const thisname = name_p[offset];
13894 /* The pv is copied from the outer PADNAME to the
13895 inner PADNAMEs so we don't need to compare the
13898 if (thisname && PadnameLEN(thisname) == PadnameLEN(name)
13899 && PadnamePV(thisname) == PadnamePV(name)) {
13906 assert(!PadnameIsOUR(name));
13907 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13908 return PadnamePROTOCV(name);
13910 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13914 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13919 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13920 if (flags & ~RV2CVOPCV_FLAG_MASK)
13921 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13922 if (cvop->op_type != OP_RV2CV)
13924 if (cvop->op_private & OPpENTERSUB_AMPER)
13926 if (!(cvop->op_flags & OPf_KIDS))
13928 rvop = cUNOPx(cvop)->op_first;
13929 switch (rvop->op_type) {
13931 gv = cGVOPx_gv(rvop);
13933 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13934 cv = MUTABLE_CV(SvRV(gv));
13938 if (flags & RV2CVOPCV_RETURN_STUB)
13944 if (flags & RV2CVOPCV_MARK_EARLY)
13945 rvop->op_private |= OPpEARLY_CV;
13950 SV *rv = cSVOPx_sv(rvop);
13953 cv = (CV*)SvRV(rv);
13957 cv = find_lexical_cv(rvop->op_targ);
13962 } NOT_REACHED; /* NOTREACHED */
13964 if (SvTYPE((SV*)cv) != SVt_PVCV)
13966 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13967 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13971 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13972 if (CvLEXICAL(cv) || CvNAMED(cv))
13974 if (!CvANON(cv) || !gv)
13984 =for apidoc ck_entersub_args_list
13986 Performs the default fixup of the arguments part of an C<entersub>
13987 op tree. This consists of applying list context to each of the
13988 argument ops. This is the standard treatment used on a call marked
13989 with C<&>, or a method call, or a call through a subroutine reference,
13990 or any other call where the callee can't be identified at compile time,
13991 or a call where the callee has no prototype.
13997 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
14001 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14003 aop = cUNOPx(entersubop)->op_first;
14004 if (!OpHAS_SIBLING(aop))
14005 aop = cUNOPx(aop)->op_first;
14006 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14007 /* skip the extra attributes->import() call implicitly added in
14008 * something like foo(my $x : bar)
14010 if ( aop->op_type == OP_ENTERSUB
14011 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14015 op_lvalue(aop, OP_ENTERSUB);
14021 =for apidoc ck_entersub_args_proto
14023 Performs the fixup of the arguments part of an C<entersub> op tree
14024 based on a subroutine prototype. This makes various modifications to
14025 the argument ops, from applying context up to inserting C<refgen> ops,
14026 and checking the number and syntactic types of arguments, as directed by
14027 the prototype. This is the standard treatment used on a subroutine call,
14028 not marked with C<&>, where the callee can be identified at compile time
14029 and has a prototype.
14031 C<protosv> supplies the subroutine prototype to be applied to the call.
14032 It may be a normal defined scalar, of which the string value will be used.
14033 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14034 that has been cast to C<SV*>) which has a prototype. The prototype
14035 supplied, in whichever form, does not need to match the actual callee
14036 referenced by the op tree.
14038 If the argument ops disagree with the prototype, for example by having
14039 an unacceptable number of arguments, a valid op tree is returned anyway.
14040 The error is reflected in the parser state, normally resulting in a single
14041 exception at the top level of parsing which covers all the compilation
14042 errors that occurred. In the error message, the callee is referred to
14043 by the name defined by the C<namegv> parameter.
14049 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14052 const char *proto, *proto_end;
14053 OP *aop, *prev, *cvop, *parent;
14056 I32 contextclass = 0;
14057 const char *e = NULL;
14058 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14059 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14060 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14061 "flags=%lx", (unsigned long) SvFLAGS(protosv));
14062 if (SvTYPE(protosv) == SVt_PVCV)
14063 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14064 else proto = SvPV(protosv, proto_len);
14065 proto = S_strip_spaces(aTHX_ proto, &proto_len);
14066 proto_end = proto + proto_len;
14067 parent = entersubop;
14068 aop = cUNOPx(entersubop)->op_first;
14069 if (!OpHAS_SIBLING(aop)) {
14071 aop = cUNOPx(aop)->op_first;
14074 aop = OpSIBLING(aop);
14075 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14076 while (aop != cvop) {
14079 if (proto >= proto_end)
14081 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14082 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14083 SVfARG(namesv)), SvUTF8(namesv));
14093 /* _ must be at the end */
14094 if (proto[1] && !memCHRs(";@%", proto[1]))
14110 if ( o3->op_type != OP_UNDEF
14111 && o3->op_type != OP_ANONCODE
14112 && (o3->op_type != OP_SREFGEN
14113 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14115 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14117 bad_type_gv(arg, namegv, o3,
14118 arg == 1 ? "block or sub {}" : "sub {}");
14121 /* '*' allows any scalar type, including bareword */
14124 if (o3->op_type == OP_RV2GV)
14125 goto wrapref; /* autoconvert GLOB -> GLOBref */
14126 else if (o3->op_type == OP_CONST)
14127 o3->op_private &= ~OPpCONST_STRICT;
14133 if (o3->op_type == OP_RV2AV ||
14134 o3->op_type == OP_PADAV ||
14135 o3->op_type == OP_RV2HV ||
14136 o3->op_type == OP_PADHV
14142 case '[': case ']':
14149 switch (*proto++) {
14151 if (contextclass++ == 0) {
14152 e = (char *) memchr(proto, ']', proto_end - proto);
14153 if (!e || e == proto)
14161 if (contextclass) {
14162 const char *p = proto;
14163 const char *const end = proto;
14165 while (*--p != '[')
14166 /* \[$] accepts any scalar lvalue */
14168 && Perl_op_lvalue_flags(aTHX_
14170 OP_READ, /* not entersub */
14173 bad_type_gv(arg, namegv, o3,
14174 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14179 if (o3->op_type == OP_RV2GV)
14182 bad_type_gv(arg, namegv, o3, "symbol");
14185 if (o3->op_type == OP_ENTERSUB
14186 && !(o3->op_flags & OPf_STACKED))
14189 bad_type_gv(arg, namegv, o3, "subroutine");
14192 if (o3->op_type == OP_RV2SV ||
14193 o3->op_type == OP_PADSV ||
14194 o3->op_type == OP_HELEM ||
14195 o3->op_type == OP_AELEM)
14197 if (!contextclass) {
14198 /* \$ accepts any scalar lvalue */
14199 if (Perl_op_lvalue_flags(aTHX_
14201 OP_READ, /* not entersub */
14204 bad_type_gv(arg, namegv, o3, "scalar");
14208 if (o3->op_type == OP_RV2AV ||
14209 o3->op_type == OP_PADAV)
14211 o3->op_flags &=~ OPf_PARENS;
14215 bad_type_gv(arg, namegv, o3, "array");
14218 if (o3->op_type == OP_RV2HV ||
14219 o3->op_type == OP_PADHV)
14221 o3->op_flags &=~ OPf_PARENS;
14225 bad_type_gv(arg, namegv, o3, "hash");
14228 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14230 if (contextclass && e) {
14235 default: goto oops;
14245 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14246 SVfARG(cv_name((CV *)namegv, NULL, 0)),
14251 op_lvalue(aop, OP_ENTERSUB);
14253 aop = OpSIBLING(aop);
14255 if (aop == cvop && *proto == '_') {
14256 /* generate an access to $_ */
14257 op_sibling_splice(parent, prev, 0, newDEFSVOP());
14259 if (!optional && proto_end > proto &&
14260 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14262 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14263 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14264 SVfARG(namesv)), SvUTF8(namesv));
14270 =for apidoc ck_entersub_args_proto_or_list
14272 Performs the fixup of the arguments part of an C<entersub> op tree either
14273 based on a subroutine prototype or using default list-context processing.
14274 This is the standard treatment used on a subroutine call, not marked
14275 with C<&>, where the callee can be identified at compile time.
14277 C<protosv> supplies the subroutine prototype to be applied to the call,
14278 or indicates that there is no prototype. It may be a normal scalar,
14279 in which case if it is defined then the string value will be used
14280 as a prototype, and if it is undefined then there is no prototype.
14281 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14282 that has been cast to C<SV*>), of which the prototype will be used if it
14283 has one. The prototype (or lack thereof) supplied, in whichever form,
14284 does not need to match the actual callee referenced by the op tree.
14286 If the argument ops disagree with the prototype, for example by having
14287 an unacceptable number of arguments, a valid op tree is returned anyway.
14288 The error is reflected in the parser state, normally resulting in a single
14289 exception at the top level of parsing which covers all the compilation
14290 errors that occurred. In the error message, the callee is referred to
14291 by the name defined by the C<namegv> parameter.
14297 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14298 GV *namegv, SV *protosv)
14300 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14301 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14302 return ck_entersub_args_proto(entersubop, namegv, protosv);
14304 return ck_entersub_args_list(entersubop);
14308 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14310 IV cvflags = SvIVX(protosv);
14311 int opnum = cvflags & 0xffff;
14312 OP *aop = cUNOPx(entersubop)->op_first;
14314 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14318 if (!OpHAS_SIBLING(aop))
14319 aop = cUNOPx(aop)->op_first;
14320 aop = OpSIBLING(aop);
14321 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14323 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14324 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14325 SVfARG(namesv)), SvUTF8(namesv));
14328 op_free(entersubop);
14329 switch(cvflags >> 16) {
14330 case 'F': return newSVOP(OP_CONST, 0,
14331 newSVpv(CopFILE(PL_curcop),0));
14332 case 'L': return newSVOP(
14334 Perl_newSVpvf(aTHX_
14335 "%" LINE_Tf, CopLINE(PL_curcop)
14338 case 'P': return newSVOP(OP_CONST, 0,
14340 ? newSVhek(HvNAME_HEK(PL_curstash))
14345 NOT_REACHED; /* NOTREACHED */
14348 OP *prev, *cvop, *first, *parent;
14351 parent = entersubop;
14352 if (!OpHAS_SIBLING(aop)) {
14354 aop = cUNOPx(aop)->op_first;
14357 first = prev = aop;
14358 aop = OpSIBLING(aop);
14359 /* find last sibling */
14361 OpHAS_SIBLING(cvop);
14362 prev = cvop, cvop = OpSIBLING(cvop))
14364 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14365 /* Usually, OPf_SPECIAL on an op with no args means that it had
14366 * parens, but these have their own meaning for that flag: */
14367 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14368 && opnum != OP_DELETE && opnum != OP_EXISTS)
14369 flags |= OPf_SPECIAL;
14370 /* excise cvop from end of sibling chain */
14371 op_sibling_splice(parent, prev, 1, NULL);
14373 if (aop == cvop) aop = NULL;
14375 /* detach remaining siblings from the first sibling, then
14376 * dispose of original optree */
14379 op_sibling_splice(parent, first, -1, NULL);
14380 op_free(entersubop);
14382 if (cvflags == (OP_ENTEREVAL | (1<<16)))
14383 flags |= OPpEVAL_BYTES <<8;
14385 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14387 case OA_BASEOP_OR_UNOP:
14388 case OA_FILESTATOP:
14390 return newOP(opnum,flags); /* zero args */
14392 return newUNOP(opnum,flags,aop); /* one arg */
14393 /* too many args */
14400 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14401 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14402 SVfARG(namesv)), SvUTF8(namesv));
14404 nextop = OpSIBLING(aop);
14410 return opnum == OP_RUNCV
14411 ? newSVOP(OP_RUNCV, 0, &PL_sv_undef)
14414 return op_convert_list(opnum,0,aop);
14417 NOT_REACHED; /* NOTREACHED */
14422 =for apidoc cv_get_call_checker_flags
14424 Retrieves the function that will be used to fix up a call to C<cv>.
14425 Specifically, the function is applied to an C<entersub> op tree for a
14426 subroutine call, not marked with C<&>, where the callee can be identified
14427 at compile time as C<cv>.
14429 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14430 for it is returned in C<*ckobj_p>, and control flags are returned in
14431 C<*ckflags_p>. The function is intended to be called in this manner:
14433 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14435 In this call, C<entersubop> is a pointer to the C<entersub> op,
14436 which may be replaced by the check function, and C<namegv> supplies
14437 the name that should be used by the check function to refer
14438 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14439 It is permitted to apply the check function in non-standard situations,
14440 such as to a call to a different subroutine or to a method call.
14442 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
14443 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14444 instead, anything that can be used as the first argument to L</cv_name>.
14445 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14446 check function requires C<namegv> to be a genuine GV.
14448 By default, the check function is
14449 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14450 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14451 flag is clear. This implements standard prototype processing. It can
14452 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14454 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14455 indicates that the caller only knows about the genuine GV version of
14456 C<namegv>, and accordingly the corresponding bit will always be set in
14457 C<*ckflags_p>, regardless of the check function's recorded requirements.
14458 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14459 indicates the caller knows about the possibility of passing something
14460 other than a GV as C<namegv>, and accordingly the corresponding bit may
14461 be either set or clear in C<*ckflags_p>, indicating the check function's
14462 recorded requirements.
14464 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14465 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14466 (for which see above). All other bits should be clear.
14468 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14470 =for apidoc cv_get_call_checker
14472 The original form of L</cv_get_call_checker_flags>, which does not return
14473 checker flags. When using a checker function returned by this function,
14474 it is only safe to call it with a genuine GV as its C<namegv> argument.
14480 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14481 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14484 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14485 PERL_UNUSED_CONTEXT;
14486 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14488 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14489 *ckobj_p = callmg->mg_obj;
14490 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14492 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14493 *ckobj_p = (SV*)cv;
14494 *ckflags_p = gflags & MGf_REQUIRE_GV;
14499 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14502 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14503 PERL_UNUSED_CONTEXT;
14504 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14509 =for apidoc cv_set_call_checker_flags
14511 Sets the function that will be used to fix up a call to C<cv>.
14512 Specifically, the function is applied to an C<entersub> op tree for a
14513 subroutine call, not marked with C<&>, where the callee can be identified
14514 at compile time as C<cv>.
14516 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14517 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14518 The function should be defined like this:
14520 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14522 It is intended to be called in this manner:
14524 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14526 In this call, C<entersubop> is a pointer to the C<entersub> op,
14527 which may be replaced by the check function, and C<namegv> supplies
14528 the name that should be used by the check function to refer
14529 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14530 It is permitted to apply the check function in non-standard situations,
14531 such as to a call to a different subroutine or to a method call.
14533 C<namegv> may not actually be a GV. For efficiency, perl may pass a
14534 CV or other SV instead. Whatever is passed can be used as the first
14535 argument to L</cv_name>. You can force perl to pass a GV by including
14536 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14538 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14539 bit currently has a defined meaning (for which see above). All other
14540 bits should be clear.
14542 The current setting for a particular CV can be retrieved by
14543 L</cv_get_call_checker_flags>.
14545 =for apidoc cv_set_call_checker
14547 The original form of L</cv_set_call_checker_flags>, which passes it the
14548 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
14549 of that flag setting is that the check function is guaranteed to get a
14550 genuine GV as its C<namegv> argument.
14556 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14558 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14559 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14563 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14564 SV *ckobj, U32 ckflags)
14566 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14567 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14568 if (SvMAGICAL((SV*)cv))
14569 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14572 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14573 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14575 if (callmg->mg_flags & MGf_REFCOUNTED) {
14576 SvREFCNT_dec(callmg->mg_obj);
14577 callmg->mg_flags &= ~MGf_REFCOUNTED;
14579 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14580 callmg->mg_obj = ckobj;
14581 if (ckobj != (SV*)cv) {
14582 SvREFCNT_inc_simple_void_NN(ckobj);
14583 callmg->mg_flags |= MGf_REFCOUNTED;
14585 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14586 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14591 S_entersub_alloc_targ(pTHX_ OP * const o)
14593 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14594 o->op_private |= OPpENTERSUB_HASTARG;
14598 Perl_ck_subr(pTHX_ OP *o)
14603 SV **const_class = NULL;
14605 PERL_ARGS_ASSERT_CK_SUBR;
14607 aop = cUNOPx(o)->op_first;
14608 if (!OpHAS_SIBLING(aop))
14609 aop = cUNOPx(aop)->op_first;
14610 aop = OpSIBLING(aop);
14611 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14612 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14613 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14615 o->op_private &= ~1;
14616 o->op_private |= (PL_hints & HINT_STRICT_REFS);
14617 if (PERLDB_SUB && PL_curstash != PL_debstash)
14618 o->op_private |= OPpENTERSUB_DB;
14619 switch (cvop->op_type) {
14621 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14625 case OP_METHOD_NAMED:
14626 case OP_METHOD_SUPER:
14627 case OP_METHOD_REDIR:
14628 case OP_METHOD_REDIR_SUPER:
14629 o->op_flags |= OPf_REF;
14630 if (aop->op_type == OP_CONST) {
14631 aop->op_private &= ~OPpCONST_STRICT;
14632 const_class = &cSVOPx(aop)->op_sv;
14634 else if (aop->op_type == OP_LIST) {
14635 OP * const sib = OpSIBLING(cUNOPx(aop)->op_first);
14636 if (sib && sib->op_type == OP_CONST) {
14637 sib->op_private &= ~OPpCONST_STRICT;
14638 const_class = &cSVOPx(sib)->op_sv;
14641 /* make class name a shared cow string to speedup method calls */
14642 /* constant string might be replaced with object, f.e. bigint */
14643 if (const_class && SvPOK(*const_class)) {
14645 const char* str = SvPV(*const_class, len);
14647 SV* const shared = newSVpvn_share(
14648 str, SvUTF8(*const_class)
14649 ? -(SSize_t)len : (SSize_t)len,
14652 if (SvREADONLY(*const_class))
14653 SvREADONLY_on(shared);
14654 SvREFCNT_dec(*const_class);
14655 *const_class = shared;
14662 S_entersub_alloc_targ(aTHX_ o);
14663 return ck_entersub_args_list(o);
14665 Perl_call_checker ckfun;
14668 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14669 if (CvISXSUB(cv) || !CvROOT(cv))
14670 S_entersub_alloc_targ(aTHX_ o);
14672 /* The original call checker API guarantees that a GV will
14673 be provided with the right name. So, if the old API was
14674 used (or the REQUIRE_GV flag was passed), we have to reify
14675 the CV’s GV, unless this is an anonymous sub. This is not
14676 ideal for lexical subs, as its stringification will include
14677 the package. But it is the best we can do. */
14678 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14679 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14682 else namegv = MUTABLE_GV(cv);
14683 /* After a syntax error in a lexical sub, the cv that
14684 rv2cv_op_cv returns may be a nameless stub. */
14685 if (!namegv) return ck_entersub_args_list(o);
14688 return ckfun(aTHX_ o, namegv, ckobj);
14693 Perl_ck_svconst(pTHX_ OP *o)
14695 SV * const sv = cSVOPo->op_sv;
14696 PERL_ARGS_ASSERT_CK_SVCONST;
14697 PERL_UNUSED_CONTEXT;
14698 #ifdef PERL_COPY_ON_WRITE
14699 /* Since the read-only flag may be used to protect a string buffer, we
14700 cannot do copy-on-write with existing read-only scalars that are not
14701 already copy-on-write scalars. To allow $_ = "hello" to do COW with
14702 that constant, mark the constant as COWable here, if it is not
14703 already read-only. */
14704 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14707 # ifdef PERL_DEBUG_READONLY_COW
14717 Perl_ck_trunc(pTHX_ OP *o)
14719 PERL_ARGS_ASSERT_CK_TRUNC;
14721 if (o->op_flags & OPf_KIDS) {
14722 SVOP *kid = cSVOPx(cUNOPo->op_first);
14724 if (kid->op_type == OP_NULL)
14725 kid = cSVOPx(OpSIBLING(kid));
14726 if (kid && kid->op_type == OP_CONST &&
14727 (kid->op_private & OPpCONST_BARE) &&
14730 o->op_flags |= OPf_SPECIAL;
14731 kid->op_private &= ~OPpCONST_STRICT;
14732 if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
14733 no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
14741 Perl_ck_substr(pTHX_ OP *o)
14743 PERL_ARGS_ASSERT_CK_SUBSTR;
14746 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
14747 OP *kid = cLISTOPo->op_first;
14749 if (kid->op_type == OP_NULL)
14750 kid = OpSIBLING(kid);
14752 /* Historically, substr(delete $foo{bar},...) has been allowed
14753 with 4-arg substr. Keep it working by applying entersub
14755 op_lvalue(kid, OP_ENTERSUB);
14762 Perl_ck_tell(pTHX_ OP *o)
14764 PERL_ARGS_ASSERT_CK_TELL;
14766 if (o->op_flags & OPf_KIDS) {
14767 OP *kid = cLISTOPo->op_first;
14768 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
14769 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
14774 PERL_STATIC_INLINE OP *
14775 S_last_non_null_kid(OP *o) {
14777 if (cUNOPo->op_flags & OPf_KIDS) {
14778 OP *k = cLISTOPo->op_first;
14780 if (k->op_type != OP_NULL) {
14791 Perl_ck_each(pTHX_ OP *o)
14793 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
14794 const unsigned orig_type = o->op_type;
14796 PERL_ARGS_ASSERT_CK_EACH;
14799 switch (kid->op_type) {
14804 /* Catch out an anonhash here, since the behaviour might be
14807 * The typical tree is:
14814 * If the contents of the block is more complex you might get:
14822 * Similarly for the anonlist version below.
14824 if (orig_type == OP_EACH &&
14825 ckWARN(WARN_SYNTAX) &&
14826 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14827 ( cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14828 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14829 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14830 /* look for last non-null kid, since we might have:
14831 each %{ some code ; +{ anon hash } }
14833 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14834 if (k && k->op_type == OP_ANONHASH) {
14835 /* diag_listed_as: each on anonymous %s will always start from the beginning */
14836 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous hash will always start from the beginning");
14841 if (orig_type == OP_EACH &&
14842 ckWARN(WARN_SYNTAX) &&
14843 (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14844 (cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14845 cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14846 (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14847 OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14848 if (k && k->op_type == OP_ANONLIST) {
14849 /* diag_listed_as: each on anonymous %s will always start from the beginning */
14850 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous array will always start from the beginning");
14855 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
14856 : orig_type == OP_KEYS ? OP_AKEYS
14860 if (kid->op_private == OPpCONST_BARE
14861 || !SvROK(cSVOPx_sv(kid))
14862 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
14863 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
14868 qerror(Perl_mess(aTHX_
14869 "Experimental %s on scalar is now forbidden",
14870 PL_op_desc[orig_type]));
14872 bad_type_pv(1, "hash or array", o, kid);
14880 Perl_ck_length(pTHX_ OP *o)
14882 PERL_ARGS_ASSERT_CK_LENGTH;
14886 if (ckWARN(WARN_SYNTAX)) {
14887 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14891 const bool hash = kid->op_type == OP_PADHV
14892 || kid->op_type == OP_RV2HV;
14893 switch (kid->op_type) {
14898 name = op_varname(kid);
14904 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14905 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14907 SVfARG(name), hash ? "keys " : "", SVfARG(name)
14910 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14911 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14912 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14914 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14915 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14916 "length() used on @array (did you mean \"scalar(@array)\"?)");
14925 Perl_ck_isa(pTHX_ OP *o)
14927 OP *classop = cBINOPo->op_last;
14929 PERL_ARGS_ASSERT_CK_ISA;
14931 /* Convert barename into PV */
14932 if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
14933 /* TODO: Optionally convert package to raw HV here */
14934 classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
14941 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14942 and modify the optree to make them work inplace */
14945 S_inplace_aassign(pTHX_ OP *o) {
14947 OP *modop, *modop_pushmark;
14949 OP *oleft, *oleft_pushmark;
14951 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14953 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14955 assert(cUNOPo->op_first->op_type == OP_NULL);
14956 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14957 assert(modop_pushmark->op_type == OP_PUSHMARK);
14958 modop = OpSIBLING(modop_pushmark);
14960 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14963 /* no other operation except sort/reverse */
14964 if (OpHAS_SIBLING(modop))
14967 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14968 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14970 if (modop->op_flags & OPf_STACKED) {
14971 /* skip sort subroutine/block */
14972 assert(oright->op_type == OP_NULL);
14973 oright = OpSIBLING(oright);
14976 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14977 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14978 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14979 oleft = OpSIBLING(oleft_pushmark);
14981 /* Check the lhs is an array */
14983 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14984 || OpHAS_SIBLING(oleft)
14985 || (oleft->op_private & OPpLVAL_INTRO)
14989 /* Only one thing on the rhs */
14990 if (OpHAS_SIBLING(oright))
14993 /* check the array is the same on both sides */
14994 if (oleft->op_type == OP_RV2AV) {
14995 if (oright->op_type != OP_RV2AV
14996 || !cUNOPx(oright)->op_first
14997 || cUNOPx(oright)->op_first->op_type != OP_GV
14998 || cUNOPx(oleft )->op_first->op_type != OP_GV
14999 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15000 cGVOPx_gv(cUNOPx(oright)->op_first)
15004 else if (oright->op_type != OP_PADAV
15005 || oright->op_targ != oleft->op_targ
15009 /* This actually is an inplace assignment */
15011 modop->op_private |= OPpSORT_INPLACE;
15013 /* transfer MODishness etc from LHS arg to RHS arg */
15014 oright->op_flags = oleft->op_flags;
15016 /* remove the aassign op and the lhs */
15018 op_null(oleft_pushmark);
15019 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15020 op_null(cUNOPx(oleft)->op_first);
15026 =for apidoc_section $custom
15028 =for apidoc Perl_custom_op_xop
15029 Return the XOP structure for a given custom op. This macro should be
15030 considered internal to C<OP_NAME> and the other access macros: use them instead.
15031 This macro does call a function. Prior
15032 to 5.19.6, this was implemented as a
15039 /* use PERL_MAGIC_ext to call a function to free the xop structure when
15040 * freeing PL_custom_ops */
15043 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
15047 PERL_UNUSED_ARG(mg);
15048 xop = INT2PTR(XOP *, SvIV(sv));
15049 Safefree(xop->xop_name);
15050 Safefree(xop->xop_desc);
15056 static const MGVTBL custom_op_register_vtbl = {
15061 custom_op_register_free, /* free */
15071 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
15077 static const XOP xop_null = { 0, 0, 0, 0, 0 };
15079 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
15080 assert(o->op_type == OP_CUSTOM);
15082 /* This is wrong. It assumes a function pointer can be cast to IV,
15083 * which isn't guaranteed, but this is what the old custom OP code
15084 * did. In principle it should be safer to Copy the bytes of the
15085 * pointer into a PV: since the new interface is hidden behind
15086 * functions, this can be changed later if necessary. */
15087 /* Change custom_op_xop if this ever happens */
15088 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
15091 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
15093 /* See if the op isn't registered, but its name *is* registered.
15094 * That implies someone is using the pre-5.14 API,where only name and
15095 * description could be registered. If so, fake up a real
15097 * We only check for an existing name, and assume no one will have
15098 * just registered a desc */
15099 if (!he && PL_custom_op_names &&
15100 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
15105 /* XXX does all this need to be shared mem? */
15106 Newxz(xop, 1, XOP);
15107 pv = SvPV(HeVAL(he), l);
15108 XopENTRY_set(xop, xop_name, savepvn(pv, l));
15109 if (PL_custom_op_descs &&
15110 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
15112 pv = SvPV(HeVAL(he), l);
15113 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
15115 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
15116 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
15117 /* add magic to the SV so that the xop struct (pointed to by
15118 * SvIV(sv)) is freed. Normally a static xop is registered, but
15119 * for this backcompat hack, we've alloced one */
15120 (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
15121 &custom_op_register_vtbl, NULL, 0);
15126 xop = (XOP *)&xop_null;
15128 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
15133 if(field == XOPe_xop_ptr) {
15136 const U32 flags = XopFLAGS(xop);
15137 if(flags & field) {
15139 case XOPe_xop_name:
15140 any.xop_name = xop->xop_name;
15142 case XOPe_xop_desc:
15143 any.xop_desc = xop->xop_desc;
15145 case XOPe_xop_class:
15146 any.xop_class = xop->xop_class;
15148 case XOPe_xop_peep:
15149 any.xop_peep = xop->xop_peep;
15154 "panic: custom_op_get_field(): invalid field %d\n",
15160 case XOPe_xop_name:
15161 any.xop_name = XOPd_xop_name;
15163 case XOPe_xop_desc:
15164 any.xop_desc = XOPd_xop_desc;
15166 case XOPe_xop_class:
15167 any.xop_class = XOPd_xop_class;
15169 case XOPe_xop_peep:
15170 any.xop_peep = XOPd_xop_peep;
15183 =for apidoc custom_op_register
15184 Register a custom op. See L<perlguts/"Custom Operators">.
15190 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
15194 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
15196 /* see the comment in custom_op_xop */
15197 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
15199 if (!PL_custom_ops)
15200 PL_custom_ops = newHV();
15202 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
15203 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
15208 =for apidoc core_prototype
15210 This function assigns the prototype of the named core function to C<sv>, or
15211 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
15212 C<NULL> if the core function has no prototype. C<code> is a code as returned
15213 by C<keyword()>. It must not be equal to 0.
15219 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
15222 int i = 0, n = 0, seen_question = 0, defgv = 0;
15224 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
15225 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
15226 bool nullret = FALSE;
15228 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
15232 if (!sv) sv = sv_newmortal();
15234 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
15236 switch (code < 0 ? -code : code) {
15237 case KEY_and : case KEY_chop: case KEY_chomp:
15238 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
15239 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
15240 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
15241 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
15242 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
15243 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
15244 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
15245 case KEY_x : case KEY_xor :
15246 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
15247 case KEY_glob: retsetpvs("_;", OP_GLOB);
15248 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
15249 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
15250 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
15251 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
15252 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
15254 case KEY_evalbytes:
15255 name = "entereval"; break;
15263 while (i < MAXO) { /* The slow way. */
15264 if (strEQ(name, PL_op_name[i])
15265 || strEQ(name, PL_op_desc[i]))
15267 if (nullret) { assert(opnum); *opnum = i; return NULL; }
15274 defgv = PL_opargs[i] & OA_DEFGV;
15275 oa = PL_opargs[i] >> OASHIFT;
15277 if (oa & OA_OPTIONAL && !seen_question && (
15278 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
15283 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
15284 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
15285 /* But globs are already references (kinda) */
15286 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
15290 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
15291 && !scalar_mod_type(NULL, i)) {
15296 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
15300 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
15301 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
15302 str[n-1] = '_'; defgv = 0;
15306 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
15308 sv_setpvn(sv, str, n - 1);
15309 if (opnum) *opnum = i;
15314 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
15317 OP * const argop = (opnum == OP_SELECT && code) ? NULL :
15318 newSVOP(OP_COREARGS,0,coreargssv);
15321 PERL_ARGS_ASSERT_CORESUB_OP;
15325 return op_append_elem(OP_LINESEQ,
15328 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
15335 o = newUNOP(OP_AVHVSWITCH,0,argop);
15336 o->op_private = opnum-OP_EACH;
15338 case OP_SELECT: /* which represents OP_SSELECT as well */
15343 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
15344 newSVOP(OP_CONST, 0, newSVuv(1))
15346 coresub_op(newSVuv((UV)OP_SSELECT), 0,
15348 coresub_op(coreargssv, 0, OP_SELECT)
15352 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
15354 return op_append_elem(
15357 opnum == OP_WANTARRAY || opnum == OP_RUNCV
15358 ? OPpOFFBYONE << 8 : 0)
15360 case OA_BASEOP_OR_UNOP:
15361 if (opnum == OP_ENTEREVAL) {
15362 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
15363 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
15365 else o = newUNOP(opnum,0,argop);
15366 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
15369 if (is_handle_constructor(o, 1))
15370 argop->op_private |= OPpCOREARGS_DEREF1;
15371 if (scalar_mod_type(NULL, opnum))
15372 argop->op_private |= OPpCOREARGS_SCALARMOD;
15376 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
15377 if (is_handle_constructor(o, 2))
15378 argop->op_private |= OPpCOREARGS_DEREF2;
15379 if (opnum == OP_SUBSTR) {
15380 o->op_private |= OPpMAYBE_LVSUB;
15389 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
15390 SV * const *new_const_svp)
15392 const char *hvname;
15393 bool is_const = cBOOL(CvCONST(old_cv));
15394 SV *old_const_sv = is_const ? cv_const_sv_or_av(old_cv) : NULL;
15396 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
15398 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
15400 /* They are 2 constant subroutines generated from
15401 the same constant. This probably means that
15402 they are really the "same" proxy subroutine
15403 instantiated in 2 places. Most likely this is
15404 when a constant is exported twice. Don't warn.
15407 (ckWARN(WARN_REDEFINE)
15409 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15410 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15411 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15412 strEQ(hvname, "autouse"))
15416 && ckWARN_d(WARN_REDEFINE)
15417 && (!new_const_svp ||
15420 SvTYPE(old_const_sv) == SVt_PVAV ||
15421 SvTYPE(*new_const_svp) == SVt_PVAV ||
15422 sv_cmp(old_const_sv, *new_const_svp))
15425 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15427 ? "Constant subroutine %" SVf " redefined"
15428 : CvIsMETHOD(old_cv)
15429 ? "Method %" SVf " redefined"
15430 : "Subroutine %" SVf " redefined",
15436 =for apidoc_section $hook
15438 These functions provide convenient and thread-safe means of manipulating
15445 =for apidoc wrap_op_checker
15447 Puts a C function into the chain of check functions for a specified op
15448 type. This is the preferred way to manipulate the L</PL_check> array.
15449 C<opcode> specifies which type of op is to be affected. C<new_checker>
15450 is a pointer to the C function that is to be added to that opcode's
15451 check chain, and C<old_checker_p> points to the storage location where a
15452 pointer to the next function in the chain will be stored. The value of
15453 C<new_checker> is written into the L</PL_check> array, while the value
15454 previously stored there is written to C<*old_checker_p>.
15456 L</PL_check> is global to an entire process, and a module wishing to
15457 hook op checking may find itself invoked more than once per process,
15458 typically in different threads. To handle that situation, this function
15459 is idempotent. The location C<*old_checker_p> must initially (once
15460 per process) contain a null pointer. A C variable of static duration
15461 (declared at file scope, typically also marked C<static> to give
15462 it internal linkage) will be implicitly initialised appropriately,
15463 if it does not have an explicit initialiser. This function will only
15464 actually modify the check chain if it finds C<*old_checker_p> to be null.
15465 This function is also thread safe on the small scale. It uses appropriate
15466 locking to avoid race conditions in accessing L</PL_check>.
15468 When this function is called, the function referenced by C<new_checker>
15469 must be ready to be called, except for C<*old_checker_p> being unfilled.
15470 In a threading situation, C<new_checker> may be called immediately,
15471 even before this function has returned. C<*old_checker_p> will always
15472 be appropriately set before C<new_checker> is called. If C<new_checker>
15473 decides not to do anything special with an op that it is given (which
15474 is the usual case for most uses of op check hooking), it must chain the
15475 check function referenced by C<*old_checker_p>.
15477 Taken all together, XS code to hook an op checker should typically look
15478 something like this:
15480 static Perl_check_t nxck_frob;
15481 static OP *myck_frob(pTHX_ OP *op) {
15483 op = nxck_frob(aTHX_ op);
15488 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
15490 If you want to influence compilation of calls to a specific subroutine,
15491 then use L</cv_set_call_checker_flags> rather than hooking checking of
15492 all C<entersub> ops.
15498 Perl_wrap_op_checker(pTHX_ Optype opcode,
15499 Perl_check_t new_checker, Perl_check_t *old_checker_p)
15502 PERL_UNUSED_CONTEXT;
15503 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15504 if (*old_checker_p) return;
15505 OP_CHECK_MUTEX_LOCK;
15506 if (!*old_checker_p) {
15507 *old_checker_p = PL_check[opcode];
15508 PL_check[opcode] = new_checker;
15510 OP_CHECK_MUTEX_UNLOCK;
15515 /* Efficient sub that returns a constant scalar value. */
15517 const_sv_xsub(pTHX_ CV* cv)
15520 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15521 PERL_UNUSED_ARG(items);
15531 const_av_xsub(pTHX_ CV* cv)
15534 AV * const av = MUTABLE_AV(XSANY.any_ptr);
15542 if (SvRMAGICAL(av))
15543 Perl_croak(aTHX_ "Magical list constants are not supported");
15544 if (GIMME_V != G_LIST) {
15546 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15549 EXTEND(SP, AvFILLp(av)+1);
15550 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15551 XSRETURN(AvFILLp(av)+1);
15554 /* Copy an existing cop->cop_warnings field.
15555 * If it's one of the standard addresses, just re-use the address.
15556 * This is the e implementation for the DUP_WARNINGS() macro
15560 Perl_dup_warnings(pTHX_ char* warnings)
15562 if (warnings == NULL || specialWARN(warnings))
15565 return rcpv_copy(warnings);
15569 =for apidoc rcpv_new
15571 Create a new shared memory refcounted string with the requested size, and
15572 with the requested initialization and a refcount of 1. The actual space
15573 allocated will be 1 byte more than requested and rcpv_new() will ensure that
15574 the extra byte is a null regardless of any flags settings.
15576 If the RCPVf_NO_COPY flag is set then the pv argument will be
15577 ignored, otherwise the contents of the pv pointer will be copied into
15578 the new buffer or if it is NULL the function will do nothing and return NULL.
15580 If the RCPVf_USE_STRLEN flag is set then the len argument is ignored and
15581 recomputed using C<strlen(pv)>. It is an error to combine RCPVf_USE_STRLEN
15582 and RCPVf_NO_COPY at the same time.
15584 Under DEBUGGING rcpv_new() will assert() if it is asked to create a 0 length
15585 shared string unless the RCPVf_ALLOW_EMPTY flag is set.
15587 The return value from the function is suitable for passing into rcpv_copy() and
15588 rcpv_free(). To access the RCPV * from the returned value use the RCPVx() macro.
15589 The 'len' member of the RCPV struct stores the allocated length (including the
15590 extra byte), but the RCPV_LEN() macro returns the requested length (not
15591 including the extra byte).
15593 Note that rcpv_new() does NOT use a hash table or anything like that to
15594 dedupe inputs given the same text content. Each call with a non-null pv
15595 parameter will produce a distinct pointer with its own refcount regardless of
15602 Perl_rcpv_new(pTHX_ const char *pv, STRLEN len, U32 flags) {
15605 PERL_ARGS_ASSERT_RCPV_NEW;
15607 PERL_UNUSED_CONTEXT;
15609 /* Musn't use both at the same time */
15610 assert((flags & (RCPVf_NO_COPY|RCPVf_USE_STRLEN))!=
15611 (RCPVf_NO_COPY|RCPVf_USE_STRLEN));
15613 if (!pv && (flags & RCPVf_NO_COPY) == 0)
15616 if (flags & RCPVf_USE_STRLEN)
15619 assert(len || (flags & RCPVf_ALLOW_EMPTY));
15621 len++; /* add one for the null we will add to the end */
15623 rcpv = (RCPV *)PerlMemShared_malloc(sizeof(struct rcpv) + len);
15627 rcpv->len = len; /* store length including null,
15628 RCPV_LEN() subtracts 1 to account for this */
15629 rcpv->refcount = 1;
15631 if ((flags & RCPVf_NO_COPY) == 0) {
15632 (void)memcpy(rcpv->pv, pv, len-1);
15634 rcpv->pv[len-1]= '\0'; /* the last byte should always be null */
15639 =for apidoc rcpv_free
15641 refcount decrement a shared memory refcounted string, and when
15642 the refcount goes to 0 free it using perlmemshared_free().
15644 it is the callers responsibility to ensure that the pv is the
15645 result of a rcpv_new() call.
15647 Always returns NULL so it can be used like this:
15649 thing = rcpv_free(thing);
15655 Perl_rcpv_free(pTHX_ char *pv) {
15657 PERL_ARGS_ASSERT_RCPV_FREE;
15659 PERL_UNUSED_CONTEXT;
15663 RCPV *rcpv = RCPVx(pv);
15665 assert(rcpv->refcount);
15669 if (--rcpv->refcount == 0) {
15671 PerlMemShared_free(rcpv);
15678 =for apidoc rcpv_copy
15680 refcount increment a shared memory refcounted string, and when
15681 the refcount goes to 0 free it using PerlMemShared_free().
15683 It is the callers responsibility to ensure that the pv is the
15684 result of a rcpv_new() call.
15686 Returns the same pointer that was passed in.
15688 new = rcpv_copy(pv);
15695 Perl_rcpv_copy(pTHX_ char *pv) {
15697 PERL_ARGS_ASSERT_RCPV_COPY;
15699 PERL_UNUSED_CONTEXT;
15703 RCPV *rcpv = RCPVx(pv);
15711 * ex: set ts=8 sts=4 sw=4 et: