4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * Note that during the build of miniperl, a temporary copy of this file
26 * is made, called opmini.c.
28 * A Perl program is compiled into a tree of OP nodes. Each op contains:
29 * * structural OP pointers to its children and siblings (op_sibling,
30 * op_first etc) that define the tree structure;
31 * * execution order OP pointers (op_next, plus sometimes op_other,
32 * op_lastop etc) that define the execution sequence plus variants;
33 * * a pointer to the C "pp" function that would execute the op;
34 * * any data specific to that op.
35 * For example, an OP_CONST op points to the pp_const() function and to an
36 * SV containing the constant value. When pp_const() is executed, its job
37 * is to push that SV onto the stack.
39 * OPs are mainly created by the newFOO() functions, which are mainly
40 * called from the parser (in perly.y) as the code is parsed. For example
41 * the Perl code $a + $b * $c would cause the equivalent of the following
42 * to be called (oversimplifying a bit):
44 * newBINOP(OP_ADD, flags,
46 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
49 * As the parser reduces low-level rules, it creates little op subtrees;
50 * as higher-level rules are resolved, these subtrees get joined together
51 * as branches on a bigger subtree, until eventually a top-level rule like
52 * a subroutine definition is reduced, at which point there is one large
55 * The execution order pointers (op_next) are generated as the subtrees
56 * are joined together. Consider this sub-expression: A*B + C/D: at the
57 * point when it's just been parsed, the op tree looks like:
65 * with the intended execution order being:
67 * [PREV] => A => B => [*] => C => D => [/] => [+] => [NEXT]
69 * At this point all the nodes' op_next pointers will have been set,
71 * * we don't know what the [NEXT] node will be yet;
72 * * we don't know what the [PREV] node will be yet, but when it gets
73 * created and needs its op_next set, it needs to be set to point to
74 * A, which is non-obvious.
75 * To handle both those cases, we temporarily set the top node's
76 * op_next to point to the first node to be executed in this subtree (A in
77 * this case). This means that initially a subtree's op_next chain,
78 * starting from the top node, will visit each node in execution sequence
79 * then point back at the top node.
80 * When we embed this subtree in a larger tree, its top op_next is used
81 * to get the start node, then is set to point to its new neighbour.
82 * For example the two separate [*],A,B and [/],C,D subtrees would
84 * [*] => A; A => B; B => [*]
86 * [/] => C; C => D; D => [/]
87 * When these two subtrees were joined together to make the [+] subtree,
88 * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89 * set to point to [/]'s op_next, i.e. C.
91 * This op_next linking is done by the LINKLIST() macro and its underlying
92 * op_linklist() function. Given a top-level op, if its op_next is
93 * non-null, it's already been linked, so leave it. Otherwise link it with
94 * its children as described above, possibly recursively if any of the
95 * children have a null op_next.
97 * In summary: given a subtree, its top-level node's op_next will either
99 * NULL: the subtree hasn't been LINKLIST()ed yet;
100 * fake: points to the start op for this subtree;
101 * real: once the subtree has been embedded into a larger tree
106 Here's an older description from Larry.
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
112 An execution-order pass
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines. The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order. (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again). As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node. But
130 it's still not the real execution order.
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer. At that point, we can call
135 into peep() to do that code's portion of the 3rd pass. It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140 get the compile time state of %^H for that block. Storing %^H in every
141 block (or even COP) would be very expensive, so a different approach is
142 taken. The (running) state of %^H is serialised into a tree of HE-like
143 structs. Stores into %^H are chained onto the current leaf as a struct
144 refcounted_he * with the key and the value. Deletes from %^H are saved
145 with a value of PL_sv_placeholder. The state of %^H at any point can be
146 turned back into a regular HV by walking back up the tree from that point's
147 leaf, ignoring any key you've already seen (placeholder or not), storing
148 the rest into the HV structure, then removing the placeholders. Hence
149 memory is only used to store the %^H deltas from the enclosing COP, rather
150 than the entire %^H on each COP.
152 To cause actions on %^H to write out the serialisation records, it has
153 magic type 'H'. This magic (itself) does nothing, but its presence causes
154 the values to gain magic type 'h', which has entries for set and clear.
155 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158 it will be correctly restored when any inner compiling scope is exited.
164 #include "keywords.h"
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
174 /* Used to avoid recursion through the op tree in scalarvoid() and
179 SSize_t defer_stack_alloc = 0; \
180 SSize_t defer_ix = -1; \
181 OP **defer_stack = NULL;
182 #define DEFER_OP_CLEANUP Safefree(defer_stack)
183 #define DEFERRED_OP_STEP 100
184 #define DEFER_OP(o) \
186 if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
187 defer_stack_alloc += DEFERRED_OP_STEP; \
188 assert(defer_stack_alloc > 0); \
189 Renew(defer_stack, defer_stack_alloc, OP *); \
191 defer_stack[++defer_ix] = o; \
193 #define DEFER_REVERSE(count) \
197 OP **top = defer_stack + defer_ix; \
198 /* top - (cnt) + 1 isn't safe here */ \
199 OP **bottom = top - (cnt - 1); \
201 assert(bottom >= defer_stack); \
202 while (top > bottom) { \
210 #define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
212 /* remove any leading "empty" ops from the op_next chain whose first
213 * node's address is stored in op_p. Store the updated address of the
214 * first node in op_p.
218 S_prune_chain_head(OP** op_p)
221 && ( (*op_p)->op_type == OP_NULL
222 || (*op_p)->op_type == OP_SCOPE
223 || (*op_p)->op_type == OP_SCALAR
224 || (*op_p)->op_type == OP_LINESEQ)
226 *op_p = (*op_p)->op_next;
230 /* See the explanatory comments above struct opslab in op.h. */
232 #ifdef PERL_DEBUG_READONLY_OPS
233 # define PERL_SLAB_SIZE 128
234 # define PERL_MAX_SLAB_SIZE 4096
235 # include <sys/mman.h>
238 #ifndef PERL_SLAB_SIZE
239 # define PERL_SLAB_SIZE 64
241 #ifndef PERL_MAX_SLAB_SIZE
242 # define PERL_MAX_SLAB_SIZE 2048
245 /* rounds up to nearest pointer */
246 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
247 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
250 S_new_slab(pTHX_ size_t sz)
252 #ifdef PERL_DEBUG_READONLY_OPS
253 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
254 PROT_READ|PROT_WRITE,
255 MAP_ANON|MAP_PRIVATE, -1, 0);
256 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
257 (unsigned long) sz, slab));
258 if (slab == MAP_FAILED) {
259 perror("mmap failed");
262 slab->opslab_size = (U16)sz;
264 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
267 /* The context is unused in non-Windows */
270 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
274 /* requires double parens and aTHX_ */
275 #define DEBUG_S_warn(args) \
277 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
281 Perl_Slab_Alloc(pTHX_ size_t sz)
289 /* We only allocate ops from the slab during subroutine compilation.
290 We find the slab via PL_compcv, hence that must be non-NULL. It could
291 also be pointing to a subroutine which is now fully set up (CvROOT()
292 pointing to the top of the optree for that sub), or a subroutine
293 which isn't using the slab allocator. If our sanity checks aren't met,
294 don't use a slab, but allocate the OP directly from the heap. */
295 if (!PL_compcv || CvROOT(PL_compcv)
296 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
298 o = (OP*)PerlMemShared_calloc(1, sz);
302 /* While the subroutine is under construction, the slabs are accessed via
303 CvSTART(), to avoid needing to expand PVCV by one pointer for something
304 unneeded at runtime. Once a subroutine is constructed, the slabs are
305 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
306 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
308 if (!CvSTART(PL_compcv)) {
310 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
311 CvSLABBED_on(PL_compcv);
312 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
314 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
316 opsz = SIZE_TO_PSIZE(sz);
317 sz = opsz + OPSLOT_HEADER_P;
319 /* The slabs maintain a free list of OPs. In particular, constant folding
320 will free up OPs, so it makes sense to re-use them where possible. A
321 freed up slot is used in preference to a new allocation. */
322 if (slab->opslab_freed) {
323 OP **too = &slab->opslab_freed;
325 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
326 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
327 DEBUG_S_warn((aTHX_ "Alas! too small"));
328 o = *(too = &o->op_next);
329 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
333 Zero(o, opsz, I32 *);
339 #define INIT_OPSLOT \
340 slot->opslot_slab = slab; \
341 slot->opslot_next = slab2->opslab_first; \
342 slab2->opslab_first = slot; \
343 o = &slot->opslot_op; \
346 /* The partially-filled slab is next in the chain. */
347 slab2 = slab->opslab_next ? slab->opslab_next : slab;
348 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
349 /* Remaining space is too small. */
351 /* If we can fit a BASEOP, add it to the free chain, so as not
353 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
354 slot = &slab2->opslab_slots;
356 o->op_type = OP_FREED;
357 o->op_next = slab->opslab_freed;
358 slab->opslab_freed = o;
361 /* Create a new slab. Make this one twice as big. */
362 slot = slab2->opslab_first;
363 while (slot->opslot_next) slot = slot->opslot_next;
364 slab2 = S_new_slab(aTHX_
365 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
367 : (DIFF(slab2, slot)+1)*2);
368 slab2->opslab_next = slab->opslab_next;
369 slab->opslab_next = slab2;
371 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
373 /* Create a new op slot */
374 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
375 assert(slot >= &slab2->opslab_slots);
376 if (DIFF(&slab2->opslab_slots, slot)
377 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
378 slot = &slab2->opslab_slots;
380 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
383 /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
384 assert(!o->op_moresib);
385 assert(!o->op_sibparent);
392 #ifdef PERL_DEBUG_READONLY_OPS
394 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
396 PERL_ARGS_ASSERT_SLAB_TO_RO;
398 if (slab->opslab_readonly) return;
399 slab->opslab_readonly = 1;
400 for (; slab; slab = slab->opslab_next) {
401 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
402 (unsigned long) slab->opslab_size, slab));*/
403 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
404 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
405 (unsigned long)slab->opslab_size, errno);
410 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
414 PERL_ARGS_ASSERT_SLAB_TO_RW;
416 if (!slab->opslab_readonly) return;
418 for (; slab2; slab2 = slab2->opslab_next) {
419 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
420 (unsigned long) size, slab2));*/
421 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
422 PROT_READ|PROT_WRITE)) {
423 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
424 (unsigned long)slab2->opslab_size, errno);
427 slab->opslab_readonly = 0;
431 # define Slab_to_rw(op) NOOP
434 /* This cannot possibly be right, but it was copied from the old slab
435 allocator, to which it was originally added, without explanation, in
438 # define PerlMemShared PerlMem
441 /* make freed ops die if they're inadvertently executed */
446 DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
451 Perl_Slab_Free(pTHX_ void *op)
453 OP * const o = (OP *)op;
456 PERL_ARGS_ASSERT_SLAB_FREE;
459 o->op_ppaddr = S_pp_freed;
462 if (!o->op_slabbed) {
464 PerlMemShared_free(op);
469 /* If this op is already freed, our refcount will get screwy. */
470 assert(o->op_type != OP_FREED);
471 o->op_type = OP_FREED;
472 o->op_next = slab->opslab_freed;
473 slab->opslab_freed = o;
474 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
475 OpslabREFCNT_dec_padok(slab);
479 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
481 const bool havepad = !!PL_comppad;
482 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
485 PAD_SAVE_SETNULLPAD();
492 Perl_opslab_free(pTHX_ OPSLAB *slab)
495 PERL_ARGS_ASSERT_OPSLAB_FREE;
497 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
498 assert(slab->opslab_refcnt == 1);
500 slab2 = slab->opslab_next;
502 slab->opslab_refcnt = ~(size_t)0;
504 #ifdef PERL_DEBUG_READONLY_OPS
505 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
507 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
508 perror("munmap failed");
512 PerlMemShared_free(slab);
519 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
523 size_t savestack_count = 0;
525 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
529 for (slot = slab2->opslab_first;
531 slot = slot->opslot_next) {
532 if (slot->opslot_op.op_type != OP_FREED
533 && !(slot->opslot_op.op_savefree
539 assert(slot->opslot_op.op_slabbed);
540 op_free(&slot->opslot_op);
541 if (slab->opslab_refcnt == 1) goto free;
544 } while ((slab2 = slab2->opslab_next));
545 /* > 1 because the CV still holds a reference count. */
546 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
548 assert(savestack_count == slab->opslab_refcnt-1);
550 /* Remove the CV’s reference count. */
551 slab->opslab_refcnt--;
558 #ifdef PERL_DEBUG_READONLY_OPS
560 Perl_op_refcnt_inc(pTHX_ OP *o)
563 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
564 if (slab && slab->opslab_readonly) {
577 Perl_op_refcnt_dec(pTHX_ OP *o)
580 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
582 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
584 if (slab && slab->opslab_readonly) {
586 result = --o->op_targ;
589 result = --o->op_targ;
595 * In the following definition, the ", (OP*)0" is just to make the compiler
596 * think the expression is of the right type: croak actually does a Siglongjmp.
598 #define CHECKOP(type,o) \
599 ((PL_op_mask && PL_op_mask[type]) \
600 ? ( op_free((OP*)o), \
601 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
603 : PL_check[type](aTHX_ (OP*)o))
605 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
607 #define OpTYPE_set(o,type) \
609 o->op_type = (OPCODE)type; \
610 o->op_ppaddr = PL_ppaddr[type]; \
614 S_no_fh_allowed(pTHX_ OP *o)
616 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
618 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
624 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
626 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
627 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
632 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
634 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
636 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
641 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
643 PERL_ARGS_ASSERT_BAD_TYPE_PV;
645 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
646 (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
649 /* remove flags var, its unused in all callers, move to to right end since gv
650 and kid are always the same */
652 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
654 SV * const namesv = cv_name((CV *)gv, NULL, 0);
655 PERL_ARGS_ASSERT_BAD_TYPE_GV;
657 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
658 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
662 S_no_bareword_allowed(pTHX_ OP *o)
664 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
666 qerror(Perl_mess(aTHX_
667 "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
669 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
672 /* "register" allocation */
675 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
678 const bool is_our = (PL_parser->in_my == KEY_our);
680 PERL_ARGS_ASSERT_ALLOCMY;
682 if (flags & ~SVf_UTF8)
683 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
686 /* complain about "my $<special_var>" etc etc */
690 || ( (flags & SVf_UTF8)
691 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
692 || (name[1] == '_' && len > 2)))
694 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
696 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
697 /* diag_listed_as: Can't use global %s in "%s" */
698 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
699 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
700 PL_parser->in_my == KEY_state ? "state" : "my"));
702 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
703 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
707 /* allocate a spare slot and store the name in that slot */
709 off = pad_add_name_pvn(name, len,
710 (is_our ? padadd_OUR :
711 PL_parser->in_my == KEY_state ? padadd_STATE : 0),
712 PL_parser->in_my_stash,
714 /* $_ is always in main::, even with our */
715 ? (PL_curstash && !memEQs(name,len,"$_")
721 /* anon sub prototypes contains state vars should always be cloned,
722 * otherwise the state var would be shared between anon subs */
724 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
725 CvCLONE_on(PL_compcv);
731 =head1 Optree Manipulation Functions
733 =for apidoc alloccopstash
735 Available only under threaded builds, this function allocates an entry in
736 C<PL_stashpad> for the stash passed to it.
743 Perl_alloccopstash(pTHX_ HV *hv)
745 PADOFFSET off = 0, o = 1;
746 bool found_slot = FALSE;
748 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
750 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
752 for (; o < PL_stashpadmax; ++o) {
753 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
754 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
755 found_slot = TRUE, off = o;
758 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
759 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
760 off = PL_stashpadmax;
761 PL_stashpadmax += 10;
764 PL_stashpad[PL_stashpadix = off] = hv;
769 /* free the body of an op without examining its contents.
770 * Always use this rather than FreeOp directly */
773 S_op_destroy(pTHX_ OP *o)
781 =for apidoc Am|void|op_free|OP *o
783 Free an op. Only use this when an op is no longer linked to from any
790 Perl_op_free(pTHX_ OP *o)
798 /* Though ops may be freed twice, freeing the op after its slab is a
800 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
801 /* During the forced freeing of ops after compilation failure, kidops
802 may be freed before their parents. */
803 if (!o || o->op_type == OP_FREED)
808 /* an op should only ever acquire op_private flags that we know about.
809 * If this fails, you may need to fix something in regen/op_private.
810 * Don't bother testing if:
811 * * the op_ppaddr doesn't match the op; someone may have
812 * overridden the op and be doing strange things with it;
813 * * we've errored, as op flags are often left in an
814 * inconsistent state then. Note that an error when
815 * compiling the main program leaves PL_parser NULL, so
816 * we can't spot faults in the main code, only
817 * evaled/required code */
819 if ( o->op_ppaddr == PL_ppaddr[o->op_type]
821 && !PL_parser->error_count)
823 assert(!(o->op_private & ~PL_op_private_valid[type]));
827 if (o->op_private & OPpREFCOUNTED) {
838 refcnt = OpREFCNT_dec(o);
841 /* Need to find and remove any pattern match ops from the list
842 we maintain for reset(). */
843 find_and_forget_pmops(o);
853 /* Call the op_free hook if it has been set. Do it now so that it's called
854 * at the right time for refcounted ops, but still before all of the kids
858 if (o->op_flags & OPf_KIDS) {
860 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
861 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
862 if (!kid || kid->op_type == OP_FREED)
863 /* During the forced freeing of ops after
864 compilation failure, kidops may be freed before
867 if (!(kid->op_flags & OPf_KIDS))
868 /* If it has no kids, just free it now */
875 type = (OPCODE)o->op_targ;
878 Slab_to_rw(OpSLAB(o));
880 /* COP* is not cleared by op_clear() so that we may track line
881 * numbers etc even after null() */
882 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
890 } while ( (o = POP_DEFERRED_OP()) );
895 /* S_op_clear_gv(): free a GV attached to an OP */
899 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
901 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
905 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
906 || o->op_type == OP_MULTIDEREF)
909 ? ((GV*)PAD_SVl(*ixp)) : NULL;
911 ? (GV*)(*svp) : NULL;
913 /* It's possible during global destruction that the GV is freed
914 before the optree. Whilst the SvREFCNT_inc is happy to bump from
915 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
916 will trigger an assertion failure, because the entry to sv_clear
917 checks that the scalar is not already freed. A check of for
918 !SvIS_FREED(gv) turns out to be invalid, because during global
919 destruction the reference count can be forced down to zero
920 (with SVf_BREAK set). In which case raising to 1 and then
921 dropping to 0 triggers cleanup before it should happen. I
922 *think* that this might actually be a general, systematic,
923 weakness of the whole idea of SVf_BREAK, in that code *is*
924 allowed to raise and lower references during global destruction,
925 so any *valid* code that happens to do this during global
926 destruction might well trigger premature cleanup. */
927 bool still_valid = gv && SvREFCNT(gv);
930 SvREFCNT_inc_simple_void(gv);
933 pad_swipe(*ixp, TRUE);
941 int try_downgrade = SvREFCNT(gv) == 2;
944 gv_try_downgrade(gv);
950 Perl_op_clear(pTHX_ OP *o)
955 PERL_ARGS_ASSERT_OP_CLEAR;
957 switch (o->op_type) {
958 case OP_NULL: /* Was holding old type, if any. */
961 case OP_ENTEREVAL: /* Was holding hints. */
962 case OP_ARGDEFELEM: /* Was holding signature index. */
966 if (!(o->op_flags & OPf_REF)
967 || (PL_check[o->op_type] != Perl_ck_ftst))
974 S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
976 S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
979 case OP_METHOD_REDIR:
980 case OP_METHOD_REDIR_SUPER:
982 if (cMETHOPx(o)->op_rclass_targ) {
983 pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
984 cMETHOPx(o)->op_rclass_targ = 0;
987 SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
988 cMETHOPx(o)->op_rclass_sv = NULL;
991 case OP_METHOD_NAMED:
992 case OP_METHOD_SUPER:
993 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
994 cMETHOPx(o)->op_u.op_meth_sv = NULL;
997 pad_swipe(o->op_targ, 1);
1004 SvREFCNT_dec(cSVOPo->op_sv);
1005 cSVOPo->op_sv = NULL;
1008 Even if op_clear does a pad_free for the target of the op,
1009 pad_free doesn't actually remove the sv that exists in the pad;
1010 instead it lives on. This results in that it could be reused as
1011 a target later on when the pad was reallocated.
1014 pad_swipe(o->op_targ,1);
1024 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1029 if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1030 && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1033 if (cPADOPo->op_padix > 0) {
1034 pad_swipe(cPADOPo->op_padix, TRUE);
1035 cPADOPo->op_padix = 0;
1038 SvREFCNT_dec(cSVOPo->op_sv);
1039 cSVOPo->op_sv = NULL;
1043 PerlMemShared_free(cPVOPo->op_pv);
1044 cPVOPo->op_pv = NULL;
1048 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1052 if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */
1053 && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */
1055 if (o->op_private & OPpSPLIT_LEX)
1056 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1059 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1061 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1068 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1069 op_free(cPMOPo->op_code_list);
1070 cPMOPo->op_code_list = NULL;
1071 forget_pmop(cPMOPo);
1072 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1073 /* we use the same protection as the "SAFE" version of the PM_ macros
1074 * here since sv_clean_all might release some PMOPs
1075 * after PL_regex_padav has been cleared
1076 * and the clearing of PL_regex_padav needs to
1077 * happen before sv_clean_all
1080 if(PL_regex_pad) { /* We could be in destruction */
1081 const IV offset = (cPMOPo)->op_pmoffset;
1082 ReREFCNT_dec(PM_GETRE(cPMOPo));
1083 PL_regex_pad[offset] = &PL_sv_undef;
1084 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1088 ReREFCNT_dec(PM_GETRE(cPMOPo));
1089 PM_SETRE(cPMOPo, NULL);
1095 PerlMemShared_free(cUNOP_AUXo->op_aux);
1098 case OP_MULTICONCAT:
1100 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1101 /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1102 * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1103 * utf8 shared strings */
1104 char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1105 char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1107 PerlMemShared_free(p1);
1109 PerlMemShared_free(p2);
1110 PerlMemShared_free(aux);
1116 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1117 UV actions = items->uv;
1119 bool is_hash = FALSE;
1122 switch (actions & MDEREF_ACTION_MASK) {
1125 actions = (++items)->uv;
1128 case MDEREF_HV_padhv_helem:
1131 case MDEREF_AV_padav_aelem:
1132 pad_free((++items)->pad_offset);
1135 case MDEREF_HV_gvhv_helem:
1138 case MDEREF_AV_gvav_aelem:
1140 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1142 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1146 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1149 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1151 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1153 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1155 goto do_vivify_rv2xv_elem;
1157 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1160 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1161 pad_free((++items)->pad_offset);
1162 goto do_vivify_rv2xv_elem;
1164 case MDEREF_HV_pop_rv2hv_helem:
1165 case MDEREF_HV_vivify_rv2hv_helem:
1168 do_vivify_rv2xv_elem:
1169 case MDEREF_AV_pop_rv2av_aelem:
1170 case MDEREF_AV_vivify_rv2av_aelem:
1172 switch (actions & MDEREF_INDEX_MASK) {
1173 case MDEREF_INDEX_none:
1176 case MDEREF_INDEX_const:
1180 pad_swipe((++items)->pad_offset, 1);
1182 SvREFCNT_dec((++items)->sv);
1188 case MDEREF_INDEX_padsv:
1189 pad_free((++items)->pad_offset);
1191 case MDEREF_INDEX_gvsv:
1193 S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1195 S_op_clear_gv(aTHX_ o, &((++items)->sv));
1200 if (actions & MDEREF_FLAG_last)
1213 actions >>= MDEREF_SHIFT;
1216 /* start of malloc is at op_aux[-1], where the length is
1218 PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1223 if (o->op_targ > 0) {
1224 pad_free(o->op_targ);
1230 S_cop_free(pTHX_ COP* cop)
1232 PERL_ARGS_ASSERT_COP_FREE;
1235 if (! specialWARN(cop->cop_warnings))
1236 PerlMemShared_free(cop->cop_warnings);
1237 cophh_free(CopHINTHASH_get(cop));
1238 if (PL_curcop == cop)
1243 S_forget_pmop(pTHX_ PMOP *const o)
1245 HV * const pmstash = PmopSTASH(o);
1247 PERL_ARGS_ASSERT_FORGET_PMOP;
1249 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1250 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1252 PMOP **const array = (PMOP**) mg->mg_ptr;
1253 U32 count = mg->mg_len / sizeof(PMOP**);
1257 if (array[i] == o) {
1258 /* Found it. Move the entry at the end to overwrite it. */
1259 array[i] = array[--count];
1260 mg->mg_len = count * sizeof(PMOP**);
1261 /* Could realloc smaller at this point always, but probably
1262 not worth it. Probably worth free()ing if we're the
1265 Safefree(mg->mg_ptr);
1278 S_find_and_forget_pmops(pTHX_ OP *o)
1280 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1282 if (o->op_flags & OPf_KIDS) {
1283 OP *kid = cUNOPo->op_first;
1285 switch (kid->op_type) {
1290 forget_pmop((PMOP*)kid);
1292 find_and_forget_pmops(kid);
1293 kid = OpSIBLING(kid);
1299 =for apidoc Am|void|op_null|OP *o
1301 Neutralizes an op when it is no longer needed, but is still linked to from
1308 Perl_op_null(pTHX_ OP *o)
1312 PERL_ARGS_ASSERT_OP_NULL;
1314 if (o->op_type == OP_NULL)
1317 o->op_targ = o->op_type;
1318 OpTYPE_set(o, OP_NULL);
1322 Perl_op_refcnt_lock(pTHX)
1323 PERL_TSA_ACQUIRE(PL_op_mutex)
1328 PERL_UNUSED_CONTEXT;
1333 Perl_op_refcnt_unlock(pTHX)
1334 PERL_TSA_RELEASE(PL_op_mutex)
1339 PERL_UNUSED_CONTEXT;
1345 =for apidoc op_sibling_splice
1347 A general function for editing the structure of an existing chain of
1348 op_sibling nodes. By analogy with the perl-level C<splice()> function, allows
1349 you to delete zero or more sequential nodes, replacing them with zero or
1350 more different nodes. Performs the necessary op_first/op_last
1351 housekeeping on the parent node and op_sibling manipulation on the
1352 children. The last deleted node will be marked as as the last node by
1353 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1355 Note that op_next is not manipulated, and nodes are not freed; that is the
1356 responsibility of the caller. It also won't create a new list op for an
1357 empty list etc; use higher-level functions like op_append_elem() for that.
1359 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1360 the splicing doesn't affect the first or last op in the chain.
1362 C<start> is the node preceding the first node to be spliced. Node(s)
1363 following it will be deleted, and ops will be inserted after it. If it is
1364 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1367 C<del_count> is the number of nodes to delete. If zero, no nodes are deleted.
1368 If -1 or greater than or equal to the number of remaining kids, all
1369 remaining kids are deleted.
1371 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1372 If C<NULL>, no nodes are inserted.
1374 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1379 action before after returns
1380 ------ ----- ----- -------
1383 splice(P, A, 2, X-Y-Z) | | B-C
1387 splice(P, NULL, 1, X-Y) | | A
1391 splice(P, NULL, 3, NULL) | | A-B-C
1395 splice(P, B, 0, X-Y) | | NULL
1399 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1400 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1406 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1410 OP *last_del = NULL;
1411 OP *last_ins = NULL;
1414 first = OpSIBLING(start);
1418 first = cLISTOPx(parent)->op_first;
1420 assert(del_count >= -1);
1422 if (del_count && first) {
1424 while (--del_count && OpHAS_SIBLING(last_del))
1425 last_del = OpSIBLING(last_del);
1426 rest = OpSIBLING(last_del);
1427 OpLASTSIB_set(last_del, NULL);
1434 while (OpHAS_SIBLING(last_ins))
1435 last_ins = OpSIBLING(last_ins);
1436 OpMAYBESIB_set(last_ins, rest, NULL);
1442 OpMAYBESIB_set(start, insert, NULL);
1447 cLISTOPx(parent)->op_first = insert;
1449 parent->op_flags |= OPf_KIDS;
1451 parent->op_flags &= ~OPf_KIDS;
1455 /* update op_last etc */
1462 /* ought to use OP_CLASS(parent) here, but that can't handle
1463 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1465 type = parent->op_type;
1466 if (type == OP_CUSTOM) {
1468 type = XopENTRYCUSTOM(parent, xop_class);
1471 if (type == OP_NULL)
1472 type = parent->op_targ;
1473 type = PL_opargs[type] & OA_CLASS_MASK;
1476 lastop = last_ins ? last_ins : start ? start : NULL;
1477 if ( type == OA_BINOP
1478 || type == OA_LISTOP
1482 cLISTOPx(parent)->op_last = lastop;
1485 OpLASTSIB_set(lastop, parent);
1487 return last_del ? first : NULL;
1490 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1494 =for apidoc op_parent
1496 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1502 Perl_op_parent(OP *o)
1504 PERL_ARGS_ASSERT_OP_PARENT;
1505 while (OpHAS_SIBLING(o))
1507 return o->op_sibparent;
1510 /* replace the sibling following start with a new UNOP, which becomes
1511 * the parent of the original sibling; e.g.
1513 * op_sibling_newUNOP(P, A, unop-args...)
1521 * where U is the new UNOP.
1523 * parent and start args are the same as for op_sibling_splice();
1524 * type and flags args are as newUNOP().
1526 * Returns the new UNOP.
1530 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1534 kid = op_sibling_splice(parent, start, 1, NULL);
1535 newop = newUNOP(type, flags, kid);
1536 op_sibling_splice(parent, start, 0, newop);
1541 /* lowest-level newLOGOP-style function - just allocates and populates
1542 * the struct. Higher-level stuff should be done by S_new_logop() /
1543 * newLOGOP(). This function exists mainly to avoid op_first assignment
1544 * being spread throughout this file.
1548 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1553 NewOp(1101, logop, 1, LOGOP);
1554 OpTYPE_set(logop, type);
1555 logop->op_first = first;
1556 logop->op_other = other;
1558 logop->op_flags = OPf_KIDS;
1559 while (kid && OpHAS_SIBLING(kid))
1560 kid = OpSIBLING(kid);
1562 OpLASTSIB_set(kid, (OP*)logop);
1567 /* Contextualizers */
1570 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1572 Applies a syntactic context to an op tree representing an expression.
1573 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1574 or C<G_VOID> to specify the context to apply. The modified op tree
1581 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1583 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1585 case G_SCALAR: return scalar(o);
1586 case G_ARRAY: return list(o);
1587 case G_VOID: return scalarvoid(o);
1589 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1596 =for apidoc Am|OP*|op_linklist|OP *o
1597 This function is the implementation of the L</LINKLIST> macro. It should
1598 not be called directly.
1604 Perl_op_linklist(pTHX_ OP *o)
1608 PERL_ARGS_ASSERT_OP_LINKLIST;
1613 /* establish postfix order */
1614 first = cUNOPo->op_first;
1617 o->op_next = LINKLIST(first);
1620 OP *sibl = OpSIBLING(kid);
1622 kid->op_next = LINKLIST(sibl);
1637 S_scalarkids(pTHX_ OP *o)
1639 if (o && o->op_flags & OPf_KIDS) {
1641 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1648 S_scalarboolean(pTHX_ OP *o)
1650 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1652 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1653 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1654 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1655 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1656 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1657 if (ckWARN(WARN_SYNTAX)) {
1658 const line_t oldline = CopLINE(PL_curcop);
1660 if (PL_parser && PL_parser->copline != NOLINE) {
1661 /* This ensures that warnings are reported at the first line
1662 of the conditional, not the last. */
1663 CopLINE_set(PL_curcop, PL_parser->copline);
1665 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1666 CopLINE_set(PL_curcop, oldline);
1673 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1676 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1677 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1679 const char funny = o->op_type == OP_PADAV
1680 || o->op_type == OP_RV2AV ? '@' : '%';
1681 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1683 if (cUNOPo->op_first->op_type != OP_GV
1684 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1686 return varname(gv, funny, 0, NULL, 0, subscript_type);
1689 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1694 S_op_varname(pTHX_ const OP *o)
1696 return S_op_varname_subscript(aTHX_ o, 1);
1700 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1701 { /* or not so pretty :-) */
1702 if (o->op_type == OP_CONST) {
1704 if (SvPOK(*retsv)) {
1706 *retsv = sv_newmortal();
1707 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1708 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1710 else if (!SvOK(*retsv))
1713 else *retpv = "...";
1717 S_scalar_slice_warning(pTHX_ const OP *o)
1720 const bool h = o->op_type == OP_HSLICE
1721 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1727 SV *keysv = NULL; /* just to silence compiler warnings */
1728 const char *key = NULL;
1730 if (!(o->op_private & OPpSLICEWARNING))
1732 if (PL_parser && PL_parser->error_count)
1733 /* This warning can be nonsensical when there is a syntax error. */
1736 kid = cLISTOPo->op_first;
1737 kid = OpSIBLING(kid); /* get past pushmark */
1738 /* weed out false positives: any ops that can return lists */
1739 switch (kid->op_type) {
1765 /* Don't warn if we have a nulled list either. */
1766 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1769 assert(OpSIBLING(kid));
1770 name = S_op_varname(aTHX_ OpSIBLING(kid));
1771 if (!name) /* XS module fiddling with the op tree */
1773 S_op_pretty(aTHX_ kid, &keysv, &key);
1774 assert(SvPOK(name));
1775 sv_chop(name,SvPVX(name)+1);
1777 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1778 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1779 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1781 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1782 lbrack, key, rbrack);
1784 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1785 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1786 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1788 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1789 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1793 Perl_scalar(pTHX_ OP *o)
1797 /* assumes no premature commitment */
1798 if (!o || (PL_parser && PL_parser->error_count)
1799 || (o->op_flags & OPf_WANT)
1800 || o->op_type == OP_RETURN)
1805 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1807 switch (o->op_type) {
1809 scalar(cBINOPo->op_first);
1810 if (o->op_private & OPpREPEAT_DOLIST) {
1811 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1812 assert(kid->op_type == OP_PUSHMARK);
1813 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1814 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1815 o->op_private &=~ OPpREPEAT_DOLIST;
1822 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1832 if (o->op_flags & OPf_KIDS) {
1833 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1839 kid = cLISTOPo->op_first;
1841 kid = OpSIBLING(kid);
1844 OP *sib = OpSIBLING(kid);
1845 if (sib && kid->op_type != OP_LEAVEWHEN
1846 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1847 || ( sib->op_targ != OP_NEXTSTATE
1848 && sib->op_targ != OP_DBSTATE )))
1854 PL_curcop = &PL_compiling;
1859 kid = cLISTOPo->op_first;
1862 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1867 /* Warn about scalar context */
1868 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1869 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1872 const char *key = NULL;
1874 /* This warning can be nonsensical when there is a syntax error. */
1875 if (PL_parser && PL_parser->error_count)
1878 if (!ckWARN(WARN_SYNTAX)) break;
1880 kid = cLISTOPo->op_first;
1881 kid = OpSIBLING(kid); /* get past pushmark */
1882 assert(OpSIBLING(kid));
1883 name = S_op_varname(aTHX_ OpSIBLING(kid));
1884 if (!name) /* XS module fiddling with the op tree */
1886 S_op_pretty(aTHX_ kid, &keysv, &key);
1887 assert(SvPOK(name));
1888 sv_chop(name,SvPVX(name)+1);
1890 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1891 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1892 "%%%" SVf "%c%s%c in scalar context better written "
1893 "as $%" SVf "%c%s%c",
1894 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1895 lbrack, key, rbrack);
1897 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1898 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1899 "%%%" SVf "%c%" SVf "%c in scalar context better "
1900 "written as $%" SVf "%c%" SVf "%c",
1901 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1902 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1909 Perl_scalarvoid(pTHX_ OP *arg)
1917 PERL_ARGS_ASSERT_SCALARVOID;
1921 SV *useless_sv = NULL;
1922 const char* useless = NULL;
1924 if (o->op_type == OP_NEXTSTATE
1925 || o->op_type == OP_DBSTATE
1926 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1927 || o->op_targ == OP_DBSTATE)))
1928 PL_curcop = (COP*)o; /* for warning below */
1930 /* assumes no premature commitment */
1931 want = o->op_flags & OPf_WANT;
1932 if ((want && want != OPf_WANT_SCALAR)
1933 || (PL_parser && PL_parser->error_count)
1934 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1939 if ((o->op_private & OPpTARGET_MY)
1940 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1942 /* newASSIGNOP has already applied scalar context, which we
1943 leave, as if this op is inside SASSIGN. */
1947 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1949 switch (o->op_type) {
1951 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1955 if (o->op_flags & OPf_STACKED)
1957 if (o->op_type == OP_REPEAT)
1958 scalar(cBINOPo->op_first);
1961 if ((o->op_flags & OPf_STACKED) &&
1962 !(o->op_private & OPpCONCAT_NESTED))
1966 if (o->op_private == 4)
2001 case OP_GETSOCKNAME:
2002 case OP_GETPEERNAME:
2007 case OP_GETPRIORITY:
2032 useless = OP_DESC(o);
2042 case OP_AELEMFAST_LEX:
2046 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2047 /* Otherwise it's "Useless use of grep iterator" */
2048 useless = OP_DESC(o);
2052 if (!(o->op_private & OPpSPLIT_ASSIGN))
2053 useless = OP_DESC(o);
2057 kid = cUNOPo->op_first;
2058 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2059 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2062 useless = "negative pattern binding (!~)";
2066 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2067 useless = "non-destructive substitution (s///r)";
2071 useless = "non-destructive transliteration (tr///r)";
2078 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2079 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2080 useless = "a variable";
2085 if (cSVOPo->op_private & OPpCONST_STRICT)
2086 no_bareword_allowed(o);
2088 if (ckWARN(WARN_VOID)) {
2090 /* don't warn on optimised away booleans, eg
2091 * use constant Foo, 5; Foo || print; */
2092 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2094 /* the constants 0 and 1 are permitted as they are
2095 conventionally used as dummies in constructs like
2096 1 while some_condition_with_side_effects; */
2097 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2099 else if (SvPOK(sv)) {
2100 SV * const dsv = newSVpvs("");
2102 = Perl_newSVpvf(aTHX_
2104 pv_pretty(dsv, SvPVX_const(sv),
2105 SvCUR(sv), 32, NULL, NULL,
2107 | PERL_PV_ESCAPE_NOCLEAR
2108 | PERL_PV_ESCAPE_UNI_DETECT));
2109 SvREFCNT_dec_NN(dsv);
2111 else if (SvOK(sv)) {
2112 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2115 useless = "a constant (undef)";
2118 op_null(o); /* don't execute or even remember it */
2122 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2126 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2130 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2134 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2139 UNOP *refgen, *rv2cv;
2142 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2145 rv2gv = ((BINOP *)o)->op_last;
2146 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2149 refgen = (UNOP *)((BINOP *)o)->op_first;
2151 if (!refgen || (refgen->op_type != OP_REFGEN
2152 && refgen->op_type != OP_SREFGEN))
2155 exlist = (LISTOP *)refgen->op_first;
2156 if (!exlist || exlist->op_type != OP_NULL
2157 || exlist->op_targ != OP_LIST)
2160 if (exlist->op_first->op_type != OP_PUSHMARK
2161 && exlist->op_first != exlist->op_last)
2164 rv2cv = (UNOP*)exlist->op_last;
2166 if (rv2cv->op_type != OP_RV2CV)
2169 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2170 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2171 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2173 o->op_private |= OPpASSIGN_CV_TO_GV;
2174 rv2gv->op_private |= OPpDONT_INIT_GV;
2175 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2187 kid = cLOGOPo->op_first;
2188 if (kid->op_type == OP_NOT
2189 && (kid->op_flags & OPf_KIDS)) {
2190 if (o->op_type == OP_AND) {
2191 OpTYPE_set(o, OP_OR);
2193 OpTYPE_set(o, OP_AND);
2203 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2204 if (!(kid->op_flags & OPf_KIDS))
2211 if (o->op_flags & OPf_STACKED)
2218 if (!(o->op_flags & OPf_KIDS))
2229 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2230 if (!(kid->op_flags & OPf_KIDS))
2236 /* If the first kid after pushmark is something that the padrange
2237 optimisation would reject, then null the list and the pushmark.
2239 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2240 && ( !(kid = OpSIBLING(kid))
2241 || ( kid->op_type != OP_PADSV
2242 && kid->op_type != OP_PADAV
2243 && kid->op_type != OP_PADHV)
2244 || kid->op_private & ~OPpLVAL_INTRO
2245 || !(kid = OpSIBLING(kid))
2246 || ( kid->op_type != OP_PADSV
2247 && kid->op_type != OP_PADAV
2248 && kid->op_type != OP_PADHV)
2249 || kid->op_private & ~OPpLVAL_INTRO)
2251 op_null(cUNOPo->op_first); /* NULL the pushmark */
2252 op_null(o); /* NULL the list */
2264 /* mortalise it, in case warnings are fatal. */
2265 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2266 "Useless use of %" SVf " in void context",
2267 SVfARG(sv_2mortal(useless_sv)));
2270 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2271 "Useless use of %s in void context",
2274 } while ( (o = POP_DEFERRED_OP()) );
2282 S_listkids(pTHX_ OP *o)
2284 if (o && o->op_flags & OPf_KIDS) {
2286 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2293 Perl_list(pTHX_ OP *o)
2297 /* assumes no premature commitment */
2298 if (!o || (o->op_flags & OPf_WANT)
2299 || (PL_parser && PL_parser->error_count)
2300 || o->op_type == OP_RETURN)
2305 if ((o->op_private & OPpTARGET_MY)
2306 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2308 return o; /* As if inside SASSIGN */
2311 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2313 switch (o->op_type) {
2315 list(cBINOPo->op_first);
2318 if (o->op_private & OPpREPEAT_DOLIST
2319 && !(o->op_flags & OPf_STACKED))
2321 list(cBINOPo->op_first);
2322 kid = cBINOPo->op_last;
2323 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2324 && SvIVX(kSVOP_sv) == 1)
2326 op_null(o); /* repeat */
2327 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2329 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2336 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2344 if (!(o->op_flags & OPf_KIDS))
2346 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2347 list(cBINOPo->op_first);
2348 return gen_constant_list(o);
2354 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2355 op_null(cUNOPo->op_first); /* NULL the pushmark */
2356 op_null(o); /* NULL the list */
2361 kid = cLISTOPo->op_first;
2363 kid = OpSIBLING(kid);
2366 OP *sib = OpSIBLING(kid);
2367 if (sib && kid->op_type != OP_LEAVEWHEN)
2373 PL_curcop = &PL_compiling;
2377 kid = cLISTOPo->op_first;
2384 S_scalarseq(pTHX_ OP *o)
2387 const OPCODE type = o->op_type;
2389 if (type == OP_LINESEQ || type == OP_SCOPE ||
2390 type == OP_LEAVE || type == OP_LEAVETRY)
2393 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2394 if ((sib = OpSIBLING(kid))
2395 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2396 || ( sib->op_targ != OP_NEXTSTATE
2397 && sib->op_targ != OP_DBSTATE )))
2402 PL_curcop = &PL_compiling;
2404 o->op_flags &= ~OPf_PARENS;
2405 if (PL_hints & HINT_BLOCK_SCOPE)
2406 o->op_flags |= OPf_PARENS;
2409 o = newOP(OP_STUB, 0);
2414 S_modkids(pTHX_ OP *o, I32 type)
2416 if (o && o->op_flags & OPf_KIDS) {
2418 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2419 op_lvalue(kid, type);
2425 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2426 * const fields. Also, convert CONST keys to HEK-in-SVs.
2427 * rop is the op that retrieves the hash;
2428 * key_op is the first key
2432 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2438 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2440 if (rop->op_first->op_type == OP_PADSV)
2441 /* @$hash{qw(keys here)} */
2442 rop = (UNOP*)rop->op_first;
2444 /* @{$hash}{qw(keys here)} */
2445 if (rop->op_first->op_type == OP_SCOPE
2446 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2448 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2455 lexname = NULL; /* just to silence compiler warnings */
2456 fields = NULL; /* just to silence compiler warnings */
2460 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2461 SvPAD_TYPED(lexname))
2462 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2463 && isGV(*fields) && GvHV(*fields);
2465 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2467 if (key_op->op_type != OP_CONST)
2469 svp = cSVOPx_svp(key_op);
2471 /* make sure it's not a bareword under strict subs */
2472 if (key_op->op_private & OPpCONST_BARE &&
2473 key_op->op_private & OPpCONST_STRICT)
2475 no_bareword_allowed((OP*)key_op);
2478 /* Make the CONST have a shared SV */
2479 if ( !SvIsCOW_shared_hash(sv = *svp)
2480 && SvTYPE(sv) < SVt_PVMG
2485 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2486 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2487 SvREFCNT_dec_NN(sv);
2492 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2494 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2495 "in variable %" PNf " of type %" HEKf,
2496 SVfARG(*svp), PNfARG(lexname),
2497 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2502 /* info returned by S_sprintf_is_multiconcatable() */
2504 struct sprintf_ismc_info {
2505 SSize_t nargs; /* num of args to sprintf (not including the format) */
2506 char *start; /* start of raw format string */
2507 char *end; /* bytes after end of raw format string */
2508 STRLEN total_len; /* total length (in bytes) of format string, not
2509 including '%s' and half of '%%' */
2510 STRLEN variant; /* number of bytes by which total_len_p would grow
2511 if upgraded to utf8 */
2512 bool utf8; /* whether the format is utf8 */
2516 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2517 * i.e. its format argument is a const string with only '%s' and '%%'
2518 * formats, and the number of args is known, e.g.
2519 * sprintf "a=%s f=%s", $a[0], scalar(f());
2521 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2523 * If successful, the sprintf_ismc_info struct pointed to by info will be
2528 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2530 OP *pm, *constop, *kid;
2533 SSize_t nargs, nformats;
2534 STRLEN cur, total_len, variant;
2537 /* if sprintf's behaviour changes, die here so that someone
2538 * can decide whether to enhance this function or skip optimising
2539 * under those new circumstances */
2540 assert(!(o->op_flags & OPf_STACKED));
2541 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2542 assert(!(o->op_private & ~OPpARG4_MASK));
2544 pm = cUNOPo->op_first;
2545 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2547 constop = OpSIBLING(pm);
2548 if (!constop || constop->op_type != OP_CONST)
2550 sv = cSVOPx_sv(constop);
2551 if (SvMAGICAL(sv) || !SvPOK(sv))
2557 /* Scan format for %% and %s and work out how many %s there are.
2558 * Abandon if other format types are found.
2565 for (p = s; p < e; p++) {
2568 if (!UTF8_IS_INVARIANT(*p))
2574 return FALSE; /* lone % at end gives "Invalid conversion" */
2583 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2586 utf8 = cBOOL(SvUTF8(sv));
2590 /* scan args; they must all be in scalar cxt */
2593 kid = OpSIBLING(constop);
2596 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2599 kid = OpSIBLING(kid);
2602 if (nargs != nformats)
2603 return FALSE; /* e.g. sprintf("%s%s", $a); */
2606 info->nargs = nargs;
2609 info->total_len = total_len;
2610 info->variant = variant;
2618 /* S_maybe_multiconcat():
2620 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2621 * convert it (and its children) into an OP_MULTICONCAT. See the code
2622 * comments just before pp_multiconcat() for the full details of what
2623 * OP_MULTICONCAT supports.
2625 * Basically we're looking for an optree with a chain of OP_CONCATS down
2626 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2627 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2635 * STRINGIFY -- PADSV[$x]
2638 * ex-PUSHMARK -- CONCAT/S
2640 * CONCAT/S -- PADSV[$d]
2642 * CONCAT -- CONST["-"]
2644 * PADSV[$a] -- PADSV[$b]
2646 * Note that at this stage the OP_SASSIGN may have already been optimised
2647 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2651 S_maybe_multiconcat(pTHX_ OP *o)
2653 OP *lastkidop; /* the right-most of any kids unshifted onto o */
2654 OP *topop; /* the top-most op in the concat tree (often equals o,
2655 unless there are assign/stringify ops above it */
2656 OP *parentop; /* the parent op of topop (or itself if no parent) */
2657 OP *targmyop; /* the op (if any) with the OPpTARGET_MY flag */
2658 OP *targetop; /* the op corresponding to target=... or target.=... */
2659 OP *stringop; /* the OP_STRINGIFY op, if any */
2660 OP *nextop; /* used for recreating the op_next chain without consts */
2661 OP *kid; /* general-purpose op pointer */
2663 UNOP_AUX_item *lenp;
2664 char *const_str, *p;
2665 struct sprintf_ismc_info sprintf_info;
2667 /* store info about each arg in args[];
2668 * toparg is the highest used slot; argp is a general
2669 * pointer to args[] slots */
2671 void *p; /* initially points to const sv (or null for op);
2672 later, set to SvPV(constsv), with ... */
2673 STRLEN len; /* ... len set to SvPV(..., len) */
2674 } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2678 SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
2681 bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2682 the last-processed arg will the LHS of one,
2683 as args are processed in reverse order */
2684 U8 stacked_last = 0; /* whether the last seen concat op was STACKED */
2685 STRLEN total_len = 0; /* sum of the lengths of the const segments */
2686 U8 flags = 0; /* what will become the op_flags and ... */
2687 U8 private_flags = 0; /* ... op_private of the multiconcat op */
2688 bool is_sprintf = FALSE; /* we're optimising an sprintf */
2689 bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
2690 bool prev_was_const = FALSE; /* previous arg was a const */
2692 /* -----------------------------------------------------------------
2695 * Examine the optree non-destructively to determine whether it's
2696 * suitable to be converted into an OP_MULTICONCAT. Accumulate
2697 * information about the optree in args[].
2707 assert( o->op_type == OP_SASSIGN
2708 || o->op_type == OP_CONCAT
2709 || o->op_type == OP_SPRINTF
2710 || o->op_type == OP_STRINGIFY);
2712 Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2714 /* first see if, at the top of the tree, there is an assign,
2715 * append and/or stringify */
2717 if (topop->op_type == OP_SASSIGN) {
2719 if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2721 if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2723 assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2726 topop = cBINOPo->op_first;
2727 targetop = OpSIBLING(topop);
2728 if (!targetop) /* probably some sort of syntax error */
2731 else if ( topop->op_type == OP_CONCAT
2732 && (topop->op_flags & OPf_STACKED)
2733 && (!(topop->op_private & OPpCONCAT_NESTED))
2738 /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2739 * decide what to do about it */
2740 assert(!(o->op_private & OPpTARGET_MY));
2742 /* barf on unknown flags */
2743 assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2744 private_flags |= OPpMULTICONCAT_APPEND;
2745 targetop = cBINOPo->op_first;
2747 topop = OpSIBLING(targetop);
2749 /* $x .= <FOO> gets optimised to rcatline instead */
2750 if (topop->op_type == OP_READLINE)
2755 /* Can targetop (the LHS) if it's a padsv, be be optimised
2756 * away and use OPpTARGET_MY instead?
2758 if ( (targetop->op_type == OP_PADSV)
2759 && !(targetop->op_private & OPpDEREF)
2760 && !(targetop->op_private & OPpPAD_STATE)
2761 /* we don't support 'my $x .= ...' */
2762 && ( o->op_type == OP_SASSIGN
2763 || !(targetop->op_private & OPpLVAL_INTRO))
2768 if (topop->op_type == OP_STRINGIFY) {
2769 if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2773 /* barf on unknown flags */
2774 assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2776 if ((topop->op_private & OPpTARGET_MY)) {
2777 if (o->op_type == OP_SASSIGN)
2778 return; /* can't have two assigns */
2782 private_flags |= OPpMULTICONCAT_STRINGIFY;
2784 topop = cBINOPx(topop)->op_first;
2785 assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2786 topop = OpSIBLING(topop);
2789 if (topop->op_type == OP_SPRINTF) {
2790 if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2792 if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2793 nargs = sprintf_info.nargs;
2794 total_len = sprintf_info.total_len;
2795 variant = sprintf_info.variant;
2796 utf8 = sprintf_info.utf8;
2798 private_flags |= OPpMULTICONCAT_FAKE;
2800 /* we have an sprintf op rather than a concat optree.
2801 * Skip most of the code below which is associated with
2802 * processing that optree. We also skip phase 2, determining
2803 * whether its cost effective to optimise, since for sprintf,
2804 * multiconcat is *always* faster */
2807 /* note that even if the sprintf itself isn't multiconcatable,
2808 * the expression as a whole may be, e.g. in
2809 * $x .= sprintf("%d",...)
2810 * the sprintf op will be left as-is, but the concat/S op may
2811 * be upgraded to multiconcat
2814 else if (topop->op_type == OP_CONCAT) {
2815 if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2818 if ((topop->op_private & OPpTARGET_MY)) {
2819 if (o->op_type == OP_SASSIGN || targmyop)
2820 return; /* can't have two assigns */
2825 /* Is it safe to convert a sassign/stringify/concat op into
2827 assert((PL_opargs[OP_SASSIGN] & OA_CLASS_MASK) == OA_BINOP);
2828 assert((PL_opargs[OP_CONCAT] & OA_CLASS_MASK) == OA_BINOP);
2829 assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2830 assert((PL_opargs[OP_SPRINTF] & OA_CLASS_MASK) == OA_LISTOP);
2831 STATIC_ASSERT_STMT( STRUCT_OFFSET(BINOP, op_last)
2832 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2833 STATIC_ASSERT_STMT( STRUCT_OFFSET(LISTOP, op_last)
2834 == STRUCT_OFFSET(UNOP_AUX, op_aux));
2836 /* Now scan the down the tree looking for a series of
2837 * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2838 * stacked). For example this tree:
2843 * CONCAT/STACKED -- EXPR5
2845 * CONCAT/STACKED -- EXPR4
2851 * corresponds to an expression like
2853 * (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2855 * Record info about each EXPR in args[]: in particular, whether it is
2856 * a stringifiable OP_CONST and if so what the const sv is.
2858 * The reason why the last concat can't be STACKED is the difference
2861 * ((($a .= $a) .= $a) .= $a) .= $a
2864 * $a . $a . $a . $a . $a
2866 * The main difference between the optrees for those two constructs
2867 * is the presence of the last STACKED. As well as modifying $a,
2868 * the former sees the changed $a between each concat, so if $s is
2869 * initially 'a', the first returns 'a' x 16, while the latter returns
2870 * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2880 if ( kid->op_type == OP_CONCAT
2884 k1 = cUNOPx(kid)->op_first;
2886 /* shouldn't happen except maybe after compile err? */
2890 /* avoid turning (A . B . ($lex = C) ...) into (A . B . C ...) */
2891 if (kid->op_private & OPpTARGET_MY)
2894 stacked_last = (kid->op_flags & OPf_STACKED);
2906 if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
2907 || (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
2909 /* At least two spare slots are needed to decompose both
2910 * concat args. If there are no slots left, continue to
2911 * examine the rest of the optree, but don't push new values
2912 * on args[]. If the optree as a whole is legal for conversion
2913 * (in particular that the last concat isn't STACKED), then
2914 * the first PERL_MULTICONCAT_MAXARG elements of the optree
2915 * can be converted into an OP_MULTICONCAT now, with the first
2916 * child of that op being the remainder of the optree -
2917 * which may itself later be converted to a multiconcat op
2921 /* the last arg is the rest of the optree */
2926 else if ( argop->op_type == OP_CONST
2927 && ((sv = cSVOPx_sv(argop)))
2928 /* defer stringification until runtime of 'constant'
2929 * things that might stringify variantly, e.g. the radix
2930 * point of NVs, or overloaded RVs */
2931 && (SvPOK(sv) || SvIOK(sv))
2932 && (!SvGMAGICAL(sv))
2935 utf8 |= cBOOL(SvUTF8(sv));
2938 /* this const may be demoted back to a plain arg later;
2939 * make sure we have enough arg slots left */
2941 prev_was_const = !prev_was_const;
2946 prev_was_const = FALSE;
2956 return; /* we don't support ((A.=B).=C)...) */
2958 /* look for two adjacent consts and don't fold them together:
2961 * $o->concat("a")->concat("b")
2964 * (but $o .= "a" . "b" should still fold)
2967 bool seen_nonconst = FALSE;
2968 for (argp = toparg; argp >= args; argp--) {
2969 if (argp->p == NULL) {
2970 seen_nonconst = TRUE;
2976 /* both previous and current arg were constants;
2977 * leave the current OP_CONST as-is */
2985 /* -----------------------------------------------------------------
2988 * At this point we have determined that the optree *can* be converted
2989 * into a multiconcat. Having gathered all the evidence, we now decide
2990 * whether it *should*.
2994 /* we need at least one concat action, e.g.:
3000 * otherwise we could be doing something like $x = "foo", which
3001 * if treated as as a concat, would fail to COW.
3003 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3006 /* Benchmarking seems to indicate that we gain if:
3007 * * we optimise at least two actions into a single multiconcat
3008 * (e.g concat+concat, sassign+concat);
3009 * * or if we can eliminate at least 1 OP_CONST;
3010 * * or if we can eliminate a padsv via OPpTARGET_MY
3014 /* eliminated at least one OP_CONST */
3016 /* eliminated an OP_SASSIGN */
3017 || o->op_type == OP_SASSIGN
3018 /* eliminated an OP_PADSV */
3019 || (!targmyop && is_targable)
3021 /* definitely a net gain to optimise */
3024 /* ... if not, what else? */
3026 /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3027 * multiconcat is faster (due to not creating a temporary copy of
3028 * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3034 && topop->op_type == OP_CONCAT
3036 PADOFFSET t = targmyop->op_targ;
3037 OP *k1 = cBINOPx(topop)->op_first;
3038 OP *k2 = cBINOPx(topop)->op_last;
3039 if ( k2->op_type == OP_PADSV
3041 && ( k1->op_type != OP_PADSV
3042 || k1->op_targ != t)
3047 /* need at least two concats */
3048 if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3053 /* -----------------------------------------------------------------
3056 * At this point the optree has been verified as ok to be optimised
3057 * into an OP_MULTICONCAT. Now start changing things.
3062 /* stringify all const args and determine utf8ness */
3065 for (argp = args; argp <= toparg; argp++) {
3066 SV *sv = (SV*)argp->p;
3068 continue; /* not a const op */
3069 if (utf8 && !SvUTF8(sv))
3070 sv_utf8_upgrade_nomg(sv);
3071 argp->p = SvPV_nomg(sv, argp->len);
3072 total_len += argp->len;
3074 /* see if any strings would grow if converted to utf8 */
3076 char *p = (char*)argp->p;
3077 STRLEN len = argp->len;
3080 if (!UTF8_IS_INVARIANT(c))
3086 /* create and populate aux struct */
3090 aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3091 sizeof(UNOP_AUX_item)
3093 PERL_MULTICONCAT_HEADER_SIZE
3094 + ((nargs + 1) * (variant ? 2 : 1))
3097 const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3099 /* Extract all the non-const expressions from the concat tree then
3100 * dispose of the old tree, e.g. convert the tree from this:
3104 * STRINGIFY -- TARGET
3106 * ex-PUSHMARK -- CONCAT
3121 * ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3123 * except that if EXPRi is an OP_CONST, it's discarded.
3125 * During the conversion process, EXPR ops are stripped from the tree
3126 * and unshifted onto o. Finally, any of o's remaining original
3127 * childen are discarded and o is converted into an OP_MULTICONCAT.
3129 * In this middle of this, o may contain both: unshifted args on the
3130 * left, and some remaining original args on the right. lastkidop
3131 * is set to point to the right-most unshifted arg to delineate
3132 * between the two sets.
3137 /* create a copy of the format with the %'s removed, and record
3138 * the sizes of the const string segments in the aux struct */
3140 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3142 p = sprintf_info.start;
3145 for (; p < sprintf_info.end; p++) {
3149 (lenp++)->ssize = q - oldq;
3156 lenp->ssize = q - oldq;
3157 assert((STRLEN)(q - const_str) == total_len);
3159 /* Attach all the args (i.e. the kids of the sprintf) to o (which
3160 * may or may not be topop) The pushmark and const ops need to be
3161 * kept in case they're an op_next entry point.
3163 lastkidop = cLISTOPx(topop)->op_last;
3164 kid = cUNOPx(topop)->op_first; /* pushmark */
3166 op_null(OpSIBLING(kid)); /* const */
3168 kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3169 op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3170 lastkidop->op_next = o;
3175 lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3179 /* Concatenate all const strings into const_str.
3180 * Note that args[] contains the RHS args in reverse order, so
3181 * we scan args[] from top to bottom to get constant strings
3184 for (argp = toparg; argp >= args; argp--) {
3186 /* not a const op */
3187 (++lenp)->ssize = -1;
3189 STRLEN l = argp->len;
3190 Copy(argp->p, p, l, char);
3192 if (lenp->ssize == -1)
3203 for (argp = args; argp <= toparg; argp++) {
3204 /* only keep non-const args, except keep the first-in-next-chain
3205 * arg no matter what it is (but nulled if OP_CONST), because it
3206 * may be the entry point to this subtree from the previous
3209 bool last = (argp == toparg);
3212 /* set prev to the sibling *before* the arg to be cut out,
3213 * e.g. when cutting EXPR:
3218 * prev= CONCAT -- EXPR
3221 if (argp == args && kid->op_type != OP_CONCAT) {
3222 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3223 * so the expression to be cut isn't kid->op_last but
3226 /* find the op before kid */
3228 o2 = cUNOPx(parentop)->op_first;
3229 while (o2 && o2 != kid) {
3237 else if (kid == o && lastkidop)
3238 prev = last ? lastkidop : OpSIBLING(lastkidop);
3240 prev = last ? NULL : cUNOPx(kid)->op_first;
3242 if (!argp->p || last) {
3244 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3245 /* and unshift to front of o */
3246 op_sibling_splice(o, NULL, 0, aop);
3247 /* record the right-most op added to o: later we will
3248 * free anything to the right of it */
3251 aop->op_next = nextop;
3254 /* null the const at start of op_next chain */
3258 nextop = prev->op_next;
3261 /* the last two arguments are both attached to the same concat op */
3262 if (argp < toparg - 1)
3267 /* Populate the aux struct */
3269 aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
3270 aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
3271 aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
3272 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
3273 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
3275 /* if variant > 0, calculate a variant const string and lengths where
3276 * the utf8 version of the string will take 'variant' more bytes than
3280 char *p = const_str;
3281 STRLEN ulen = total_len + variant;
3282 UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3283 UNOP_AUX_item *ulens = lens + (nargs + 1);
3284 char *up = (char*)PerlMemShared_malloc(ulen);
3287 aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
3288 aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3290 for (n = 0; n < (nargs + 1); n++) {
3292 char * orig_up = up;
3293 for (i = (lens++)->ssize; i > 0; i--) {
3295 append_utf8_from_native_byte(c, (U8**)&up);
3297 (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3302 /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3303 * that op's first child - an ex-PUSHMARK - because the op_next of
3304 * the previous op may point to it (i.e. it's the entry point for
3309 ? op_sibling_splice(o, lastkidop, 1, NULL)
3310 : op_sibling_splice(stringop, NULL, 1, NULL);
3311 assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3312 op_sibling_splice(o, NULL, 0, pmop);
3319 * target .= A.B.C...
3325 if (o->op_type == OP_SASSIGN) {
3326 /* Move the target subtree from being the last of o's children
3327 * to being the last of o's preserved children.
3328 * Note the difference between 'target = ...' and 'target .= ...':
3329 * for the former, target is executed last; for the latter,
3332 kid = OpSIBLING(lastkidop);
3333 op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3334 op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3335 lastkidop->op_next = kid->op_next;
3336 lastkidop = targetop;
3339 /* Move the target subtree from being the first of o's
3340 * original children to being the first of *all* o's children.
3343 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3344 op_sibling_splice(o, NULL, 0, targetop); /* and paste*/
3347 /* if the RHS of .= doesn't contain a concat (e.g.
3348 * $x .= "foo"), it gets missed by the "strip ops from the
3349 * tree and add to o" loop earlier */
3350 assert(topop->op_type != OP_CONCAT);
3352 /* in e.g. $x .= "$y", move the $y expression
3353 * from being a child of OP_STRINGIFY to being the
3354 * second child of the OP_CONCAT
3356 assert(cUNOPx(stringop)->op_first == topop);
3357 op_sibling_splice(stringop, NULL, 1, NULL);
3358 op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3360 assert(topop == OpSIBLING(cBINOPo->op_first));
3369 * my $lex = A.B.C...
3372 * The original padsv op is kept but nulled in case it's the
3373 * entry point for the optree (which it will be for
3376 private_flags |= OPpTARGET_MY;
3377 private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3378 o->op_targ = targetop->op_targ;
3379 targetop->op_targ = 0;
3383 flags |= OPf_STACKED;
3385 else if (targmyop) {
3386 private_flags |= OPpTARGET_MY;
3387 if (o != targmyop) {
3388 o->op_targ = targmyop->op_targ;
3389 targmyop->op_targ = 0;
3393 /* detach the emaciated husk of the sprintf/concat optree and free it */
3395 kid = op_sibling_splice(o, lastkidop, 1, NULL);
3401 /* and convert o into a multiconcat */
3403 o->op_flags = (flags|OPf_KIDS|stacked_last
3404 |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3405 o->op_private = private_flags;
3406 o->op_type = OP_MULTICONCAT;
3407 o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT];
3408 cUNOP_AUXo->op_aux = aux;
3412 /* do all the final processing on an optree (e.g. running the peephole
3413 * optimiser on it), then attach it to cv (if cv is non-null)
3417 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3421 /* XXX for some reason, evals, require and main optrees are
3422 * never attached to their CV; instead they just hang off
3423 * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3424 * and get manually freed when appropriate */
3426 startp = &CvSTART(cv);
3428 startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3431 optree->op_private |= OPpREFCOUNTED;
3432 OpREFCNT_set(optree, 1);
3433 optimize_optree(optree);
3435 finalize_optree(optree);
3436 S_prune_chain_head(startp);
3439 /* now that optimizer has done its work, adjust pad values */
3440 pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3441 : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3447 =for apidoc optimize_optree
3449 This function applies some optimisations to the optree in top-down order.
3450 It is called before the peephole optimizer, which processes ops in
3451 execution order. Note that finalize_optree() also does a top-down scan,
3452 but is called *after* the peephole optimizer.
3458 Perl_optimize_optree(pTHX_ OP* o)
3460 PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3463 SAVEVPTR(PL_curcop);
3471 /* helper for optimize_optree() which optimises on op then recurses
3472 * to optimise any children.
3476 S_optimize_op(pTHX_ OP* o)
3480 PERL_ARGS_ASSERT_OPTIMIZE_OP;
3482 assert(o->op_type != OP_FREED);
3484 switch (o->op_type) {
3487 PL_curcop = ((COP*)o); /* for warnings */
3495 S_maybe_multiconcat(aTHX_ o);
3499 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3500 DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
3507 if (o->op_flags & OPf_KIDS) {
3510 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3514 DEFER_REVERSE(child_count);
3516 } while ( ( o = POP_DEFERRED_OP() ) );
3523 =for apidoc finalize_optree
3525 This function finalizes the optree. Should be called directly after
3526 the complete optree is built. It does some additional
3527 checking which can't be done in the normal C<ck_>xxx functions and makes
3528 the tree thread-safe.
3533 Perl_finalize_optree(pTHX_ OP* o)
3535 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3538 SAVEVPTR(PL_curcop);
3546 /* Relocate sv to the pad for thread safety.
3547 * Despite being a "constant", the SV is written to,
3548 * for reference counts, sv_upgrade() etc. */
3549 PERL_STATIC_INLINE void
3550 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3553 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3555 ix = pad_alloc(OP_CONST, SVf_READONLY);
3556 SvREFCNT_dec(PAD_SVl(ix));
3557 PAD_SETSV(ix, *svp);
3558 /* XXX I don't know how this isn't readonly already. */
3559 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3566 =for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
3568 Return the next op in a depth-first traversal of the op tree,
3569 returning NULL when the traversal is complete.
3571 The initial call must supply the root of the tree as both top and o.
3573 For now it's static, but it may be exposed to the API in the future.
3579 S_traverse_op_tree(OP *top, OP *o) {
3582 PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3584 if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3585 return cUNOPo->op_first;
3587 else if ((sib = OpSIBLING(o))) {
3591 OP *parent = o->op_sibparent;
3592 assert(!(o->op_moresib));
3593 while (parent && parent != top) {
3594 OP *sib = OpSIBLING(parent);
3597 parent = parent->op_sibparent;
3605 S_finalize_op(pTHX_ OP* o)
3608 PERL_ARGS_ASSERT_FINALIZE_OP;
3611 assert(o->op_type != OP_FREED);
3613 switch (o->op_type) {
3616 PL_curcop = ((COP*)o); /* for warnings */
3619 if (OpHAS_SIBLING(o)) {
3620 OP *sib = OpSIBLING(o);
3621 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3622 && ckWARN(WARN_EXEC)
3623 && OpHAS_SIBLING(sib))
3625 const OPCODE type = OpSIBLING(sib)->op_type;
3626 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3627 const line_t oldline = CopLINE(PL_curcop);
3628 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3629 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3630 "Statement unlikely to be reached");
3631 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3632 "\t(Maybe you meant system() when you said exec()?)\n");
3633 CopLINE_set(PL_curcop, oldline);
3640 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3641 GV * const gv = cGVOPo_gv;
3642 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3643 /* XXX could check prototype here instead of just carping */
3644 SV * const sv = sv_newmortal();
3645 gv_efullname3(sv, gv, NULL);
3646 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3647 "%" SVf "() called too early to check prototype",
3654 if (cSVOPo->op_private & OPpCONST_STRICT)
3655 no_bareword_allowed(o);
3659 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3664 /* Relocate all the METHOP's SVs to the pad for thread safety. */
3665 case OP_METHOD_NAMED:
3666 case OP_METHOD_SUPER:
3667 case OP_METHOD_REDIR:
3668 case OP_METHOD_REDIR_SUPER:
3669 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3678 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3681 rop = (UNOP*)((BINOP*)o)->op_first;
3686 S_scalar_slice_warning(aTHX_ o);
3690 kid = OpSIBLING(cLISTOPo->op_first);
3691 if (/* I bet there's always a pushmark... */
3692 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3693 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3698 key_op = (SVOP*)(kid->op_type == OP_CONST
3700 : OpSIBLING(kLISTOP->op_first));
3702 rop = (UNOP*)((LISTOP*)o)->op_last;
3705 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3707 S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
3711 if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3715 S_scalar_slice_warning(aTHX_ o);
3719 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3720 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3728 if (o->op_flags & OPf_KIDS) {
3731 /* check that op_last points to the last sibling, and that
3732 * the last op_sibling/op_sibparent field points back to the
3733 * parent, and that the only ops with KIDS are those which are
3734 * entitled to them */
3735 U32 type = o->op_type;
3739 if (type == OP_NULL) {
3741 /* ck_glob creates a null UNOP with ex-type GLOB
3742 * (which is a list op. So pretend it wasn't a listop */
3743 if (type == OP_GLOB)
3746 family = PL_opargs[type] & OA_CLASS_MASK;
3748 has_last = ( family == OA_BINOP
3749 || family == OA_LISTOP
3750 || family == OA_PMOP
3751 || family == OA_LOOP
3753 assert( has_last /* has op_first and op_last, or ...
3754 ... has (or may have) op_first: */
3755 || family == OA_UNOP
3756 || family == OA_UNOP_AUX
3757 || family == OA_LOGOP
3758 || family == OA_BASEOP_OR_UNOP
3759 || family == OA_FILESTATOP
3760 || family == OA_LOOPEXOP
3761 || family == OA_METHOP
3762 || type == OP_CUSTOM
3763 || type == OP_NULL /* new_logop does this */
3766 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3767 if (!OpHAS_SIBLING(kid)) {
3769 assert(kid == cLISTOPo->op_last);
3770 assert(kid->op_sibparent == o);
3775 } while (( o = traverse_op_tree(top, o)) != NULL);
3779 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3781 Propagate lvalue ("modifiable") context to an op and its children.
3782 C<type> represents the context type, roughly based on the type of op that
3783 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3784 because it has no op type of its own (it is signalled by a flag on
3787 This function detects things that can't be modified, such as C<$x+1>, and
3788 generates errors for them. For example, C<$x+1 = 2> would cause it to be
3789 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3791 It also flags things that need to behave specially in an lvalue context,
3792 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3798 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3801 PadnameLVALUE_on(pn);
3802 while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3804 /* RT #127786: cv can be NULL due to an eval within the DB package
3805 * called from an anon sub - anon subs don't have CvOUTSIDE() set
3806 * unless they contain an eval, but calling eval within DB
3807 * pretends the eval was done in the caller's scope.
3811 assert(CvPADLIST(cv));
3813 PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3814 assert(PadnameLEN(pn));
3815 PadnameLVALUE_on(pn);
3820 S_vivifies(const OPCODE type)
3823 case OP_RV2AV: case OP_ASLICE:
3824 case OP_RV2HV: case OP_KVASLICE:
3825 case OP_RV2SV: case OP_HSLICE:
3826 case OP_AELEMFAST: case OP_KVHSLICE:
3835 S_lvref(pTHX_ OP *o, I32 type)
3839 switch (o->op_type) {
3841 for (kid = OpSIBLING(cUNOPo->op_first); kid;
3842 kid = OpSIBLING(kid))
3843 S_lvref(aTHX_ kid, type);
3848 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3849 o->op_flags |= OPf_STACKED;
3850 if (o->op_flags & OPf_PARENS) {
3851 if (o->op_private & OPpLVAL_INTRO) {
3852 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3853 "localized parenthesized array in list assignment"));
3857 OpTYPE_set(o, OP_LVAVREF);
3858 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3859 o->op_flags |= OPf_MOD|OPf_REF;
3862 o->op_private |= OPpLVREF_AV;
3865 kid = cUNOPo->op_first;
3866 if (kid->op_type == OP_NULL)
3867 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3869 o->op_private = OPpLVREF_CV;
3870 if (kid->op_type == OP_GV)
3871 o->op_flags |= OPf_STACKED;
3872 else if (kid->op_type == OP_PADCV) {
3873 o->op_targ = kid->op_targ;
3875 op_free(cUNOPo->op_first);
3876 cUNOPo->op_first = NULL;
3877 o->op_flags &=~ OPf_KIDS;
3882 if (o->op_flags & OPf_PARENS) {
3884 yyerror(Perl_form(aTHX_ "Can't modify reference to "
3885 "parenthesized hash in list assignment"));
3888 o->op_private |= OPpLVREF_HV;
3892 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3893 o->op_flags |= OPf_STACKED;
3896 if (o->op_flags & OPf_PARENS) goto parenhash;
3897 o->op_private |= OPpLVREF_HV;
3900 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3903 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3904 if (o->op_flags & OPf_PARENS) goto slurpy;
3905 o->op_private |= OPpLVREF_AV;
3909 o->op_private |= OPpLVREF_ELEM;
3910 o->op_flags |= OPf_STACKED;
3914 OpTYPE_set(o, OP_LVREFSLICE);
3915 o->op_private &= OPpLVAL_INTRO;
3918 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
3920 else if (!(o->op_flags & OPf_KIDS))
3922 if (o->op_targ != OP_LIST) {
3923 S_lvref(aTHX_ cBINOPo->op_first, type);
3928 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3929 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3930 S_lvref(aTHX_ kid, type);
3934 if (o->op_flags & OPf_PARENS)
3939 /* diag_listed_as: Can't modify reference to %s in %s assignment */
3940 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3941 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3947 OpTYPE_set(o, OP_LVREF);
3949 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3950 if (type == OP_ENTERLOOP)
3951 o->op_private |= OPpLVREF_ITER;
3954 PERL_STATIC_INLINE bool
3955 S_potential_mod_type(I32 type)
3957 /* Types that only potentially result in modification. */
3958 return type == OP_GREPSTART || type == OP_ENTERSUB
3959 || type == OP_REFGEN || type == OP_LEAVESUBLV;
3963 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3967 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3970 if (!o || (PL_parser && PL_parser->error_count))
3973 if ((o->op_private & OPpTARGET_MY)
3974 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3979 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
3981 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3983 switch (o->op_type) {
3988 if ((o->op_flags & OPf_PARENS))
3992 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3993 !(o->op_flags & OPf_STACKED)) {
3994 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
3995 assert(cUNOPo->op_first->op_type == OP_NULL);
3996 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
3999 else { /* lvalue subroutine call */
4000 o->op_private |= OPpLVAL_INTRO;
4001 PL_modcount = RETURN_UNLIMITED_NUMBER;
4002 if (S_potential_mod_type(type)) {
4003 o->op_private |= OPpENTERSUB_INARGS;
4006 else { /* Compile-time error message: */
4007 OP *kid = cUNOPo->op_first;
4012 if (kid->op_type != OP_PUSHMARK) {
4013 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4015 "panic: unexpected lvalue entersub "
4016 "args: type/targ %ld:%" UVuf,
4017 (long)kid->op_type, (UV)kid->op_targ);
4018 kid = kLISTOP->op_first;
4020 while (OpHAS_SIBLING(kid))
4021 kid = OpSIBLING(kid);
4022 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4023 break; /* Postpone until runtime */
4026 kid = kUNOP->op_first;
4027 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4028 kid = kUNOP->op_first;
4029 if (kid->op_type == OP_NULL)
4031 "Unexpected constant lvalue entersub "
4032 "entry via type/targ %ld:%" UVuf,
4033 (long)kid->op_type, (UV)kid->op_targ);
4034 if (kid->op_type != OP_GV) {
4041 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4042 ? MUTABLE_CV(SvRV(gv))
4048 if (flags & OP_LVALUE_NO_CROAK)
4051 namesv = cv_name(cv, NULL, 0);
4052 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4053 "subroutine call of &%" SVf " in %s",
4054 SVfARG(namesv), PL_op_desc[type]),
4062 if (flags & OP_LVALUE_NO_CROAK) return NULL;
4063 /* grep, foreach, subcalls, refgen */
4064 if (S_potential_mod_type(type))
4066 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4067 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4070 type ? PL_op_desc[type] : "local"));
4083 case OP_RIGHT_SHIFT:
4092 if (!(o->op_flags & OPf_STACKED))
4098 if (o->op_flags & OPf_STACKED) {
4102 if (!(o->op_private & OPpREPEAT_DOLIST))
4105 const I32 mods = PL_modcount;
4106 modkids(cBINOPo->op_first, type);
4107 if (type != OP_AASSIGN)
4109 kid = cBINOPo->op_last;
4110 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4111 const IV iv = SvIV(kSVOP_sv);
4112 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4114 mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4117 PL_modcount = RETURN_UNLIMITED_NUMBER;
4123 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4124 op_lvalue(kid, type);
4129 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4130 PL_modcount = RETURN_UNLIMITED_NUMBER;
4131 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4132 fiable since some contexts need to know. */
4133 o->op_flags |= OPf_MOD;
4138 if (scalar_mod_type(o, type))
4140 ref(cUNOPo->op_first, o->op_type);
4147 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
4148 if (type == OP_LEAVESUBLV && (
4149 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4150 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4152 o->op_private |= OPpMAYBE_LVSUB;
4156 PL_modcount = RETURN_UNLIMITED_NUMBER;
4161 if (type == OP_LEAVESUBLV)
4162 o->op_private |= OPpMAYBE_LVSUB;
4165 if (type == OP_LEAVESUBLV
4166 && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4167 o->op_private |= OPpMAYBE_LVSUB;
4170 PL_hints |= HINT_BLOCK_SCOPE;
4171 if (type == OP_LEAVESUBLV)
4172 o->op_private |= OPpMAYBE_LVSUB;
4176 ref(cUNOPo->op_first, o->op_type);
4180 PL_hints |= HINT_BLOCK_SCOPE;
4190 case OP_AELEMFAST_LEX:
4197 PL_modcount = RETURN_UNLIMITED_NUMBER;
4198 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4200 /* Treat \(@foo) like ordinary list, but still mark it as modi-
4201 fiable since some contexts need to know. */
4202 o->op_flags |= OPf_MOD;
4205 if (scalar_mod_type(o, type))
4207 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4208 && type == OP_LEAVESUBLV)
4209 o->op_private |= OPpMAYBE_LVSUB;
4213 if (!type) /* local() */
4214 Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4215 PNfARG(PAD_COMPNAME(o->op_targ)));
4216 if (!(o->op_private & OPpLVAL_INTRO)
4217 || ( type != OP_SASSIGN && type != OP_AASSIGN
4218 && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
4219 S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4227 if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4231 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4237 if (type == OP_LEAVESUBLV)
4238 o->op_private |= OPpMAYBE_LVSUB;
4239 if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4240 /* substr and vec */
4241 /* If this op is in merely potential (non-fatal) modifiable
4242 context, then apply OP_ENTERSUB context to
4243 the kid op (to avoid croaking). Other-
4244 wise pass this op’s own type so the correct op is mentioned
4245 in error messages. */
4246 op_lvalue(OpSIBLING(cBINOPo->op_first),
4247 S_potential_mod_type(type)
4255 ref(cBINOPo->op_first, o->op_type);
4256 if (type == OP_ENTERSUB &&
4257 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4258 o->op_private |= OPpLVAL_DEFER;
4259 if (type == OP_LEAVESUBLV)
4260 o->op_private |= OPpMAYBE_LVSUB;
4267 o->op_private |= OPpLVALUE;
4273 if (o->op_flags & OPf_KIDS)
4274 op_lvalue(cLISTOPo->op_last, type);
4279 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
4281 else if (!(o->op_flags & OPf_KIDS))
4284 if (o->op_targ != OP_LIST) {
4285 OP *sib = OpSIBLING(cLISTOPo->op_first);
4286 /* OP_TRANS and OP_TRANSR with argument have a weird optree
4293 * compared with things like OP_MATCH which have the argument
4299 * so handle specially to correctly get "Can't modify" croaks etc
4302 if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4304 /* this should trigger a "Can't modify transliteration" err */
4305 op_lvalue(sib, type);
4307 op_lvalue(cBINOPo->op_first, type);
4313 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4314 /* elements might be in void context because the list is
4315 in scalar context or because they are attribute sub calls */
4316 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4317 op_lvalue(kid, type);
4325 if (type == OP_LEAVESUBLV
4326 || !S_vivifies(cLOGOPo->op_first->op_type))
4327 op_lvalue(cLOGOPo->op_first, type);
4328 if (type == OP_LEAVESUBLV
4329 || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4330 op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4334 if (type == OP_NULL) { /* local */
4336 if (!FEATURE_MYREF_IS_ENABLED)
4337 Perl_croak(aTHX_ "The experimental declared_refs "
4338 "feature is not enabled");
4339 Perl_ck_warner_d(aTHX_
4340 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4341 "Declaring references is experimental");
4342 op_lvalue(cUNOPo->op_first, OP_NULL);
4345 if (type != OP_AASSIGN && type != OP_SASSIGN
4346 && type != OP_ENTERLOOP)
4348 /* Don’t bother applying lvalue context to the ex-list. */
4349 kid = cUNOPx(cUNOPo->op_first)->op_first;
4350 assert (!OpHAS_SIBLING(kid));
4353 if (type == OP_NULL) /* local */
4355 if (type != OP_AASSIGN) goto nomod;
4356 kid = cUNOPo->op_first;
4359 const U8 ec = PL_parser ? PL_parser->error_count : 0;
4360 S_lvref(aTHX_ kid, type);
4361 if (!PL_parser || PL_parser->error_count == ec) {
4362 if (!FEATURE_REFALIASING_IS_ENABLED)
4364 "Experimental aliasing via reference not enabled");
4365 Perl_ck_warner_d(aTHX_
4366 packWARN(WARN_EXPERIMENTAL__REFALIASING),
4367 "Aliasing via reference is experimental");
4370 if (o->op_type == OP_REFGEN)
4371 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4376 if ((o->op_private & OPpSPLIT_ASSIGN)) {
4377 /* This is actually @array = split. */
4378 PL_modcount = RETURN_UNLIMITED_NUMBER;
4384 op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4388 /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4389 their argument is a filehandle; thus \stat(".") should not set
4391 if (type == OP_REFGEN &&
4392 PL_check[o->op_type] == Perl_ck_ftst)
4395 if (type != OP_LEAVESUBLV)
4396 o->op_flags |= OPf_MOD;
4398 if (type == OP_AASSIGN || type == OP_SASSIGN)
4399 o->op_flags |= OPf_SPECIAL
4400 |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4401 else if (!type) { /* local() */
4404 o->op_private |= OPpLVAL_INTRO;
4405 o->op_flags &= ~OPf_SPECIAL;
4406 PL_hints |= HINT_BLOCK_SCOPE;
4411 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4412 "Useless localization of %s", OP_DESC(o));
4415 else if (type != OP_GREPSTART && type != OP_ENTERSUB
4416 && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4417 o->op_flags |= OPf_REF;
4422 S_scalar_mod_type(const OP *o, I32 type)
4427 if (o && o->op_type == OP_RV2GV)
4451 case OP_RIGHT_SHIFT:
4480 S_is_handle_constructor(const OP *o, I32 numargs)
4482 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4484 switch (o->op_type) {
4492 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
4505 S_refkids(pTHX_ OP *o, I32 type)
4507 if (o && o->op_flags & OPf_KIDS) {
4509 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4516 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4521 PERL_ARGS_ASSERT_DOREF;
4523 if (PL_parser && PL_parser->error_count)
4526 switch (o->op_type) {
4528 if ((type == OP_EXISTS || type == OP_DEFINED) &&
4529 !(o->op_flags & OPf_STACKED)) {
4530 OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
4531 assert(cUNOPo->op_first->op_type == OP_NULL);
4532 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
4533 o->op_flags |= OPf_SPECIAL;
4535 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4536 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4537 : type == OP_RV2HV ? OPpDEREF_HV
4539 o->op_flags |= OPf_MOD;
4545 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4546 doref(kid, type, set_op_ref);
4549 if (type == OP_DEFINED)
4550 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4551 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4554 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4555 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4556 : type == OP_RV2HV ? OPpDEREF_HV
4558 o->op_flags |= OPf_MOD;
4565 o->op_flags |= OPf_REF;
4568 if (type == OP_DEFINED)
4569 o->op_flags |= OPf_SPECIAL; /* don't create GV */
4570 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4576 o->op_flags |= OPf_REF;
4581 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4583 doref(cBINOPo->op_first, type, set_op_ref);
4587 doref(cBINOPo->op_first, o->op_type, set_op_ref);
4588 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4589 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4590 : type == OP_RV2HV ? OPpDEREF_HV
4592 o->op_flags |= OPf_MOD;
4602 if (!(o->op_flags & OPf_KIDS))
4604 doref(cLISTOPo->op_last, type, set_op_ref);
4614 S_dup_attrlist(pTHX_ OP *o)
4618 PERL_ARGS_ASSERT_DUP_ATTRLIST;
4620 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4621 * where the first kid is OP_PUSHMARK and the remaining ones
4622 * are OP_CONST. We need to push the OP_CONST values.
4624 if (o->op_type == OP_CONST)
4625 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4627 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4629 for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4630 if (o->op_type == OP_CONST)
4631 rop = op_append_elem(OP_LIST, rop,
4632 newSVOP(OP_CONST, o->op_flags,
4633 SvREFCNT_inc_NN(cSVOPo->op_sv)));
4640 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4642 PERL_ARGS_ASSERT_APPLY_ATTRS;
4644 SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4646 /* fake up C<use attributes $pkg,$rv,@attrs> */
4648 #define ATTRSMODULE "attributes"
4649 #define ATTRSMODULE_PM "attributes.pm"
4652 aTHX_ PERL_LOADMOD_IMPORT_OPS,
4653 newSVpvs(ATTRSMODULE),
4655 op_prepend_elem(OP_LIST,
4656 newSVOP(OP_CONST, 0, stashsv),
4657 op_prepend_elem(OP_LIST,
4658 newSVOP(OP_CONST, 0,
4660 dup_attrlist(attrs))));
4665 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4667 OP *pack, *imop, *arg;
4668 SV *meth, *stashsv, **svp;
4670 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4675 assert(target->op_type == OP_PADSV ||
4676 target->op_type == OP_PADHV ||
4677 target->op_type == OP_PADAV);
4679 /* Ensure that attributes.pm is loaded. */
4680 /* Don't force the C<use> if we don't need it. */
4681 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4682 if (svp && *svp != &PL_sv_undef)
4683 NOOP; /* already in %INC */
4685 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4686 newSVpvs(ATTRSMODULE), NULL);
4688 /* Need package name for method call. */
4689 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4691 /* Build up the real arg-list. */
4692 stashsv = newSVhek(HvNAME_HEK(stash));
4694 arg = newOP(OP_PADSV, 0);
4695 arg->op_targ = target->op_targ;
4696 arg = op_prepend_elem(OP_LIST,
4697 newSVOP(OP_CONST, 0, stashsv),
4698 op_prepend_elem(OP_LIST,
4699 newUNOP(OP_REFGEN, 0,
4701 dup_attrlist(attrs)));
4703 /* Fake up a method call to import */
4704 meth = newSVpvs_share("import");
4705 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4706 op_append_elem(OP_LIST,
4707 op_prepend_elem(OP_LIST, pack, arg),
4708 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
4710 /* Combine the ops. */
4711 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
4715 =notfor apidoc apply_attrs_string
4717 Attempts to apply a list of attributes specified by the C<attrstr> and
4718 C<len> arguments to the subroutine identified by the C<cv> argument which
4719 is expected to be associated with the package identified by the C<stashpv>
4720 argument (see L<attributes>). It gets this wrong, though, in that it
4721 does not correctly identify the boundaries of the individual attribute
4722 specifications within C<attrstr>. This is not really intended for the
4723 public API, but has to be listed here for systems such as AIX which
4724 need an explicit export list for symbols. (It's called from XS code
4725 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
4726 to respect attribute syntax properly would be welcome.
4732 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
4733 const char *attrstr, STRLEN len)
4737 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
4740 len = strlen(attrstr);
4744 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
4746 const char * const sstr = attrstr;
4747 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
4748 attrs = op_append_elem(OP_LIST, attrs,
4749 newSVOP(OP_CONST, 0,
4750 newSVpvn(sstr, attrstr-sstr)));
4754 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
4755 newSVpvs(ATTRSMODULE),
4756 NULL, op_prepend_elem(OP_LIST,
4757 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
4758 op_prepend_elem(OP_LIST,
4759 newSVOP(OP_CONST, 0,
4760 newRV(MUTABLE_SV(cv))),
4765 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
4768 OP *new_proto = NULL;
4773 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
4779 if (o->op_type == OP_CONST) {
4780 pv = SvPV(cSVOPo_sv, pvlen);
4781 if (memBEGINs(pv, pvlen, "prototype(")) {
4782 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4783 SV ** const tmpo = cSVOPx_svp(o);
4784 SvREFCNT_dec(cSVOPo_sv);
4789 } else if (o->op_type == OP_LIST) {
4791 assert(o->op_flags & OPf_KIDS);
4792 lasto = cLISTOPo->op_first;
4793 assert(lasto->op_type == OP_PUSHMARK);
4794 for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
4795 if (o->op_type == OP_CONST) {
4796 pv = SvPV(cSVOPo_sv, pvlen);
4797 if (memBEGINs(pv, pvlen, "prototype(")) {
4798 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
4799 SV ** const tmpo = cSVOPx_svp(o);
4800 SvREFCNT_dec(cSVOPo_sv);
4802 if (new_proto && ckWARN(WARN_MISC)) {
4804 const char * newp = SvPV(cSVOPo_sv, new_len);
4805 Perl_warner(aTHX_ packWARN(WARN_MISC),
4806 "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
4807 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
4813 /* excise new_proto from the list */
4814 op_sibling_splice(*attrs, lasto, 1, NULL);
4821 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4822 would get pulled in with no real need */
4823 if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4832 svname = sv_newmortal();
4833 gv_efullname3(svname, name, NULL);
4835 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4836 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4838 svname = (SV *)name;
4839 if (ckWARN(WARN_ILLEGALPROTO))
4840 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4842 if (*proto && ckWARN(WARN_PROTOTYPE)) {
4843 STRLEN old_len, new_len;
4844 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4845 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4847 if (curstash && svname == (SV *)name
4848 && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4849 svname = sv_2mortal(newSVsv(PL_curstname));
4850 sv_catpvs(svname, "::");
4851 sv_catsv(svname, (SV *)name);
4854 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4855 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4857 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4858 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4868 S_cant_declare(pTHX_ OP *o)
4870 if (o->op_type == OP_NULL
4871 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4872 o = cUNOPo->op_first;
4873 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4874 o->op_type == OP_NULL
4875 && o->op_flags & OPf_SPECIAL
4878 PL_parser->in_my == KEY_our ? "our" :
4879 PL_parser->in_my == KEY_state ? "state" :
4884 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4887 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4889 PERL_ARGS_ASSERT_MY_KID;
4891 if (!o || (PL_parser && PL_parser->error_count))
4896 if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4898 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4899 my_kid(kid, attrs, imopsp);
4901 } else if (type == OP_UNDEF || type == OP_STUB) {
4903 } else if (type == OP_RV2SV || /* "our" declaration */
4906 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4907 S_cant_declare(aTHX_ o);
4909 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4911 PL_parser->in_my = FALSE;
4912 PL_parser->in_my_stash = NULL;
4913 apply_attrs(GvSTASH(gv),
4914 (type == OP_RV2SV ? GvSVn(gv) :
4915 type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4916 type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4919 o->op_private |= OPpOUR_INTRO;
4922 else if (type == OP_REFGEN || type == OP_SREFGEN) {
4923 if (!FEATURE_MYREF_IS_ENABLED)
4924 Perl_croak(aTHX_ "The experimental declared_refs "
4925 "feature is not enabled");
4926 Perl_ck_warner_d(aTHX_
4927 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4928 "Declaring references is experimental");
4929 /* Kid is a nulled OP_LIST, handled above. */
4930 my_kid(cUNOPo->op_first, attrs, imopsp);
4933 else if (type != OP_PADSV &&
4936 type != OP_PUSHMARK)
4938 S_cant_declare(aTHX_ o);
4941 else if (attrs && type != OP_PUSHMARK) {
4945 PL_parser->in_my = FALSE;
4946 PL_parser->in_my_stash = NULL;
4948 /* check for C<my Dog $spot> when deciding package */
4949 stash = PAD_COMPNAME_TYPE(o->op_targ);
4951 stash = PL_curstash;
4952 apply_attrs_my(stash, o, attrs, imopsp);
4954 o->op_flags |= OPf_MOD;
4955 o->op_private |= OPpLVAL_INTRO;
4957 o->op_private |= OPpPAD_STATE;
4962 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4965 int maybe_scalar = 0;
4967 PERL_ARGS_ASSERT_MY_ATTRS;
4969 /* [perl #17376]: this appears to be premature, and results in code such as
4970 C< our(%x); > executing in list mode rather than void mode */
4972 if (o->op_flags & OPf_PARENS)
4982 o = my_kid(o, attrs, &rops);
4984 if (maybe_scalar && o->op_type == OP_PADSV) {
4985 o = scalar(op_append_list(OP_LIST, rops, o));
4986 o->op_private |= OPpLVAL_INTRO;
4989 /* The listop in rops might have a pushmark at the beginning,
4990 which will mess up list assignment. */
4991 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
4992 if (rops->op_type == OP_LIST &&
4993 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4995 OP * const pushmark = lrops->op_first;
4996 /* excise pushmark */
4997 op_sibling_splice(rops, NULL, 1, NULL);
5000 o = op_append_list(OP_LIST, o, rops);
5003 PL_parser->in_my = FALSE;
5004 PL_parser->in_my_stash = NULL;
5009 Perl_sawparens(pTHX_ OP *o)
5011 PERL_UNUSED_CONTEXT;
5013 o->op_flags |= OPf_PARENS;
5018 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
5022 const OPCODE ltype = left->op_type;
5023 const OPCODE rtype = right->op_type;
5025 PERL_ARGS_ASSERT_BIND_MATCH;
5027 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
5028 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
5030 const char * const desc
5032 rtype == OP_SUBST || rtype == OP_TRANS
5033 || rtype == OP_TRANSR
5035 ? (int)rtype : OP_MATCH];
5036 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
5038 S_op_varname(aTHX_ left);
5040 Perl_warner(aTHX_ packWARN(WARN_MISC),
5041 "Applying %s to %" SVf " will act on scalar(%" SVf ")",
5042 desc, SVfARG(name), SVfARG(name));
5044 const char * const sample = (isary
5045 ? "@array" : "%hash");
5046 Perl_warner(aTHX_ packWARN(WARN_MISC),
5047 "Applying %s to %s will act on scalar(%s)",
5048 desc, sample, sample);
5052 if (rtype == OP_CONST &&
5053 cSVOPx(right)->op_private & OPpCONST_BARE &&
5054 cSVOPx(right)->op_private & OPpCONST_STRICT)
5056 no_bareword_allowed(right);
5059 /* !~ doesn't make sense with /r, so error on it for now */
5060 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
5062 /* diag_listed_as: Using !~ with %s doesn't make sense */
5063 yyerror("Using !~ with s///r doesn't make sense");
5064 if (rtype == OP_TRANSR && type == OP_NOT)
5065 /* diag_listed_as: Using !~ with %s doesn't make sense */
5066 yyerror("Using !~ with tr///r doesn't make sense");
5068 ismatchop = (rtype == OP_MATCH ||
5069 rtype == OP_SUBST ||
5070 rtype == OP_TRANS || rtype == OP_TRANSR)
5071 && !(right->op_flags & OPf_SPECIAL);
5072 if (ismatchop && right->op_private & OPpTARGET_MY) {
5074 right->op_private &= ~OPpTARGET_MY;
5076 if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
5077 if (left->op_type == OP_PADSV
5078 && !(left->op_private & OPpLVAL_INTRO))
5080 right->op_targ = left->op_targ;
5085 right->op_flags |= OPf_STACKED;
5086 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
5087 ! (rtype == OP_TRANS &&
5088 right->op_private & OPpTRANS_IDENTICAL) &&
5089 ! (rtype == OP_SUBST &&
5090 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
5091 left = op_lvalue(left, rtype);
5092 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
5093 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
5095 o = op_prepend_elem(rtype, scalar(left), right);
5098 return newUNOP(OP_NOT, 0, scalar(o));
5102 return bind_match(type, left,
5103 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
5107 Perl_invert(pTHX_ OP *o)
5111 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
5115 =for apidoc Amx|OP *|op_scope|OP *o
5117 Wraps up an op tree with some additional ops so that at runtime a dynamic
5118 scope will be created. The original ops run in the new dynamic scope,
5119 and then, provided that they exit normally, the scope will be unwound.
5120 The additional ops used to create and unwind the dynamic scope will
5121 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
5122 instead if the ops are simple enough to not need the full dynamic scope
5129 Perl_op_scope(pTHX_ OP *o)
5133 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
5134 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
5135 OpTYPE_set(o, OP_LEAVE);
5137 else if (o->op_type == OP_LINESEQ) {
5139 OpTYPE_set(o, OP_SCOPE);
5140 kid = ((LISTOP*)o)->op_first;
5141 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
5144 /* The following deals with things like 'do {1 for 1}' */
5145 kid = OpSIBLING(kid);
5147 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
5152 o = newLISTOP(OP_SCOPE, 0, o, NULL);
5158 Perl_op_unscope(pTHX_ OP *o)
5160 if (o && o->op_type == OP_LINESEQ) {
5161 OP *kid = cLISTOPo->op_first;
5162 for(; kid; kid = OpSIBLING(kid))
5163 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
5170 =for apidoc Am|int|block_start|int full
5172 Handles compile-time scope entry.
5173 Arranges for hints to be restored on block
5174 exit and also handles pad sequence numbers to make lexical variables scope
5175 right. Returns a savestack index for use with C<block_end>.
5181 Perl_block_start(pTHX_ int full)
5183 const int retval = PL_savestack_ix;
5185 PL_compiling.cop_seq = PL_cop_seqmax;
5187 pad_block_start(full);
5189 PL_hints &= ~HINT_BLOCK_SCOPE;
5190 SAVECOMPILEWARNINGS();
5191 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
5192 SAVEI32(PL_compiling.cop_seq);
5193 PL_compiling.cop_seq = 0;
5195 CALL_BLOCK_HOOKS(bhk_start, full);
5201 =for apidoc Am|OP *|block_end|I32 floor|OP *seq
5203 Handles compile-time scope exit. C<floor>
5204 is the savestack index returned by
5205 C<block_start>, and C<seq> is the body of the block. Returns the block,
5212 Perl_block_end(pTHX_ I32 floor, OP *seq)
5214 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
5215 OP* retval = scalarseq(seq);
5218 /* XXX Is the null PL_parser check necessary here? */
5219 assert(PL_parser); /* Let’s find out under debugging builds. */
5220 if (PL_parser && PL_parser->parsed_sub) {
5221 o = newSTATEOP(0, NULL, NULL);
5223 retval = op_append_elem(OP_LINESEQ, retval, o);
5226 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
5230 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
5234 /* pad_leavemy has created a sequence of introcv ops for all my
5235 subs declared in the block. We have to replicate that list with
5236 clonecv ops, to deal with this situation:
5241 sub s1 { state sub foo { \&s2 } }
5244 Originally, I was going to have introcv clone the CV and turn
5245 off the stale flag. Since &s1 is declared before &s2, the
5246 introcv op for &s1 is executed (on sub entry) before the one for
5247 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
5248 cloned, since it is a state sub) closes over &s2 and expects
5249 to see it in its outer CV’s pad. If the introcv op clones &s1,
5250 then &s2 is still marked stale. Since &s1 is not active, and
5251 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
5252 ble will not stay shared’ warning. Because it is the same stub
5253 that will be used when the introcv op for &s2 is executed, clos-
5254 ing over it is safe. Hence, we have to turn off the stale flag
5255 on all lexical subs in the block before we clone any of them.
5256 Hence, having introcv clone the sub cannot work. So we create a
5257 list of ops like this:
5281 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
5282 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
5283 for (;; kid = OpSIBLING(kid)) {
5284 OP *newkid = newOP(OP_CLONECV, 0);
5285 newkid->op_targ = kid->op_targ;
5286 o = op_append_elem(OP_LINESEQ, o, newkid);
5287 if (kid == last) break;
5289 retval = op_prepend_elem(OP_LINESEQ, o, retval);
5292 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
5298 =head1 Compile-time scope hooks
5300 =for apidoc Aox||blockhook_register
5302 Register a set of hooks to be called when the Perl lexical scope changes
5303 at compile time. See L<perlguts/"Compile-time scope hooks">.
5309 Perl_blockhook_register(pTHX_ BHK *hk)
5311 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
5313 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
5317 Perl_newPROG(pTHX_ OP *o)
5321 PERL_ARGS_ASSERT_NEWPROG;
5328 PL_eval_root = newUNOP(OP_LEAVEEVAL,
5329 ((PL_in_eval & EVAL_KEEPERR)
5330 ? OPf_SPECIAL : 0), o);
5333 assert(CxTYPE(cx) == CXt_EVAL);
5335 if ((cx->blk_gimme & G_WANT) == G_VOID)
5336 scalarvoid(PL_eval_root);
5337 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
5340 scalar(PL_eval_root);
5342 start = op_linklist(PL_eval_root);
5343 PL_eval_root->op_next = 0;
5344 i = PL_savestack_ix;
5347 S_process_optree(aTHX_ NULL, PL_eval_root, start);
5349 PL_savestack_ix = i;
5352 if (o->op_type == OP_STUB) {
5353 /* This block is entered if nothing is compiled for the main
5354 program. This will be the case for an genuinely empty main
5355 program, or one which only has BEGIN blocks etc, so already
5358 Historically (5.000) the guard above was !o. However, commit
5359 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
5360 c71fccf11fde0068, changed perly.y so that newPROG() is now
5361 called with the output of block_end(), which returns a new
5362 OP_STUB for the case of an empty optree. ByteLoader (and
5363 maybe other things) also take this path, because they set up
5364 PL_main_start and PL_main_root directly, without generating an
5367 If the parsing the main program aborts (due to parse errors,
5368 or due to BEGIN or similar calling exit), then newPROG()
5369 isn't even called, and hence this code path and its cleanups
5370 are skipped. This shouldn't make a make a difference:
5371 * a non-zero return from perl_parse is a failure, and
5372 perl_destruct() should be called immediately.
5373 * however, if exit(0) is called during the parse, then
5374 perl_parse() returns 0, and perl_run() is called. As
5375 PL_main_start will be NULL, perl_run() will return
5376 promptly, and the exit code will remain 0.
5379 PL_comppad_name = 0;
5381 S_op_destroy(aTHX_ o);
5384 PL_main_root = op_scope(sawparens(scalarvoid(o)));
5385 PL_curcop = &PL_compiling;
5386 start = LINKLIST(PL_main_root);
5387 PL_main_root->op_next = 0;
5388 S_process_optree(aTHX_ NULL, PL_main_root, start);
5389 cv_forget_slab(PL_compcv);
5392 /* Register with debugger */
5394 CV * const cv = get_cvs("DB::postponed", 0);
5398 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
5400 call_sv(MUTABLE_SV(cv), G_DISCARD);
5407 Perl_localize(pTHX_ OP *o, I32 lex)
5409 PERL_ARGS_ASSERT_LOCALIZE;
5411 if (o->op_flags & OPf_PARENS)
5412 /* [perl #17376]: this appears to be premature, and results in code such as
5413 C< our(%x); > executing in list mode rather than void mode */
5420 if ( PL_parser->bufptr > PL_parser->oldbufptr
5421 && PL_parser->bufptr[-1] == ','
5422 && ckWARN(WARN_PARENTHESIS))
5424 char *s = PL_parser->bufptr;
5427 /* some heuristics to detect a potential error */
5428 while (*s && (strchr(", \t\n", *s)))
5432 if (*s && (strchr("@$%", *s) || (!lex && *s == '*'))
5434 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
5437 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
5439 while (*s && (strchr(", \t\n", *s)))
5445 if (sigil && (*s == ';' || *s == '=')) {
5446 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
5447 "Parentheses missing around \"%s\" list",
5449 ? (PL_parser->in_my == KEY_our
5451 : PL_parser->in_my == KEY_state
5461 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
5462 PL_parser->in_my = FALSE;
5463 PL_parser->in_my_stash = NULL;
5468 Perl_jmaybe(pTHX_ OP *o)
5470 PERL_ARGS_ASSERT_JMAYBE;
5472 if (o->op_type == OP_LIST) {
5474 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
5475 o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
5480 PERL_STATIC_INLINE OP *
5481 S_op_std_init(pTHX_ OP *o)
5483 I32 type = o->op_type;
5485 PERL_ARGS_ASSERT_OP_STD_INIT;
5487 if (PL_opargs[type] & OA_RETSCALAR)
5489 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
5490 o->op_targ = pad_alloc(type, SVs_PADTMP);
5495 PERL_STATIC_INLINE OP *
5496 S_op_integerize(pTHX_ OP *o)
5498 I32 type = o->op_type;
5500 PERL_ARGS_ASSERT_OP_INTEGERIZE;
5502 /* integerize op. */
5503 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
5506 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
5509 if (type == OP_NEGATE)
5510 /* XXX might want a ck_negate() for this */
5511 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
5516 /* This function exists solely to provide a scope to limit
5517 setjmp/longjmp() messing with auto variables.
5519 PERL_STATIC_INLINE int
5520 S_fold_constants_eval(pTHX) {
5536 S_fold_constants(pTHX_ OP *const o)
5541 I32 type = o->op_type;
5546 SV * const oldwarnhook = PL_warnhook;
5547 SV * const olddiehook = PL_diehook;
5549 U8 oldwarn = PL_dowarn;
5552 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
5554 if (!(PL_opargs[type] & OA_FOLDCONST))
5563 #ifdef USE_LOCALE_CTYPE
5564 if (IN_LC_COMPILETIME(LC_CTYPE))
5573 #ifdef USE_LOCALE_COLLATE
5574 if (IN_LC_COMPILETIME(LC_COLLATE))
5579 /* XXX what about the numeric ops? */
5580 #ifdef USE_LOCALE_NUMERIC
5581 if (IN_LC_COMPILETIME(LC_NUMERIC))
5586 if (!OpHAS_SIBLING(cLISTOPo->op_first)
5587 || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
5590 SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
5591 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
5593 const char *s = SvPVX_const(sv);
5594 while (s < SvEND(sv)) {
5595 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
5602 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
5605 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
5606 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
5610 if (PL_parser && PL_parser->error_count)
5611 goto nope; /* Don't try to run w/ errors */
5613 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
5614 switch (curop->op_type) {
5616 if ( (curop->op_private & OPpCONST_BARE)
5617 && (curop->op_private & OPpCONST_STRICT)) {
5618 no_bareword_allowed(curop);
5626 /* Foldable; move to next op in list */
5630 /* No other op types are considered foldable */
5635 curop = LINKLIST(o);
5636 old_next = o->op_next;
5640 old_cxix = cxstack_ix;
5641 create_eval_scope(NULL, G_FAKINGEVAL);
5643 /* Verify that we don't need to save it: */
5644 assert(PL_curcop == &PL_compiling);
5645 StructCopy(&PL_compiling, ¬_compiling, COP);
5646 PL_curcop = ¬_compiling;
5647 /* The above ensures that we run with all the correct hints of the
5648 currently compiling COP, but that IN_PERL_RUNTIME is true. */
5649 assert(IN_PERL_RUNTIME);
5650 PL_warnhook = PERL_WARNHOOK_FATAL;
5653 /* Effective $^W=1. */
5654 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5655 PL_dowarn |= G_WARN_ON;
5657 ret = S_fold_constants_eval(aTHX);
5661 sv = *(PL_stack_sp--);
5662 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
5663 pad_swipe(o->op_targ, FALSE);
5665 else if (SvTEMP(sv)) { /* grab mortal temp? */
5666 SvREFCNT_inc_simple_void(sv);
5669 else { assert(SvIMMORTAL(sv)); }
5672 /* Something tried to die. Abandon constant folding. */
5673 /* Pretend the error never happened. */
5675 o->op_next = old_next;
5678 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
5679 PL_warnhook = oldwarnhook;
5680 PL_diehook = olddiehook;
5681 /* XXX note that this croak may fail as we've already blown away
5682 * the stack - eg any nested evals */
5683 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
5685 PL_dowarn = oldwarn;
5686 PL_warnhook = oldwarnhook;
5687 PL_diehook = olddiehook;
5688 PL_curcop = &PL_compiling;
5690 /* if we croaked, depending on how we croaked the eval scope
5691 * may or may not have already been popped */
5692 if (cxstack_ix > old_cxix) {
5693 assert(cxstack_ix == old_cxix + 1);
5694 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5695 delete_eval_scope();
5700 /* OP_STRINGIFY and constant folding are used to implement qq.
5701 Here the constant folding is an implementation detail that we
5702 want to hide. If the stringify op is itself already marked
5703 folded, however, then it is actually a folded join. */
5704 is_stringify = type == OP_STRINGIFY && !o->op_folded;
5709 else if (!SvIMMORTAL(sv)) {
5713 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5714 if (!is_stringify) newop->op_folded = 1;
5722 S_gen_constant_list(pTHX_ OP *o)
5725 OP *curop, *old_next;
5726 SV * const oldwarnhook = PL_warnhook;
5727 SV * const olddiehook = PL_diehook;
5729 U8 oldwarn = PL_dowarn;
5739 if (PL_parser && PL_parser->error_count)
5740 return o; /* Don't attempt to run with errors */
5742 curop = LINKLIST(o);
5743 old_next = o->op_next;
5745 op_was_null = o->op_type == OP_NULL;
5746 if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5747 o->op_type = OP_CUSTOM;
5750 o->op_type = OP_NULL;
5751 S_prune_chain_head(&curop);
5754 old_cxix = cxstack_ix;
5755 create_eval_scope(NULL, G_FAKINGEVAL);
5757 old_curcop = PL_curcop;
5758 StructCopy(old_curcop, ¬_compiling, COP);
5759 PL_curcop = ¬_compiling;
5760 /* The above ensures that we run with all the correct hints of the
5761 current COP, but that IN_PERL_RUNTIME is true. */
5762 assert(IN_PERL_RUNTIME);
5763 PL_warnhook = PERL_WARNHOOK_FATAL;
5767 /* Effective $^W=1. */
5768 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5769 PL_dowarn |= G_WARN_ON;
5773 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5774 PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5776 Perl_pp_pushmark(aTHX);
5779 assert (!(curop->op_flags & OPf_SPECIAL));
5780 assert(curop->op_type == OP_RANGE);
5781 Perl_pp_anonlist(aTHX);
5785 o->op_next = old_next;
5789 PL_warnhook = oldwarnhook;
5790 PL_diehook = olddiehook;
5791 Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5796 PL_dowarn = oldwarn;
5797 PL_warnhook = oldwarnhook;
5798 PL_diehook = olddiehook;
5799 PL_curcop = old_curcop;
5801 if (cxstack_ix > old_cxix) {
5802 assert(cxstack_ix == old_cxix + 1);
5803 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5804 delete_eval_scope();
5809 OpTYPE_set(o, OP_RV2AV);
5810 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
5811 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
5812 o->op_opt = 0; /* needs to be revisited in rpeep() */
5813 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5815 /* replace subtree with an OP_CONST */
5816 curop = ((UNOP*)o)->op_first;
5817 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5820 if (AvFILLp(av) != -1)
5821 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5824 SvREADONLY_on(*svp);
5831 =head1 Optree Manipulation Functions
5834 /* List constructors */
5837 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
5839 Append an item to the list of ops contained directly within a list-type
5840 op, returning the lengthened list. C<first> is the list-type op,
5841 and C<last> is the op to append to the list. C<optype> specifies the
5842 intended opcode for the list. If C<first> is not already a list of the
5843 right type, it will be upgraded into one. If either C<first> or C<last>
5844 is null, the other is returned unchanged.
5850 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5858 if (first->op_type != (unsigned)type
5859 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5861 return newLISTOP(type, 0, first, last);
5864 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
5865 first->op_flags |= OPf_KIDS;
5870 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
5872 Concatenate the lists of ops contained directly within two list-type ops,
5873 returning the combined list. C<first> and C<last> are the list-type ops
5874 to concatenate. C<optype> specifies the intended opcode for the list.
5875 If either C<first> or C<last> is not already a list of the right type,
5876 it will be upgraded into one. If either C<first> or C<last> is null,
5877 the other is returned unchanged.
5883 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5891 if (first->op_type != (unsigned)type)
5892 return op_prepend_elem(type, first, last);
5894 if (last->op_type != (unsigned)type)
5895 return op_append_elem(type, first, last);
5897 OpMORESIB_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
5898 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
5899 OpLASTSIB_set(((LISTOP*)first)->op_last, first);
5900 first->op_flags |= (last->op_flags & OPf_KIDS);
5902 S_op_destroy(aTHX_ last);
5908 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
5910 Prepend an item to the list of ops contained directly within a list-type
5911 op, returning the lengthened list. C<first> is the op to prepend to the
5912 list, and C<last> is the list-type op. C<optype> specifies the intended
5913 opcode for the list. If C<last> is not already a list of the right type,
5914 it will be upgraded into one. If either C<first> or C<last> is null,
5915 the other is returned unchanged.
5921 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5929 if (last->op_type == (unsigned)type) {
5930 if (type == OP_LIST) { /* already a PUSHMARK there */
5931 /* insert 'first' after pushmark */
5932 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5933 if (!(first->op_flags & OPf_PARENS))
5934 last->op_flags &= ~OPf_PARENS;
5937 op_sibling_splice(last, NULL, 0, first);
5938 last->op_flags |= OPf_KIDS;
5942 return newLISTOP(type, 0, first, last);
5946 =for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
5948 Converts C<o> into a list op if it is not one already, and then converts it
5949 into the specified C<type>, calling its check function, allocating a target if
5950 it needs one, and folding constants.
5952 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5953 C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
5954 C<op_convert_list> to make it the right type.
5960 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5963 if (type < 0) type = -type, flags |= OPf_SPECIAL;
5964 if (!o || o->op_type != OP_LIST)
5965 o = force_list(o, 0);
5968 o->op_flags &= ~OPf_WANT;
5969 o->op_private &= ~OPpLVAL_INTRO;
5972 if (!(PL_opargs[type] & OA_MARK))
5973 op_null(cLISTOPo->op_first);
5975 OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5976 if (kid2 && kid2->op_type == OP_COREARGS) {
5977 op_null(cLISTOPo->op_first);
5978 kid2->op_private |= OPpCOREARGS_PUSHMARK;
5982 if (type != OP_SPLIT)
5983 /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5984 * ck_split() create a real PMOP and leave the op's type as listop
5985 * for now. Otherwise op_free() etc will crash.
5987 OpTYPE_set(o, type);
5989 o->op_flags |= flags;
5990 if (flags & OPf_FOLDED)
5993 o = CHECKOP(type, o);
5994 if (o->op_type != (unsigned)type)
5997 return fold_constants(op_integerize(op_std_init(o)));
6004 =head1 Optree construction
6006 =for apidoc Am|OP *|newNULLLIST
6008 Constructs, checks, and returns a new C<stub> op, which represents an
6009 empty list expression.
6015 Perl_newNULLLIST(pTHX)
6017 return newOP(OP_STUB, 0);
6020 /* promote o and any siblings to be a list if its not already; i.e.
6028 * pushmark - o - A - B
6030 * If nullit it true, the list op is nulled.
6034 S_force_list(pTHX_ OP *o, bool nullit)
6036 if (!o || o->op_type != OP_LIST) {
6039 /* manually detach any siblings then add them back later */
6040 rest = OpSIBLING(o);
6041 OpLASTSIB_set(o, NULL);
6043 o = newLISTOP(OP_LIST, 0, o, NULL);
6045 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
6053 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
6055 Constructs, checks, and returns an op of any list type. C<type> is
6056 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6057 C<OPf_KIDS> will be set automatically if required. C<first> and C<last>
6058 supply up to two ops to be direct children of the list op; they are
6059 consumed by this function and become part of the constructed op tree.
6061 For most list operators, the check function expects all the kid ops to be
6062 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
6063 appropriate. What you want to do in that case is create an op of type
6064 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
6065 See L</op_convert_list> for more information.
6072 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6077 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
6078 || type == OP_CUSTOM);
6080 NewOp(1101, listop, 1, LISTOP);
6082 OpTYPE_set(listop, type);
6085 listop->op_flags = (U8)flags;
6089 else if (!first && last)
6092 OpMORESIB_set(first, last);
6093 listop->op_first = first;
6094 listop->op_last = last;
6095 if (type == OP_LIST) {
6096 OP* const pushop = newOP(OP_PUSHMARK, 0);
6097 OpMORESIB_set(pushop, first);
6098 listop->op_first = pushop;
6099 listop->op_flags |= OPf_KIDS;
6101 listop->op_last = pushop;
6103 if (listop->op_last)
6104 OpLASTSIB_set(listop->op_last, (OP*)listop);
6106 return CHECKOP(type, listop);
6110 =for apidoc Am|OP *|newOP|I32 type|I32 flags
6112 Constructs, checks, and returns an op of any base type (any type that
6113 has no extra fields). C<type> is the opcode. C<flags> gives the
6114 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
6121 Perl_newOP(pTHX_ I32 type, I32 flags)
6126 if (type == -OP_ENTEREVAL) {
6127 type = OP_ENTEREVAL;
6128 flags |= OPpEVAL_BYTES<<8;
6131 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
6132 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6133 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6134 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6136 NewOp(1101, o, 1, OP);
6137 OpTYPE_set(o, type);
6138 o->op_flags = (U8)flags;
6141 o->op_private = (U8)(0 | (flags >> 8));
6142 if (PL_opargs[type] & OA_RETSCALAR)
6144 if (PL_opargs[type] & OA_TARGET)
6145 o->op_targ = pad_alloc(type, SVs_PADTMP);
6146 return CHECKOP(type, o);
6150 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
6152 Constructs, checks, and returns an op of any unary type. C<type> is
6153 the opcode. C<flags> gives the eight bits of C<op_flags>, except that
6154 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
6155 bits, the eight bits of C<op_private>, except that the bit with value 1
6156 is automatically set. C<first> supplies an optional op to be the direct
6157 child of the unary op; it is consumed by this function and become part
6158 of the constructed op tree.
6164 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
6169 if (type == -OP_ENTEREVAL) {
6170 type = OP_ENTEREVAL;
6171 flags |= OPpEVAL_BYTES<<8;
6174 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
6175 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
6176 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
6177 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
6178 || type == OP_SASSIGN
6179 || type == OP_ENTERTRY
6180 || type == OP_CUSTOM
6181 || type == OP_NULL );
6184 first = newOP(OP_STUB, 0);
6185 if (PL_opargs[type] & OA_MARK)
6186 first = force_list(first, 1);
6188 NewOp(1101, unop, 1, UNOP);
6189 OpTYPE_set(unop, type);
6190 unop->op_first = first;
6191 unop->op_flags = (U8)(flags | OPf_KIDS);
6192 unop->op_private = (U8)(1 | (flags >> 8));
6194 if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
6195 OpLASTSIB_set(first, (OP*)unop);
6197 unop = (UNOP*) CHECKOP(type, unop);
6201 return fold_constants(op_integerize(op_std_init((OP *) unop)));
6205 =for apidoc newUNOP_AUX
6207 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
6208 initialised to C<aux>
6214 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
6219 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
6220 || type == OP_CUSTOM);
6222 NewOp(1101, unop, 1, UNOP_AUX);
6223 unop->op_type = (OPCODE)type;
6224 unop->op_ppaddr = PL_ppaddr[type];
6225 unop->op_first = first;
6226 unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
6227 unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
6230 if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
6231 OpLASTSIB_set(first, (OP*)unop);
6233 unop = (UNOP_AUX*) CHECKOP(type, unop);
6235 return op_std_init((OP *) unop);
6239 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
6241 Constructs, checks, and returns an op of method type with a method name
6242 evaluated at runtime. C<type> is the opcode. C<flags> gives the eight
6243 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
6244 and, shifted up eight bits, the eight bits of C<op_private>, except that
6245 the bit with value 1 is automatically set. C<dynamic_meth> supplies an
6246 op which evaluates method name; it is consumed by this function and
6247 become part of the constructed op tree.
6248 Supported optypes: C<OP_METHOD>.
6254 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
6258 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
6259 || type == OP_CUSTOM);
6261 NewOp(1101, methop, 1, METHOP);
6263 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
6264 methop->op_flags = (U8)(flags | OPf_KIDS);
6265 methop->op_u.op_first = dynamic_meth;
6266 methop->op_private = (U8)(1 | (flags >> 8));
6268 if (!OpHAS_SIBLING(dynamic_meth))
6269 OpLASTSIB_set(dynamic_meth, (OP*)methop);
6273 methop->op_flags = (U8)(flags & ~OPf_KIDS);
6274 methop->op_u.op_meth_sv = const_meth;
6275 methop->op_private = (U8)(0 | (flags >> 8));
6276 methop->op_next = (OP*)methop;
6280 methop->op_rclass_targ = 0;
6282 methop->op_rclass_sv = NULL;
6285 OpTYPE_set(methop, type);
6286 return CHECKOP(type, methop);
6290 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
6291 PERL_ARGS_ASSERT_NEWMETHOP;
6292 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
6296 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
6298 Constructs, checks, and returns an op of method type with a constant
6299 method name. C<type> is the opcode. C<flags> gives the eight bits of
6300 C<op_flags>, and, shifted up eight bits, the eight bits of
6301 C<op_private>. C<const_meth> supplies a constant method name;
6302 it must be a shared COW string.
6303 Supported optypes: C<OP_METHOD_NAMED>.
6309 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
6310 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
6311 return newMETHOP_internal(type, flags, NULL, const_meth);
6315 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
6317 Constructs, checks, and returns an op of any binary type. C<type>
6318 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
6319 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6320 the eight bits of C<op_private>, except that the bit with value 1 or
6321 2 is automatically set as required. C<first> and C<last> supply up to
6322 two ops to be the direct children of the binary op; they are consumed
6323 by this function and become part of the constructed op tree.
6329 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
6334 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
6335 || type == OP_NULL || type == OP_CUSTOM);
6337 NewOp(1101, binop, 1, BINOP);
6340 first = newOP(OP_NULL, 0);
6342 OpTYPE_set(binop, type);
6343 binop->op_first = first;
6344 binop->op_flags = (U8)(flags | OPf_KIDS);
6347 binop->op_private = (U8)(1 | (flags >> 8));
6350 binop->op_private = (U8)(2 | (flags >> 8));
6351 OpMORESIB_set(first, last);
6354 if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
6355 OpLASTSIB_set(last, (OP*)binop);
6357 binop->op_last = OpSIBLING(binop->op_first);
6359 OpLASTSIB_set(binop->op_last, (OP*)binop);
6361 binop = (BINOP*)CHECKOP(type, binop);
6362 if (binop->op_next || binop->op_type != (OPCODE)type)
6365 return fold_constants(op_integerize(op_std_init((OP *)binop)));
6368 /* Helper function for S_pmtrans(): comparison function to sort an array
6369 * of codepoint range pairs. Sorts by start point, or if equal, by end
6372 static int uvcompare(const void *a, const void *b)
6373 __attribute__nonnull__(1)
6374 __attribute__nonnull__(2)
6375 __attribute__pure__;
6376 static int uvcompare(const void *a, const void *b)
6378 if (*((const UV *)a) < (*(const UV *)b))
6380 if (*((const UV *)a) > (*(const UV *)b))
6382 if (*((const UV *)a+1) < (*(const UV *)b+1))
6384 if (*((const UV *)a+1) > (*(const UV *)b+1))
6389 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
6390 * containing the search and replacement strings, assemble into
6391 * a translation table attached as o->op_pv.
6392 * Free expr and repl.
6393 * It expects the toker to have already set the
6394 * OPpTRANS_COMPLEMENT
6397 * flags as appropriate; this function may add
6400 * OPpTRANS_IDENTICAL
6406 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
6408 SV * const tstr = ((SVOP*)expr)->op_sv;
6409 SV * const rstr = ((SVOP*)repl)->op_sv;
6412 const U8 *t = (U8*)SvPV_const(tstr, tlen);
6413 const U8 *r = (U8*)SvPV_const(rstr, rlen);
6417 SSize_t struct_size; /* malloced size of table struct */
6419 const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6420 const bool squash = cBOOL(o->op_private & OPpTRANS_SQUASH);
6421 const bool del = cBOOL(o->op_private & OPpTRANS_DELETE);
6424 PERL_ARGS_ASSERT_PMTRANS;
6426 PL_hints |= HINT_BLOCK_SCOPE;
6429 o->op_private |= OPpTRANS_FROM_UTF;
6432 o->op_private |= OPpTRANS_TO_UTF;
6434 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
6436 /* for utf8 translations, op_sv will be set to point to a swash
6437 * containing codepoint ranges. This is done by first assembling
6438 * a textual representation of the ranges in listsv then compiling
6439 * it using swash_init(). For more details of the textual format,
6440 * see L<perlunicode.pod/"User-Defined Character Properties"> .
6443 SV* const listsv = newSVpvs("# comment\n");
6445 const U8* tend = t + tlen;
6446 const U8* rend = r + rlen;
6462 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
6463 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
6466 const U32 flags = UTF8_ALLOW_DEFAULT;
6470 t = tsave = bytes_to_utf8(t, &len);
6473 if (!to_utf && rlen) {
6475 r = rsave = bytes_to_utf8(r, &len);
6479 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
6480 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
6485 * replace t/tlen/tend with a version that has the ranges
6488 U8 tmpbuf[UTF8_MAXBYTES+1];
6491 Newx(cp, 2*tlen, UV);
6493 transv = newSVpvs("");
6495 /* convert search string into array of (start,end) range
6496 * codepoint pairs stored in cp[]. Most "ranges" will start
6497 * and end at the same char */
6499 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6501 /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
6502 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
6504 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
6508 cp[2*i+1] = cp[2*i];
6513 /* sort the ranges */
6514 qsort(cp, i, 2*sizeof(UV), uvcompare);
6516 /* Create a utf8 string containing the complement of the
6517 * codepoint ranges. For example if cp[] contains [A,B], [C,D],
6518 * then transv will contain the equivalent of:
6519 * join '', map chr, 0, ILLEGAL_UTF8_BYTE, A - 1,
6520 * B + 1, ILLEGAL_UTF8_BYTE, C - 1,
6521 * D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
6522 * A range of a single char skips the ILLEGAL_UTF8_BYTE and
6525 for (j = 0; j < i; j++) {
6527 diff = val - nextmin;
6529 t = uvchr_to_utf8(tmpbuf,nextmin);
6530 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6532 U8 range_mark = ILLEGAL_UTF8_BYTE;
6533 t = uvchr_to_utf8(tmpbuf, val - 1);
6534 sv_catpvn(transv, (char *)&range_mark, 1);
6535 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6543 t = uvchr_to_utf8(tmpbuf,nextmin);
6544 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6546 U8 range_mark = ILLEGAL_UTF8_BYTE;
6547 sv_catpvn(transv, (char *)&range_mark, 1);
6549 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
6550 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
6551 t = (const U8*)SvPVX_const(transv);
6552 tlen = SvCUR(transv);
6556 else if (!rlen && !del) {
6557 r = t; rlen = tlen; rend = tend;
6561 if ((!rlen && !del) || t == r ||
6562 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
6564 o->op_private |= OPpTRANS_IDENTICAL;
6568 /* extract char ranges from t and r and append them to listsv */
6570 while (t < tend || tfirst <= tlast) {
6571 /* see if we need more "t" chars */
6572 if (tfirst > tlast) {
6573 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6575 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6577 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
6584 /* now see if we need more "r" chars */
6585 if (rfirst > rlast) {
6587 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6589 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
6591 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
6600 rfirst = rlast = 0xffffffff;
6604 /* now see which range will peter out first, if either. */
6605 tdiff = tlast - tfirst;
6606 rdiff = rlast - rfirst;
6607 tcount += tdiff + 1;
6608 rcount += rdiff + 1;
6615 if (rfirst == 0xffffffff) {
6616 diff = tdiff; /* oops, pretend rdiff is infinite */
6618 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
6619 (long)tfirst, (long)tlast);
6621 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
6625 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
6626 (long)tfirst, (long)(tfirst + diff),
6629 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
6630 (long)tfirst, (long)rfirst);
6632 if (rfirst + diff > max)
6633 max = rfirst + diff;
6635 grows = (tfirst < rfirst &&
6636 UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff));
6642 /* compile listsv into a swash and attach to o */
6650 else if (max > 0xff)
6655 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
6657 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6658 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6659 PAD_SETSV(cPADOPo->op_padix, swash);
6661 SvREADONLY_on(swash);
6663 cSVOPo->op_sv = swash;
6665 SvREFCNT_dec(listsv);
6666 SvREFCNT_dec(transv);
6668 if (!del && havefinal && rlen)
6669 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
6670 newSVuv((UV)final), 0);
6679 else if (rlast == 0xffffffff)
6685 /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6686 * table. Entries with the value -1 indicate chars not to be
6687 * translated, while -2 indicates a search char without a
6688 * corresponding replacement char under /d.
6690 * Normally, the table has 256 slots. However, in the presence of
6691 * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
6692 * added, and if there are enough replacement chars to start pairing
6693 * with the \x{100},... search chars, then a larger (> 256) table
6696 * In addition, regardless of whether under /c, an extra slot at the
6697 * end is used to store the final repeating char, or -3 under an empty
6698 * replacement list, or -2 under /d; which makes the runtime code
6701 * The toker will have already expanded char ranges in t and r.
6704 /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
6705 * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
6706 * The OPtrans_map struct already contains one slot; hence the -1.
6708 struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
6709 tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
6711 cPVOPo->op_pv = (char*)tbl;
6716 /* in this branch, j is a count of 'consumed' (i.e. paired off
6717 * with a search char) replacement chars (so j <= rlen always)
6719 for (i = 0; i < tlen; i++)
6720 tbl->map[t[i]] = -1;
6722 for (i = 0, j = 0; i < 256; i++) {
6728 tbl->map[i] = r[j-1];
6730 tbl->map[i] = (short)i;
6733 tbl->map[i] = r[j++];
6735 if ( tbl->map[i] >= 0
6736 && UVCHR_IS_INVARIANT((UV)i)
6737 && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
6747 /* More replacement chars than search chars:
6748 * store excess replacement chars at end of main table.
6751 struct_size += excess;
6752 tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
6753 struct_size + excess * sizeof(short));
6754 tbl->size += excess;
6755 cPVOPo->op_pv = (char*)tbl;
6757 for (i = 0; i < excess; i++)
6758 tbl->map[i + 256] = r[j+i];
6761 /* no more replacement chars than search chars */
6762 if (!rlen && !del && !squash)
6763 o->op_private |= OPpTRANS_IDENTICAL;
6766 tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
6769 if (!rlen && !del) {
6772 o->op_private |= OPpTRANS_IDENTICAL;
6774 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
6775 o->op_private |= OPpTRANS_IDENTICAL;
6778 for (i = 0; i < 256; i++)
6780 for (i = 0, j = 0; i < tlen; i++,j++) {
6783 if (tbl->map[t[i]] == -1)
6784 tbl->map[t[i]] = -2;
6789 if (tbl->map[t[i]] == -1) {
6790 if ( UVCHR_IS_INVARIANT(t[i])
6791 && ! UVCHR_IS_INVARIANT(r[j]))
6793 tbl->map[t[i]] = r[j];
6796 tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
6799 /* both non-utf8 and utf8 code paths end up here */
6802 if(del && rlen == tlen) {
6803 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
6804 } else if(rlen > tlen && !complement) {
6805 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
6809 o->op_private |= OPpTRANS_GROWS;
6818 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
6820 Constructs, checks, and returns an op of any pattern matching type.
6821 C<type> is the opcode. C<flags> gives the eight bits of C<op_flags>
6822 and, shifted up eight bits, the eight bits of C<op_private>.
6828 Perl_newPMOP(pTHX_ I32 type, I32 flags)
6833 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
6834 || type == OP_CUSTOM);
6836 NewOp(1101, pmop, 1, PMOP);
6837 OpTYPE_set(pmop, type);
6838 pmop->op_flags = (U8)flags;
6839 pmop->op_private = (U8)(0 | (flags >> 8));
6840 if (PL_opargs[type] & OA_RETSCALAR)
6843 if (PL_hints & HINT_RE_TAINT)
6844 pmop->op_pmflags |= PMf_RETAINT;
6845 #ifdef USE_LOCALE_CTYPE
6846 if (IN_LC_COMPILETIME(LC_CTYPE)) {
6847 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
6852 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
6854 if (PL_hints & HINT_RE_FLAGS) {
6855 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6856 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
6858 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
6859 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
6860 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
6862 if (reflags && SvOK(reflags)) {
6863 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
6869 assert(SvPOK(PL_regex_pad[0]));
6870 if (SvCUR(PL_regex_pad[0])) {
6871 /* Pop off the "packed" IV from the end. */
6872 SV *const repointer_list = PL_regex_pad[0];
6873 const char *p = SvEND(repointer_list) - sizeof(IV);
6874 const IV offset = *((IV*)p);
6876 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
6878 SvEND_set(repointer_list, p);
6880 pmop->op_pmoffset = offset;
6881 /* This slot should be free, so assert this: */
6882 assert(PL_regex_pad[offset] == &PL_sv_undef);
6884 SV * const repointer = &PL_sv_undef;
6885 av_push(PL_regex_padav, repointer);
6886 pmop->op_pmoffset = av_tindex(PL_regex_padav);
6887 PL_regex_pad = AvARRAY(PL_regex_padav);
6891 return CHECKOP(type, pmop);
6899 /* Any pad names in scope are potentially lvalues. */
6900 for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
6901 PADNAME *pn = PAD_COMPNAME_SV(i);
6902 if (!pn || !PadnameLEN(pn))
6904 if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
6905 S_mark_padname_lvalue(aTHX_ pn);
6909 /* Given some sort of match op o, and an expression expr containing a
6910 * pattern, either compile expr into a regex and attach it to o (if it's
6911 * constant), or convert expr into a runtime regcomp op sequence (if it's
6914 * Flags currently has 2 bits of meaning:
6915 * 1: isreg indicates that the pattern is part of a regex construct, eg
6916 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
6917 * split "pattern", which aren't. In the former case, expr will be a list
6918 * if the pattern contains more than one term (eg /a$b/).
6919 * 2: The pattern is for a split.
6921 * When the pattern has been compiled within a new anon CV (for
6922 * qr/(?{...})/ ), then floor indicates the savestack level just before
6923 * the new sub was created
6927 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
6931 I32 repl_has_vars = 0;
6932 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
6933 bool is_compiletime;
6935 bool isreg = cBOOL(flags & 1);
6936 bool is_split = cBOOL(flags & 2);
6938 PERL_ARGS_ASSERT_PMRUNTIME;
6941 return pmtrans(o, expr, repl);
6944 /* find whether we have any runtime or code elements;
6945 * at the same time, temporarily set the op_next of each DO block;
6946 * then when we LINKLIST, this will cause the DO blocks to be excluded
6947 * from the op_next chain (and from having LINKLIST recursively
6948 * applied to them). We fix up the DOs specially later */
6952 if (expr->op_type == OP_LIST) {
6954 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6955 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
6957 assert(!o->op_next);
6958 if (UNLIKELY(!OpHAS_SIBLING(o))) {
6959 assert(PL_parser && PL_parser->error_count);
6960 /* This can happen with qr/ (?{(^{})/. Just fake up
6961 the op we were expecting to see, to avoid crashing
6963 op_sibling_splice(expr, o, 0,
6964 newSVOP(OP_CONST, 0, &PL_sv_no));
6966 o->op_next = OpSIBLING(o);
6968 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
6972 else if (expr->op_type != OP_CONST)
6977 /* fix up DO blocks; treat each one as a separate little sub;
6978 * also, mark any arrays as LIST/REF */
6980 if (expr->op_type == OP_LIST) {
6982 for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6984 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
6985 assert( !(o->op_flags & OPf_WANT));
6986 /* push the array rather than its contents. The regex
6987 * engine will retrieve and join the elements later */
6988 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
6992 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
6994 o->op_next = NULL; /* undo temporary hack from above */
6997 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
6998 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
7000 assert(leaveop->op_first->op_type == OP_ENTER);
7001 assert(OpHAS_SIBLING(leaveop->op_first));
7002 o->op_next = OpSIBLING(leaveop->op_first);
7004 assert(leaveop->op_flags & OPf_KIDS);
7005 assert(leaveop->op_last->op_next == (OP*)leaveop);
7006 leaveop->op_next = NULL; /* stop on last op */
7007 op_null((OP*)leaveop);
7011 OP *scope = cLISTOPo->op_first;
7012 assert(scope->op_type == OP_SCOPE);
7013 assert(scope->op_flags & OPf_KIDS);
7014 scope->op_next = NULL; /* stop on last op */
7018 /* XXX optimize_optree() must be called on o before
7019 * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7020 * currently cope with a peephole-optimised optree.
7021 * Calling optimize_optree() here ensures that condition
7022 * is met, but may mean optimize_optree() is applied
7023 * to the same optree later (where hopefully it won't do any
7024 * harm as it can't convert an op to multiconcat if it's
7025 * already been converted */
7028 /* have to peep the DOs individually as we've removed it from
7029 * the op_next chain */
7031 S_prune_chain_head(&(o->op_next));
7033 /* runtime finalizes as part of finalizing whole tree */
7037 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7038 assert( !(expr->op_flags & OPf_WANT));
7039 /* push the array rather than its contents. The regex
7040 * engine will retrieve and join the elements later */
7041 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7044 PL_hints |= HINT_BLOCK_SCOPE;
7046 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7048 if (is_compiletime) {
7049 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7050 regexp_engine const *eng = current_re_engine();
7053 /* make engine handle split ' ' specially */
7054 pm->op_pmflags |= PMf_SPLIT;
7055 rx_flags |= RXf_SPLIT;
7058 /* Skip compiling if parser found an error for this pattern */
7059 if (pm->op_pmflags & PMf_HAS_ERROR) {
7063 if (!has_code || !eng->op_comp) {
7064 /* compile-time simple constant pattern */
7066 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7067 /* whoops! we guessed that a qr// had a code block, but we
7068 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7069 * that isn't required now. Note that we have to be pretty
7070 * confident that nothing used that CV's pad while the
7071 * regex was parsed, except maybe op targets for \Q etc.
7072 * If there were any op targets, though, they should have
7073 * been stolen by constant folding.
7077 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7078 while (++i <= AvFILLp(PL_comppad)) {
7079 # ifdef USE_PAD_RESET
7080 /* under USE_PAD_RESET, pad swipe replaces a swiped
7081 * folded constant with a fresh padtmp */
7082 assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7084 assert(!PL_curpad[i]);
7088 /* But we know that one op is using this CV's slab. */
7089 cv_forget_slab(PL_compcv);
7091 pm->op_pmflags &= ~PMf_HAS_CV;
7096 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7097 rx_flags, pm->op_pmflags)
7098 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7099 rx_flags, pm->op_pmflags)
7104 /* compile-time pattern that includes literal code blocks */
7105 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7108 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7111 if (pm->op_pmflags & PMf_HAS_CV) {
7113 /* this QR op (and the anon sub we embed it in) is never
7114 * actually executed. It's just a placeholder where we can
7115 * squirrel away expr in op_code_list without the peephole
7116 * optimiser etc processing it for a second time */
7117 OP *qr = newPMOP(OP_QR, 0);
7118 ((PMOP*)qr)->op_code_list = expr;
7120 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7121 SvREFCNT_inc_simple_void(PL_compcv);
7122 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7123 ReANY(re)->qr_anoncv = cv;
7125 /* attach the anon CV to the pad so that
7126 * pad_fixup_inner_anons() can find it */
7127 (void)pad_add_anon(cv, o->op_type);
7128 SvREFCNT_inc_simple_void(cv);
7131 pm->op_code_list = expr;
7136 /* runtime pattern: build chain of regcomp etc ops */
7138 PADOFFSET cv_targ = 0;
7140 reglist = isreg && expr->op_type == OP_LIST;
7145 pm->op_code_list = expr;
7146 /* don't free op_code_list; its ops are embedded elsewhere too */
7147 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7151 /* make engine handle split ' ' specially */
7152 pm->op_pmflags |= PMf_SPLIT;
7154 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7155 * to allow its op_next to be pointed past the regcomp and
7156 * preceding stacking ops;
7157 * OP_REGCRESET is there to reset taint before executing the
7159 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7160 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7162 if (pm->op_pmflags & PMf_HAS_CV) {
7163 /* we have a runtime qr with literal code. This means
7164 * that the qr// has been wrapped in a new CV, which
7165 * means that runtime consts, vars etc will have been compiled
7166 * against a new pad. So... we need to execute those ops
7167 * within the environment of the new CV. So wrap them in a call
7168 * to a new anon sub. i.e. for
7172 * we build an anon sub that looks like
7174 * sub { "a", $b, '(?{...})' }
7176 * and call it, passing the returned list to regcomp.
7177 * Or to put it another way, the list of ops that get executed
7181 * ------ -------------------
7182 * pushmark (for regcomp)
7183 * pushmark (for entersub)
7187 * regcreset regcreset
7189 * const("a") const("a")
7191 * const("(?{...})") const("(?{...})")
7196 SvREFCNT_inc_simple_void(PL_compcv);
7197 CvLVALUE_on(PL_compcv);
7198 /* these lines are just an unrolled newANONATTRSUB */
7199 expr = newSVOP(OP_ANONCODE, 0,
7200 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7201 cv_targ = expr->op_targ;
7202 expr = newUNOP(OP_REFGEN, 0, expr);
7204 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
7207 rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7208 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7209 | (reglist ? OPf_STACKED : 0);
7210 rcop->op_targ = cv_targ;
7212 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
7213 if (PL_hints & HINT_RE_EVAL)
7214 S_set_haseval(aTHX);
7216 /* establish postfix order */
7217 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7219 rcop->op_next = expr;
7220 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
7223 rcop->op_next = LINKLIST(expr);
7224 expr->op_next = (OP*)rcop;
7227 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7233 /* If we are looking at s//.../e with a single statement, get past
7234 the implicit do{}. */
7235 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7236 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7237 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7240 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7241 if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7242 && !OpHAS_SIBLING(sib))
7245 if (curop->op_type == OP_CONST)
7247 else if (( (curop->op_type == OP_RV2SV ||
7248 curop->op_type == OP_RV2AV ||
7249 curop->op_type == OP_RV2HV ||
7250 curop->op_type == OP_RV2GV)
7251 && cUNOPx(curop)->op_first
7252 && cUNOPx(curop)->op_first->op_type == OP_GV )
7253 || curop->op_type == OP_PADSV
7254 || curop->op_type == OP_PADAV
7255 || curop->op_type == OP_PADHV
7256 || curop->op_type == OP_PADANY) {
7264 || !RX_PRELEN(PM_GETRE(pm))
7265 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7267 pm->op_pmflags |= PMf_CONST; /* const for long enough */
7268 op_prepend_elem(o->op_type, scalar(repl), o);
7271 rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7272 rcop->op_private = 1;
7274 /* establish postfix order */
7275 rcop->op_next = LINKLIST(repl);
7276 repl->op_next = (OP*)rcop;
7278 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7279 assert(!(pm->op_pmflags & PMf_ONCE));
7280 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7289 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
7291 Constructs, checks, and returns an op of any type that involves an
7292 embedded SV. C<type> is the opcode. C<flags> gives the eight bits
7293 of C<op_flags>. C<sv> gives the SV to embed in the op; this function
7294 takes ownership of one reference to it.
7300 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7305 PERL_ARGS_ASSERT_NEWSVOP;
7307 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7308 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7309 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7310 || type == OP_CUSTOM);
7312 NewOp(1101, svop, 1, SVOP);
7313 OpTYPE_set(svop, type);
7315 svop->op_next = (OP*)svop;
7316 svop->op_flags = (U8)flags;
7317 svop->op_private = (U8)(0 | (flags >> 8));
7318 if (PL_opargs[type] & OA_RETSCALAR)
7320 if (PL_opargs[type] & OA_TARGET)
7321 svop->op_targ = pad_alloc(type, SVs_PADTMP);
7322 return CHECKOP(type, svop);
7326 =for apidoc Am|OP *|newDEFSVOP|
7328 Constructs and returns an op to access C<$_>.
7334 Perl_newDEFSVOP(pTHX)
7336 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7342 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
7344 Constructs, checks, and returns an op of any type that involves a
7345 reference to a pad element. C<type> is the opcode. C<flags> gives the
7346 eight bits of C<op_flags>. A pad slot is automatically allocated, and
7347 is populated with C<sv>; this function takes ownership of one reference
7350 This function only exists if Perl has been compiled to use ithreads.
7356 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7361 PERL_ARGS_ASSERT_NEWPADOP;
7363 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7364 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7365 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7366 || type == OP_CUSTOM);
7368 NewOp(1101, padop, 1, PADOP);
7369 OpTYPE_set(padop, type);
7371 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7372 SvREFCNT_dec(PAD_SVl(padop->op_padix));
7373 PAD_SETSV(padop->op_padix, sv);
7375 padop->op_next = (OP*)padop;
7376 padop->op_flags = (U8)flags;
7377 if (PL_opargs[type] & OA_RETSCALAR)
7379 if (PL_opargs[type] & OA_TARGET)
7380 padop->op_targ = pad_alloc(type, SVs_PADTMP);
7381 return CHECKOP(type, padop);
7384 #endif /* USE_ITHREADS */
7387 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
7389 Constructs, checks, and returns an op of any type that involves an
7390 embedded reference to a GV. C<type> is the opcode. C<flags> gives the
7391 eight bits of C<op_flags>. C<gv> identifies the GV that the op should
7392 reference; calling this function does not transfer ownership of any
7399 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7401 PERL_ARGS_ASSERT_NEWGVOP;
7404 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7406 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7411 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
7413 Constructs, checks, and returns an op of any type that involves an
7414 embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
7415 the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
7416 Depending on the op type, the memory referenced by C<pv> may be freed
7417 when the op is destroyed. If the op is of a freeing type, C<pv> must
7418 have been allocated using C<PerlMemShared_malloc>.
7424 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7427 const bool utf8 = cBOOL(flags & SVf_UTF8);
7432 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7433 || type == OP_RUNCV || type == OP_CUSTOM
7434 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7436 NewOp(1101, pvop, 1, PVOP);
7437 OpTYPE_set(pvop, type);
7439 pvop->op_next = (OP*)pvop;
7440 pvop->op_flags = (U8)flags;
7441 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7442 if (PL_opargs[type] & OA_RETSCALAR)
7444 if (PL_opargs[type] & OA_TARGET)
7445 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7446 return CHECKOP(type, pvop);
7450 Perl_package(pTHX_ OP *o)
7452 SV *const sv = cSVOPo->op_sv;
7454 PERL_ARGS_ASSERT_PACKAGE;
7456 SAVEGENERICSV(PL_curstash);
7457 save_item(PL_curstname);
7459 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7461 sv_setsv(PL_curstname, sv);
7463 PL_hints |= HINT_BLOCK_SCOPE;
7464 PL_parser->copline = NOLINE;
7470 Perl_package_version( pTHX_ OP *v )
7472 U32 savehints = PL_hints;
7473 PERL_ARGS_ASSERT_PACKAGE_VERSION;
7474 PL_hints &= ~HINT_STRICT_VARS;
7475 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7476 PL_hints = savehints;
7481 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7486 SV *use_version = NULL;
7488 PERL_ARGS_ASSERT_UTILIZE;
7490 if (idop->op_type != OP_CONST)
7491 Perl_croak(aTHX_ "Module name must be constant");
7496 SV * const vesv = ((SVOP*)version)->op_sv;
7498 if (!arg && !SvNIOKp(vesv)) {
7505 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7506 Perl_croak(aTHX_ "Version number must be a constant number");
7508 /* Make copy of idop so we don't free it twice */
7509 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7511 /* Fake up a method call to VERSION */
7512 meth = newSVpvs_share("VERSION");
7513 veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7514 op_append_elem(OP_LIST,
7515 op_prepend_elem(OP_LIST, pack, version),
7516 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7520 /* Fake up an import/unimport */
7521 if (arg && arg->op_type == OP_STUB) {
7522 imop = arg; /* no import on explicit () */
7524 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
7525 imop = NULL; /* use 5.0; */
7527 use_version = ((SVOP*)idop)->op_sv;
7529 idop->op_private |= OPpCONST_NOVER;
7534 /* Make copy of idop so we don't free it twice */
7535 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
7537 /* Fake up a method call to import/unimport */
7539 ? newSVpvs_share("import") : newSVpvs_share("unimport");
7540 imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
7541 op_append_elem(OP_LIST,
7542 op_prepend_elem(OP_LIST, pack, arg),
7543 newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7547 /* Fake up the BEGIN {}, which does its thing immediately. */
7549 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7552 op_append_elem(OP_LINESEQ,
7553 op_append_elem(OP_LINESEQ,
7554 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7555 newSTATEOP(0, NULL, veop)),
7556 newSTATEOP(0, NULL, imop) ));
7560 * feature bundle that corresponds to the required version. */
7561 use_version = sv_2mortal(new_version(use_version));
7562 S_enable_feature_bundle(aTHX_ use_version);
7564 /* If a version >= 5.11.0 is requested, strictures are on by default! */
7565 if (vcmp(use_version,
7566 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
7567 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7568 PL_hints |= HINT_STRICT_REFS;
7569 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7570 PL_hints |= HINT_STRICT_SUBS;
7571 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7572 PL_hints |= HINT_STRICT_VARS;
7574 /* otherwise they are off */
7576 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7577 PL_hints &= ~HINT_STRICT_REFS;
7578 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7579 PL_hints &= ~HINT_STRICT_SUBS;
7580 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7581 PL_hints &= ~HINT_STRICT_VARS;
7585 /* The "did you use incorrect case?" warning used to be here.
7586 * The problem is that on case-insensitive filesystems one
7587 * might get false positives for "use" (and "require"):
7588 * "use Strict" or "require CARP" will work. This causes
7589 * portability problems for the script: in case-strict
7590 * filesystems the script will stop working.
7592 * The "incorrect case" warning checked whether "use Foo"
7593 * imported "Foo" to your namespace, but that is wrong, too:
7594 * there is no requirement nor promise in the language that
7595 * a Foo.pm should or would contain anything in package "Foo".
7597 * There is very little Configure-wise that can be done, either:
7598 * the case-sensitivity of the build filesystem of Perl does not
7599 * help in guessing the case-sensitivity of the runtime environment.
7602 PL_hints |= HINT_BLOCK_SCOPE;
7603 PL_parser->copline = NOLINE;
7604 COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7608 =head1 Embedding Functions
7610 =for apidoc load_module
7612 Loads the module whose name is pointed to by the string part of C<name>.
7613 Note that the actual module name, not its filename, should be given.
7614 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7615 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7616 trailing arguments can be used to specify arguments to the module's C<import()>
7617 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7618 on the flags. The flags argument is a bitwise-ORed collection of any of
7619 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7620 (or 0 for no flags).
7622 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7623 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7624 the trailing optional arguments may be omitted entirely. Otherwise, if
7625 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7626 exactly one C<OP*>, containing the op tree that produces the relevant import
7627 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7628 will be used as import arguments; and the list must be terminated with C<(SV*)
7629 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7630 set, the trailing C<NULL> pointer is needed even if no import arguments are
7631 desired. The reference count for each specified C<SV*> argument is
7632 decremented. In addition, the C<name> argument is modified.
7634 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7640 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7644 PERL_ARGS_ASSERT_LOAD_MODULE;
7646 va_start(args, ver);
7647 vload_module(flags, name, ver, &args);
7651 #ifdef PERL_IMPLICIT_CONTEXT
7653 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
7657 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
7658 va_start(args, ver);
7659 vload_module(flags, name, ver, &args);
7665 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
7668 OP * const modname = newSVOP(OP_CONST, 0, name);
7670 PERL_ARGS_ASSERT_VLOAD_MODULE;
7672 modname->op_private |= OPpCONST_BARE;
7674 veop = newSVOP(OP_CONST, 0, ver);
7678 if (flags & PERL_LOADMOD_NOIMPORT) {
7679 imop = sawparens(newNULLLIST());
7681 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
7682 imop = va_arg(*args, OP*);
7687 sv = va_arg(*args, SV*);
7689 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
7690 sv = va_arg(*args, SV*);
7694 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
7695 * that it has a PL_parser to play with while doing that, and also
7696 * that it doesn't mess with any existing parser, by creating a tmp
7697 * new parser with lex_start(). This won't actually be used for much,
7698 * since pp_require() will create another parser for the real work.
7699 * The ENTER/LEAVE pair protect callers from any side effects of use. */
7702 SAVEVPTR(PL_curcop);
7703 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
7704 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
7705 veop, modname, imop);
7709 PERL_STATIC_INLINE OP *
7710 S_new_entersubop(pTHX_ GV *gv, OP *arg)
7712 return newUNOP(OP_ENTERSUB, OPf_STACKED,
7713 newLISTOP(OP_LIST, 0, arg,
7714 newUNOP(OP_RV2CV, 0,
7715 newGVOP(OP_GV, 0, gv))));
7719 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
7724 PERL_ARGS_ASSERT_DOFILE;
7726 if (!force_builtin && (gv = gv_override("do", 2))) {
7727 doop = S_new_entersubop(aTHX_ gv, term);
7730 doop = newUNOP(OP_DOFILE, 0, scalar(term));
7736 =head1 Optree construction
7738 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
7740 Constructs, checks, and returns an C<lslice> (list slice) op. C<flags>
7741 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
7742 be set automatically, and, shifted up eight bits, the eight bits of
7743 C<op_private>, except that the bit with value 1 or 2 is automatically
7744 set as required. C<listval> and C<subscript> supply the parameters of
7745 the slice; they are consumed by this function and become part of the
7746 constructed op tree.
7752 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
7754 return newBINOP(OP_LSLICE, flags,
7755 list(force_list(subscript, 1)),
7756 list(force_list(listval, 1)) );
7759 #define ASSIGN_LIST 1
7760 #define ASSIGN_REF 2
7763 S_assignment_type(pTHX_ const OP *o)
7772 if (o->op_type == OP_SREFGEN)
7774 OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
7775 type = kid->op_type;
7776 flags = o->op_flags | kid->op_flags;
7777 if (!(flags & OPf_PARENS)
7778 && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
7779 kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
7783 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
7784 o = cUNOPo->op_first;
7785 flags = o->op_flags;
7790 if (type == OP_COND_EXPR) {
7791 OP * const sib = OpSIBLING(cLOGOPo->op_first);
7792 const I32 t = assignment_type(sib);
7793 const I32 f = assignment_type(OpSIBLING(sib));
7795 if (t == ASSIGN_LIST && f == ASSIGN_LIST)
7797 if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
7798 yyerror("Assignment to both a list and a scalar");
7802 if (type == OP_LIST &&
7803 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
7804 o->op_private & OPpLVAL_INTRO)
7807 if (type == OP_LIST || flags & OPf_PARENS ||
7808 type == OP_RV2AV || type == OP_RV2HV ||
7809 type == OP_ASLICE || type == OP_HSLICE ||
7810 type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
7813 if (type == OP_PADAV || type == OP_PADHV)
7816 if (type == OP_RV2SV)
7823 S_newONCEOP(pTHX_ OP *initop, OP *padop)
7825 const PADOFFSET target = padop->op_targ;
7826 OP *const other = newOP(OP_PADSV,
7828 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7829 OP *const first = newOP(OP_NULL, 0);
7830 OP *const nullop = newCONDOP(0, first, initop, other);
7831 /* XXX targlex disabled for now; see ticket #124160
7832 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7834 OP *const condop = first->op_next;
7836 OpTYPE_set(condop, OP_ONCE);
7837 other->op_targ = target;
7838 nullop->op_flags |= OPf_WANT_SCALAR;
7840 /* Store the initializedness of state vars in a separate
7843 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7844 /* hijacking PADSTALE for uninitialized state variables */
7845 SvPADSTALE_on(PAD_SVl(condop->op_targ));
7851 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7853 Constructs, checks, and returns an assignment op. C<left> and C<right>
7854 supply the parameters of the assignment; they are consumed by this
7855 function and become part of the constructed op tree.
7857 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7858 a suitable conditional optree is constructed. If C<optype> is the opcode
7859 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7860 performs the binary operation and assigns the result to the left argument.
7861 Either way, if C<optype> is non-zero then C<flags> has no effect.
7863 If C<optype> is zero, then a plain scalar or list assignment is
7864 constructed. Which type of assignment it is is automatically determined.
7865 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7866 will be set automatically, and, shifted up eight bits, the eight bits
7867 of C<op_private>, except that the bit with value 1 or 2 is automatically
7874 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7880 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7881 right = scalar(right);
7882 return newLOGOP(optype, 0,
7883 op_lvalue(scalar(left), optype),
7884 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7887 return newBINOP(optype, OPf_STACKED,
7888 op_lvalue(scalar(left), optype), scalar(right));
7892 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7893 OP *state_var_op = NULL;
7894 static const char no_list_state[] = "Initialization of state variables"
7895 " in list currently forbidden";
7898 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7899 left->op_private &= ~ OPpSLICEWARNING;
7902 left = op_lvalue(left, OP_AASSIGN);
7903 curop = list(force_list(left, 1));
7904 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7905 o->op_private = (U8)(0 | (flags >> 8));
7907 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7909 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7910 if (!(left->op_flags & OPf_PARENS) &&
7911 lop->op_type == OP_PUSHMARK &&
7912 (vop = OpSIBLING(lop)) &&
7913 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7914 !(vop->op_flags & OPf_PARENS) &&
7915 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7916 (OPpLVAL_INTRO|OPpPAD_STATE) &&
7917 (eop = OpSIBLING(vop)) &&
7918 eop->op_type == OP_ENTERSUB &&
7919 !OpHAS_SIBLING(eop)) {
7923 if ((lop->op_type == OP_PADSV ||
7924 lop->op_type == OP_PADAV ||
7925 lop->op_type == OP_PADHV ||
7926 lop->op_type == OP_PADANY)
7927 && (lop->op_private & OPpPAD_STATE)
7929 yyerror(no_list_state);
7930 lop = OpSIBLING(lop);
7934 else if ( (left->op_private & OPpLVAL_INTRO)
7935 && (left->op_private & OPpPAD_STATE)
7936 && ( left->op_type == OP_PADSV
7937 || left->op_type == OP_PADAV
7938 || left->op_type == OP_PADHV
7939 || left->op_type == OP_PADANY)
7941 /* All single variable list context state assignments, hence
7951 if (left->op_flags & OPf_PARENS)
7952 yyerror(no_list_state);
7954 state_var_op = left;
7957 /* optimise @a = split(...) into:
7958 * @{expr}: split(..., @{expr}) (where @a is not flattened)
7959 * @a, my @a, local @a: split(...) (where @a is attached to
7960 * the split op itself)
7964 && right->op_type == OP_SPLIT
7965 /* don't do twice, e.g. @b = (@a = split) */
7966 && !(right->op_private & OPpSPLIT_ASSIGN))
7970 if ( ( left->op_type == OP_RV2AV
7971 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7972 || left->op_type == OP_PADAV)
7974 /* @pkg or @lex or local @pkg' or 'my @lex' */
7978 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7979 = cPADOPx(gvop)->op_padix;
7980 cPADOPx(gvop)->op_padix = 0; /* steal it */
7982 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7983 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7984 cSVOPx(gvop)->op_sv = NULL; /* steal it */
7986 right->op_private |=
7987 left->op_private & OPpOUR_INTRO;
7990 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7991 left->op_targ = 0; /* steal it */
7992 right->op_private |= OPpSPLIT_LEX;
7994 right->op_private |= left->op_private & OPpLVAL_INTRO;
7997 tmpop = cUNOPo->op_first; /* to list (nulled) */
7998 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
7999 assert(OpSIBLING(tmpop) == right);
8000 assert(!OpHAS_SIBLING(right));
8001 /* detach the split subtreee from the o tree,
8002 * then free the residual o tree */
8003 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8004 op_free(o); /* blow off assign */
8005 right->op_private |= OPpSPLIT_ASSIGN;
8006 right->op_flags &= ~OPf_WANT;
8007 /* "I don't know and I don't care." */
8010 else if (left->op_type == OP_RV2AV) {
8013 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8014 assert(OpSIBLING(pushop) == left);
8015 /* Detach the array ... */
8016 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8017 /* ... and attach it to the split. */
8018 op_sibling_splice(right, cLISTOPx(right)->op_last,
8020 right->op_flags |= OPf_STACKED;
8021 /* Detach split and expunge aassign as above. */
8024 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8025 ((LISTOP*)right)->op_last->op_type == OP_CONST)
8027 /* convert split(...,0) to split(..., PL_modcount+1) */
8029 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8030 SV * const sv = *svp;
8031 if (SvIOK(sv) && SvIVX(sv) == 0)
8033 if (right->op_private & OPpSPLIT_IMPLIM) {
8034 /* our own SV, created in ck_split */
8036 sv_setiv(sv, PL_modcount+1);
8039 /* SV may belong to someone else */
8041 *svp = newSViv(PL_modcount+1);
8048 o = S_newONCEOP(aTHX_ o, state_var_op);
8051 if (assign_type == ASSIGN_REF)
8052 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8054 right = newOP(OP_UNDEF, 0);
8055 if (right->op_type == OP_READLINE) {
8056 right->op_flags |= OPf_STACKED;
8057 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8061 o = newBINOP(OP_SASSIGN, flags,
8062 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8068 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8070 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8071 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8072 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8073 If C<label> is non-null, it supplies the name of a label to attach to
8074 the state op; this function takes ownership of the memory pointed at by
8075 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8078 If C<o> is null, the state op is returned. Otherwise the state op is
8079 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8080 is consumed by this function and becomes part of the returned op tree.
8086 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8089 const U32 seq = intro_my();
8090 const U32 utf8 = flags & SVf_UTF8;
8093 PL_parser->parsed_sub = 0;
8097 NewOp(1101, cop, 1, COP);
8098 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8099 OpTYPE_set(cop, OP_DBSTATE);
8102 OpTYPE_set(cop, OP_NEXTSTATE);
8104 cop->op_flags = (U8)flags;
8105 CopHINTS_set(cop, PL_hints);
8107 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8109 cop->op_next = (OP*)cop;
8112 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8113 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8115 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8117 PL_hints |= HINT_BLOCK_SCOPE;
8118 /* It seems that we need to defer freeing this pointer, as other parts
8119 of the grammar end up wanting to copy it after this op has been
8124 if (PL_parser->preambling != NOLINE) {
8125 CopLINE_set(cop, PL_parser->preambling);
8126 PL_parser->copline = NOLINE;
8128 else if (PL_parser->copline == NOLINE)
8129 CopLINE_set(cop, CopLINE(PL_curcop));
8131 CopLINE_set(cop, PL_parser->copline);
8132 PL_parser->copline = NOLINE;
8135 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
8137 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8139 CopSTASH_set(cop, PL_curstash);
8141 if (cop->op_type == OP_DBSTATE) {
8142 /* this line can have a breakpoint - store the cop in IV */
8143 AV *av = CopFILEAVx(PL_curcop);
8145 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8146 if (svp && *svp != &PL_sv_undef ) {
8147 (void)SvIOK_on(*svp);
8148 SvIV_set(*svp, PTR2IV(cop));
8153 if (flags & OPf_SPECIAL)
8155 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8159 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8161 Constructs, checks, and returns a logical (flow control) op. C<type>
8162 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8163 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8164 the eight bits of C<op_private>, except that the bit with value 1 is
8165 automatically set. C<first> supplies the expression controlling the
8166 flow, and C<other> supplies the side (alternate) chain of ops; they are
8167 consumed by this function and become part of the constructed op tree.
8173 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8175 PERL_ARGS_ASSERT_NEWLOGOP;
8177 return new_logop(type, flags, &first, &other);
8181 S_search_const(pTHX_ OP *o)
8183 PERL_ARGS_ASSERT_SEARCH_CONST;
8185 switch (o->op_type) {
8189 if (o->op_flags & OPf_KIDS)
8190 return search_const(cUNOPo->op_first);
8197 if (!(o->op_flags & OPf_KIDS))
8199 kid = cLISTOPo->op_first;
8201 switch (kid->op_type) {
8205 kid = OpSIBLING(kid);
8208 if (kid != cLISTOPo->op_last)
8214 kid = cLISTOPo->op_last;
8216 return search_const(kid);
8224 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8232 int prepend_not = 0;
8234 PERL_ARGS_ASSERT_NEW_LOGOP;
8239 /* [perl #59802]: Warn about things like "return $a or $b", which
8240 is parsed as "(return $a) or $b" rather than "return ($a or
8241 $b)". NB: This also applies to xor, which is why we do it
8244 switch (first->op_type) {
8248 /* XXX: Perhaps we should emit a stronger warning for these.
8249 Even with the high-precedence operator they don't seem to do
8252 But until we do, fall through here.
8258 /* XXX: Currently we allow people to "shoot themselves in the
8259 foot" by explicitly writing "(return $a) or $b".
8261 Warn unless we are looking at the result from folding or if
8262 the programmer explicitly grouped the operators like this.
8263 The former can occur with e.g.
8265 use constant FEATURE => ( $] >= ... );
8266 sub { not FEATURE and return or do_stuff(); }
8268 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8269 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8270 "Possible precedence issue with control flow operator");
8271 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8277 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8278 return newBINOP(type, flags, scalar(first), scalar(other));
8280 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8281 || type == OP_CUSTOM);
8283 scalarboolean(first);
8285 /* search for a constant op that could let us fold the test */
8286 if ((cstop = search_const(first))) {
8287 if (cstop->op_private & OPpCONST_STRICT)
8288 no_bareword_allowed(cstop);
8289 else if ((cstop->op_private & OPpCONST_BARE))
8290 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8291 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8292 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8293 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8294 /* Elide the (constant) lhs, since it can't affect the outcome */
8296 if (other->op_type == OP_CONST)
8297 other->op_private |= OPpCONST_SHORTCIRCUIT;
8299 if (other->op_type == OP_LEAVE)
8300 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8301 else if (other->op_type == OP_MATCH
8302 || other->op_type == OP_SUBST
8303 || other->op_type == OP_TRANSR
8304 || other->op_type == OP_TRANS)
8305 /* Mark the op as being unbindable with =~ */
8306 other->op_flags |= OPf_SPECIAL;
8308 other->op_folded = 1;
8312 /* Elide the rhs, since the outcome is entirely determined by
8313 * the (constant) lhs */
8315 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8316 const OP *o2 = other;
8317 if ( ! (o2->op_type == OP_LIST
8318 && (( o2 = cUNOPx(o2)->op_first))
8319 && o2->op_type == OP_PUSHMARK
8320 && (( o2 = OpSIBLING(o2))) )
8323 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8324 || o2->op_type == OP_PADHV)
8325 && o2->op_private & OPpLVAL_INTRO
8326 && !(o2->op_private & OPpPAD_STATE))
8328 Perl_croak(aTHX_ "This use of my() in false conditional is "
8329 "no longer allowed");
8333 if (cstop->op_type == OP_CONST)
8334 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8339 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8340 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8342 const OP * const k1 = ((UNOP*)first)->op_first;
8343 const OP * const k2 = OpSIBLING(k1);
8345 switch (first->op_type)
8348 if (k2 && k2->op_type == OP_READLINE
8349 && (k2->op_flags & OPf_STACKED)
8350 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8352 warnop = k2->op_type;
8357 if (k1->op_type == OP_READDIR
8358 || k1->op_type == OP_GLOB
8359 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8360 || k1->op_type == OP_EACH
8361 || k1->op_type == OP_AEACH)
8363 warnop = ((k1->op_type == OP_NULL)
8364 ? (OPCODE)k1->op_targ : k1->op_type);
8369 const line_t oldline = CopLINE(PL_curcop);
8370 /* This ensures that warnings are reported at the first line
8371 of the construction, not the last. */
8372 CopLINE_set(PL_curcop, PL_parser->copline);
8373 Perl_warner(aTHX_ packWARN(WARN_MISC),
8374 "Value of %s%s can be \"0\"; test with defined()",
8376 ((warnop == OP_READLINE || warnop == OP_GLOB)
8377 ? " construct" : "() operator"));
8378 CopLINE_set(PL_curcop, oldline);
8382 /* optimize AND and OR ops that have NOTs as children */
8383 if (first->op_type == OP_NOT
8384 && (first->op_flags & OPf_KIDS)
8385 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8386 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8388 if (type == OP_AND || type == OP_OR) {
8394 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8396 prepend_not = 1; /* prepend a NOT op later */
8401 logop = alloc_LOGOP(type, first, LINKLIST(other));
8402 logop->op_flags |= (U8)flags;
8403 logop->op_private = (U8)(1 | (flags >> 8));
8405 /* establish postfix order */
8406 logop->op_next = LINKLIST(first);
8407 first->op_next = (OP*)logop;
8408 assert(!OpHAS_SIBLING(first));
8409 op_sibling_splice((OP*)logop, first, 0, other);
8411 CHECKOP(type,logop);
8413 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8414 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8422 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8424 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8425 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8426 will be set automatically, and, shifted up eight bits, the eight bits of
8427 C<op_private>, except that the bit with value 1 is automatically set.
8428 C<first> supplies the expression selecting between the two branches,
8429 and C<trueop> and C<falseop> supply the branches; they are consumed by
8430 this function and become part of the constructed op tree.
8436 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8444 PERL_ARGS_ASSERT_NEWCONDOP;
8447 return newLOGOP(OP_AND, 0, first, trueop);
8449 return newLOGOP(OP_OR, 0, first, falseop);
8451 scalarboolean(first);
8452 if ((cstop = search_const(first))) {
8453 /* Left or right arm of the conditional? */
8454 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8455 OP *live = left ? trueop : falseop;
8456 OP *const dead = left ? falseop : trueop;
8457 if (cstop->op_private & OPpCONST_BARE &&
8458 cstop->op_private & OPpCONST_STRICT) {
8459 no_bareword_allowed(cstop);
8463 if (live->op_type == OP_LEAVE)
8464 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8465 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8466 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8467 /* Mark the op as being unbindable with =~ */
8468 live->op_flags |= OPf_SPECIAL;
8469 live->op_folded = 1;
8472 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8473 logop->op_flags |= (U8)flags;
8474 logop->op_private = (U8)(1 | (flags >> 8));
8475 logop->op_next = LINKLIST(falseop);
8477 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8480 /* establish postfix order */
8481 start = LINKLIST(first);
8482 first->op_next = (OP*)logop;
8484 /* make first, trueop, falseop siblings */
8485 op_sibling_splice((OP*)logop, first, 0, trueop);
8486 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8488 o = newUNOP(OP_NULL, 0, (OP*)logop);
8490 trueop->op_next = falseop->op_next = o;
8497 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8499 Constructs and returns a C<range> op, with subordinate C<flip> and
8500 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8501 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8502 for both the C<flip> and C<range> ops, except that the bit with value
8503 1 is automatically set. C<left> and C<right> supply the expressions
8504 controlling the endpoints of the range; they are consumed by this function
8505 and become part of the constructed op tree.
8511 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8519 PERL_ARGS_ASSERT_NEWRANGE;
8521 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8522 range->op_flags = OPf_KIDS;
8523 leftstart = LINKLIST(left);
8524 range->op_private = (U8)(1 | (flags >> 8));
8526 /* make left and right siblings */
8527 op_sibling_splice((OP*)range, left, 0, right);
8529 range->op_next = (OP*)range;
8530 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8531 flop = newUNOP(OP_FLOP, 0, flip);
8532 o = newUNOP(OP_NULL, 0, flop);
8534 range->op_next = leftstart;
8536 left->op_next = flip;
8537 right->op_next = flop;
8540 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8541 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8543 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8544 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8545 SvPADTMP_on(PAD_SV(flip->op_targ));
8547 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8548 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8550 /* check barewords before they might be optimized aways */
8551 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8552 no_bareword_allowed(left);
8553 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8554 no_bareword_allowed(right);
8557 if (!flip->op_private || !flop->op_private)
8558 LINKLIST(o); /* blow off optimizer unless constant */
8564 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8566 Constructs, checks, and returns an op tree expressing a loop. This is
8567 only a loop in the control flow through the op tree; it does not have
8568 the heavyweight loop structure that allows exiting the loop by C<last>
8569 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8570 top-level op, except that some bits will be set automatically as required.
8571 C<expr> supplies the expression controlling loop iteration, and C<block>
8572 supplies the body of the loop; they are consumed by this function and
8573 become part of the constructed op tree. C<debuggable> is currently
8574 unused and should always be 1.
8580 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8584 const bool once = block && block->op_flags & OPf_SPECIAL &&
8585 block->op_type == OP_NULL;
8587 PERL_UNUSED_ARG(debuggable);
8591 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8592 || ( expr->op_type == OP_NOT
8593 && cUNOPx(expr)->op_first->op_type == OP_CONST
8594 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8597 /* Return the block now, so that S_new_logop does not try to
8599 return block; /* do {} while 0 does once */
8600 if (expr->op_type == OP_READLINE
8601 || expr->op_type == OP_READDIR
8602 || expr->op_type == OP_GLOB
8603 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8604 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8605 expr = newUNOP(OP_DEFINED, 0,
8606 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8607 } else if (expr->op_flags & OPf_KIDS) {
8608 const OP * const k1 = ((UNOP*)expr)->op_first;
8609 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8610 switch (expr->op_type) {
8612 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8613 && (k2->op_flags & OPf_STACKED)
8614 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8615 expr = newUNOP(OP_DEFINED, 0, expr);
8619 if (k1 && (k1->op_type == OP_READDIR
8620 || k1->op_type == OP_GLOB
8621 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8622 || k1->op_type == OP_EACH
8623 || k1->op_type == OP_AEACH))
8624 expr = newUNOP(OP_DEFINED, 0, expr);
8630 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8631 * op, in listop. This is wrong. [perl #27024] */
8633 block = newOP(OP_NULL, 0);
8634 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8635 o = new_logop(OP_AND, 0, &expr, &listop);
8642 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8644 if (once && o != listop)
8646 assert(cUNOPo->op_first->op_type == OP_AND
8647 || cUNOPo->op_first->op_type == OP_OR);
8648 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8652 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
8654 o->op_flags |= flags;
8656 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8661 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8663 Constructs, checks, and returns an op tree expressing a C<while> loop.
8664 This is a heavyweight loop, with structure that allows exiting the loop
8665 by C<last> and suchlike.
8667 C<loop> is an optional preconstructed C<enterloop> op to use in the
8668 loop; if it is null then a suitable op will be constructed automatically.
8669 C<expr> supplies the loop's controlling expression. C<block> supplies the
8670 main body of the loop, and C<cont> optionally supplies a C<continue> block
8671 that operates as a second half of the body. All of these optree inputs
8672 are consumed by this function and become part of the constructed op tree.
8674 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8675 op and, shifted up eight bits, the eight bits of C<op_private> for
8676 the C<leaveloop> op, except that (in both cases) some bits will be set
8677 automatically. C<debuggable> is currently unused and should always be 1.
8678 C<has_my> can be supplied as true to force the
8679 loop body to be enclosed in its own scope.
8685 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8686 OP *expr, OP *block, OP *cont, I32 has_my)
8695 PERL_UNUSED_ARG(debuggable);
8698 if (expr->op_type == OP_READLINE
8699 || expr->op_type == OP_READDIR
8700 || expr->op_type == OP_GLOB
8701 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8702 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8703 expr = newUNOP(OP_DEFINED, 0,
8704 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8705 } else if (expr->op_flags & OPf_KIDS) {
8706 const OP * const k1 = ((UNOP*)expr)->op_first;
8707 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8708 switch (expr->op_type) {
8710 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8711 && (k2->op_flags & OPf_STACKED)
8712 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8713 expr = newUNOP(OP_DEFINED, 0, expr);
8717 if (k1 && (k1->op_type == OP_READDIR
8718 || k1->op_type == OP_GLOB
8719 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8720 || k1->op_type == OP_EACH
8721 || k1->op_type == OP_AEACH))
8722 expr = newUNOP(OP_DEFINED, 0, expr);
8729 block = newOP(OP_NULL, 0);
8730 else if (cont || has_my) {
8731 block = op_scope(block);
8735 next = LINKLIST(cont);
8738 OP * const unstack = newOP(OP_UNSTACK, 0);
8741 cont = op_append_elem(OP_LINESEQ, cont, unstack);
8745 listop = op_append_list(OP_LINESEQ, block, cont);
8747 redo = LINKLIST(listop);
8751 o = new_logop(OP_AND, 0, &expr, &listop);
8752 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8754 return expr; /* listop already freed by new_logop */
8757 ((LISTOP*)listop)->op_last->op_next =
8758 (o == listop ? redo : LINKLIST(o));
8764 NewOp(1101,loop,1,LOOP);
8765 OpTYPE_set(loop, OP_ENTERLOOP);
8766 loop->op_private = 0;
8767 loop->op_next = (OP*)loop;
8770 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8772 loop->op_redoop = redo;
8773 loop->op_lastop = o;
8774 o->op_private |= loopflags;
8777 loop->op_nextop = next;
8779 loop->op_nextop = o;
8781 o->op_flags |= flags;
8782 o->op_private |= (flags >> 8);
8787 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8789 Constructs, checks, and returns an op tree expressing a C<foreach>
8790 loop (iteration through a list of values). This is a heavyweight loop,
8791 with structure that allows exiting the loop by C<last> and suchlike.
8793 C<sv> optionally supplies the variable that will be aliased to each
8794 item in turn; if null, it defaults to C<$_>.
8795 C<expr> supplies the list of values to iterate over. C<block> supplies
8796 the main body of the loop, and C<cont> optionally supplies a C<continue>
8797 block that operates as a second half of the body. All of these optree
8798 inputs are consumed by this function and become part of the constructed
8801 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8802 op and, shifted up eight bits, the eight bits of C<op_private> for
8803 the C<leaveloop> op, except that (in both cases) some bits will be set
8810 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8815 PADOFFSET padoff = 0;
8819 PERL_ARGS_ASSERT_NEWFOROP;
8822 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
8823 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8824 OpTYPE_set(sv, OP_RV2GV);
8826 /* The op_type check is needed to prevent a possible segfault
8827 * if the loop variable is undeclared and 'strict vars' is in
8828 * effect. This is illegal but is nonetheless parsed, so we
8829 * may reach this point with an OP_CONST where we're expecting
8832 if (cUNOPx(sv)->op_first->op_type == OP_GV
8833 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8834 iterpflags |= OPpITER_DEF;
8836 else if (sv->op_type == OP_PADSV) { /* private variable */
8837 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8838 padoff = sv->op_targ;
8842 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8844 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8847 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8849 PADNAME * const pn = PAD_COMPNAME(padoff);
8850 const char * const name = PadnamePV(pn);
8852 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8853 iterpflags |= OPpITER_DEF;
8857 sv = newGVOP(OP_GV, 0, PL_defgv);
8858 iterpflags |= OPpITER_DEF;
8861 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8862 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8863 iterflags |= OPf_STACKED;
8865 else if (expr->op_type == OP_NULL &&
8866 (expr->op_flags & OPf_KIDS) &&
8867 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8869 /* Basically turn for($x..$y) into the same as for($x,$y), but we
8870 * set the STACKED flag to indicate that these values are to be
8871 * treated as min/max values by 'pp_enteriter'.
8873 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8874 LOGOP* const range = (LOGOP*) flip->op_first;
8875 OP* const left = range->op_first;
8876 OP* const right = OpSIBLING(left);
8879 range->op_flags &= ~OPf_KIDS;
8880 /* detach range's children */
8881 op_sibling_splice((OP*)range, NULL, -1, NULL);
8883 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8884 listop->op_first->op_next = range->op_next;
8885 left->op_next = range->op_other;
8886 right->op_next = (OP*)listop;
8887 listop->op_next = listop->op_first;
8890 expr = (OP*)(listop);
8892 iterflags |= OPf_STACKED;
8895 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8898 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8899 op_append_elem(OP_LIST, list(expr),
8901 assert(!loop->op_next);
8902 /* for my $x () sets OPpLVAL_INTRO;
8903 * for our $x () sets OPpOUR_INTRO */
8904 loop->op_private = (U8)iterpflags;
8905 if (loop->op_slabbed
8906 && DIFF(loop, OpSLOT(loop)->opslot_next)
8907 < SIZE_TO_PSIZE(sizeof(LOOP)))
8910 NewOp(1234,tmp,1,LOOP);
8911 Copy(loop,tmp,1,LISTOP);
8912 assert(loop->op_last->op_sibparent == (OP*)loop);
8913 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8914 S_op_destroy(aTHX_ (OP*)loop);
8917 else if (!loop->op_slabbed)
8919 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8920 OpLASTSIB_set(loop->op_last, (OP*)loop);
8922 loop->op_targ = padoff;
8923 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8928 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8930 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8931 or C<last>). C<type> is the opcode. C<label> supplies the parameter
8932 determining the target of the op; it is consumed by this function and
8933 becomes part of the constructed op tree.
8939 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8943 PERL_ARGS_ASSERT_NEWLOOPEX;
8945 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8946 || type == OP_CUSTOM);
8948 if (type != OP_GOTO) {
8949 /* "last()" means "last" */
8950 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8951 o = newOP(type, OPf_SPECIAL);
8955 /* Check whether it's going to be a goto &function */
8956 if (label->op_type == OP_ENTERSUB
8957 && !(label->op_flags & OPf_STACKED))
8958 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8961 /* Check for a constant argument */
8962 if (label->op_type == OP_CONST) {
8963 SV * const sv = ((SVOP *)label)->op_sv;
8965 const char *s = SvPV_const(sv,l);
8966 if (l == strlen(s)) {
8968 SvUTF8(((SVOP*)label)->op_sv),
8970 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8974 /* If we have already created an op, we do not need the label. */
8977 else o = newUNOP(type, OPf_STACKED, label);
8979 PL_hints |= HINT_BLOCK_SCOPE;
8983 /* if the condition is a literal array or hash
8984 (or @{ ... } etc), make a reference to it.
8987 S_ref_array_or_hash(pTHX_ OP *cond)
8990 && (cond->op_type == OP_RV2AV
8991 || cond->op_type == OP_PADAV
8992 || cond->op_type == OP_RV2HV
8993 || cond->op_type == OP_PADHV))
8995 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8998 && (cond->op_type == OP_ASLICE
8999 || cond->op_type == OP_KVASLICE
9000 || cond->op_type == OP_HSLICE
9001 || cond->op_type == OP_KVHSLICE)) {
9003 /* anonlist now needs a list from this op, was previously used in
9005 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9006 cond->op_flags |= OPf_WANT_LIST;
9008 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9015 /* These construct the optree fragments representing given()
9018 entergiven and enterwhen are LOGOPs; the op_other pointer
9019 points up to the associated leave op. We need this so we
9020 can put it in the context and make break/continue work.
9021 (Also, of course, pp_enterwhen will jump straight to
9022 op_other if the match fails.)
9026 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9027 I32 enter_opcode, I32 leave_opcode,
9028 PADOFFSET entertarg)
9034 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9035 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9037 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9038 enterop->op_targ = 0;
9039 enterop->op_private = 0;
9041 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9044 /* prepend cond if we have one */
9045 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9047 o->op_next = LINKLIST(cond);
9048 cond->op_next = (OP *) enterop;
9051 /* This is a default {} block */
9052 enterop->op_flags |= OPf_SPECIAL;
9053 o ->op_flags |= OPf_SPECIAL;
9055 o->op_next = (OP *) enterop;
9058 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9059 entergiven and enterwhen both
9062 enterop->op_next = LINKLIST(block);
9063 block->op_next = enterop->op_other = o;
9068 /* Does this look like a boolean operation? For these purposes
9069 a boolean operation is:
9070 - a subroutine call [*]
9071 - a logical connective
9072 - a comparison operator
9073 - a filetest operator, with the exception of -s -M -A -C
9074 - defined(), exists() or eof()
9075 - /$re/ or $foo =~ /$re/
9077 [*] possibly surprising
9080 S_looks_like_bool(pTHX_ const OP *o)
9082 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9084 switch(o->op_type) {
9087 return looks_like_bool(cLOGOPo->op_first);
9091 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9094 looks_like_bool(cLOGOPo->op_first)
9095 && looks_like_bool(sibl));
9101 o->op_flags & OPf_KIDS
9102 && looks_like_bool(cUNOPo->op_first));
9106 case OP_NOT: case OP_XOR:
9108 case OP_EQ: case OP_NE: case OP_LT:
9109 case OP_GT: case OP_LE: case OP_GE:
9111 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9112 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9114 case OP_SEQ: case OP_SNE: case OP_SLT:
9115 case OP_SGT: case OP_SLE: case OP_SGE:
9119 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9120 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9121 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9122 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9123 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9124 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9125 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9126 case OP_FTTEXT: case OP_FTBINARY:
9128 case OP_DEFINED: case OP_EXISTS:
9129 case OP_MATCH: case OP_EOF:
9137 /* optimised-away (index() != -1) or similar comparison */
9138 if (o->op_private & OPpTRUEBOOL)
9143 /* Detect comparisons that have been optimized away */
9144 if (cSVOPo->op_sv == &PL_sv_yes
9145 || cSVOPo->op_sv == &PL_sv_no)
9157 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9159 Constructs, checks, and returns an op tree expressing a C<given> block.
9160 C<cond> supplies the expression to whose value C<$_> will be locally
9161 aliased, and C<block> supplies the body of the C<given> construct; they
9162 are consumed by this function and become part of the constructed op tree.
9163 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9169 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9171 PERL_ARGS_ASSERT_NEWGIVENOP;
9172 PERL_UNUSED_ARG(defsv_off);
9175 return newGIVWHENOP(
9176 ref_array_or_hash(cond),
9178 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9183 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9185 Constructs, checks, and returns an op tree expressing a C<when> block.
9186 C<cond> supplies the test expression, and C<block> supplies the block
9187 that will be executed if the test evaluates to true; they are consumed
9188 by this function and become part of the constructed op tree. C<cond>
9189 will be interpreted DWIMically, often as a comparison against C<$_>,
9190 and may be null to generate a C<default> block.
9196 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9198 const bool cond_llb = (!cond || looks_like_bool(cond));
9201 PERL_ARGS_ASSERT_NEWWHENOP;
9206 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9208 scalar(ref_array_or_hash(cond)));
9211 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9214 /* must not conflict with SVf_UTF8 */
9215 #define CV_CKPROTO_CURSTASH 0x1
9218 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9219 const STRLEN len, const U32 flags)
9221 SV *name = NULL, *msg;
9222 const char * cvp = SvROK(cv)
9223 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9224 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9227 STRLEN clen = CvPROTOLEN(cv), plen = len;
9229 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9231 if (p == NULL && cvp == NULL)
9234 if (!ckWARN_d(WARN_PROTOTYPE))
9238 p = S_strip_spaces(aTHX_ p, &plen);
9239 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9240 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9241 if (plen == clen && memEQ(cvp, p, plen))
9244 if (flags & SVf_UTF8) {
9245 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9249 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9255 msg = sv_newmortal();
9260 gv_efullname3(name = sv_newmortal(), gv, NULL);
9261 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9262 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9263 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9264 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9265 sv_catpvs(name, "::");
9267 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9268 assert (CvNAMED(SvRV_const(gv)));
9269 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9271 else sv_catsv(name, (SV *)gv);
9273 else name = (SV *)gv;
9275 sv_setpvs(msg, "Prototype mismatch:");
9277 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9279 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9280 UTF8fARG(SvUTF8(cv),clen,cvp)
9283 sv_catpvs(msg, ": none");
9284 sv_catpvs(msg, " vs ");
9286 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9288 sv_catpvs(msg, "none");
9289 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9292 static void const_sv_xsub(pTHX_ CV* cv);
9293 static void const_av_xsub(pTHX_ CV* cv);
9297 =head1 Optree Manipulation Functions
9299 =for apidoc cv_const_sv
9301 If C<cv> is a constant sub eligible for inlining, returns the constant
9302 value returned by the sub. Otherwise, returns C<NULL>.
9304 Constant subs can be created with C<newCONSTSUB> or as described in
9305 L<perlsub/"Constant Functions">.
9310 Perl_cv_const_sv(const CV *const cv)
9315 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9317 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9318 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9323 Perl_cv_const_sv_or_av(const CV * const cv)
9327 if (SvROK(cv)) return SvRV((SV *)cv);
9328 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9329 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9332 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9333 * Can be called in 2 ways:
9336 * look for a single OP_CONST with attached value: return the value
9338 * allow_lex && !CvCONST(cv);
9340 * examine the clone prototype, and if contains only a single
9341 * OP_CONST, return the value; or if it contains a single PADSV ref-
9342 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9343 * a candidate for "constizing" at clone time, and return NULL.
9347 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9355 for (; o; o = o->op_next) {
9356 const OPCODE type = o->op_type;
9358 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9360 || type == OP_PUSHMARK)
9362 if (type == OP_DBSTATE)
9364 if (type == OP_LEAVESUB)
9368 if (type == OP_CONST && cSVOPo->op_sv)
9370 else if (type == OP_UNDEF && !o->op_private) {
9374 else if (allow_lex && type == OP_PADSV) {
9375 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9377 sv = &PL_sv_undef; /* an arbitrary non-null value */
9395 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9396 PADNAME * const name, SV ** const const_svp)
9402 if (CvFLAGS(PL_compcv)) {
9403 /* might have had built-in attrs applied */
9404 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9405 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9406 && ckWARN(WARN_MISC))
9408 /* protect against fatal warnings leaking compcv */
9409 SAVEFREESV(PL_compcv);
9410 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9411 SvREFCNT_inc_simple_void_NN(PL_compcv);
9414 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9415 & ~(CVf_LVALUE * pureperl));
9420 /* redundant check for speed: */
9421 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9422 const line_t oldline = CopLINE(PL_curcop);
9425 : sv_2mortal(newSVpvn_utf8(
9426 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9428 if (PL_parser && PL_parser->copline != NOLINE)
9429 /* This ensures that warnings are reported at the first
9430 line of a redefinition, not the last. */
9431 CopLINE_set(PL_curcop, PL_parser->copline);
9432 /* protect against fatal warnings leaking compcv */
9433 SAVEFREESV(PL_compcv);
9434 report_redefined_cv(namesv, cv, const_svp);
9435 SvREFCNT_inc_simple_void_NN(PL_compcv);
9436 CopLINE_set(PL_curcop, oldline);
9443 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9448 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9451 CV *compcv = PL_compcv;
9454 PADOFFSET pax = o->op_targ;
9455 CV *outcv = CvOUTSIDE(PL_compcv);
9458 bool reusable = FALSE;
9460 #ifdef PERL_DEBUG_READONLY_OPS
9461 OPSLAB *slab = NULL;
9464 PERL_ARGS_ASSERT_NEWMYSUB;
9466 PL_hints |= HINT_BLOCK_SCOPE;
9468 /* Find the pad slot for storing the new sub.
9469 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9470 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9471 ing sub. And then we need to dig deeper if this is a lexical from
9473 my sub foo; sub { sub foo { } }
9476 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9477 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9478 pax = PARENT_PAD_INDEX(name);
9479 outcv = CvOUTSIDE(outcv);
9484 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9485 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9486 spot = (CV **)svspot;
9488 if (!(PL_parser && PL_parser->error_count))
9489 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9492 assert(proto->op_type == OP_CONST);
9493 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9494 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9504 if (PL_parser && PL_parser->error_count) {
9506 SvREFCNT_dec(PL_compcv);
9511 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9513 svspot = (SV **)(spot = &clonee);
9515 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9518 assert (SvTYPE(*spot) == SVt_PVCV);
9520 hek = CvNAME_HEK(*spot);
9524 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9525 CvNAME_HEK_set(*spot, hek =
9528 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9532 CvLEXICAL_on(*spot);
9534 cv = PadnamePROTOCV(name);
9535 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9539 /* This makes sub {}; work as expected. */
9540 if (block->op_type == OP_STUB) {
9541 const line_t l = PL_parser->copline;
9543 block = newSTATEOP(0, NULL, 0);
9544 PL_parser->copline = l;
9546 block = CvLVALUE(compcv)
9547 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9548 ? newUNOP(OP_LEAVESUBLV, 0,
9549 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9550 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9551 start = LINKLIST(block);
9553 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9554 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9562 const bool exists = CvROOT(cv) || CvXSUB(cv);
9564 /* if the subroutine doesn't exist and wasn't pre-declared
9565 * with a prototype, assume it will be AUTOLOADed,
9566 * skipping the prototype check
9568 if (exists || SvPOK(cv))
9569 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9571 /* already defined? */
9573 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9579 /* just a "sub foo;" when &foo is already defined */
9584 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9591 SvREFCNT_inc_simple_void_NN(const_sv);
9592 SvFLAGS(const_sv) |= SVs_PADTMP;
9594 assert(!CvROOT(cv) && !CvCONST(cv));
9598 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9599 CvFILE_set_from_cop(cv, PL_curcop);
9600 CvSTASH_set(cv, PL_curstash);
9603 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9604 CvXSUBANY(cv).any_ptr = const_sv;
9605 CvXSUB(cv) = const_sv_xsub;
9609 CvFLAGS(cv) |= CvMETHOD(compcv);
9611 SvREFCNT_dec(compcv);
9616 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9617 determine whether this sub definition is in the same scope as its
9618 declaration. If this sub definition is inside an inner named pack-
9619 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9620 the package sub. So check PadnameOUTER(name) too.
9622 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9623 assert(!CvWEAKOUTSIDE(compcv));
9624 SvREFCNT_dec(CvOUTSIDE(compcv));
9625 CvWEAKOUTSIDE_on(compcv);
9627 /* XXX else do we have a circular reference? */
9629 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
9630 /* transfer PL_compcv to cv */
9632 cv_flags_t preserved_flags =
9633 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9634 PADLIST *const temp_padl = CvPADLIST(cv);
9635 CV *const temp_cv = CvOUTSIDE(cv);
9636 const cv_flags_t other_flags =
9637 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9638 OP * const cvstart = CvSTART(cv);
9642 CvFLAGS(compcv) | preserved_flags;
9643 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9644 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9645 CvPADLIST_set(cv, CvPADLIST(compcv));
9646 CvOUTSIDE(compcv) = temp_cv;
9647 CvPADLIST_set(compcv, temp_padl);
9648 CvSTART(cv) = CvSTART(compcv);
9649 CvSTART(compcv) = cvstart;
9650 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9651 CvFLAGS(compcv) |= other_flags;
9653 if (CvFILE(cv) && CvDYNFILE(cv)) {
9654 Safefree(CvFILE(cv));
9657 /* inner references to compcv must be fixed up ... */
9658 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9659 if (PERLDB_INTER)/* Advice debugger on the new sub. */
9660 ++PL_sub_generation;
9663 /* Might have had built-in attributes applied -- propagate them. */
9664 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9666 /* ... before we throw it away */
9667 SvREFCNT_dec(compcv);
9668 PL_compcv = compcv = cv;
9677 if (!CvNAME_HEK(cv)) {
9678 if (hek) (void)share_hek_hek(hek);
9682 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9683 hek = share_hek(PadnamePV(name)+1,
9684 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9687 CvNAME_HEK_set(cv, hek);
9693 CvFILE_set_from_cop(cv, PL_curcop);
9694 CvSTASH_set(cv, PL_curstash);
9697 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9699 SvUTF8_on(MUTABLE_SV(cv));
9703 /* If we assign an optree to a PVCV, then we've defined a
9704 * subroutine that the debugger could be able to set a breakpoint
9705 * in, so signal to pp_entereval that it should not throw away any
9706 * saved lines at scope exit. */
9708 PL_breakable_sub_gen++;
9710 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9711 itself has a refcount. */
9713 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9714 #ifdef PERL_DEBUG_READONLY_OPS
9715 slab = (OPSLAB *)CvSTART(cv);
9717 S_process_optree(aTHX_ cv, block, start);
9722 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9723 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9727 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9728 SV * const tmpstr = sv_newmortal();
9729 GV * const db_postponed = gv_fetchpvs("DB::postponed",
9730 GV_ADDMULTI, SVt_PVHV);
9732 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9735 (long)CopLINE(PL_curcop));
9736 if (HvNAME_HEK(PL_curstash)) {
9737 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9738 sv_catpvs(tmpstr, "::");
9741 sv_setpvs(tmpstr, "__ANON__::");
9743 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9744 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9745 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9746 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9747 hv = GvHVn(db_postponed);
9748 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9749 CV * const pcv = GvCV(db_postponed);
9755 call_sv(MUTABLE_SV(pcv), G_DISCARD);
9763 assert(CvDEPTH(outcv));
9765 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9767 cv_clone_into(clonee, *spot);
9768 else *spot = cv_clone(clonee);
9769 SvREFCNT_dec_NN(clonee);
9773 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9774 PADOFFSET depth = CvDEPTH(outcv);
9777 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9779 *svspot = SvREFCNT_inc_simple_NN(cv);
9780 SvREFCNT_dec(oldcv);
9786 PL_parser->copline = NOLINE;
9788 #ifdef PERL_DEBUG_READONLY_OPS
9797 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9799 Construct a Perl subroutine, also performing some surrounding jobs.
9801 This function is expected to be called in a Perl compilation context,
9802 and some aspects of the subroutine are taken from global variables
9803 associated with compilation. In particular, C<PL_compcv> represents
9804 the subroutine that is currently being compiled. It must be non-null
9805 when this function is called, and some aspects of the subroutine being
9806 constructed are taken from it. The constructed subroutine may actually
9807 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9809 If C<block> is null then the subroutine will have no body, and for the
9810 time being it will be an error to call it. This represents a forward
9811 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
9812 non-null then it provides the Perl code of the subroutine body, which
9813 will be executed when the subroutine is called. This body includes
9814 any argument unwrapping code resulting from a subroutine signature or
9815 similar. The pad use of the code must correspond to the pad attached
9816 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
9817 C<leavesublv> op; this function will add such an op. C<block> is consumed
9818 by this function and will become part of the constructed subroutine.
9820 C<proto> specifies the subroutine's prototype, unless one is supplied
9821 as an attribute (see below). If C<proto> is null, then the subroutine
9822 will not have a prototype. If C<proto> is non-null, it must point to a
9823 C<const> op whose value is a string, and the subroutine will have that
9824 string as its prototype. If a prototype is supplied as an attribute, the
9825 attribute takes precedence over C<proto>, but in that case C<proto> should
9826 preferably be null. In any case, C<proto> is consumed by this function.
9828 C<attrs> supplies attributes to be applied the subroutine. A handful of
9829 attributes take effect by built-in means, being applied to C<PL_compcv>
9830 immediately when seen. Other attributes are collected up and attached
9831 to the subroutine by this route. C<attrs> may be null to supply no
9832 attributes, or point to a C<const> op for a single attribute, or point
9833 to a C<list> op whose children apart from the C<pushmark> are C<const>
9834 ops for one or more attributes. Each C<const> op must be a string,
9835 giving the attribute name optionally followed by parenthesised arguments,
9836 in the manner in which attributes appear in Perl source. The attributes
9837 will be applied to the sub by this function. C<attrs> is consumed by
9840 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9841 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
9842 must point to a C<const> op, which will be consumed by this function,
9843 and its string value supplies a name for the subroutine. The name may
9844 be qualified or unqualified, and if it is unqualified then a default
9845 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
9846 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9847 by which the subroutine will be named.
9849 If there is already a subroutine of the specified name, then the new
9850 sub will either replace the existing one in the glob or be merged with
9851 the existing one. A warning may be generated about redefinition.
9853 If the subroutine has one of a few special names, such as C<BEGIN> or
9854 C<END>, then it will be claimed by the appropriate queue for automatic
9855 running of phase-related subroutines. In this case the relevant glob will
9856 be left not containing any subroutine, even if it did contain one before.
9857 In the case of C<BEGIN>, the subroutine will be executed and the reference
9858 to it disposed of before this function returns.
9860 The function returns a pointer to the constructed subroutine. If the sub
9861 is anonymous then ownership of one counted reference to the subroutine
9862 is transferred to the caller. If the sub is named then the caller does
9863 not get ownership of a reference. In most such cases, where the sub
9864 has a non-phase name, the sub will be alive at the point it is returned
9865 by virtue of being contained in the glob that names it. A phase-named
9866 subroutine will usually be alive by virtue of the reference owned by the
9867 phase's automatic run queue. But a C<BEGIN> subroutine, having already
9868 been executed, will quite likely have been destroyed already by the
9869 time this function returns, making it erroneous for the caller to make
9870 any use of the returned pointer. It is the caller's responsibility to
9871 ensure that it knows which of these situations applies.
9878 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9879 OP *block, bool o_is_gv)
9883 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9885 CV *cv = NULL; /* the previous CV with this name, if any */
9887 const bool ec = PL_parser && PL_parser->error_count;
9888 /* If the subroutine has no body, no attributes, and no builtin attributes
9889 then it's just a sub declaration, and we may be able to get away with
9890 storing with a placeholder scalar in the symbol table, rather than a
9891 full CV. If anything is present then it will take a full CV to
9893 const I32 gv_fetch_flags
9894 = ec ? GV_NOADD_NOINIT :
9895 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9896 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9898 const char * const name =
9899 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9901 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9902 bool evanescent = FALSE;
9904 #ifdef PERL_DEBUG_READONLY_OPS
9905 OPSLAB *slab = NULL;
9913 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
9914 hek and CvSTASH pointer together can imply the GV. If the name
9915 contains a package name, then GvSTASH(CvGV(cv)) may differ from
9916 CvSTASH, so forego the optimisation if we find any.
9917 Also, we may be called from load_module at run time, so
9918 PL_curstash (which sets CvSTASH) may not point to the stash the
9919 sub is stored in. */
9920 /* XXX This optimization is currently disabled for packages other
9921 than main, since there was too much CPAN breakage. */
9923 ec ? GV_NOADD_NOINIT
9924 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9925 || PL_curstash != PL_defstash
9926 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9928 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9929 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9931 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9932 SV * const sv = sv_newmortal();
9933 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9934 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9935 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9936 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9938 } else if (PL_curstash) {
9939 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9942 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9948 move_proto_attr(&proto, &attrs, gv, 0);
9951 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9956 assert(proto->op_type == OP_CONST);
9957 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9958 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9974 SvREFCNT_dec(PL_compcv);
9979 if (name && block) {
9980 const char *s = (char *) my_memrchr(name, ':', namlen);
9982 if (strEQ(s, "BEGIN")) {
9983 if (PL_in_eval & EVAL_KEEPERR)
9984 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9986 SV * const errsv = ERRSV;
9987 /* force display of errors found but not reported */
9988 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9989 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9996 if (!block && SvTYPE(gv) != SVt_PVGV) {
9997 /* If we are not defining a new sub and the existing one is not a
9999 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10000 /* We are applying attributes to an existing sub, so we need it
10001 upgraded if it is a constant. */
10002 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10003 gv_init_pvn(gv, PL_curstash, name, namlen,
10004 SVf_UTF8 * name_is_utf8);
10006 else { /* Maybe prototype now, and had at maximum
10007 a prototype or const/sub ref before. */
10008 if (SvTYPE(gv) > SVt_NULL) {
10009 cv_ckproto_len_flags((const CV *)gv,
10010 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10016 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10018 SvUTF8_on(MUTABLE_SV(gv));
10021 sv_setiv(MUTABLE_SV(gv), -1);
10024 SvREFCNT_dec(PL_compcv);
10025 cv = PL_compcv = NULL;
10030 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10034 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10040 /* This makes sub {}; work as expected. */
10041 if (block->op_type == OP_STUB) {
10042 const line_t l = PL_parser->copline;
10044 block = newSTATEOP(0, NULL, 0);
10045 PL_parser->copline = l;
10047 block = CvLVALUE(PL_compcv)
10048 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10049 && (!isGV(gv) || !GvASSUMECV(gv)))
10050 ? newUNOP(OP_LEAVESUBLV, 0,
10051 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10052 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10053 start = LINKLIST(block);
10054 block->op_next = 0;
10055 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10057 S_op_const_sv(aTHX_ start, PL_compcv,
10058 cBOOL(CvCLONE(PL_compcv)));
10065 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10066 cv_ckproto_len_flags((const CV *)gv,
10067 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10068 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10070 /* All the other code for sub redefinition warnings expects the
10071 clobbered sub to be a CV. Instead of making all those code
10072 paths more complex, just inline the RV version here. */
10073 const line_t oldline = CopLINE(PL_curcop);
10074 assert(IN_PERL_COMPILETIME);
10075 if (PL_parser && PL_parser->copline != NOLINE)
10076 /* This ensures that warnings are reported at the first
10077 line of a redefinition, not the last. */
10078 CopLINE_set(PL_curcop, PL_parser->copline);
10079 /* protect against fatal warnings leaking compcv */
10080 SAVEFREESV(PL_compcv);
10082 if (ckWARN(WARN_REDEFINE)
10083 || ( ckWARN_d(WARN_REDEFINE)
10084 && ( !const_sv || SvRV(gv) == const_sv
10085 || sv_cmp(SvRV(gv), const_sv) ))) {
10087 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10088 "Constant subroutine %" SVf " redefined",
10089 SVfARG(cSVOPo->op_sv));
10092 SvREFCNT_inc_simple_void_NN(PL_compcv);
10093 CopLINE_set(PL_curcop, oldline);
10094 SvREFCNT_dec(SvRV(gv));
10099 const bool exists = CvROOT(cv) || CvXSUB(cv);
10101 /* if the subroutine doesn't exist and wasn't pre-declared
10102 * with a prototype, assume it will be AUTOLOADed,
10103 * skipping the prototype check
10105 if (exists || SvPOK(cv))
10106 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10107 /* already defined (or promised)? */
10108 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10109 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10115 /* just a "sub foo;" when &foo is already defined */
10116 SAVEFREESV(PL_compcv);
10123 SvREFCNT_inc_simple_void_NN(const_sv);
10124 SvFLAGS(const_sv) |= SVs_PADTMP;
10126 assert(!CvROOT(cv) && !CvCONST(cv));
10127 cv_forget_slab(cv);
10128 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10129 CvXSUBANY(cv).any_ptr = const_sv;
10130 CvXSUB(cv) = const_sv_xsub;
10134 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10137 if (isGV(gv) || CvMETHOD(PL_compcv)) {
10138 if (name && isGV(gv))
10139 GvCV_set(gv, NULL);
10140 cv = newCONSTSUB_flags(
10141 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10145 assert(SvREFCNT((SV*)cv) != 0);
10146 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10150 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10151 prepare_SV_for_RV((SV *)gv);
10152 SvOK_off((SV *)gv);
10155 SvRV_set(gv, const_sv);
10159 SvREFCNT_dec(PL_compcv);
10164 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10165 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10168 if (cv) { /* must reuse cv if autoloaded */
10169 /* transfer PL_compcv to cv */
10171 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10172 PADLIST *const temp_av = CvPADLIST(cv);
10173 CV *const temp_cv = CvOUTSIDE(cv);
10174 const cv_flags_t other_flags =
10175 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10176 OP * const cvstart = CvSTART(cv);
10180 assert(!CvCVGV_RC(cv));
10181 assert(CvGV(cv) == gv);
10186 PERL_HASH(hash, name, namlen);
10196 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10198 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10199 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10200 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10201 CvOUTSIDE(PL_compcv) = temp_cv;
10202 CvPADLIST_set(PL_compcv, temp_av);
10203 CvSTART(cv) = CvSTART(PL_compcv);
10204 CvSTART(PL_compcv) = cvstart;
10205 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10206 CvFLAGS(PL_compcv) |= other_flags;
10208 if (CvFILE(cv) && CvDYNFILE(cv)) {
10209 Safefree(CvFILE(cv));
10211 CvFILE_set_from_cop(cv, PL_curcop);
10212 CvSTASH_set(cv, PL_curstash);
10214 /* inner references to PL_compcv must be fixed up ... */
10215 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10216 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10217 ++PL_sub_generation;
10220 /* Might have had built-in attributes applied -- propagate them. */
10221 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10223 /* ... before we throw it away */
10224 SvREFCNT_dec(PL_compcv);
10229 if (name && isGV(gv)) {
10232 if (HvENAME_HEK(GvSTASH(gv)))
10233 /* sub Foo::bar { (shift)+1 } */
10234 gv_method_changed(gv);
10238 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10239 prepare_SV_for_RV((SV *)gv);
10240 SvOK_off((SV *)gv);
10243 SvRV_set(gv, (SV *)cv);
10244 if (HvENAME_HEK(PL_curstash))
10245 mro_method_changed_in(PL_curstash);
10249 assert(SvREFCNT((SV*)cv) != 0);
10251 if (!CvHASGV(cv)) {
10257 PERL_HASH(hash, name, namlen);
10258 CvNAME_HEK_set(cv, share_hek(name,
10264 CvFILE_set_from_cop(cv, PL_curcop);
10265 CvSTASH_set(cv, PL_curstash);
10269 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10271 SvUTF8_on(MUTABLE_SV(cv));
10275 /* If we assign an optree to a PVCV, then we've defined a
10276 * subroutine that the debugger could be able to set a breakpoint
10277 * in, so signal to pp_entereval that it should not throw away any
10278 * saved lines at scope exit. */
10280 PL_breakable_sub_gen++;
10281 CvROOT(cv) = block;
10282 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10283 itself has a refcount. */
10285 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10286 #ifdef PERL_DEBUG_READONLY_OPS
10287 slab = (OPSLAB *)CvSTART(cv);
10289 S_process_optree(aTHX_ cv, block, start);
10294 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10295 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10296 ? GvSTASH(CvGV(cv))
10300 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10302 SvREFCNT_inc_simple_void_NN(cv);
10305 if (block && has_name) {
10306 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10307 SV * const tmpstr = cv_name(cv,NULL,0);
10308 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10309 GV_ADDMULTI, SVt_PVHV);
10311 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10312 CopFILE(PL_curcop),
10314 (long)CopLINE(PL_curcop));
10315 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10316 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10317 hv = GvHVn(db_postponed);
10318 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10319 CV * const pcv = GvCV(db_postponed);
10325 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10331 if (PL_parser && PL_parser->error_count)
10332 clear_special_blocks(name, gv, cv);
10335 process_special_blocks(floor, name, gv, cv);
10341 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10343 PL_parser->copline = NOLINE;
10344 LEAVE_SCOPE(floor);
10346 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10348 #ifdef PERL_DEBUG_READONLY_OPS
10352 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10353 pad_add_weakref(cv);
10359 S_clear_special_blocks(pTHX_ const char *const fullname,
10360 GV *const gv, CV *const cv) {
10364 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10366 colon = strrchr(fullname,':');
10367 name = colon ? colon + 1 : fullname;
10369 if ((*name == 'B' && strEQ(name, "BEGIN"))
10370 || (*name == 'E' && strEQ(name, "END"))
10371 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10372 || (*name == 'C' && strEQ(name, "CHECK"))
10373 || (*name == 'I' && strEQ(name, "INIT"))) {
10378 GvCV_set(gv, NULL);
10379 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10383 /* Returns true if the sub has been freed. */
10385 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10389 const char *const colon = strrchr(fullname,':');
10390 const char *const name = colon ? colon + 1 : fullname;
10392 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10394 if (*name == 'B') {
10395 if (strEQ(name, "BEGIN")) {
10396 const I32 oldscope = PL_scopestack_ix;
10399 if (floor) LEAVE_SCOPE(floor);
10401 PUSHSTACKi(PERLSI_REQUIRE);
10402 SAVECOPFILE(&PL_compiling);
10403 SAVECOPLINE(&PL_compiling);
10404 SAVEVPTR(PL_curcop);
10406 DEBUG_x( dump_sub(gv) );
10407 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10408 GvCV_set(gv,0); /* cv has been hijacked */
10409 call_list(oldscope, PL_beginav);
10413 return !PL_savebegin;
10418 if (*name == 'E') {
10419 if strEQ(name, "END") {
10420 DEBUG_x( dump_sub(gv) );
10421 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10424 } else if (*name == 'U') {
10425 if (strEQ(name, "UNITCHECK")) {
10426 /* It's never too late to run a unitcheck block */
10427 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10431 } else if (*name == 'C') {
10432 if (strEQ(name, "CHECK")) {
10434 /* diag_listed_as: Too late to run %s block */
10435 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10436 "Too late to run CHECK block");
10437 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10441 } else if (*name == 'I') {
10442 if (strEQ(name, "INIT")) {
10444 /* diag_listed_as: Too late to run %s block */
10445 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10446 "Too late to run INIT block");
10447 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10453 DEBUG_x( dump_sub(gv) );
10455 GvCV_set(gv,0); /* cv has been hijacked */
10461 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10463 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10464 rather than of counted length, and no flags are set. (This means that
10465 C<name> is always interpreted as Latin-1.)
10471 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10473 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10477 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10479 Construct a constant subroutine, also performing some surrounding
10480 jobs. A scalar constant-valued subroutine is eligible for inlining
10481 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10482 123 }>>. Other kinds of constant subroutine have other treatment.
10484 The subroutine will have an empty prototype and will ignore any arguments
10485 when called. Its constant behaviour is determined by C<sv>. If C<sv>
10486 is null, the subroutine will yield an empty list. If C<sv> points to a
10487 scalar, the subroutine will always yield that scalar. If C<sv> points
10488 to an array, the subroutine will always yield a list of the elements of
10489 that array in list context, or the number of elements in the array in
10490 scalar context. This function takes ownership of one counted reference
10491 to the scalar or array, and will arrange for the object to live as long
10492 as the subroutine does. If C<sv> points to a scalar then the inlining
10493 assumes that the value of the scalar will never change, so the caller
10494 must ensure that the scalar is not subsequently written to. If C<sv>
10495 points to an array then no such assumption is made, so it is ostensibly
10496 safe to mutate the array or its elements, but whether this is really
10497 supported has not been determined.
10499 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10500 Other aspects of the subroutine will be left in their default state.
10501 The caller is free to mutate the subroutine beyond its initial state
10502 after this function has returned.
10504 If C<name> is null then the subroutine will be anonymous, with its
10505 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10506 subroutine will be named accordingly, referenced by the appropriate glob.
10507 C<name> is a string of length C<len> bytes giving a sigilless symbol
10508 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10509 otherwise. The name may be either qualified or unqualified. If the
10510 name is unqualified then it defaults to being in the stash specified by
10511 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10512 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10515 C<flags> should not have bits set other than C<SVf_UTF8>.
10517 If there is already a subroutine of the specified name, then the new sub
10518 will replace the existing one in the glob. A warning may be generated
10519 about the redefinition.
10521 If the subroutine has one of a few special names, such as C<BEGIN> or
10522 C<END>, then it will be claimed by the appropriate queue for automatic
10523 running of phase-related subroutines. In this case the relevant glob will
10524 be left not containing any subroutine, even if it did contain one before.
10525 Execution of the subroutine will likely be a no-op, unless C<sv> was
10526 a tied array or the caller modified the subroutine in some interesting
10527 way before it was executed. In the case of C<BEGIN>, the treatment is
10528 buggy: the sub will be executed when only half built, and may be deleted
10529 prematurely, possibly causing a crash.
10531 The function returns a pointer to the constructed subroutine. If the sub
10532 is anonymous then ownership of one counted reference to the subroutine
10533 is transferred to the caller. If the sub is named then the caller does
10534 not get ownership of a reference. In most such cases, where the sub
10535 has a non-phase name, the sub will be alive at the point it is returned
10536 by virtue of being contained in the glob that names it. A phase-named
10537 subroutine will usually be alive by virtue of the reference owned by
10538 the phase's automatic run queue. A C<BEGIN> subroutine may have been
10539 destroyed already by the time this function returns, but currently bugs
10540 occur in that case before the caller gets control. It is the caller's
10541 responsibility to ensure that it knows which of these situations applies.
10547 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10551 const char *const file = CopFILE(PL_curcop);
10555 if (IN_PERL_RUNTIME) {
10556 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10557 * an op shared between threads. Use a non-shared COP for our
10559 SAVEVPTR(PL_curcop);
10560 SAVECOMPILEWARNINGS();
10561 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10562 PL_curcop = &PL_compiling;
10564 SAVECOPLINE(PL_curcop);
10565 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10568 PL_hints &= ~HINT_BLOCK_SCOPE;
10571 SAVEGENERICSV(PL_curstash);
10572 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10575 /* Protect sv against leakage caused by fatal warnings. */
10576 if (sv) SAVEFREESV(sv);
10578 /* file becomes the CvFILE. For an XS, it's usually static storage,
10579 and so doesn't get free()d. (It's expected to be from the C pre-
10580 processor __FILE__ directive). But we need a dynamically allocated one,
10581 and we need it to get freed. */
10582 cv = newXS_len_flags(name, len,
10583 sv && SvTYPE(sv) == SVt_PVAV
10586 file ? file : "", "",
10587 &sv, XS_DYNAMIC_FILENAME | flags);
10589 assert(SvREFCNT((SV*)cv) != 0);
10590 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10599 =for apidoc U||newXS
10601 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
10602 static storage, as it is used directly as CvFILE(), without a copy being made.
10608 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10610 PERL_ARGS_ASSERT_NEWXS;
10611 return newXS_len_flags(
10612 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10617 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10618 const char *const filename, const char *const proto,
10621 PERL_ARGS_ASSERT_NEWXS_FLAGS;
10622 return newXS_len_flags(
10623 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10628 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10630 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10631 return newXS_len_flags(
10632 name, strlen(name), subaddr, NULL, NULL, NULL, 0
10637 =for apidoc m|CV *|newXS_len_flags|const char *name|STRLEN len|XSUBADDR_t subaddr|const char *const filename|const char *const proto|SV **const_svp|U32 flags
10639 Construct an XS subroutine, also performing some surrounding jobs.
10641 The subroutine will have the entry point C<subaddr>. It will have
10642 the prototype specified by the nul-terminated string C<proto>, or
10643 no prototype if C<proto> is null. The prototype string is copied;
10644 the caller can mutate the supplied string afterwards. If C<filename>
10645 is non-null, it must be a nul-terminated filename, and the subroutine
10646 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
10647 point directly to the supplied string, which must be static. If C<flags>
10648 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10651 Other aspects of the subroutine will be left in their default state.
10652 If anything else needs to be done to the subroutine for it to function
10653 correctly, it is the caller's responsibility to do that after this
10654 function has constructed it. However, beware of the subroutine
10655 potentially being destroyed before this function returns, as described
10658 If C<name> is null then the subroutine will be anonymous, with its
10659 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10660 subroutine will be named accordingly, referenced by the appropriate glob.
10661 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10662 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10663 The name may be either qualified or unqualified, with the stash defaulting
10664 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
10665 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10666 they have there, such as C<GV_ADDWARN>. The symbol is always added to
10667 the stash if necessary, with C<GV_ADDMULTI> semantics.
10669 If there is already a subroutine of the specified name, then the new sub
10670 will replace the existing one in the glob. A warning may be generated
10671 about the redefinition. If the old subroutine was C<CvCONST> then the
10672 decision about whether to warn is influenced by an expectation about
10673 whether the new subroutine will become a constant of similar value.
10674 That expectation is determined by C<const_svp>. (Note that the call to
10675 this function doesn't make the new subroutine C<CvCONST> in any case;
10676 that is left to the caller.) If C<const_svp> is null then it indicates
10677 that the new subroutine will not become a constant. If C<const_svp>
10678 is non-null then it indicates that the new subroutine will become a
10679 constant, and it points to an C<SV*> that provides the constant value
10680 that the subroutine will have.
10682 If the subroutine has one of a few special names, such as C<BEGIN> or
10683 C<END>, then it will be claimed by the appropriate queue for automatic
10684 running of phase-related subroutines. In this case the relevant glob will
10685 be left not containing any subroutine, even if it did contain one before.
10686 In the case of C<BEGIN>, the subroutine will be executed and the reference
10687 to it disposed of before this function returns, and also before its
10688 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
10689 constructed by this function to be ready for execution then the caller
10690 must prevent this happening by giving the subroutine a different name.
10692 The function returns a pointer to the constructed subroutine. If the sub
10693 is anonymous then ownership of one counted reference to the subroutine
10694 is transferred to the caller. If the sub is named then the caller does
10695 not get ownership of a reference. In most such cases, where the sub
10696 has a non-phase name, the sub will be alive at the point it is returned
10697 by virtue of being contained in the glob that names it. A phase-named
10698 subroutine will usually be alive by virtue of the reference owned by the
10699 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10700 been executed, will quite likely have been destroyed already by the
10701 time this function returns, making it erroneous for the caller to make
10702 any use of the returned pointer. It is the caller's responsibility to
10703 ensure that it knows which of these situations applies.
10709 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10710 XSUBADDR_t subaddr, const char *const filename,
10711 const char *const proto, SV **const_svp,
10715 bool interleave = FALSE;
10716 bool evanescent = FALSE;
10718 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10721 GV * const gv = gv_fetchpvn(
10722 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10723 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10724 sizeof("__ANON__::__ANON__") - 1,
10725 GV_ADDMULTI | flags, SVt_PVCV);
10727 if ((cv = (name ? GvCV(gv) : NULL))) {
10729 /* just a cached method */
10733 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10734 /* already defined (or promised) */
10735 /* Redundant check that allows us to avoid creating an SV
10736 most of the time: */
10737 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10738 report_redefined_cv(newSVpvn_flags(
10739 name,len,(flags&SVf_UTF8)|SVs_TEMP
10750 if (cv) /* must reuse cv if autoloaded */
10753 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10757 if (HvENAME_HEK(GvSTASH(gv)))
10758 gv_method_changed(gv); /* newXS */
10762 assert(SvREFCNT((SV*)cv) != 0);
10766 /* XSUBs can't be perl lang/perl5db.pl debugged
10767 if (PERLDB_LINE_OR_SAVESRC)
10768 (void)gv_fetchfile(filename); */
10769 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10770 if (flags & XS_DYNAMIC_FILENAME) {
10772 CvFILE(cv) = savepv(filename);
10774 /* NOTE: not copied, as it is expected to be an external constant string */
10775 CvFILE(cv) = (char *)filename;
10778 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10779 CvFILE(cv) = (char*)PL_xsubfilename;
10782 CvXSUB(cv) = subaddr;
10783 #ifndef PERL_IMPLICIT_CONTEXT
10784 CvHSCXT(cv) = &PL_stack_sp;
10790 evanescent = process_special_blocks(0, name, gv, cv);
10793 } /* <- not a conditional branch */
10796 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10798 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10799 if (interleave) LEAVE;
10800 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10805 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10807 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10809 PERL_ARGS_ASSERT_NEWSTUB;
10810 assert(!GvCVu(gv));
10813 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10814 gv_method_changed(gv);
10816 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10820 CvGV_set(cv, cvgv);
10821 CvFILE_set_from_cop(cv, PL_curcop);
10822 CvSTASH_set(cv, PL_curstash);
10828 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10835 if (PL_parser && PL_parser->error_count) {
10841 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10842 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10845 if ((cv = GvFORM(gv))) {
10846 if (ckWARN(WARN_REDEFINE)) {
10847 const line_t oldline = CopLINE(PL_curcop);
10848 if (PL_parser && PL_parser->copline != NOLINE)
10849 CopLINE_set(PL_curcop, PL_parser->copline);
10851 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10852 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10854 /* diag_listed_as: Format %s redefined */
10855 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10856 "Format STDOUT redefined");
10858 CopLINE_set(PL_curcop, oldline);
10863 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10865 CvFILE_set_from_cop(cv, PL_curcop);
10868 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10870 start = LINKLIST(root);
10872 S_process_optree(aTHX_ cv, root, start);
10873 cv_forget_slab(cv);
10878 PL_parser->copline = NOLINE;
10879 LEAVE_SCOPE(floor);
10880 PL_compiling.cop_seq = 0;
10884 Perl_newANONLIST(pTHX_ OP *o)
10886 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10890 Perl_newANONHASH(pTHX_ OP *o)
10892 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10896 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10898 return newANONATTRSUB(floor, proto, NULL, block);
10902 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10904 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10906 newSVOP(OP_ANONCODE, 0,
10908 if (CvANONCONST(cv))
10909 anoncode = newUNOP(OP_ANONCONST, 0,
10910 op_convert_list(OP_ENTERSUB,
10911 OPf_STACKED|OPf_WANT_SCALAR,
10913 return newUNOP(OP_REFGEN, 0, anoncode);
10917 Perl_oopsAV(pTHX_ OP *o)
10921 PERL_ARGS_ASSERT_OOPSAV;
10923 switch (o->op_type) {
10926 OpTYPE_set(o, OP_PADAV);
10927 return ref(o, OP_RV2AV);
10931 OpTYPE_set(o, OP_RV2AV);
10936 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10943 Perl_oopsHV(pTHX_ OP *o)
10947 PERL_ARGS_ASSERT_OOPSHV;
10949 switch (o->op_type) {
10952 OpTYPE_set(o, OP_PADHV);
10953 return ref(o, OP_RV2HV);
10957 OpTYPE_set(o, OP_RV2HV);
10958 /* rv2hv steals the bottom bit for its own uses */
10959 o->op_private &= ~OPpARG1_MASK;
10964 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10971 Perl_newAVREF(pTHX_ OP *o)
10975 PERL_ARGS_ASSERT_NEWAVREF;
10977 if (o->op_type == OP_PADANY) {
10978 OpTYPE_set(o, OP_PADAV);
10981 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10982 Perl_croak(aTHX_ "Can't use an array as a reference");
10984 return newUNOP(OP_RV2AV, 0, scalar(o));
10988 Perl_newGVREF(pTHX_ I32 type, OP *o)
10990 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10991 return newUNOP(OP_NULL, 0, o);
10992 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10996 Perl_newHVREF(pTHX_ OP *o)
11000 PERL_ARGS_ASSERT_NEWHVREF;
11002 if (o->op_type == OP_PADANY) {
11003 OpTYPE_set(o, OP_PADHV);
11006 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11007 Perl_croak(aTHX_ "Can't use a hash as a reference");
11009 return newUNOP(OP_RV2HV, 0, scalar(o));
11013 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11015 if (o->op_type == OP_PADANY) {
11017 OpTYPE_set(o, OP_PADCV);
11019 return newUNOP(OP_RV2CV, flags, scalar(o));
11023 Perl_newSVREF(pTHX_ OP *o)
11027 PERL_ARGS_ASSERT_NEWSVREF;
11029 if (o->op_type == OP_PADANY) {
11030 OpTYPE_set(o, OP_PADSV);
11034 return newUNOP(OP_RV2SV, 0, scalar(o));
11037 /* Check routines. See the comments at the top of this file for details
11038 * on when these are called */
11041 Perl_ck_anoncode(pTHX_ OP *o)
11043 PERL_ARGS_ASSERT_CK_ANONCODE;
11045 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11046 cSVOPo->op_sv = NULL;
11051 S_io_hints(pTHX_ OP *o)
11053 #if O_BINARY != 0 || O_TEXT != 0
11055 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11057 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11060 const char *d = SvPV_const(*svp, len);
11061 const I32 mode = mode_from_discipline(d, len);
11062 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11064 if (mode & O_BINARY)
11065 o->op_private |= OPpOPEN_IN_RAW;
11069 o->op_private |= OPpOPEN_IN_CRLF;
11073 svp = hv_fetchs(table, "open_OUT", FALSE);
11076 const char *d = SvPV_const(*svp, len);
11077 const I32 mode = mode_from_discipline(d, len);
11078 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11080 if (mode & O_BINARY)
11081 o->op_private |= OPpOPEN_OUT_RAW;
11085 o->op_private |= OPpOPEN_OUT_CRLF;
11090 PERL_UNUSED_CONTEXT;
11091 PERL_UNUSED_ARG(o);
11096 Perl_ck_backtick(pTHX_ OP *o)
11101 PERL_ARGS_ASSERT_CK_BACKTICK;
11103 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11104 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11105 && (gv = gv_override("readpipe",8)))
11107 /* detach rest of siblings from o and its first child */
11108 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11109 newop = S_new_entersubop(aTHX_ gv, sibl);
11111 else if (!(o->op_flags & OPf_KIDS))
11112 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11117 S_io_hints(aTHX_ o);
11122 Perl_ck_bitop(pTHX_ OP *o)
11124 PERL_ARGS_ASSERT_CK_BITOP;
11126 o->op_private = (U8)(PL_hints & HINT_INTEGER);
11128 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11129 && OP_IS_INFIX_BIT(o->op_type))
11131 const OP * const left = cBINOPo->op_first;
11132 const OP * const right = OpSIBLING(left);
11133 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11134 (left->op_flags & OPf_PARENS) == 0) ||
11135 (OP_IS_NUMCOMPARE(right->op_type) &&
11136 (right->op_flags & OPf_PARENS) == 0))
11137 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11138 "Possible precedence problem on bitwise %s operator",
11139 o->op_type == OP_BIT_OR
11140 ||o->op_type == OP_NBIT_OR ? "|"
11141 : o->op_type == OP_BIT_AND
11142 ||o->op_type == OP_NBIT_AND ? "&"
11143 : o->op_type == OP_BIT_XOR
11144 ||o->op_type == OP_NBIT_XOR ? "^"
11145 : o->op_type == OP_SBIT_OR ? "|."
11146 : o->op_type == OP_SBIT_AND ? "&." : "^."
11152 PERL_STATIC_INLINE bool
11153 is_dollar_bracket(pTHX_ const OP * const o)
11156 PERL_UNUSED_CONTEXT;
11157 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11158 && (kid = cUNOPx(o)->op_first)
11159 && kid->op_type == OP_GV
11160 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11163 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11166 Perl_ck_cmp(pTHX_ OP *o)
11172 OP *indexop, *constop, *start;
11176 PERL_ARGS_ASSERT_CK_CMP;
11178 is_eq = ( o->op_type == OP_EQ
11179 || o->op_type == OP_NE
11180 || o->op_type == OP_I_EQ
11181 || o->op_type == OP_I_NE);
11183 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11184 const OP *kid = cUNOPo->op_first;
11187 ( is_dollar_bracket(aTHX_ kid)
11188 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11190 || ( kid->op_type == OP_CONST
11191 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11195 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11196 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11199 /* convert (index(...) == -1) and variations into
11200 * (r)index/BOOL(,NEG)
11205 indexop = cUNOPo->op_first;
11206 constop = OpSIBLING(indexop);
11208 if (indexop->op_type == OP_CONST) {
11210 indexop = OpSIBLING(constop);
11215 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11218 /* ($lex = index(....)) == -1 */
11219 if (indexop->op_private & OPpTARGET_MY)
11222 if (constop->op_type != OP_CONST)
11225 sv = cSVOPx_sv(constop);
11226 if (!(sv && SvIOK_notUV(sv)))
11230 if (iv != -1 && iv != 0)
11234 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11235 if (!(iv0 ^ reverse))
11239 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11244 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11245 if (!(iv0 ^ reverse))
11249 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11254 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11260 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11266 indexop->op_flags &= ~OPf_PARENS;
11267 indexop->op_flags |= (o->op_flags & OPf_PARENS);
11268 indexop->op_private |= OPpTRUEBOOL;
11270 indexop->op_private |= OPpINDEX_BOOLNEG;
11271 /* cut out the index op and free the eq,const ops */
11272 (void)op_sibling_splice(o, start, 1, NULL);
11280 Perl_ck_concat(pTHX_ OP *o)
11282 const OP * const kid = cUNOPo->op_first;
11284 PERL_ARGS_ASSERT_CK_CONCAT;
11285 PERL_UNUSED_CONTEXT;
11287 /* reuse the padtmp returned by the concat child */
11288 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11289 !(kUNOP->op_first->op_flags & OPf_MOD))
11291 o->op_flags |= OPf_STACKED;
11292 o->op_private |= OPpCONCAT_NESTED;
11298 Perl_ck_spair(pTHX_ OP *o)
11302 PERL_ARGS_ASSERT_CK_SPAIR;
11304 if (o->op_flags & OPf_KIDS) {
11308 const OPCODE type = o->op_type;
11309 o = modkids(ck_fun(o), type);
11310 kid = cUNOPo->op_first;
11311 kidkid = kUNOP->op_first;
11312 newop = OpSIBLING(kidkid);
11314 const OPCODE type = newop->op_type;
11315 if (OpHAS_SIBLING(newop))
11317 if (o->op_type == OP_REFGEN
11318 && ( type == OP_RV2CV
11319 || ( !(newop->op_flags & OPf_PARENS)
11320 && ( type == OP_RV2AV || type == OP_PADAV
11321 || type == OP_RV2HV || type == OP_PADHV))))
11322 NOOP; /* OK (allow srefgen for \@a and \%h) */
11323 else if (OP_GIMME(newop,0) != G_SCALAR)
11326 /* excise first sibling */
11327 op_sibling_splice(kid, NULL, 1, NULL);
11330 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11331 * and OP_CHOMP into OP_SCHOMP */
11332 o->op_ppaddr = PL_ppaddr[++o->op_type];
11337 Perl_ck_delete(pTHX_ OP *o)
11339 PERL_ARGS_ASSERT_CK_DELETE;
11343 if (o->op_flags & OPf_KIDS) {
11344 OP * const kid = cUNOPo->op_first;
11345 switch (kid->op_type) {
11347 o->op_flags |= OPf_SPECIAL;
11350 o->op_private |= OPpSLICE;
11353 o->op_flags |= OPf_SPECIAL;
11358 o->op_flags |= OPf_SPECIAL;
11361 o->op_private |= OPpKVSLICE;
11364 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11365 "element or slice");
11367 if (kid->op_private & OPpLVAL_INTRO)
11368 o->op_private |= OPpLVAL_INTRO;
11375 Perl_ck_eof(pTHX_ OP *o)
11377 PERL_ARGS_ASSERT_CK_EOF;
11379 if (o->op_flags & OPf_KIDS) {
11381 if (cLISTOPo->op_first->op_type == OP_STUB) {
11383 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11388 kid = cLISTOPo->op_first;
11389 if (kid->op_type == OP_RV2GV)
11390 kid->op_private |= OPpALLOW_FAKE;
11397 Perl_ck_eval(pTHX_ OP *o)
11401 PERL_ARGS_ASSERT_CK_EVAL;
11403 PL_hints |= HINT_BLOCK_SCOPE;
11404 if (o->op_flags & OPf_KIDS) {
11405 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11408 if (o->op_type == OP_ENTERTRY) {
11411 /* cut whole sibling chain free from o */
11412 op_sibling_splice(o, NULL, -1, NULL);
11415 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11417 /* establish postfix order */
11418 enter->op_next = (OP*)enter;
11420 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11421 OpTYPE_set(o, OP_LEAVETRY);
11422 enter->op_other = o;
11427 S_set_haseval(aTHX);
11431 const U8 priv = o->op_private;
11433 /* the newUNOP will recursively call ck_eval(), which will handle
11434 * all the stuff at the end of this function, like adding
11437 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11439 o->op_targ = (PADOFFSET)PL_hints;
11440 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11441 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11442 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11443 /* Store a copy of %^H that pp_entereval can pick up. */
11444 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11445 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11446 /* append hhop to only child */
11447 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11449 o->op_private |= OPpEVAL_HAS_HH;
11451 if (!(o->op_private & OPpEVAL_BYTES)
11452 && FEATURE_UNIEVAL_IS_ENABLED)
11453 o->op_private |= OPpEVAL_UNICODE;
11458 Perl_ck_exec(pTHX_ OP *o)
11460 PERL_ARGS_ASSERT_CK_EXEC;
11462 if (o->op_flags & OPf_STACKED) {
11465 kid = OpSIBLING(cUNOPo->op_first);
11466 if (kid->op_type == OP_RV2GV)
11475 Perl_ck_exists(pTHX_ OP *o)
11477 PERL_ARGS_ASSERT_CK_EXISTS;
11480 if (o->op_flags & OPf_KIDS) {
11481 OP * const kid = cUNOPo->op_first;
11482 if (kid->op_type == OP_ENTERSUB) {
11483 (void) ref(kid, o->op_type);
11484 if (kid->op_type != OP_RV2CV
11485 && !(PL_parser && PL_parser->error_count))
11487 "exists argument is not a subroutine name");
11488 o->op_private |= OPpEXISTS_SUB;
11490 else if (kid->op_type == OP_AELEM)
11491 o->op_flags |= OPf_SPECIAL;
11492 else if (kid->op_type != OP_HELEM)
11493 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11494 "element or a subroutine");
11501 Perl_ck_rvconst(pTHX_ OP *o)
11504 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11506 PERL_ARGS_ASSERT_CK_RVCONST;
11508 if (o->op_type == OP_RV2HV)
11509 /* rv2hv steals the bottom bit for its own uses */
11510 o->op_private &= ~OPpARG1_MASK;
11512 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11514 if (kid->op_type == OP_CONST) {
11517 SV * const kidsv = kid->op_sv;
11519 /* Is it a constant from cv_const_sv()? */
11520 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11523 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11524 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11525 const char *badthing;
11526 switch (o->op_type) {
11528 badthing = "a SCALAR";
11531 badthing = "an ARRAY";
11534 badthing = "a HASH";
11542 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11543 SVfARG(kidsv), badthing);
11546 * This is a little tricky. We only want to add the symbol if we
11547 * didn't add it in the lexer. Otherwise we get duplicate strict
11548 * warnings. But if we didn't add it in the lexer, we must at
11549 * least pretend like we wanted to add it even if it existed before,
11550 * or we get possible typo warnings. OPpCONST_ENTERED says
11551 * whether the lexer already added THIS instance of this symbol.
11553 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11554 gv = gv_fetchsv(kidsv,
11555 o->op_type == OP_RV2CV
11556 && o->op_private & OPpMAY_RETURN_CONSTANT
11558 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11561 : o->op_type == OP_RV2SV
11563 : o->op_type == OP_RV2AV
11565 : o->op_type == OP_RV2HV
11572 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11573 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11574 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11576 OpTYPE_set(kid, OP_GV);
11577 SvREFCNT_dec(kid->op_sv);
11578 #ifdef USE_ITHREADS
11579 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11580 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11581 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11582 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11583 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11585 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11587 kid->op_private = 0;
11588 /* FAKE globs in the symbol table cause weird bugs (#77810) */
11596 Perl_ck_ftst(pTHX_ OP *o)
11599 const I32 type = o->op_type;
11601 PERL_ARGS_ASSERT_CK_FTST;
11603 if (o->op_flags & OPf_REF) {
11606 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11607 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11608 const OPCODE kidtype = kid->op_type;
11610 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11611 && !kid->op_folded) {
11612 OP * const newop = newGVOP(type, OPf_REF,
11613 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11618 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11619 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11621 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11622 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11623 array_passed_to_stat, name);
11626 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11627 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11630 scalar((OP *) kid);
11631 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11632 o->op_private |= OPpFT_ACCESS;
11633 if (type != OP_STAT && type != OP_LSTAT
11634 && PL_check[kidtype] == Perl_ck_ftst
11635 && kidtype != OP_STAT && kidtype != OP_LSTAT
11637 o->op_private |= OPpFT_STACKED;
11638 kid->op_private |= OPpFT_STACKING;
11639 if (kidtype == OP_FTTTY && (
11640 !(kid->op_private & OPpFT_STACKED)
11641 || kid->op_private & OPpFT_AFTER_t
11643 o->op_private |= OPpFT_AFTER_t;
11648 if (type == OP_FTTTY)
11649 o = newGVOP(type, OPf_REF, PL_stdingv);
11651 o = newUNOP(type, 0, newDEFSVOP());
11657 Perl_ck_fun(pTHX_ OP *o)
11659 const int type = o->op_type;
11660 I32 oa = PL_opargs[type] >> OASHIFT;
11662 PERL_ARGS_ASSERT_CK_FUN;
11664 if (o->op_flags & OPf_STACKED) {
11665 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11666 oa &= ~OA_OPTIONAL;
11668 return no_fh_allowed(o);
11671 if (o->op_flags & OPf_KIDS) {
11672 OP *prev_kid = NULL;
11673 OP *kid = cLISTOPo->op_first;
11675 bool seen_optional = FALSE;
11677 if (kid->op_type == OP_PUSHMARK ||
11678 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11681 kid = OpSIBLING(kid);
11683 if (kid && kid->op_type == OP_COREARGS) {
11684 bool optional = FALSE;
11687 if (oa & OA_OPTIONAL) optional = TRUE;
11690 if (optional) o->op_private |= numargs;
11695 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11696 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11697 kid = newDEFSVOP();
11698 /* append kid to chain */
11699 op_sibling_splice(o, prev_kid, 0, kid);
11701 seen_optional = TRUE;
11708 /* list seen where single (scalar) arg expected? */
11709 if (numargs == 1 && !(oa >> 4)
11710 && kid->op_type == OP_LIST && type != OP_SCALAR)
11712 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11714 if (type != OP_DELETE) scalar(kid);
11725 if ((type == OP_PUSH || type == OP_UNSHIFT)
11726 && !OpHAS_SIBLING(kid))
11727 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11728 "Useless use of %s with no values",
11731 if (kid->op_type == OP_CONST
11732 && ( !SvROK(cSVOPx_sv(kid))
11733 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
11735 bad_type_pv(numargs, "array", o, kid);
11736 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11737 || kid->op_type == OP_RV2GV) {
11738 bad_type_pv(1, "array", o, kid);
11740 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11741 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11742 PL_op_desc[type]), 0);
11745 op_lvalue(kid, type);
11749 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11750 bad_type_pv(numargs, "hash", o, kid);
11751 op_lvalue(kid, type);
11755 /* replace kid with newop in chain */
11757 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11758 newop->op_next = newop;
11763 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11764 if (kid->op_type == OP_CONST &&
11765 (kid->op_private & OPpCONST_BARE))
11767 OP * const newop = newGVOP(OP_GV, 0,
11768 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11769 /* replace kid with newop in chain */
11770 op_sibling_splice(o, prev_kid, 1, newop);
11774 else if (kid->op_type == OP_READLINE) {
11775 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11776 bad_type_pv(numargs, "HANDLE", o, kid);
11779 I32 flags = OPf_SPECIAL;
11781 PADOFFSET targ = 0;
11783 /* is this op a FH constructor? */
11784 if (is_handle_constructor(o,numargs)) {
11785 const char *name = NULL;
11788 bool want_dollar = TRUE;
11791 /* Set a flag to tell rv2gv to vivify
11792 * need to "prove" flag does not mean something
11793 * else already - NI-S 1999/05/07
11796 if (kid->op_type == OP_PADSV) {
11798 = PAD_COMPNAME_SV(kid->op_targ);
11799 name = PadnamePV (pn);
11800 len = PadnameLEN(pn);
11801 name_utf8 = PadnameUTF8(pn);
11803 else if (kid->op_type == OP_RV2SV
11804 && kUNOP->op_first->op_type == OP_GV)
11806 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11808 len = GvNAMELEN(gv);
11809 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11811 else if (kid->op_type == OP_AELEM
11812 || kid->op_type == OP_HELEM)
11815 OP *op = ((BINOP*)kid)->op_first;
11819 const char * const a =
11820 kid->op_type == OP_AELEM ?
11822 if (((op->op_type == OP_RV2AV) ||
11823 (op->op_type == OP_RV2HV)) &&
11824 (firstop = ((UNOP*)op)->op_first) &&
11825 (firstop->op_type == OP_GV)) {
11826 /* packagevar $a[] or $h{} */
11827 GV * const gv = cGVOPx_gv(firstop);
11830 Perl_newSVpvf(aTHX_
11835 else if (op->op_type == OP_PADAV
11836 || op->op_type == OP_PADHV) {
11837 /* lexicalvar $a[] or $h{} */
11838 const char * const padname =
11839 PAD_COMPNAME_PV(op->op_targ);
11842 Perl_newSVpvf(aTHX_
11848 name = SvPV_const(tmpstr, len);
11849 name_utf8 = SvUTF8(tmpstr);
11850 sv_2mortal(tmpstr);
11854 name = "__ANONIO__";
11856 want_dollar = FALSE;
11858 op_lvalue(kid, type);
11862 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11863 namesv = PAD_SVl(targ);
11864 if (want_dollar && *name != '$')
11865 sv_setpvs(namesv, "$");
11868 sv_catpvn(namesv, name, len);
11869 if ( name_utf8 ) SvUTF8_on(namesv);
11873 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11875 kid->op_targ = targ;
11876 kid->op_private |= priv;
11882 if ((type == OP_UNDEF || type == OP_POS)
11883 && numargs == 1 && !(oa >> 4)
11884 && kid->op_type == OP_LIST)
11885 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11886 op_lvalue(scalar(kid), type);
11891 kid = OpSIBLING(kid);
11893 /* FIXME - should the numargs or-ing move after the too many
11894 * arguments check? */
11895 o->op_private |= numargs;
11897 return too_many_arguments_pv(o,OP_DESC(o), 0);
11900 else if (PL_opargs[type] & OA_DEFGV) {
11901 /* Ordering of these two is important to keep f_map.t passing. */
11903 return newUNOP(type, 0, newDEFSVOP());
11907 while (oa & OA_OPTIONAL)
11909 if (oa && oa != OA_LIST)
11910 return too_few_arguments_pv(o,OP_DESC(o), 0);
11916 Perl_ck_glob(pTHX_ OP *o)
11920 PERL_ARGS_ASSERT_CK_GLOB;
11923 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11924 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11926 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11930 * \ null - const(wildcard)
11935 * \ mark - glob - rv2cv
11936 * | \ gv(CORE::GLOBAL::glob)
11938 * \ null - const(wildcard)
11940 o->op_flags |= OPf_SPECIAL;
11941 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11942 o = S_new_entersubop(aTHX_ gv, o);
11943 o = newUNOP(OP_NULL, 0, o);
11944 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11947 else o->op_flags &= ~OPf_SPECIAL;
11948 #if !defined(PERL_EXTERNAL_GLOB)
11949 if (!PL_globhook) {
11951 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11952 newSVpvs("File::Glob"), NULL, NULL, NULL);
11955 #endif /* !PERL_EXTERNAL_GLOB */
11956 gv = (GV *)newSV(0);
11957 gv_init(gv, 0, "", 0, 0);
11959 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11960 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11966 Perl_ck_grep(pTHX_ OP *o)
11970 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11972 PERL_ARGS_ASSERT_CK_GREP;
11974 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11976 if (o->op_flags & OPf_STACKED) {
11977 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11978 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11979 return no_fh_allowed(o);
11980 o->op_flags &= ~OPf_STACKED;
11982 kid = OpSIBLING(cLISTOPo->op_first);
11983 if (type == OP_MAPWHILE)
11988 if (PL_parser && PL_parser->error_count)
11990 kid = OpSIBLING(cLISTOPo->op_first);
11991 if (kid->op_type != OP_NULL)
11992 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11993 kid = kUNOP->op_first;
11995 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11996 kid->op_next = (OP*)gwop;
11997 o->op_private = gwop->op_private = 0;
11998 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12000 kid = OpSIBLING(cLISTOPo->op_first);
12001 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12002 op_lvalue(kid, OP_GREPSTART);
12008 Perl_ck_index(pTHX_ OP *o)
12010 PERL_ARGS_ASSERT_CK_INDEX;
12012 if (o->op_flags & OPf_KIDS) {
12013 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12015 kid = OpSIBLING(kid); /* get past "big" */
12016 if (kid && kid->op_type == OP_CONST) {
12017 const bool save_taint = TAINT_get;
12018 SV *sv = kSVOP->op_sv;
12019 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12020 && SvOK(sv) && !SvROK(sv))
12023 sv_copypv(sv, kSVOP->op_sv);
12024 SvREFCNT_dec_NN(kSVOP->op_sv);
12027 if (SvOK(sv)) fbm_compile(sv, 0);
12028 TAINT_set(save_taint);
12029 #ifdef NO_TAINT_SUPPORT
12030 PERL_UNUSED_VAR(save_taint);
12038 Perl_ck_lfun(pTHX_ OP *o)
12040 const OPCODE type = o->op_type;
12042 PERL_ARGS_ASSERT_CK_LFUN;
12044 return modkids(ck_fun(o), type);
12048 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12050 PERL_ARGS_ASSERT_CK_DEFINED;
12052 if ((o->op_flags & OPf_KIDS)) {
12053 switch (cUNOPo->op_first->op_type) {
12056 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12057 " (Maybe you should just omit the defined()?)");
12058 NOT_REACHED; /* NOTREACHED */
12062 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12063 " (Maybe you should just omit the defined()?)");
12064 NOT_REACHED; /* NOTREACHED */
12075 Perl_ck_readline(pTHX_ OP *o)
12077 PERL_ARGS_ASSERT_CK_READLINE;
12079 if (o->op_flags & OPf_KIDS) {
12080 OP *kid = cLISTOPo->op_first;
12081 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12085 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12093 Perl_ck_rfun(pTHX_ OP *o)
12095 const OPCODE type = o->op_type;
12097 PERL_ARGS_ASSERT_CK_RFUN;
12099 return refkids(ck_fun(o), type);
12103 Perl_ck_listiob(pTHX_ OP *o)
12107 PERL_ARGS_ASSERT_CK_LISTIOB;
12109 kid = cLISTOPo->op_first;
12111 o = force_list(o, 1);
12112 kid = cLISTOPo->op_first;
12114 if (kid->op_type == OP_PUSHMARK)
12115 kid = OpSIBLING(kid);
12116 if (kid && o->op_flags & OPf_STACKED)
12117 kid = OpSIBLING(kid);
12118 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12119 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12120 && !kid->op_folded) {
12121 o->op_flags |= OPf_STACKED; /* make it a filehandle */
12123 /* replace old const op with new OP_RV2GV parent */
12124 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12125 OP_RV2GV, OPf_REF);
12126 kid = OpSIBLING(kid);
12131 op_append_elem(o->op_type, o, newDEFSVOP());
12133 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12134 return listkids(o);
12138 Perl_ck_smartmatch(pTHX_ OP *o)
12141 PERL_ARGS_ASSERT_CK_SMARTMATCH;
12142 if (0 == (o->op_flags & OPf_SPECIAL)) {
12143 OP *first = cBINOPo->op_first;
12144 OP *second = OpSIBLING(first);
12146 /* Implicitly take a reference to an array or hash */
12148 /* remove the original two siblings, then add back the
12149 * (possibly different) first and second sibs.
12151 op_sibling_splice(o, NULL, 1, NULL);
12152 op_sibling_splice(o, NULL, 1, NULL);
12153 first = ref_array_or_hash(first);
12154 second = ref_array_or_hash(second);
12155 op_sibling_splice(o, NULL, 0, second);
12156 op_sibling_splice(o, NULL, 0, first);
12158 /* Implicitly take a reference to a regular expression */
12159 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12160 OpTYPE_set(first, OP_QR);
12162 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12163 OpTYPE_set(second, OP_QR);
12172 S_maybe_targlex(pTHX_ OP *o)
12174 OP * const kid = cLISTOPo->op_first;
12175 /* has a disposable target? */
12176 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12177 && !(kid->op_flags & OPf_STACKED)
12178 /* Cannot steal the second time! */
12179 && !(kid->op_private & OPpTARGET_MY)
12182 OP * const kkid = OpSIBLING(kid);
12184 /* Can just relocate the target. */
12185 if (kkid && kkid->op_type == OP_PADSV
12186 && (!(kkid->op_private & OPpLVAL_INTRO)
12187 || kkid->op_private & OPpPAD_STATE))
12189 kid->op_targ = kkid->op_targ;
12191 /* Now we do not need PADSV and SASSIGN.
12192 * Detach kid and free the rest. */
12193 op_sibling_splice(o, NULL, 1, NULL);
12195 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
12203 Perl_ck_sassign(pTHX_ OP *o)
12206 OP * const kid = cBINOPo->op_first;
12208 PERL_ARGS_ASSERT_CK_SASSIGN;
12210 if (OpHAS_SIBLING(kid)) {
12211 OP *kkid = OpSIBLING(kid);
12212 /* For state variable assignment with attributes, kkid is a list op
12213 whose op_last is a padsv. */
12214 if ((kkid->op_type == OP_PADSV ||
12215 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12216 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12219 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12220 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12221 return S_newONCEOP(aTHX_ o, kkid);
12224 return S_maybe_targlex(aTHX_ o);
12229 Perl_ck_match(pTHX_ OP *o)
12231 PERL_UNUSED_CONTEXT;
12232 PERL_ARGS_ASSERT_CK_MATCH;
12238 Perl_ck_method(pTHX_ OP *o)
12240 SV *sv, *methsv, *rclass;
12241 const char* method;
12244 STRLEN len, nsplit = 0, i;
12246 OP * const kid = cUNOPo->op_first;
12248 PERL_ARGS_ASSERT_CK_METHOD;
12249 if (kid->op_type != OP_CONST) return o;
12253 /* replace ' with :: */
12254 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12255 SvEND(sv) - SvPVX(sv) )))
12258 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12261 method = SvPVX_const(sv);
12263 utf8 = SvUTF8(sv) ? -1 : 1;
12265 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12270 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12272 if (!nsplit) { /* $proto->method() */
12274 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12277 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12279 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12282 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12283 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12284 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12285 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12287 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12288 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12290 #ifdef USE_ITHREADS
12291 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12293 cMETHOPx(new_op)->op_rclass_sv = rclass;
12300 Perl_ck_null(pTHX_ OP *o)
12302 PERL_ARGS_ASSERT_CK_NULL;
12303 PERL_UNUSED_CONTEXT;
12308 Perl_ck_open(pTHX_ OP *o)
12310 PERL_ARGS_ASSERT_CK_OPEN;
12312 S_io_hints(aTHX_ o);
12314 /* In case of three-arg dup open remove strictness
12315 * from the last arg if it is a bareword. */
12316 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12317 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
12321 if ((last->op_type == OP_CONST) && /* The bareword. */
12322 (last->op_private & OPpCONST_BARE) &&
12323 (last->op_private & OPpCONST_STRICT) &&
12324 (oa = OpSIBLING(first)) && /* The fh. */
12325 (oa = OpSIBLING(oa)) && /* The mode. */
12326 (oa->op_type == OP_CONST) &&
12327 SvPOK(((SVOP*)oa)->op_sv) &&
12328 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12329 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
12330 (last == OpSIBLING(oa))) /* The bareword. */
12331 last->op_private &= ~OPpCONST_STRICT;
12337 Perl_ck_prototype(pTHX_ OP *o)
12339 PERL_ARGS_ASSERT_CK_PROTOTYPE;
12340 if (!(o->op_flags & OPf_KIDS)) {
12342 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12348 Perl_ck_refassign(pTHX_ OP *o)
12350 OP * const right = cLISTOPo->op_first;
12351 OP * const left = OpSIBLING(right);
12352 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12355 PERL_ARGS_ASSERT_CK_REFASSIGN;
12357 assert (left->op_type == OP_SREFGEN);
12360 /* we use OPpPAD_STATE in refassign to mean either of those things,
12361 * and the code assumes the two flags occupy the same bit position
12362 * in the various ops below */
12363 assert(OPpPAD_STATE == OPpOUR_INTRO);
12365 switch (varop->op_type) {
12367 o->op_private |= OPpLVREF_AV;
12370 o->op_private |= OPpLVREF_HV;
12374 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12375 o->op_targ = varop->op_targ;
12376 varop->op_targ = 0;
12377 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12381 o->op_private |= OPpLVREF_AV;
12383 NOT_REACHED; /* NOTREACHED */
12385 o->op_private |= OPpLVREF_HV;
12389 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12390 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12392 /* Point varop to its GV kid, detached. */
12393 varop = op_sibling_splice(varop, NULL, -1, NULL);
12397 OP * const kidparent =
12398 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12399 OP * const kid = cUNOPx(kidparent)->op_first;
12400 o->op_private |= OPpLVREF_CV;
12401 if (kid->op_type == OP_GV) {
12403 goto detach_and_stack;
12405 if (kid->op_type != OP_PADCV) goto bad;
12406 o->op_targ = kid->op_targ;
12412 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12413 o->op_private |= OPpLVREF_ELEM;
12416 /* Detach varop. */
12417 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12421 /* diag_listed_as: Can't modify reference to %s in %s assignment */
12422 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12427 if (!FEATURE_REFALIASING_IS_ENABLED)
12429 "Experimental aliasing via reference not enabled");
12430 Perl_ck_warner_d(aTHX_
12431 packWARN(WARN_EXPERIMENTAL__REFALIASING),
12432 "Aliasing via reference is experimental");
12434 o->op_flags |= OPf_STACKED;
12435 op_sibling_splice(o, right, 1, varop);
12438 o->op_flags &=~ OPf_STACKED;
12439 op_sibling_splice(o, right, 1, NULL);
12446 Perl_ck_repeat(pTHX_ OP *o)
12448 PERL_ARGS_ASSERT_CK_REPEAT;
12450 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12452 o->op_private |= OPpREPEAT_DOLIST;
12453 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12454 kids = force_list(kids, 1); /* promote it to a list */
12455 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12463 Perl_ck_require(pTHX_ OP *o)
12467 PERL_ARGS_ASSERT_CK_REQUIRE;
12469 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12470 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12474 if (kid->op_type == OP_CONST) {
12475 SV * const sv = kid->op_sv;
12476 U32 const was_readonly = SvREADONLY(sv);
12477 if (kid->op_private & OPpCONST_BARE) {
12482 if (was_readonly) {
12483 SvREADONLY_off(sv);
12485 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12490 /* treat ::foo::bar as foo::bar */
12491 if (len >= 2 && s[0] == ':' && s[1] == ':')
12492 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12494 DIE(aTHX_ "Bareword in require maps to empty filename");
12496 for (; s < end; s++) {
12497 if (*s == ':' && s[1] == ':') {
12499 Move(s+2, s+1, end - s - 1, char);
12503 SvEND_set(sv, end);
12504 sv_catpvs(sv, ".pm");
12505 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12506 hek = share_hek(SvPVX(sv),
12507 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12509 sv_sethek(sv, hek);
12511 SvFLAGS(sv) |= was_readonly;
12513 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12516 if (SvREFCNT(sv) > 1) {
12517 kid->op_sv = newSVpvn_share(
12518 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12519 SvREFCNT_dec_NN(sv);
12524 if (was_readonly) SvREADONLY_off(sv);
12525 PERL_HASH(hash, s, len);
12527 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12529 sv_sethek(sv, hek);
12531 SvFLAGS(sv) |= was_readonly;
12537 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12538 /* handle override, if any */
12539 && (gv = gv_override("require", 7))) {
12541 if (o->op_flags & OPf_KIDS) {
12542 kid = cUNOPo->op_first;
12543 op_sibling_splice(o, NULL, -1, NULL);
12546 kid = newDEFSVOP();
12549 newop = S_new_entersubop(aTHX_ gv, kid);
12557 Perl_ck_return(pTHX_ OP *o)
12561 PERL_ARGS_ASSERT_CK_RETURN;
12563 kid = OpSIBLING(cLISTOPo->op_first);
12564 if (PL_compcv && CvLVALUE(PL_compcv)) {
12565 for (; kid; kid = OpSIBLING(kid))
12566 op_lvalue(kid, OP_LEAVESUBLV);
12573 Perl_ck_select(pTHX_ OP *o)
12578 PERL_ARGS_ASSERT_CK_SELECT;
12580 if (o->op_flags & OPf_KIDS) {
12581 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12582 if (kid && OpHAS_SIBLING(kid)) {
12583 OpTYPE_set(o, OP_SSELECT);
12585 return fold_constants(op_integerize(op_std_init(o)));
12589 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12590 if (kid && kid->op_type == OP_RV2GV)
12591 kid->op_private &= ~HINT_STRICT_REFS;
12596 Perl_ck_shift(pTHX_ OP *o)
12598 const I32 type = o->op_type;
12600 PERL_ARGS_ASSERT_CK_SHIFT;
12602 if (!(o->op_flags & OPf_KIDS)) {
12605 if (!CvUNIQUE(PL_compcv)) {
12606 o->op_flags |= OPf_SPECIAL;
12610 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12612 return newUNOP(type, 0, scalar(argop));
12614 return scalar(ck_fun(o));
12618 Perl_ck_sort(pTHX_ OP *o)
12622 HV * const hinthv =
12623 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12626 PERL_ARGS_ASSERT_CK_SORT;
12629 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12631 const I32 sorthints = (I32)SvIV(*svp);
12632 if ((sorthints & HINT_SORT_STABLE) != 0)
12633 o->op_private |= OPpSORT_STABLE;
12634 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12635 o->op_private |= OPpSORT_UNSTABLE;
12639 if (o->op_flags & OPf_STACKED)
12641 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12643 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
12644 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
12646 /* if the first arg is a code block, process it and mark sort as
12648 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12650 if (kid->op_type == OP_LEAVE)
12651 op_null(kid); /* wipe out leave */
12652 /* Prevent execution from escaping out of the sort block. */
12655 /* provide scalar context for comparison function/block */
12656 kid = scalar(firstkid);
12657 kid->op_next = kid;
12658 o->op_flags |= OPf_SPECIAL;
12660 else if (kid->op_type == OP_CONST
12661 && kid->op_private & OPpCONST_BARE) {
12665 const char * const name = SvPV(kSVOP_sv, len);
12667 assert (len < 256);
12668 Copy(name, tmpbuf+1, len, char);
12669 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12670 if (off != NOT_IN_PAD) {
12671 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12673 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12674 sv_catpvs(fq, "::");
12675 sv_catsv(fq, kSVOP_sv);
12676 SvREFCNT_dec_NN(kSVOP_sv);
12680 OP * const padop = newOP(OP_PADCV, 0);
12681 padop->op_targ = off;
12682 /* replace the const op with the pad op */
12683 op_sibling_splice(firstkid, NULL, 1, padop);
12689 firstkid = OpSIBLING(firstkid);
12692 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12693 /* provide list context for arguments */
12696 op_lvalue(kid, OP_GREPSTART);
12702 /* for sort { X } ..., where X is one of
12703 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12704 * elide the second child of the sort (the one containing X),
12705 * and set these flags as appropriate
12709 * Also, check and warn on lexical $a, $b.
12713 S_simplify_sort(pTHX_ OP *o)
12715 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12719 const char *gvname;
12722 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12724 kid = kUNOP->op_first; /* get past null */
12725 if (!(have_scopeop = kid->op_type == OP_SCOPE)
12726 && kid->op_type != OP_LEAVE)
12728 kid = kLISTOP->op_last; /* get past scope */
12729 switch(kid->op_type) {
12733 if (!have_scopeop) goto padkids;
12738 k = kid; /* remember this node*/
12739 if (kBINOP->op_first->op_type != OP_RV2SV
12740 || kBINOP->op_last ->op_type != OP_RV2SV)
12743 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12744 then used in a comparison. This catches most, but not
12745 all cases. For instance, it catches
12746 sort { my($a); $a <=> $b }
12748 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12749 (although why you'd do that is anyone's guess).
12753 if (!ckWARN(WARN_SYNTAX)) return;
12754 kid = kBINOP->op_first;
12756 if (kid->op_type == OP_PADSV) {
12757 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12758 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12759 && ( PadnamePV(name)[1] == 'a'
12760 || PadnamePV(name)[1] == 'b' ))
12761 /* diag_listed_as: "my %s" used in sort comparison */
12762 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12763 "\"%s %s\" used in sort comparison",
12764 PadnameIsSTATE(name)
12769 } while ((kid = OpSIBLING(kid)));
12772 kid = kBINOP->op_first; /* get past cmp */
12773 if (kUNOP->op_first->op_type != OP_GV)
12775 kid = kUNOP->op_first; /* get past rv2sv */
12777 if (GvSTASH(gv) != PL_curstash)
12779 gvname = GvNAME(gv);
12780 if (*gvname == 'a' && gvname[1] == '\0')
12782 else if (*gvname == 'b' && gvname[1] == '\0')
12787 kid = k; /* back to cmp */
12788 /* already checked above that it is rv2sv */
12789 kid = kBINOP->op_last; /* down to 2nd arg */
12790 if (kUNOP->op_first->op_type != OP_GV)
12792 kid = kUNOP->op_first; /* get past rv2sv */
12794 if (GvSTASH(gv) != PL_curstash)
12796 gvname = GvNAME(gv);
12798 ? !(*gvname == 'a' && gvname[1] == '\0')
12799 : !(*gvname == 'b' && gvname[1] == '\0'))
12801 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12803 o->op_private |= OPpSORT_DESCEND;
12804 if (k->op_type == OP_NCMP)
12805 o->op_private |= OPpSORT_NUMERIC;
12806 if (k->op_type == OP_I_NCMP)
12807 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12808 kid = OpSIBLING(cLISTOPo->op_first);
12809 /* cut out and delete old block (second sibling) */
12810 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12815 Perl_ck_split(pTHX_ OP *o)
12821 PERL_ARGS_ASSERT_CK_SPLIT;
12823 assert(o->op_type == OP_LIST);
12825 if (o->op_flags & OPf_STACKED)
12826 return no_fh_allowed(o);
12828 kid = cLISTOPo->op_first;
12829 /* delete leading NULL node, then add a CONST if no other nodes */
12830 assert(kid->op_type == OP_NULL);
12831 op_sibling_splice(o, NULL, 1,
12832 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12834 kid = cLISTOPo->op_first;
12836 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12837 /* remove match expression, and replace with new optree with
12838 * a match op at its head */
12839 op_sibling_splice(o, NULL, 1, NULL);
12840 /* pmruntime will handle split " " behavior with flag==2 */
12841 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12842 op_sibling_splice(o, NULL, 0, kid);
12845 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12847 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12848 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12849 "Use of /g modifier is meaningless in split");
12852 /* eliminate the split op, and move the match op (plus any children)
12853 * into its place, then convert the match op into a split op. i.e.
12855 * SPLIT MATCH SPLIT(ex-MATCH)
12857 * MATCH - A - B - C => R - A - B - C => R - A - B - C
12863 * (R, if it exists, will be a regcomp op)
12866 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12867 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12868 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12869 OpTYPE_set(kid, OP_SPLIT);
12870 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
12871 kid->op_private = o->op_private;
12874 kid = sibs; /* kid is now the string arg of the split */
12877 kid = newDEFSVOP();
12878 op_append_elem(OP_SPLIT, o, kid);
12882 kid = OpSIBLING(kid);
12884 kid = newSVOP(OP_CONST, 0, newSViv(0));
12885 op_append_elem(OP_SPLIT, o, kid);
12886 o->op_private |= OPpSPLIT_IMPLIM;
12890 if (OpHAS_SIBLING(kid))
12891 return too_many_arguments_pv(o,OP_DESC(o), 0);
12897 Perl_ck_stringify(pTHX_ OP *o)
12899 OP * const kid = OpSIBLING(cUNOPo->op_first);
12900 PERL_ARGS_ASSERT_CK_STRINGIFY;
12901 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12902 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
12903 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
12904 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12906 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12914 Perl_ck_join(pTHX_ OP *o)
12916 OP * const kid = OpSIBLING(cLISTOPo->op_first);
12918 PERL_ARGS_ASSERT_CK_JOIN;
12920 if (kid && kid->op_type == OP_MATCH) {
12921 if (ckWARN(WARN_SYNTAX)) {
12922 const REGEXP *re = PM_GETRE(kPMOP);
12924 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12925 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12926 : newSVpvs_flags( "STRING", SVs_TEMP );
12927 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12928 "/%" SVf "/ should probably be written as \"%" SVf "\"",
12929 SVfARG(msg), SVfARG(msg));
12933 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12934 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12935 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12936 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12938 const OP * const bairn = OpSIBLING(kid); /* the list */
12939 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12940 && OP_GIMME(bairn,0) == G_SCALAR)
12942 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12943 op_sibling_splice(o, kid, 1, NULL));
12953 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12955 Examines an op, which is expected to identify a subroutine at runtime,
12956 and attempts to determine at compile time which subroutine it identifies.
12957 This is normally used during Perl compilation to determine whether
12958 a prototype can be applied to a function call. C<cvop> is the op
12959 being considered, normally an C<rv2cv> op. A pointer to the identified
12960 subroutine is returned, if it could be determined statically, and a null
12961 pointer is returned if it was not possible to determine statically.
12963 Currently, the subroutine can be identified statically if the RV that the
12964 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12965 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
12966 suitable if the constant value must be an RV pointing to a CV. Details of
12967 this process may change in future versions of Perl. If the C<rv2cv> op
12968 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12969 the subroutine statically: this flag is used to suppress compile-time
12970 magic on a subroutine call, forcing it to use default runtime behaviour.
12972 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12973 of a GV reference is modified. If a GV was examined and its CV slot was
12974 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12975 If the op is not optimised away, and the CV slot is later populated with
12976 a subroutine having a prototype, that flag eventually triggers the warning
12977 "called too early to check prototype".
12979 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12980 of returning a pointer to the subroutine it returns a pointer to the
12981 GV giving the most appropriate name for the subroutine in this context.
12982 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12983 (C<CvANON>) subroutine that is referenced through a GV it will be the
12984 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
12985 A null pointer is returned as usual if there is no statically-determinable
12991 /* shared by toke.c:yylex */
12993 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12995 PADNAME *name = PAD_COMPNAME(off);
12996 CV *compcv = PL_compcv;
12997 while (PadnameOUTER(name)) {
12998 assert(PARENT_PAD_INDEX(name));
12999 compcv = CvOUTSIDE(compcv);
13000 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13001 [off = PARENT_PAD_INDEX(name)];
13003 assert(!PadnameIsOUR(name));
13004 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13005 return PadnamePROTOCV(name);
13007 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13011 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13016 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13017 if (flags & ~RV2CVOPCV_FLAG_MASK)
13018 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13019 if (cvop->op_type != OP_RV2CV)
13021 if (cvop->op_private & OPpENTERSUB_AMPER)
13023 if (!(cvop->op_flags & OPf_KIDS))
13025 rvop = cUNOPx(cvop)->op_first;
13026 switch (rvop->op_type) {
13028 gv = cGVOPx_gv(rvop);
13030 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13031 cv = MUTABLE_CV(SvRV(gv));
13035 if (flags & RV2CVOPCV_RETURN_STUB)
13041 if (flags & RV2CVOPCV_MARK_EARLY)
13042 rvop->op_private |= OPpEARLY_CV;
13047 SV *rv = cSVOPx_sv(rvop);
13050 cv = (CV*)SvRV(rv);
13054 cv = find_lexical_cv(rvop->op_targ);
13059 } NOT_REACHED; /* NOTREACHED */
13061 if (SvTYPE((SV*)cv) != SVt_PVCV)
13063 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13064 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13068 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13069 if (CvLEXICAL(cv) || CvNAMED(cv))
13071 if (!CvANON(cv) || !gv)
13081 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13083 Performs the default fixup of the arguments part of an C<entersub>
13084 op tree. This consists of applying list context to each of the
13085 argument ops. This is the standard treatment used on a call marked
13086 with C<&>, or a method call, or a call through a subroutine reference,
13087 or any other call where the callee can't be identified at compile time,
13088 or a call where the callee has no prototype.
13094 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13098 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13100 aop = cUNOPx(entersubop)->op_first;
13101 if (!OpHAS_SIBLING(aop))
13102 aop = cUNOPx(aop)->op_first;
13103 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13104 /* skip the extra attributes->import() call implicitly added in
13105 * something like foo(my $x : bar)
13107 if ( aop->op_type == OP_ENTERSUB
13108 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13112 op_lvalue(aop, OP_ENTERSUB);
13118 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13120 Performs the fixup of the arguments part of an C<entersub> op tree
13121 based on a subroutine prototype. This makes various modifications to
13122 the argument ops, from applying context up to inserting C<refgen> ops,
13123 and checking the number and syntactic types of arguments, as directed by
13124 the prototype. This is the standard treatment used on a subroutine call,
13125 not marked with C<&>, where the callee can be identified at compile time
13126 and has a prototype.
13128 C<protosv> supplies the subroutine prototype to be applied to the call.
13129 It may be a normal defined scalar, of which the string value will be used.
13130 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13131 that has been cast to C<SV*>) which has a prototype. The prototype
13132 supplied, in whichever form, does not need to match the actual callee
13133 referenced by the op tree.
13135 If the argument ops disagree with the prototype, for example by having
13136 an unacceptable number of arguments, a valid op tree is returned anyway.
13137 The error is reflected in the parser state, normally resulting in a single
13138 exception at the top level of parsing which covers all the compilation
13139 errors that occurred. In the error message, the callee is referred to
13140 by the name defined by the C<namegv> parameter.
13146 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13149 const char *proto, *proto_end;
13150 OP *aop, *prev, *cvop, *parent;
13153 I32 contextclass = 0;
13154 const char *e = NULL;
13155 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13156 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13157 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13158 "flags=%lx", (unsigned long) SvFLAGS(protosv));
13159 if (SvTYPE(protosv) == SVt_PVCV)
13160 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13161 else proto = SvPV(protosv, proto_len);
13162 proto = S_strip_spaces(aTHX_ proto, &proto_len);
13163 proto_end = proto + proto_len;
13164 parent = entersubop;
13165 aop = cUNOPx(entersubop)->op_first;
13166 if (!OpHAS_SIBLING(aop)) {
13168 aop = cUNOPx(aop)->op_first;
13171 aop = OpSIBLING(aop);
13172 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13173 while (aop != cvop) {
13176 if (proto >= proto_end)
13178 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13179 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13180 SVfARG(namesv)), SvUTF8(namesv));
13190 /* _ must be at the end */
13191 if (proto[1] && !strchr(";@%", proto[1]))
13207 if ( o3->op_type != OP_UNDEF
13208 && (o3->op_type != OP_SREFGEN
13209 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13211 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13213 bad_type_gv(arg, namegv, o3,
13214 arg == 1 ? "block or sub {}" : "sub {}");
13217 /* '*' allows any scalar type, including bareword */
13220 if (o3->op_type == OP_RV2GV)
13221 goto wrapref; /* autoconvert GLOB -> GLOBref */
13222 else if (o3->op_type == OP_CONST)
13223 o3->op_private &= ~OPpCONST_STRICT;
13229 if (o3->op_type == OP_RV2AV ||
13230 o3->op_type == OP_PADAV ||
13231 o3->op_type == OP_RV2HV ||
13232 o3->op_type == OP_PADHV
13238 case '[': case ']':
13245 switch (*proto++) {
13247 if (contextclass++ == 0) {
13248 e = (char *) memchr(proto, ']', proto_end - proto);
13249 if (!e || e == proto)
13257 if (contextclass) {
13258 const char *p = proto;
13259 const char *const end = proto;
13261 while (*--p != '[')
13262 /* \[$] accepts any scalar lvalue */
13264 && Perl_op_lvalue_flags(aTHX_
13266 OP_READ, /* not entersub */
13269 bad_type_gv(arg, namegv, o3,
13270 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13275 if (o3->op_type == OP_RV2GV)
13278 bad_type_gv(arg, namegv, o3, "symbol");
13281 if (o3->op_type == OP_ENTERSUB
13282 && !(o3->op_flags & OPf_STACKED))
13285 bad_type_gv(arg, namegv, o3, "subroutine");
13288 if (o3->op_type == OP_RV2SV ||
13289 o3->op_type == OP_PADSV ||
13290 o3->op_type == OP_HELEM ||
13291 o3->op_type == OP_AELEM)
13293 if (!contextclass) {
13294 /* \$ accepts any scalar lvalue */
13295 if (Perl_op_lvalue_flags(aTHX_
13297 OP_READ, /* not entersub */
13300 bad_type_gv(arg, namegv, o3, "scalar");
13304 if (o3->op_type == OP_RV2AV ||
13305 o3->op_type == OP_PADAV)
13307 o3->op_flags &=~ OPf_PARENS;
13311 bad_type_gv(arg, namegv, o3, "array");
13314 if (o3->op_type == OP_RV2HV ||
13315 o3->op_type == OP_PADHV)
13317 o3->op_flags &=~ OPf_PARENS;
13321 bad_type_gv(arg, namegv, o3, "hash");
13324 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13326 if (contextclass && e) {
13331 default: goto oops;
13341 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13342 SVfARG(cv_name((CV *)namegv, NULL, 0)),
13347 op_lvalue(aop, OP_ENTERSUB);
13349 aop = OpSIBLING(aop);
13351 if (aop == cvop && *proto == '_') {
13352 /* generate an access to $_ */
13353 op_sibling_splice(parent, prev, 0, newDEFSVOP());
13355 if (!optional && proto_end > proto &&
13356 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13358 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13359 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13360 SVfARG(namesv)), SvUTF8(namesv));
13366 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13368 Performs the fixup of the arguments part of an C<entersub> op tree either
13369 based on a subroutine prototype or using default list-context processing.
13370 This is the standard treatment used on a subroutine call, not marked
13371 with C<&>, where the callee can be identified at compile time.
13373 C<protosv> supplies the subroutine prototype to be applied to the call,
13374 or indicates that there is no prototype. It may be a normal scalar,
13375 in which case if it is defined then the string value will be used
13376 as a prototype, and if it is undefined then there is no prototype.
13377 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13378 that has been cast to C<SV*>), of which the prototype will be used if it
13379 has one. The prototype (or lack thereof) supplied, in whichever form,
13380 does not need to match the actual callee referenced by the op tree.
13382 If the argument ops disagree with the prototype, for example by having
13383 an unacceptable number of arguments, a valid op tree is returned anyway.
13384 The error is reflected in the parser state, normally resulting in a single
13385 exception at the top level of parsing which covers all the compilation
13386 errors that occurred. In the error message, the callee is referred to
13387 by the name defined by the C<namegv> parameter.
13393 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13394 GV *namegv, SV *protosv)
13396 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13397 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13398 return ck_entersub_args_proto(entersubop, namegv, protosv);
13400 return ck_entersub_args_list(entersubop);
13404 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13406 IV cvflags = SvIVX(protosv);
13407 int opnum = cvflags & 0xffff;
13408 OP *aop = cUNOPx(entersubop)->op_first;
13410 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13414 if (!OpHAS_SIBLING(aop))
13415 aop = cUNOPx(aop)->op_first;
13416 aop = OpSIBLING(aop);
13417 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13419 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13420 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13421 SVfARG(namesv)), SvUTF8(namesv));
13424 op_free(entersubop);
13425 switch(cvflags >> 16) {
13426 case 'F': return newSVOP(OP_CONST, 0,
13427 newSVpv(CopFILE(PL_curcop),0));
13428 case 'L': return newSVOP(
13430 Perl_newSVpvf(aTHX_
13431 "%" IVdf, (IV)CopLINE(PL_curcop)
13434 case 'P': return newSVOP(OP_CONST, 0,
13436 ? newSVhek(HvNAME_HEK(PL_curstash))
13441 NOT_REACHED; /* NOTREACHED */
13444 OP *prev, *cvop, *first, *parent;
13447 parent = entersubop;
13448 if (!OpHAS_SIBLING(aop)) {
13450 aop = cUNOPx(aop)->op_first;
13453 first = prev = aop;
13454 aop = OpSIBLING(aop);
13455 /* find last sibling */
13457 OpHAS_SIBLING(cvop);
13458 prev = cvop, cvop = OpSIBLING(cvop))
13460 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13461 /* Usually, OPf_SPECIAL on an op with no args means that it had
13462 * parens, but these have their own meaning for that flag: */
13463 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13464 && opnum != OP_DELETE && opnum != OP_EXISTS)
13465 flags |= OPf_SPECIAL;
13466 /* excise cvop from end of sibling chain */
13467 op_sibling_splice(parent, prev, 1, NULL);
13469 if (aop == cvop) aop = NULL;
13471 /* detach remaining siblings from the first sibling, then
13472 * dispose of original optree */
13475 op_sibling_splice(parent, first, -1, NULL);
13476 op_free(entersubop);
13478 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13479 flags |= OPpEVAL_BYTES <<8;
13481 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13483 case OA_BASEOP_OR_UNOP:
13484 case OA_FILESTATOP:
13485 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13488 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13489 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13490 SVfARG(namesv)), SvUTF8(namesv));
13493 return opnum == OP_RUNCV
13494 ? newPVOP(OP_RUNCV,0,NULL)
13497 return op_convert_list(opnum,0,aop);
13500 NOT_REACHED; /* NOTREACHED */
13505 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13507 Retrieves the function that will be used to fix up a call to C<cv>.
13508 Specifically, the function is applied to an C<entersub> op tree for a
13509 subroutine call, not marked with C<&>, where the callee can be identified
13510 at compile time as C<cv>.
13512 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13513 for it is returned in C<*ckobj_p>, and control flags are returned in
13514 C<*ckflags_p>. The function is intended to be called in this manner:
13516 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13518 In this call, C<entersubop> is a pointer to the C<entersub> op,
13519 which may be replaced by the check function, and C<namegv> supplies
13520 the name that should be used by the check function to refer
13521 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13522 It is permitted to apply the check function in non-standard situations,
13523 such as to a call to a different subroutine or to a method call.
13525 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13526 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13527 instead, anything that can be used as the first argument to L</cv_name>.
13528 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13529 check function requires C<namegv> to be a genuine GV.
13531 By default, the check function is
13532 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13533 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13534 flag is clear. This implements standard prototype processing. It can
13535 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13537 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13538 indicates that the caller only knows about the genuine GV version of
13539 C<namegv>, and accordingly the corresponding bit will always be set in
13540 C<*ckflags_p>, regardless of the check function's recorded requirements.
13541 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13542 indicates the caller knows about the possibility of passing something
13543 other than a GV as C<namegv>, and accordingly the corresponding bit may
13544 be either set or clear in C<*ckflags_p>, indicating the check function's
13545 recorded requirements.
13547 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13548 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13549 (for which see above). All other bits should be clear.
13551 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13553 The original form of L</cv_get_call_checker_flags>, which does not return
13554 checker flags. When using a checker function returned by this function,
13555 it is only safe to call it with a genuine GV as its C<namegv> argument.
13561 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13562 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13565 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13566 PERL_UNUSED_CONTEXT;
13567 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13569 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13570 *ckobj_p = callmg->mg_obj;
13571 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13573 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13574 *ckobj_p = (SV*)cv;
13575 *ckflags_p = gflags & MGf_REQUIRE_GV;
13580 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13583 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13584 PERL_UNUSED_CONTEXT;
13585 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13590 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13592 Sets the function that will be used to fix up a call to C<cv>.
13593 Specifically, the function is applied to an C<entersub> op tree for a
13594 subroutine call, not marked with C<&>, where the callee can be identified
13595 at compile time as C<cv>.
13597 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13598 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13599 The function should be defined like this:
13601 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13603 It is intended to be called in this manner:
13605 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13607 In this call, C<entersubop> is a pointer to the C<entersub> op,
13608 which may be replaced by the check function, and C<namegv> supplies
13609 the name that should be used by the check function to refer
13610 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13611 It is permitted to apply the check function in non-standard situations,
13612 such as to a call to a different subroutine or to a method call.
13614 C<namegv> may not actually be a GV. For efficiency, perl may pass a
13615 CV or other SV instead. Whatever is passed can be used as the first
13616 argument to L</cv_name>. You can force perl to pass a GV by including
13617 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13619 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13620 bit currently has a defined meaning (for which see above). All other
13621 bits should be clear.
13623 The current setting for a particular CV can be retrieved by
13624 L</cv_get_call_checker_flags>.
13626 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13628 The original form of L</cv_set_call_checker_flags>, which passes it the
13629 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
13630 of that flag setting is that the check function is guaranteed to get a
13631 genuine GV as its C<namegv> argument.
13637 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13639 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13640 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13644 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13645 SV *ckobj, U32 ckflags)
13647 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13648 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13649 if (SvMAGICAL((SV*)cv))
13650 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13653 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13654 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13656 if (callmg->mg_flags & MGf_REFCOUNTED) {
13657 SvREFCNT_dec(callmg->mg_obj);
13658 callmg->mg_flags &= ~MGf_REFCOUNTED;
13660 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13661 callmg->mg_obj = ckobj;
13662 if (ckobj != (SV*)cv) {
13663 SvREFCNT_inc_simple_void_NN(ckobj);
13664 callmg->mg_flags |= MGf_REFCOUNTED;
13666 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13667 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13672 S_entersub_alloc_targ(pTHX_ OP * const o)
13674 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13675 o->op_private |= OPpENTERSUB_HASTARG;
13679 Perl_ck_subr(pTHX_ OP *o)
13684 SV **const_class = NULL;
13686 PERL_ARGS_ASSERT_CK_SUBR;
13688 aop = cUNOPx(o)->op_first;
13689 if (!OpHAS_SIBLING(aop))
13690 aop = cUNOPx(aop)->op_first;
13691 aop = OpSIBLING(aop);
13692 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13693 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13694 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13696 o->op_private &= ~1;
13697 o->op_private |= (PL_hints & HINT_STRICT_REFS);
13698 if (PERLDB_SUB && PL_curstash != PL_debstash)
13699 o->op_private |= OPpENTERSUB_DB;
13700 switch (cvop->op_type) {
13702 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13706 case OP_METHOD_NAMED:
13707 case OP_METHOD_SUPER:
13708 case OP_METHOD_REDIR:
13709 case OP_METHOD_REDIR_SUPER:
13710 o->op_flags |= OPf_REF;
13711 if (aop->op_type == OP_CONST) {
13712 aop->op_private &= ~OPpCONST_STRICT;
13713 const_class = &cSVOPx(aop)->op_sv;
13715 else if (aop->op_type == OP_LIST) {
13716 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13717 if (sib && sib->op_type == OP_CONST) {
13718 sib->op_private &= ~OPpCONST_STRICT;
13719 const_class = &cSVOPx(sib)->op_sv;
13722 /* make class name a shared cow string to speedup method calls */
13723 /* constant string might be replaced with object, f.e. bigint */
13724 if (const_class && SvPOK(*const_class)) {
13726 const char* str = SvPV(*const_class, len);
13728 SV* const shared = newSVpvn_share(
13729 str, SvUTF8(*const_class)
13730 ? -(SSize_t)len : (SSize_t)len,
13733 if (SvREADONLY(*const_class))
13734 SvREADONLY_on(shared);
13735 SvREFCNT_dec(*const_class);
13736 *const_class = shared;
13743 S_entersub_alloc_targ(aTHX_ o);
13744 return ck_entersub_args_list(o);
13746 Perl_call_checker ckfun;
13749 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13750 if (CvISXSUB(cv) || !CvROOT(cv))
13751 S_entersub_alloc_targ(aTHX_ o);
13753 /* The original call checker API guarantees that a GV will be
13754 be provided with the right name. So, if the old API was
13755 used (or the REQUIRE_GV flag was passed), we have to reify
13756 the CV’s GV, unless this is an anonymous sub. This is not
13757 ideal for lexical subs, as its stringification will include
13758 the package. But it is the best we can do. */
13759 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13760 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13763 else namegv = MUTABLE_GV(cv);
13764 /* After a syntax error in a lexical sub, the cv that
13765 rv2cv_op_cv returns may be a nameless stub. */
13766 if (!namegv) return ck_entersub_args_list(o);
13769 return ckfun(aTHX_ o, namegv, ckobj);
13774 Perl_ck_svconst(pTHX_ OP *o)
13776 SV * const sv = cSVOPo->op_sv;
13777 PERL_ARGS_ASSERT_CK_SVCONST;
13778 PERL_UNUSED_CONTEXT;
13779 #ifdef PERL_COPY_ON_WRITE
13780 /* Since the read-only flag may be used to protect a string buffer, we
13781 cannot do copy-on-write with existing read-only scalars that are not
13782 already copy-on-write scalars. To allow $_ = "hello" to do COW with
13783 that constant, mark the constant as COWable here, if it is not
13784 already read-only. */
13785 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13788 # ifdef PERL_DEBUG_READONLY_COW
13798 Perl_ck_trunc(pTHX_ OP *o)
13800 PERL_ARGS_ASSERT_CK_TRUNC;
13802 if (o->op_flags & OPf_KIDS) {
13803 SVOP *kid = (SVOP*)cUNOPo->op_first;
13805 if (kid->op_type == OP_NULL)
13806 kid = (SVOP*)OpSIBLING(kid);
13807 if (kid && kid->op_type == OP_CONST &&
13808 (kid->op_private & OPpCONST_BARE) &&
13811 o->op_flags |= OPf_SPECIAL;
13812 kid->op_private &= ~OPpCONST_STRICT;
13819 Perl_ck_substr(pTHX_ OP *o)
13821 PERL_ARGS_ASSERT_CK_SUBSTR;
13824 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13825 OP *kid = cLISTOPo->op_first;
13827 if (kid->op_type == OP_NULL)
13828 kid = OpSIBLING(kid);
13830 /* Historically, substr(delete $foo{bar},...) has been allowed
13831 with 4-arg substr. Keep it working by applying entersub
13833 op_lvalue(kid, OP_ENTERSUB);
13840 Perl_ck_tell(pTHX_ OP *o)
13842 PERL_ARGS_ASSERT_CK_TELL;
13844 if (o->op_flags & OPf_KIDS) {
13845 OP *kid = cLISTOPo->op_first;
13846 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13847 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13853 Perl_ck_each(pTHX_ OP *o)
13856 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13857 const unsigned orig_type = o->op_type;
13859 PERL_ARGS_ASSERT_CK_EACH;
13862 switch (kid->op_type) {
13868 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13869 : orig_type == OP_KEYS ? OP_AKEYS
13873 if (kid->op_private == OPpCONST_BARE
13874 || !SvROK(cSVOPx_sv(kid))
13875 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13876 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
13881 qerror(Perl_mess(aTHX_
13882 "Experimental %s on scalar is now forbidden",
13883 PL_op_desc[orig_type]));
13885 bad_type_pv(1, "hash or array", o, kid);
13893 Perl_ck_length(pTHX_ OP *o)
13895 PERL_ARGS_ASSERT_CK_LENGTH;
13899 if (ckWARN(WARN_SYNTAX)) {
13900 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13904 const bool hash = kid->op_type == OP_PADHV
13905 || kid->op_type == OP_RV2HV;
13906 switch (kid->op_type) {
13911 name = S_op_varname(aTHX_ kid);
13917 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13918 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13920 SVfARG(name), hash ? "keys " : "", SVfARG(name)
13923 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13924 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13925 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13927 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13928 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13929 "length() used on @array (did you mean \"scalar(@array)\"?)");
13939 ---------------------------------------------------------
13941 Common vars in list assignment
13943 There now follows some enums and static functions for detecting
13944 common variables in list assignments. Here is a little essay I wrote
13945 for myself when trying to get my head around this. DAPM.
13949 First some random observations:
13951 * If a lexical var is an alias of something else, e.g.
13952 for my $x ($lex, $pkg, $a[0]) {...}
13953 then the act of aliasing will increase the reference count of the SV
13955 * If a package var is an alias of something else, it may still have a
13956 reference count of 1, depending on how the alias was created, e.g.
13957 in *a = *b, $a may have a refcount of 1 since the GP is shared
13958 with a single GvSV pointer to the SV. So If it's an alias of another
13959 package var, then RC may be 1; if it's an alias of another scalar, e.g.
13960 a lexical var or an array element, then it will have RC > 1.
13962 * There are many ways to create a package alias; ultimately, XS code
13963 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13964 run-time tracing mechanisms are unlikely to be able to catch all cases.
13966 * When the LHS is all my declarations, the same vars can't appear directly
13967 on the RHS, but they can indirectly via closures, aliasing and lvalue
13968 subs. But those techniques all involve an increase in the lexical
13969 scalar's ref count.
13971 * When the LHS is all lexical vars (but not necessarily my declarations),
13972 it is possible for the same lexicals to appear directly on the RHS, and
13973 without an increased ref count, since the stack isn't refcounted.
13974 This case can be detected at compile time by scanning for common lex
13975 vars with PL_generation.
13977 * lvalue subs defeat common var detection, but they do at least
13978 return vars with a temporary ref count increment. Also, you can't
13979 tell at compile time whether a sub call is lvalue.
13984 A: There are a few circumstances where there definitely can't be any
13987 LHS empty: () = (...);
13988 RHS empty: (....) = ();
13989 RHS contains only constants or other 'can't possibly be shared'
13990 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
13991 i.e. they only contain ops not marked as dangerous, whose children
13992 are also not dangerous;
13994 LHS contains a single scalar element: e.g. ($x) = (....); because
13995 after $x has been modified, it won't be used again on the RHS;
13996 RHS contains a single element with no aggregate on LHS: e.g.
13997 ($a,$b,$c) = ($x); again, once $a has been modified, its value
13998 won't be used again.
14000 B: If LHS are all 'my' lexical var declarations (or safe ops, which
14003 my ($a, $b, @c) = ...;
14005 Due to closure and goto tricks, these vars may already have content.
14006 For the same reason, an element on the RHS may be a lexical or package
14007 alias of one of the vars on the left, or share common elements, for
14010 my ($x,$y) = f(); # $x and $y on both sides
14011 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14016 my @a = @$ra; # elements of @a on both sides
14017 sub f { @a = 1..4; \@a }
14020 First, just consider scalar vars on LHS:
14022 RHS is safe only if (A), or in addition,
14023 * contains only lexical *scalar* vars, where neither side's
14024 lexicals have been flagged as aliases
14026 If RHS is not safe, then it's always legal to check LHS vars for
14027 RC==1, since the only RHS aliases will always be associated
14030 Note that in particular, RHS is not safe if:
14032 * it contains package scalar vars; e.g.:
14035 my ($x, $y) = (2, $x_alias);
14036 sub f { $x = 1; *x_alias = \$x; }
14038 * It contains other general elements, such as flattened or
14039 * spliced or single array or hash elements, e.g.
14042 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14046 use feature 'refaliasing';
14047 \($a[0], $a[1]) = \($y,$x);
14050 It doesn't matter if the array/hash is lexical or package.
14052 * it contains a function call that happens to be an lvalue
14053 sub which returns one or more of the above, e.g.
14064 (so a sub call on the RHS should be treated the same
14065 as having a package var on the RHS).
14067 * any other "dangerous" thing, such an op or built-in that
14068 returns one of the above, e.g. pp_preinc
14071 If RHS is not safe, what we can do however is at compile time flag
14072 that the LHS are all my declarations, and at run time check whether
14073 all the LHS have RC == 1, and if so skip the full scan.
14075 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14077 Here the issue is whether there can be elements of @a on the RHS
14078 which will get prematurely freed when @a is cleared prior to
14079 assignment. This is only a problem if the aliasing mechanism
14080 is one which doesn't increase the refcount - only if RC == 1
14081 will the RHS element be prematurely freed.
14083 Because the array/hash is being INTROed, it or its elements
14084 can't directly appear on the RHS:
14086 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14088 but can indirectly, e.g.:
14092 sub f { @a = 1..3; \@a }
14094 So if the RHS isn't safe as defined by (A), we must always
14095 mortalise and bump the ref count of any remaining RHS elements
14096 when assigning to a non-empty LHS aggregate.
14098 Lexical scalars on the RHS aren't safe if they've been involved in
14101 use feature 'refaliasing';
14104 \(my $lex) = \$pkg;
14105 my @a = ($lex,3); # equivalent to ($a[0],3)
14112 Similarly with lexical arrays and hashes on the RHS:
14126 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14127 my $a; ($a, my $b) = (....);
14129 The difference between (B) and (C) is that it is now physically
14130 possible for the LHS vars to appear on the RHS too, where they
14131 are not reference counted; but in this case, the compile-time
14132 PL_generation sweep will detect such common vars.
14134 So the rules for (C) differ from (B) in that if common vars are
14135 detected, the runtime "test RC==1" optimisation can no longer be used,
14136 and a full mark and sweep is required
14138 D: As (C), but in addition the LHS may contain package vars.
14140 Since package vars can be aliased without a corresponding refcount
14141 increase, all bets are off. It's only safe if (A). E.g.
14143 my ($x, $y) = (1,2);
14145 for $x_alias ($x) {
14146 ($x_alias, $y) = (3, $x); # whoops
14149 Ditto for LHS aggregate package vars.
14151 E: Any other dangerous ops on LHS, e.g.
14152 (f(), $a[0], @$r) = (...);
14154 this is similar to (E) in that all bets are off. In addition, it's
14155 impossible to determine at compile time whether the LHS
14156 contains a scalar or an aggregate, e.g.
14158 sub f : lvalue { @a }
14161 * ---------------------------------------------------------
14165 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14166 * that at least one of the things flagged was seen.
14170 AAS_MY_SCALAR = 0x001, /* my $scalar */
14171 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
14172 AAS_LEX_SCALAR = 0x004, /* $lexical */
14173 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
14174 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14175 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
14176 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
14177 AAS_DANGEROUS = 0x080, /* an op (other than the above)
14178 that's flagged OA_DANGEROUS */
14179 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
14180 not in any of the categories above */
14181 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
14186 /* helper function for S_aassign_scan().
14187 * check a PAD-related op for commonality and/or set its generation number.
14188 * Returns a boolean indicating whether its shared */
14191 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14193 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14194 /* lexical used in aliasing */
14198 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14200 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14207 Helper function for OPpASSIGN_COMMON* detection in rpeep().
14208 It scans the left or right hand subtree of the aassign op, and returns a
14209 set of flags indicating what sorts of things it found there.
14210 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14211 set PL_generation on lexical vars; if the latter, we see if
14212 PL_generation matches.
14213 'top' indicates whether we're recursing or at the top level.
14214 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14215 This fn will increment it by the number seen. It's not intended to
14216 be an accurate count (especially as many ops can push a variable
14217 number of SVs onto the stack); rather it's used as to test whether there
14218 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14222 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14225 bool kid_top = FALSE;
14227 /* first, look for a solitary @_ on the RHS */
14230 && (o->op_flags & OPf_KIDS)
14231 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14233 OP *kid = cUNOPo->op_first;
14234 if ( ( kid->op_type == OP_PUSHMARK
14235 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14236 && ((kid = OpSIBLING(kid)))
14237 && !OpHAS_SIBLING(kid)
14238 && kid->op_type == OP_RV2AV
14239 && !(kid->op_flags & OPf_REF)
14240 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14241 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14242 && ((kid = cUNOPx(kid)->op_first))
14243 && kid->op_type == OP_GV
14244 && cGVOPx_gv(kid) == PL_defgv
14246 flags |= AAS_DEFAV;
14249 switch (o->op_type) {
14252 return AAS_PKG_SCALAR;
14257 /* if !top, could be e.g. @a[0,1] */
14258 if (top && (o->op_flags & OPf_REF))
14259 return (o->op_private & OPpLVAL_INTRO)
14260 ? AAS_MY_AGG : AAS_LEX_AGG;
14261 return AAS_DANGEROUS;
14265 int comm = S_aassign_padcheck(aTHX_ o, rhs)
14266 ? AAS_LEX_SCALAR_COMM : 0;
14268 return (o->op_private & OPpLVAL_INTRO)
14269 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14275 if (cUNOPx(o)->op_first->op_type != OP_GV)
14276 return AAS_DANGEROUS; /* @{expr}, %{expr} */
14278 /* if !top, could be e.g. @a[0,1] */
14279 if (top && (o->op_flags & OPf_REF))
14280 return AAS_PKG_AGG;
14281 return AAS_DANGEROUS;
14285 if (cUNOPx(o)->op_first->op_type != OP_GV) {
14287 return AAS_DANGEROUS; /* ${expr} */
14289 return AAS_PKG_SCALAR; /* $pkg */
14292 if (o->op_private & OPpSPLIT_ASSIGN) {
14293 /* the assign in @a = split() has been optimised away
14294 * and the @a attached directly to the split op
14295 * Treat the array as appearing on the RHS, i.e.
14296 * ... = (@a = split)
14301 if (o->op_flags & OPf_STACKED)
14302 /* @{expr} = split() - the array expression is tacked
14303 * on as an extra child to split - process kid */
14304 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14307 /* ... else array is directly attached to split op */
14309 if (PL_op->op_private & OPpSPLIT_LEX)
14310 return (o->op_private & OPpLVAL_INTRO)
14311 ? AAS_MY_AGG : AAS_LEX_AGG;
14313 return AAS_PKG_AGG;
14316 /* other args of split can't be returned */
14317 return AAS_SAFE_SCALAR;
14320 /* undef counts as a scalar on the RHS:
14321 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
14322 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
14326 flags = AAS_SAFE_SCALAR;
14331 /* these are all no-ops; they don't push a potentially common SV
14332 * onto the stack, so they are neither AAS_DANGEROUS nor
14333 * AAS_SAFE_SCALAR */
14336 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14341 /* these do nothing but may have children; but their children
14342 * should also be treated as top-level */
14347 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14349 flags = AAS_DANGEROUS;
14353 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
14354 && (o->op_private & OPpTARGET_MY))
14357 return S_aassign_padcheck(aTHX_ o, rhs)
14358 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14361 /* if its an unrecognised, non-dangerous op, assume that it
14362 * it the cause of at least one safe scalar */
14364 flags = AAS_SAFE_SCALAR;
14368 /* XXX this assumes that all other ops are "transparent" - i.e. that
14369 * they can return some of their children. While this true for e.g.
14370 * sort and grep, it's not true for e.g. map. We really need a
14371 * 'transparent' flag added to regen/opcodes
14373 if (o->op_flags & OPf_KIDS) {
14375 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14376 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14382 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14383 and modify the optree to make them work inplace */
14386 S_inplace_aassign(pTHX_ OP *o) {
14388 OP *modop, *modop_pushmark;
14390 OP *oleft, *oleft_pushmark;
14392 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14394 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14396 assert(cUNOPo->op_first->op_type == OP_NULL);
14397 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14398 assert(modop_pushmark->op_type == OP_PUSHMARK);
14399 modop = OpSIBLING(modop_pushmark);
14401 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14404 /* no other operation except sort/reverse */
14405 if (OpHAS_SIBLING(modop))
14408 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14409 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14411 if (modop->op_flags & OPf_STACKED) {
14412 /* skip sort subroutine/block */
14413 assert(oright->op_type == OP_NULL);
14414 oright = OpSIBLING(oright);
14417 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14418 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14419 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14420 oleft = OpSIBLING(oleft_pushmark);
14422 /* Check the lhs is an array */
14424 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14425 || OpHAS_SIBLING(oleft)
14426 || (oleft->op_private & OPpLVAL_INTRO)
14430 /* Only one thing on the rhs */
14431 if (OpHAS_SIBLING(oright))
14434 /* check the array is the same on both sides */
14435 if (oleft->op_type == OP_RV2AV) {
14436 if (oright->op_type != OP_RV2AV
14437 || !cUNOPx(oright)->op_first
14438 || cUNOPx(oright)->op_first->op_type != OP_GV
14439 || cUNOPx(oleft )->op_first->op_type != OP_GV
14440 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14441 cGVOPx_gv(cUNOPx(oright)->op_first)
14445 else if (oright->op_type != OP_PADAV
14446 || oright->op_targ != oleft->op_targ
14450 /* This actually is an inplace assignment */
14452 modop->op_private |= OPpSORT_INPLACE;
14454 /* transfer MODishness etc from LHS arg to RHS arg */
14455 oright->op_flags = oleft->op_flags;
14457 /* remove the aassign op and the lhs */
14459 op_null(oleft_pushmark);
14460 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14461 op_null(cUNOPx(oleft)->op_first);
14467 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14468 * that potentially represent a series of one or more aggregate derefs
14469 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14470 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14471 * additional ops left in too).
14473 * The caller will have already verified that the first few ops in the
14474 * chain following 'start' indicate a multideref candidate, and will have
14475 * set 'orig_o' to the point further on in the chain where the first index
14476 * expression (if any) begins. 'orig_action' specifies what type of
14477 * beginning has already been determined by the ops between start..orig_o
14478 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14480 * 'hints' contains any hints flags that need adding (currently just
14481 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14485 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14489 UNOP_AUX_item *arg_buf = NULL;
14490 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14491 int index_skip = -1; /* don't output index arg on this action */
14493 /* similar to regex compiling, do two passes; the first pass
14494 * determines whether the op chain is convertible and calculates the
14495 * buffer size; the second pass populates the buffer and makes any
14496 * changes necessary to ops (such as moving consts to the pad on
14497 * threaded builds).
14499 * NB: for things like Coverity, note that both passes take the same
14500 * path through the logic tree (except for 'if (pass)' bits), since
14501 * both passes are following the same op_next chain; and in
14502 * particular, if it would return early on the second pass, it would
14503 * already have returned early on the first pass.
14505 for (pass = 0; pass < 2; pass++) {
14507 UV action = orig_action;
14508 OP *first_elem_op = NULL; /* first seen aelem/helem */
14509 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14510 int action_count = 0; /* number of actions seen so far */
14511 int action_ix = 0; /* action_count % (actions per IV) */
14512 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14513 bool is_last = FALSE; /* no more derefs to follow */
14514 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14515 UNOP_AUX_item *arg = arg_buf;
14516 UNOP_AUX_item *action_ptr = arg_buf;
14519 action_ptr->uv = 0;
14523 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14524 case MDEREF_HV_gvhv_helem:
14525 next_is_hash = TRUE;
14527 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14528 case MDEREF_AV_gvav_aelem:
14530 #ifdef USE_ITHREADS
14531 arg->pad_offset = cPADOPx(start)->op_padix;
14532 /* stop it being swiped when nulled */
14533 cPADOPx(start)->op_padix = 0;
14535 arg->sv = cSVOPx(start)->op_sv;
14536 cSVOPx(start)->op_sv = NULL;
14542 case MDEREF_HV_padhv_helem:
14543 case MDEREF_HV_padsv_vivify_rv2hv_helem:
14544 next_is_hash = TRUE;
14546 case MDEREF_AV_padav_aelem:
14547 case MDEREF_AV_padsv_vivify_rv2av_aelem:
14549 arg->pad_offset = start->op_targ;
14550 /* we skip setting op_targ = 0 for now, since the intact
14551 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14552 reset_start_targ = TRUE;
14557 case MDEREF_HV_pop_rv2hv_helem:
14558 next_is_hash = TRUE;
14560 case MDEREF_AV_pop_rv2av_aelem:
14564 NOT_REACHED; /* NOTREACHED */
14569 /* look for another (rv2av/hv; get index;
14570 * aelem/helem/exists/delele) sequence */
14575 UV index_type = MDEREF_INDEX_none;
14577 if (action_count) {
14578 /* if this is not the first lookup, consume the rv2av/hv */
14580 /* for N levels of aggregate lookup, we normally expect
14581 * that the first N-1 [ah]elem ops will be flagged as
14582 * /DEREF (so they autovivifiy if necessary), and the last
14583 * lookup op not to be.
14584 * For other things (like @{$h{k1}{k2}}) extra scope or
14585 * leave ops can appear, so abandon the effort in that
14587 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14590 /* rv2av or rv2hv sKR/1 */
14592 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14593 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14594 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14597 /* at this point, we wouldn't expect any of these
14598 * possible private flags:
14599 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14600 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14602 ASSUME(!(o->op_private &
14603 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14605 hints = (o->op_private & OPpHINT_STRICT_REFS);
14607 /* make sure the type of the previous /DEREF matches the
14608 * type of the next lookup */
14609 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14612 action = next_is_hash
14613 ? MDEREF_HV_vivify_rv2hv_helem
14614 : MDEREF_AV_vivify_rv2av_aelem;
14618 /* if this is the second pass, and we're at the depth where
14619 * previously we encountered a non-simple index expression,
14620 * stop processing the index at this point */
14621 if (action_count != index_skip) {
14623 /* look for one or more simple ops that return an array
14624 * index or hash key */
14626 switch (o->op_type) {
14628 /* it may be a lexical var index */
14629 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14630 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14631 ASSUME(!(o->op_private &
14632 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14634 if ( OP_GIMME(o,0) == G_SCALAR
14635 && !(o->op_flags & (OPf_REF|OPf_MOD))
14636 && o->op_private == 0)
14639 arg->pad_offset = o->op_targ;
14641 index_type = MDEREF_INDEX_padsv;
14647 if (next_is_hash) {
14648 /* it's a constant hash index */
14649 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14650 /* "use constant foo => FOO; $h{+foo}" for
14651 * some weird FOO, can leave you with constants
14652 * that aren't simple strings. It's not worth
14653 * the extra hassle for those edge cases */
14658 OP * helem_op = o->op_next;
14660 ASSUME( helem_op->op_type == OP_HELEM
14661 || helem_op->op_type == OP_NULL);
14662 if (helem_op->op_type == OP_HELEM) {
14663 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14664 if ( helem_op->op_private & OPpLVAL_INTRO
14665 || rop->op_type != OP_RV2HV
14669 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14671 #ifdef USE_ITHREADS
14672 /* Relocate sv to the pad for thread safety */
14673 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14674 arg->pad_offset = o->op_targ;
14677 arg->sv = cSVOPx_sv(o);
14682 /* it's a constant array index */
14684 SV *ix_sv = cSVOPo->op_sv;
14689 if ( action_count == 0
14692 && ( action == MDEREF_AV_padav_aelem
14693 || action == MDEREF_AV_gvav_aelem)
14695 maybe_aelemfast = TRUE;
14699 SvREFCNT_dec_NN(cSVOPo->op_sv);
14703 /* we've taken ownership of the SV */
14704 cSVOPo->op_sv = NULL;
14706 index_type = MDEREF_INDEX_const;
14711 /* it may be a package var index */
14713 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14714 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14715 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14716 || o->op_private != 0
14721 if (kid->op_type != OP_RV2SV)
14724 ASSUME(!(kid->op_flags &
14725 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14726 |OPf_SPECIAL|OPf_PARENS)));
14727 ASSUME(!(kid->op_private &
14729 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14730 |OPpDEREF|OPpLVAL_INTRO)));
14731 if( (kid->op_flags &~ OPf_PARENS)
14732 != (OPf_WANT_SCALAR|OPf_KIDS)
14733 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14738 #ifdef USE_ITHREADS
14739 arg->pad_offset = cPADOPx(o)->op_padix;
14740 /* stop it being swiped when nulled */
14741 cPADOPx(o)->op_padix = 0;
14743 arg->sv = cSVOPx(o)->op_sv;
14744 cSVOPo->op_sv = NULL;
14748 index_type = MDEREF_INDEX_gvsv;
14753 } /* action_count != index_skip */
14755 action |= index_type;
14758 /* at this point we have either:
14759 * * detected what looks like a simple index expression,
14760 * and expect the next op to be an [ah]elem, or
14761 * an nulled [ah]elem followed by a delete or exists;
14762 * * found a more complex expression, so something other
14763 * than the above follows.
14766 /* possibly an optimised away [ah]elem (where op_next is
14767 * exists or delete) */
14768 if (o->op_type == OP_NULL)
14771 /* at this point we're looking for an OP_AELEM, OP_HELEM,
14772 * OP_EXISTS or OP_DELETE */
14774 /* if a custom array/hash access checker is in scope,
14775 * abandon optimisation attempt */
14776 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14777 && PL_check[o->op_type] != Perl_ck_null)
14779 /* similarly for customised exists and delete */
14780 if ( (o->op_type == OP_EXISTS)
14781 && PL_check[o->op_type] != Perl_ck_exists)
14783 if ( (o->op_type == OP_DELETE)
14784 && PL_check[o->op_type] != Perl_ck_delete)
14787 if ( o->op_type != OP_AELEM
14788 || (o->op_private &
14789 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14791 maybe_aelemfast = FALSE;
14793 /* look for aelem/helem/exists/delete. If it's not the last elem
14794 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14795 * flags; if it's the last, then it mustn't have
14796 * OPpDEREF_AV/HV, but may have lots of other flags, like
14797 * OPpLVAL_INTRO etc
14800 if ( index_type == MDEREF_INDEX_none
14801 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
14802 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14806 /* we have aelem/helem/exists/delete with valid simple index */
14808 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14809 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
14810 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14812 /* This doesn't make much sense but is legal:
14813 * @{ local $x[0][0] } = 1
14814 * Since scope exit will undo the autovivification,
14815 * don't bother in the first place. The OP_LEAVE
14816 * assertion is in case there are other cases of both
14817 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14818 * exit that would undo the local - in which case this
14819 * block of code would need rethinking.
14821 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14823 OP *n = o->op_next;
14824 while (n && ( n->op_type == OP_NULL
14825 || n->op_type == OP_LIST))
14827 assert(n && n->op_type == OP_LEAVE);
14829 o->op_private &= ~OPpDEREF;
14834 ASSUME(!(o->op_flags &
14835 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14836 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14838 ok = (o->op_flags &~ OPf_PARENS)
14839 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14840 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14842 else if (o->op_type == OP_EXISTS) {
14843 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14844 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14845 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14846 ok = !(o->op_private & ~OPpARG1_MASK);
14848 else if (o->op_type == OP_DELETE) {
14849 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14850 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14851 ASSUME(!(o->op_private &
14852 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14853 /* don't handle slices or 'local delete'; the latter
14854 * is fairly rare, and has a complex runtime */
14855 ok = !(o->op_private & ~OPpARG1_MASK);
14856 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14857 /* skip handling run-tome error */
14858 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14861 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14862 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14863 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14864 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14865 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14866 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14871 if (!first_elem_op)
14875 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14880 action |= MDEREF_FLAG_last;
14884 /* at this point we have something that started
14885 * promisingly enough (with rv2av or whatever), but failed
14886 * to find a simple index followed by an
14887 * aelem/helem/exists/delete. If this is the first action,
14888 * give up; but if we've already seen at least one
14889 * aelem/helem, then keep them and add a new action with
14890 * MDEREF_INDEX_none, which causes it to do the vivify
14891 * from the end of the previous lookup, and do the deref,
14892 * but stop at that point. So $a[0][expr] will do one
14893 * av_fetch, vivify and deref, then continue executing at
14898 index_skip = action_count;
14899 action |= MDEREF_FLAG_last;
14900 if (index_type != MDEREF_INDEX_none)
14905 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14908 /* if there's no space for the next action, create a new slot
14909 * for it *before* we start adding args for that action */
14910 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14917 } /* while !is_last */
14925 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14926 if (index_skip == -1) {
14927 mderef->op_flags = o->op_flags
14928 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14929 if (o->op_type == OP_EXISTS)
14930 mderef->op_private = OPpMULTIDEREF_EXISTS;
14931 else if (o->op_type == OP_DELETE)
14932 mderef->op_private = OPpMULTIDEREF_DELETE;
14934 mderef->op_private = o->op_private
14935 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14937 /* accumulate strictness from every level (although I don't think
14938 * they can actually vary) */
14939 mderef->op_private |= hints;
14941 /* integrate the new multideref op into the optree and the
14944 * In general an op like aelem or helem has two child
14945 * sub-trees: the aggregate expression (a_expr) and the
14946 * index expression (i_expr):
14952 * The a_expr returns an AV or HV, while the i-expr returns an
14953 * index. In general a multideref replaces most or all of a
14954 * multi-level tree, e.g.
14970 * With multideref, all the i_exprs will be simple vars or
14971 * constants, except that i_expr1 may be arbitrary in the case
14972 * of MDEREF_INDEX_none.
14974 * The bottom-most a_expr will be either:
14975 * 1) a simple var (so padXv or gv+rv2Xv);
14976 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
14977 * so a simple var with an extra rv2Xv;
14978 * 3) or an arbitrary expression.
14980 * 'start', the first op in the execution chain, will point to
14981 * 1),2): the padXv or gv op;
14982 * 3): the rv2Xv which forms the last op in the a_expr
14983 * execution chain, and the top-most op in the a_expr
14986 * For all cases, the 'start' node is no longer required,
14987 * but we can't free it since one or more external nodes
14988 * may point to it. E.g. consider
14989 * $h{foo} = $a ? $b : $c
14990 * Here, both the op_next and op_other branches of the
14991 * cond_expr point to the gv[*h] of the hash expression, so
14992 * we can't free the 'start' op.
14994 * For expr->[...], we need to save the subtree containing the
14995 * expression; for the other cases, we just need to save the
14997 * So in all cases, we null the start op and keep it around by
14998 * making it the child of the multideref op; for the expr->
14999 * case, the expr will be a subtree of the start node.
15001 * So in the simple 1,2 case the optree above changes to
15007 * ex-gv (or ex-padxv)
15009 * with the op_next chain being
15011 * -> ex-gv -> multideref -> op-following-ex-exists ->
15013 * In the 3 case, we have
15026 * -> rest-of-a_expr subtree ->
15027 * ex-rv2xv -> multideref -> op-following-ex-exists ->
15030 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15031 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15032 * multideref attached as the child, e.g.
15038 * ex-rv2av - i_expr1
15046 /* if we free this op, don't free the pad entry */
15047 if (reset_start_targ)
15048 start->op_targ = 0;
15051 /* Cut the bit we need to save out of the tree and attach to
15052 * the multideref op, then free the rest of the tree */
15054 /* find parent of node to be detached (for use by splice) */
15056 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
15057 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15059 /* there is an arbitrary expression preceding us, e.g.
15060 * expr->[..]? so we need to save the 'expr' subtree */
15061 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15062 p = cUNOPx(p)->op_first;
15063 ASSUME( start->op_type == OP_RV2AV
15064 || start->op_type == OP_RV2HV);
15067 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15068 * above for exists/delete. */
15069 while ( (p->op_flags & OPf_KIDS)
15070 && cUNOPx(p)->op_first != start
15072 p = cUNOPx(p)->op_first;
15074 ASSUME(cUNOPx(p)->op_first == start);
15076 /* detach from main tree, and re-attach under the multideref */
15077 op_sibling_splice(mderef, NULL, 0,
15078 op_sibling_splice(p, NULL, 1, NULL));
15081 start->op_next = mderef;
15083 mderef->op_next = index_skip == -1 ? o->op_next : o;
15085 /* excise and free the original tree, and replace with
15086 * the multideref op */
15087 p = op_sibling_splice(top_op, NULL, -1, mderef);
15096 Size_t size = arg - arg_buf;
15098 if (maybe_aelemfast && action_count == 1)
15101 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15102 sizeof(UNOP_AUX_item) * (size + 1));
15103 /* for dumping etc: store the length in a hidden first slot;
15104 * we set the op_aux pointer to the second slot */
15105 arg_buf->uv = size;
15108 } /* for (pass = ...) */
15111 /* See if the ops following o are such that o will always be executed in
15112 * boolean context: that is, the SV which o pushes onto the stack will
15113 * only ever be consumed by later ops via SvTRUE(sv) or similar.
15114 * If so, set a suitable private flag on o. Normally this will be
15115 * bool_flag; but see below why maybe_flag is needed too.
15117 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15118 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15119 * already be taken, so you'll have to give that op two different flags.
15121 * More explanation of 'maybe_flag' and 'safe_and' parameters.
15122 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15123 * those underlying ops) short-circuit, which means that rather than
15124 * necessarily returning a truth value, they may return the LH argument,
15125 * which may not be boolean. For example in $x = (keys %h || -1), keys
15126 * should return a key count rather than a boolean, even though its
15127 * sort-of being used in boolean context.
15129 * So we only consider such logical ops to provide boolean context to
15130 * their LH argument if they themselves are in void or boolean context.
15131 * However, sometimes the context isn't known until run-time. In this
15132 * case the op is marked with the maybe_flag flag it.
15134 * Consider the following.
15136 * sub f { ....; if (%h) { .... } }
15138 * This is actually compiled as
15140 * sub f { ....; %h && do { .... } }
15142 * Here we won't know until runtime whether the final statement (and hence
15143 * the &&) is in void context and so is safe to return a boolean value.
15144 * So mark o with maybe_flag rather than the bool_flag.
15145 * Note that there is cost associated with determining context at runtime
15146 * (e.g. a call to block_gimme()), so it may not be worth setting (at
15147 * compile time) and testing (at runtime) maybe_flag if the scalar verses
15148 * boolean costs savings are marginal.
15150 * However, we can do slightly better with && (compared to || and //):
15151 * this op only returns its LH argument when that argument is false. In
15152 * this case, as long as the op promises to return a false value which is
15153 * valid in both boolean and scalar contexts, we can mark an op consumed
15154 * by && with bool_flag rather than maybe_flag.
15155 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15156 * than &PL_sv_no for a false result in boolean context, then it's safe. An
15157 * op which promises to handle this case is indicated by setting safe_and
15162 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15167 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15169 /* OPpTARGET_MY and boolean context probably don't mix well.
15170 * If someone finds a valid use case, maybe add an extra flag to this
15171 * function which indicates its safe to do so for this op? */
15172 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
15173 && (o->op_private & OPpTARGET_MY)));
15178 switch (lop->op_type) {
15183 /* these two consume the stack argument in the scalar case,
15184 * and treat it as a boolean in the non linenumber case */
15187 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15188 || (lop->op_private & OPpFLIP_LINENUM))
15194 /* these never leave the original value on the stack */
15203 /* OR DOR and AND evaluate their arg as a boolean, but then may
15204 * leave the original scalar value on the stack when following the
15205 * op_next route. If not in void context, we need to ensure
15206 * that whatever follows consumes the arg only in boolean context
15218 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15222 else if (!(lop->op_flags & OPf_WANT)) {
15223 /* unknown context - decide at runtime */
15235 lop = lop->op_next;
15238 o->op_private |= flag;
15243 /* mechanism for deferring recursion in rpeep() */
15245 #define MAX_DEFERRED 4
15249 if (defer_ix == (MAX_DEFERRED-1)) { \
15250 OP **defer = defer_queue[defer_base]; \
15251 CALL_RPEEP(*defer); \
15252 S_prune_chain_head(defer); \
15253 defer_base = (defer_base + 1) % MAX_DEFERRED; \
15256 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15259 #define IS_AND_OP(o) (o->op_type == OP_AND)
15260 #define IS_OR_OP(o) (o->op_type == OP_OR)
15263 /* A peephole optimizer. We visit the ops in the order they're to execute.
15264 * See the comments at the top of this file for more details about when
15265 * peep() is called */
15268 Perl_rpeep(pTHX_ OP *o)
15272 OP* oldoldop = NULL;
15273 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15274 int defer_base = 0;
15277 if (!o || o->op_opt)
15280 assert(o->op_type != OP_FREED);
15284 SAVEVPTR(PL_curcop);
15285 for (;; o = o->op_next) {
15286 if (o && o->op_opt)
15289 while (defer_ix >= 0) {
15291 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15292 CALL_RPEEP(*defer);
15293 S_prune_chain_head(defer);
15300 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15301 assert(!oldoldop || oldoldop->op_next == oldop);
15302 assert(!oldop || oldop->op_next == o);
15304 /* By default, this op has now been optimised. A couple of cases below
15305 clear this again. */
15309 /* look for a series of 1 or more aggregate derefs, e.g.
15310 * $a[1]{foo}[$i]{$k}
15311 * and replace with a single OP_MULTIDEREF op.
15312 * Each index must be either a const, or a simple variable,
15314 * First, look for likely combinations of starting ops,
15315 * corresponding to (global and lexical variants of)
15317 * $r->[...] $r->{...}
15318 * (preceding expression)->[...]
15319 * (preceding expression)->{...}
15320 * and if so, call maybe_multideref() to do a full inspection
15321 * of the op chain and if appropriate, replace with an
15329 switch (o2->op_type) {
15331 /* $pkg[..] : gv[*pkg]
15332 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
15334 /* Fail if there are new op flag combinations that we're
15335 * not aware of, rather than:
15336 * * silently failing to optimise, or
15337 * * silently optimising the flag away.
15338 * If this ASSUME starts failing, examine what new flag
15339 * has been added to the op, and decide whether the
15340 * optimisation should still occur with that flag, then
15341 * update the code accordingly. This applies to all the
15342 * other ASSUMEs in the block of code too.
15344 ASSUME(!(o2->op_flags &
15345 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15346 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15350 if (o2->op_type == OP_RV2AV) {
15351 action = MDEREF_AV_gvav_aelem;
15355 if (o2->op_type == OP_RV2HV) {
15356 action = MDEREF_HV_gvhv_helem;
15360 if (o2->op_type != OP_RV2SV)
15363 /* at this point we've seen gv,rv2sv, so the only valid
15364 * construct left is $pkg->[] or $pkg->{} */
15366 ASSUME(!(o2->op_flags & OPf_STACKED));
15367 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15368 != (OPf_WANT_SCALAR|OPf_MOD))
15371 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15372 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15373 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15375 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
15376 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15380 if (o2->op_type == OP_RV2AV) {
15381 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15384 if (o2->op_type == OP_RV2HV) {
15385 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15391 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15393 ASSUME(!(o2->op_flags &
15394 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15395 if ((o2->op_flags &
15396 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15397 != (OPf_WANT_SCALAR|OPf_MOD))
15400 ASSUME(!(o2->op_private &
15401 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15402 /* skip if state or intro, or not a deref */
15403 if ( o2->op_private != OPpDEREF_AV
15404 && o2->op_private != OPpDEREF_HV)
15408 if (o2->op_type == OP_RV2AV) {
15409 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15412 if (o2->op_type == OP_RV2HV) {
15413 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15420 /* $lex[..]: padav[@lex:1,2] sR *
15421 * or $lex{..}: padhv[%lex:1,2] sR */
15422 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15423 OPf_REF|OPf_SPECIAL)));
15424 if ((o2->op_flags &
15425 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15426 != (OPf_WANT_SCALAR|OPf_REF))
15428 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15430 /* OPf_PARENS isn't currently used in this case;
15431 * if that changes, let us know! */
15432 ASSUME(!(o2->op_flags & OPf_PARENS));
15434 /* at this point, we wouldn't expect any of the remaining
15435 * possible private flags:
15436 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15437 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15439 * OPpSLICEWARNING shouldn't affect runtime
15441 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15443 action = o2->op_type == OP_PADAV
15444 ? MDEREF_AV_padav_aelem
15445 : MDEREF_HV_padhv_helem;
15447 S_maybe_multideref(aTHX_ o, o2, action, 0);
15453 action = o2->op_type == OP_RV2AV
15454 ? MDEREF_AV_pop_rv2av_aelem
15455 : MDEREF_HV_pop_rv2hv_helem;
15458 /* (expr)->[...]: rv2av sKR/1;
15459 * (expr)->{...}: rv2hv sKR/1; */
15461 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15463 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15464 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15465 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15468 /* at this point, we wouldn't expect any of these
15469 * possible private flags:
15470 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15471 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15473 ASSUME(!(o2->op_private &
15474 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15476 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15480 S_maybe_multideref(aTHX_ o, o2, action, hints);
15489 switch (o->op_type) {
15491 PL_curcop = ((COP*)o); /* for warnings */
15494 PL_curcop = ((COP*)o); /* for warnings */
15496 /* Optimise a "return ..." at the end of a sub to just be "...".
15497 * This saves 2 ops. Before:
15498 * 1 <;> nextstate(main 1 -e:1) v ->2
15499 * 4 <@> return K ->5
15500 * 2 <0> pushmark s ->3
15501 * - <1> ex-rv2sv sK/1 ->4
15502 * 3 <#> gvsv[*cat] s ->4
15505 * - <@> return K ->-
15506 * - <0> pushmark s ->2
15507 * - <1> ex-rv2sv sK/1 ->-
15508 * 2 <$> gvsv(*cat) s ->3
15511 OP *next = o->op_next;
15512 OP *sibling = OpSIBLING(o);
15513 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15514 && OP_TYPE_IS(sibling, OP_RETURN)
15515 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15516 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15517 ||OP_TYPE_IS(sibling->op_next->op_next,
15519 && cUNOPx(sibling)->op_first == next
15520 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15523 /* Look through the PUSHMARK's siblings for one that
15524 * points to the RETURN */
15525 OP *top = OpSIBLING(next);
15526 while (top && top->op_next) {
15527 if (top->op_next == sibling) {
15528 top->op_next = sibling->op_next;
15529 o->op_next = next->op_next;
15532 top = OpSIBLING(top);
15537 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15539 * This latter form is then suitable for conversion into padrange
15540 * later on. Convert:
15542 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15546 * nextstate1 -> listop -> nextstate3
15548 * pushmark -> padop1 -> padop2
15550 if (o->op_next && (
15551 o->op_next->op_type == OP_PADSV
15552 || o->op_next->op_type == OP_PADAV
15553 || o->op_next->op_type == OP_PADHV
15555 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15556 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15557 && o->op_next->op_next->op_next && (
15558 o->op_next->op_next->op_next->op_type == OP_PADSV
15559 || o->op_next->op_next->op_next->op_type == OP_PADAV
15560 || o->op_next->op_next->op_next->op_type == OP_PADHV
15562 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15563 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15564 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15565 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15567 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15570 ns2 = pad1->op_next;
15571 pad2 = ns2->op_next;
15572 ns3 = pad2->op_next;
15574 /* we assume here that the op_next chain is the same as
15575 * the op_sibling chain */
15576 assert(OpSIBLING(o) == pad1);
15577 assert(OpSIBLING(pad1) == ns2);
15578 assert(OpSIBLING(ns2) == pad2);
15579 assert(OpSIBLING(pad2) == ns3);
15581 /* excise and delete ns2 */
15582 op_sibling_splice(NULL, pad1, 1, NULL);
15585 /* excise pad1 and pad2 */
15586 op_sibling_splice(NULL, o, 2, NULL);
15588 /* create new listop, with children consisting of:
15589 * a new pushmark, pad1, pad2. */
15590 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15591 newop->op_flags |= OPf_PARENS;
15592 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15594 /* insert newop between o and ns3 */
15595 op_sibling_splice(NULL, o, 0, newop);
15597 /*fixup op_next chain */
15598 newpm = cUNOPx(newop)->op_first; /* pushmark */
15599 o ->op_next = newpm;
15600 newpm->op_next = pad1;
15601 pad1 ->op_next = pad2;
15602 pad2 ->op_next = newop; /* listop */
15603 newop->op_next = ns3;
15605 /* Ensure pushmark has this flag if padops do */
15606 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15607 newpm->op_flags |= OPf_MOD;
15613 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15614 to carry two labels. For now, take the easier option, and skip
15615 this optimisation if the first NEXTSTATE has a label. */
15616 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15617 OP *nextop = o->op_next;
15618 while (nextop && nextop->op_type == OP_NULL)
15619 nextop = nextop->op_next;
15621 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15624 oldop->op_next = nextop;
15626 /* Skip (old)oldop assignment since the current oldop's
15627 op_next already points to the next op. */
15634 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15635 if (o->op_next->op_private & OPpTARGET_MY) {
15636 if (o->op_flags & OPf_STACKED) /* chained concats */
15637 break; /* ignore_optimization */
15639 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15640 o->op_targ = o->op_next->op_targ;
15641 o->op_next->op_targ = 0;
15642 o->op_private |= OPpTARGET_MY;
15645 op_null(o->op_next);
15649 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15650 break; /* Scalar stub must produce undef. List stub is noop */
15654 if (o->op_targ == OP_NEXTSTATE
15655 || o->op_targ == OP_DBSTATE)
15657 PL_curcop = ((COP*)o);
15659 /* XXX: We avoid setting op_seq here to prevent later calls
15660 to rpeep() from mistakenly concluding that optimisation
15661 has already occurred. This doesn't fix the real problem,
15662 though (See 20010220.007 (#5874)). AMS 20010719 */
15663 /* op_seq functionality is now replaced by op_opt */
15671 oldop->op_next = o->op_next;
15685 convert repeat into a stub with no kids.
15687 if (o->op_next->op_type == OP_CONST
15688 || ( o->op_next->op_type == OP_PADSV
15689 && !(o->op_next->op_private & OPpLVAL_INTRO))
15690 || ( o->op_next->op_type == OP_GV
15691 && o->op_next->op_next->op_type == OP_RV2SV
15692 && !(o->op_next->op_next->op_private
15693 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15695 const OP *kid = o->op_next->op_next;
15696 if (o->op_next->op_type == OP_GV)
15697 kid = kid->op_next;
15698 /* kid is now the ex-list. */
15699 if (kid->op_type == OP_NULL
15700 && (kid = kid->op_next)->op_type == OP_CONST
15701 /* kid is now the repeat count. */
15702 && kid->op_next->op_type == OP_REPEAT
15703 && kid->op_next->op_private & OPpREPEAT_DOLIST
15704 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15705 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15708 o = kid->op_next; /* repeat */
15709 oldop->op_next = o;
15710 op_free(cBINOPo->op_first);
15711 op_free(cBINOPo->op_last );
15712 o->op_flags &=~ OPf_KIDS;
15713 /* stub is a baseop; repeat is a binop */
15714 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15715 OpTYPE_set(o, OP_STUB);
15721 /* Convert a series of PAD ops for my vars plus support into a
15722 * single padrange op. Basically
15724 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15726 * becomes, depending on circumstances, one of
15728 * padrange ----------------------------------> (list) -> rest
15729 * padrange --------------------------------------------> rest
15731 * where all the pad indexes are sequential and of the same type
15733 * We convert the pushmark into a padrange op, then skip
15734 * any other pad ops, and possibly some trailing ops.
15735 * Note that we don't null() the skipped ops, to make it
15736 * easier for Deparse to undo this optimisation (and none of
15737 * the skipped ops are holding any resourses). It also makes
15738 * it easier for find_uninit_var(), as it can just ignore
15739 * padrange, and examine the original pad ops.
15743 OP *followop = NULL; /* the op that will follow the padrange op */
15746 PADOFFSET base = 0; /* init only to stop compiler whining */
15747 bool gvoid = 0; /* init only to stop compiler whining */
15748 bool defav = 0; /* seen (...) = @_ */
15749 bool reuse = 0; /* reuse an existing padrange op */
15751 /* look for a pushmark -> gv[_] -> rv2av */
15756 if ( p->op_type == OP_GV
15757 && cGVOPx_gv(p) == PL_defgv
15758 && (rv2av = p->op_next)
15759 && rv2av->op_type == OP_RV2AV
15760 && !(rv2av->op_flags & OPf_REF)
15761 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15762 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15764 q = rv2av->op_next;
15765 if (q->op_type == OP_NULL)
15767 if (q->op_type == OP_PUSHMARK) {
15777 /* scan for PAD ops */
15779 for (p = p->op_next; p; p = p->op_next) {
15780 if (p->op_type == OP_NULL)
15783 if (( p->op_type != OP_PADSV
15784 && p->op_type != OP_PADAV
15785 && p->op_type != OP_PADHV
15787 /* any private flag other than INTRO? e.g. STATE */
15788 || (p->op_private & ~OPpLVAL_INTRO)
15792 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15794 if ( p->op_type == OP_PADAV
15796 && p->op_next->op_type == OP_CONST
15797 && p->op_next->op_next
15798 && p->op_next->op_next->op_type == OP_AELEM
15802 /* for 1st padop, note what type it is and the range
15803 * start; for the others, check that it's the same type
15804 * and that the targs are contiguous */
15806 intro = (p->op_private & OPpLVAL_INTRO);
15808 gvoid = OP_GIMME(p,0) == G_VOID;
15811 if ((p->op_private & OPpLVAL_INTRO) != intro)
15813 /* Note that you'd normally expect targs to be
15814 * contiguous in my($a,$b,$c), but that's not the case
15815 * when external modules start doing things, e.g.
15816 * Function::Parameters */
15817 if (p->op_targ != base + count)
15819 assert(p->op_targ == base + count);
15820 /* Either all the padops or none of the padops should
15821 be in void context. Since we only do the optimisa-
15822 tion for av/hv when the aggregate itself is pushed
15823 on to the stack (one item), there is no need to dis-
15824 tinguish list from scalar context. */
15825 if (gvoid != (OP_GIMME(p,0) == G_VOID))
15829 /* for AV, HV, only when we're not flattening */
15830 if ( p->op_type != OP_PADSV
15832 && !(p->op_flags & OPf_REF)
15836 if (count >= OPpPADRANGE_COUNTMASK)
15839 /* there's a biggest base we can fit into a
15840 * SAVEt_CLEARPADRANGE in pp_padrange.
15841 * (The sizeof() stuff will be constant-folded, and is
15842 * intended to avoid getting "comparison is always false"
15843 * compiler warnings. See the comments above
15844 * MEM_WRAP_CHECK for more explanation on why we do this
15845 * in a weird way to avoid compiler warnings.)
15848 && (8*sizeof(base) >
15849 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15851 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15853 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15857 /* Success! We've got another valid pad op to optimise away */
15859 followop = p->op_next;
15862 if (count < 1 || (count == 1 && !defav))
15865 /* pp_padrange in specifically compile-time void context
15866 * skips pushing a mark and lexicals; in all other contexts
15867 * (including unknown till runtime) it pushes a mark and the
15868 * lexicals. We must be very careful then, that the ops we
15869 * optimise away would have exactly the same effect as the
15871 * In particular in void context, we can only optimise to
15872 * a padrange if we see the complete sequence
15873 * pushmark, pad*v, ...., list
15874 * which has the net effect of leaving the markstack as it
15875 * was. Not pushing onto the stack (whereas padsv does touch
15876 * the stack) makes no difference in void context.
15880 if (followop->op_type == OP_LIST
15881 && OP_GIMME(followop,0) == G_VOID
15884 followop = followop->op_next; /* skip OP_LIST */
15886 /* consolidate two successive my(...);'s */
15889 && oldoldop->op_type == OP_PADRANGE
15890 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15891 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15892 && !(oldoldop->op_flags & OPf_SPECIAL)
15895 assert(oldoldop->op_next == oldop);
15896 assert( oldop->op_type == OP_NEXTSTATE
15897 || oldop->op_type == OP_DBSTATE);
15898 assert(oldop->op_next == o);
15901 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15903 /* Do not assume pad offsets for $c and $d are con-
15908 if ( oldoldop->op_targ + old_count == base
15909 && old_count < OPpPADRANGE_COUNTMASK - count) {
15910 base = oldoldop->op_targ;
15911 count += old_count;
15916 /* if there's any immediately following singleton
15917 * my var's; then swallow them and the associated
15919 * my ($a,$b); my $c; my $d;
15921 * my ($a,$b,$c,$d);
15924 while ( ((p = followop->op_next))
15925 && ( p->op_type == OP_PADSV
15926 || p->op_type == OP_PADAV
15927 || p->op_type == OP_PADHV)
15928 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15929 && (p->op_private & OPpLVAL_INTRO) == intro
15930 && !(p->op_private & ~OPpLVAL_INTRO)
15932 && ( p->op_next->op_type == OP_NEXTSTATE
15933 || p->op_next->op_type == OP_DBSTATE)
15934 && count < OPpPADRANGE_COUNTMASK
15935 && base + count == p->op_targ
15938 followop = p->op_next;
15946 assert(oldoldop->op_type == OP_PADRANGE);
15947 oldoldop->op_next = followop;
15948 oldoldop->op_private = (intro | count);
15954 /* Convert the pushmark into a padrange.
15955 * To make Deparse easier, we guarantee that a padrange was
15956 * *always* formerly a pushmark */
15957 assert(o->op_type == OP_PUSHMARK);
15958 o->op_next = followop;
15959 OpTYPE_set(o, OP_PADRANGE);
15961 /* bit 7: INTRO; bit 6..0: count */
15962 o->op_private = (intro | count);
15963 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15964 | gvoid * OPf_WANT_VOID
15965 | (defav ? OPf_SPECIAL : 0));
15971 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15972 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15977 /*'keys %h' in void or scalar context: skip the OP_KEYS
15978 * and perform the functionality directly in the RV2HV/PADHV
15981 if (o->op_flags & OPf_REF) {
15982 OP *k = o->op_next;
15983 U8 want = (k->op_flags & OPf_WANT);
15985 && k->op_type == OP_KEYS
15986 && ( want == OPf_WANT_VOID
15987 || want == OPf_WANT_SCALAR)
15988 && !(k->op_private & OPpMAYBE_LVSUB)
15989 && !(k->op_flags & OPf_MOD)
15991 o->op_next = k->op_next;
15992 o->op_flags &= ~(OPf_REF|OPf_WANT);
15993 o->op_flags |= want;
15994 o->op_private |= (o->op_type == OP_PADHV ?
15995 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15996 /* for keys(%lex), hold onto the OP_KEYS's targ
15997 * since padhv doesn't have its own targ to return
15999 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16004 /* see if %h is used in boolean context */
16005 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16006 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16009 if (o->op_type != OP_PADHV)
16013 if ( o->op_type == OP_PADAV
16014 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16016 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16019 /* Skip over state($x) in void context. */
16020 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16021 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16023 oldop->op_next = o->op_next;
16024 goto redo_nextstate;
16026 if (o->op_type != OP_PADAV)
16030 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16031 OP* const pop = (o->op_type == OP_PADAV) ?
16032 o->op_next : o->op_next->op_next;
16034 if (pop && pop->op_type == OP_CONST &&
16035 ((PL_op = pop->op_next)) &&
16036 pop->op_next->op_type == OP_AELEM &&
16037 !(pop->op_next->op_private &
16038 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16039 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16042 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16043 no_bareword_allowed(pop);
16044 if (o->op_type == OP_GV)
16045 op_null(o->op_next);
16046 op_null(pop->op_next);
16048 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16049 o->op_next = pop->op_next->op_next;
16050 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16051 o->op_private = (U8)i;
16052 if (o->op_type == OP_GV) {
16055 o->op_type = OP_AELEMFAST;
16058 o->op_type = OP_AELEMFAST_LEX;
16060 if (o->op_type != OP_GV)
16064 /* Remove $foo from the op_next chain in void context. */
16066 && ( o->op_next->op_type == OP_RV2SV
16067 || o->op_next->op_type == OP_RV2AV
16068 || o->op_next->op_type == OP_RV2HV )
16069 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16070 && !(o->op_next->op_private & OPpLVAL_INTRO))
16072 oldop->op_next = o->op_next->op_next;
16073 /* Reprocess the previous op if it is a nextstate, to
16074 allow double-nextstate optimisation. */
16076 if (oldop->op_type == OP_NEXTSTATE) {
16083 o = oldop->op_next;
16086 else if (o->op_next->op_type == OP_RV2SV) {
16087 if (!(o->op_next->op_private & OPpDEREF)) {
16088 op_null(o->op_next);
16089 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16091 o->op_next = o->op_next->op_next;
16092 OpTYPE_set(o, OP_GVSV);
16095 else if (o->op_next->op_type == OP_READLINE
16096 && o->op_next->op_next->op_type == OP_CONCAT
16097 && (o->op_next->op_next->op_flags & OPf_STACKED))
16099 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16100 OpTYPE_set(o, OP_RCATLINE);
16101 o->op_flags |= OPf_STACKED;
16102 op_null(o->op_next->op_next);
16103 op_null(o->op_next);
16114 while (cLOGOP->op_other->op_type == OP_NULL)
16115 cLOGOP->op_other = cLOGOP->op_other->op_next;
16116 while (o->op_next && ( o->op_type == o->op_next->op_type
16117 || o->op_next->op_type == OP_NULL))
16118 o->op_next = o->op_next->op_next;
16120 /* If we're an OR and our next is an AND in void context, we'll
16121 follow its op_other on short circuit, same for reverse.
16122 We can't do this with OP_DOR since if it's true, its return
16123 value is the underlying value which must be evaluated
16127 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16128 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16130 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16132 o->op_next = ((LOGOP*)o->op_next)->op_other;
16134 DEFER(cLOGOP->op_other);
16139 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16140 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16149 case OP_ARGDEFELEM:
16150 while (cLOGOP->op_other->op_type == OP_NULL)
16151 cLOGOP->op_other = cLOGOP->op_other->op_next;
16152 DEFER(cLOGOP->op_other);
16157 while (cLOOP->op_redoop->op_type == OP_NULL)
16158 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16159 while (cLOOP->op_nextop->op_type == OP_NULL)
16160 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16161 while (cLOOP->op_lastop->op_type == OP_NULL)
16162 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16163 /* a while(1) loop doesn't have an op_next that escapes the
16164 * loop, so we have to explicitly follow the op_lastop to
16165 * process the rest of the code */
16166 DEFER(cLOOP->op_lastop);
16170 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16171 DEFER(cLOGOPo->op_other);
16175 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16176 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16177 assert(!(cPMOP->op_pmflags & PMf_ONCE));
16178 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16179 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16180 cPMOP->op_pmstashstartu.op_pmreplstart
16181 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16182 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16188 if (o->op_flags & OPf_SPECIAL) {
16189 /* first arg is a code block */
16190 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16191 OP * kid = cUNOPx(nullop)->op_first;
16193 assert(nullop->op_type == OP_NULL);
16194 assert(kid->op_type == OP_SCOPE
16195 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16196 /* since OP_SORT doesn't have a handy op_other-style
16197 * field that can point directly to the start of the code
16198 * block, store it in the otherwise-unused op_next field
16199 * of the top-level OP_NULL. This will be quicker at
16200 * run-time, and it will also allow us to remove leading
16201 * OP_NULLs by just messing with op_nexts without
16202 * altering the basic op_first/op_sibling layout. */
16203 kid = kLISTOP->op_first;
16205 (kid->op_type == OP_NULL
16206 && ( kid->op_targ == OP_NEXTSTATE
16207 || kid->op_targ == OP_DBSTATE ))
16208 || kid->op_type == OP_STUB
16209 || kid->op_type == OP_ENTER
16210 || (PL_parser && PL_parser->error_count));
16211 nullop->op_next = kid->op_next;
16212 DEFER(nullop->op_next);
16215 /* check that RHS of sort is a single plain array */
16216 oright = cUNOPo->op_first;
16217 if (!oright || oright->op_type != OP_PUSHMARK)
16220 if (o->op_private & OPpSORT_INPLACE)
16223 /* reverse sort ... can be optimised. */
16224 if (!OpHAS_SIBLING(cUNOPo)) {
16225 /* Nothing follows us on the list. */
16226 OP * const reverse = o->op_next;
16228 if (reverse->op_type == OP_REVERSE &&
16229 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16230 OP * const pushmark = cUNOPx(reverse)->op_first;
16231 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16232 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16233 /* reverse -> pushmark -> sort */
16234 o->op_private |= OPpSORT_REVERSE;
16236 pushmark->op_next = oright->op_next;
16246 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16248 LISTOP *enter, *exlist;
16250 if (o->op_private & OPpSORT_INPLACE)
16253 enter = (LISTOP *) o->op_next;
16256 if (enter->op_type == OP_NULL) {
16257 enter = (LISTOP *) enter->op_next;
16261 /* for $a (...) will have OP_GV then OP_RV2GV here.
16262 for (...) just has an OP_GV. */
16263 if (enter->op_type == OP_GV) {
16264 gvop = (OP *) enter;
16265 enter = (LISTOP *) enter->op_next;
16268 if (enter->op_type == OP_RV2GV) {
16269 enter = (LISTOP *) enter->op_next;
16275 if (enter->op_type != OP_ENTERITER)
16278 iter = enter->op_next;
16279 if (!iter || iter->op_type != OP_ITER)
16282 expushmark = enter->op_first;
16283 if (!expushmark || expushmark->op_type != OP_NULL
16284 || expushmark->op_targ != OP_PUSHMARK)
16287 exlist = (LISTOP *) OpSIBLING(expushmark);
16288 if (!exlist || exlist->op_type != OP_NULL
16289 || exlist->op_targ != OP_LIST)
16292 if (exlist->op_last != o) {
16293 /* Mmm. Was expecting to point back to this op. */
16296 theirmark = exlist->op_first;
16297 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16300 if (OpSIBLING(theirmark) != o) {
16301 /* There's something between the mark and the reverse, eg
16302 for (1, reverse (...))
16307 ourmark = ((LISTOP *)o)->op_first;
16308 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16311 ourlast = ((LISTOP *)o)->op_last;
16312 if (!ourlast || ourlast->op_next != o)
16315 rv2av = OpSIBLING(ourmark);
16316 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16317 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16318 /* We're just reversing a single array. */
16319 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16320 enter->op_flags |= OPf_STACKED;
16323 /* We don't have control over who points to theirmark, so sacrifice
16325 theirmark->op_next = ourmark->op_next;
16326 theirmark->op_flags = ourmark->op_flags;
16327 ourlast->op_next = gvop ? gvop : (OP *) enter;
16330 enter->op_private |= OPpITER_REVERSED;
16331 iter->op_private |= OPpITER_REVERSED;
16335 o = oldop->op_next;
16337 NOT_REACHED; /* NOTREACHED */
16343 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16344 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16349 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16350 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16353 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16355 sv = newRV((SV *)PL_compcv);
16359 OpTYPE_set(o, OP_CONST);
16360 o->op_flags |= OPf_SPECIAL;
16361 cSVOPo->op_sv = sv;
16366 if (OP_GIMME(o,0) == G_VOID
16367 || ( o->op_next->op_type == OP_LINESEQ
16368 && ( o->op_next->op_next->op_type == OP_LEAVESUB
16369 || ( o->op_next->op_next->op_type == OP_RETURN
16370 && !CvLVALUE(PL_compcv)))))
16372 OP *right = cBINOP->op_first;
16391 OP *left = OpSIBLING(right);
16392 if (left->op_type == OP_SUBSTR
16393 && (left->op_private & 7) < 4) {
16395 /* cut out right */
16396 op_sibling_splice(o, NULL, 1, NULL);
16397 /* and insert it as second child of OP_SUBSTR */
16398 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16400 left->op_private |= OPpSUBSTR_REPL_FIRST;
16402 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16409 int l, r, lr, lscalars, rscalars;
16411 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16412 Note that we do this now rather than in newASSIGNOP(),
16413 since only by now are aliased lexicals flagged as such
16415 See the essay "Common vars in list assignment" above for
16416 the full details of the rationale behind all the conditions
16419 PL_generation sorcery:
16420 To detect whether there are common vars, the global var
16421 PL_generation is incremented for each assign op we scan.
16422 Then we run through all the lexical variables on the LHS,
16423 of the assignment, setting a spare slot in each of them to
16424 PL_generation. Then we scan the RHS, and if any lexicals
16425 already have that value, we know we've got commonality.
16426 Also, if the generation number is already set to
16427 PERL_INT_MAX, then the variable is involved in aliasing, so
16428 we also have potential commonality in that case.
16434 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
16437 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16441 /* After looking for things which are *always* safe, this main
16442 * if/else chain selects primarily based on the type of the
16443 * LHS, gradually working its way down from the more dangerous
16444 * to the more restrictive and thus safer cases */
16446 if ( !l /* () = ....; */
16447 || !r /* .... = (); */
16448 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16449 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16450 || (lscalars < 2) /* ($x, undef) = ... */
16452 NOOP; /* always safe */
16454 else if (l & AAS_DANGEROUS) {
16455 /* always dangerous */
16456 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16457 o->op_private |= OPpASSIGN_COMMON_AGG;
16459 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16460 /* package vars are always dangerous - too many
16461 * aliasing possibilities */
16462 if (l & AAS_PKG_SCALAR)
16463 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16464 if (l & AAS_PKG_AGG)
16465 o->op_private |= OPpASSIGN_COMMON_AGG;
16467 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16468 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16470 /* LHS contains only lexicals and safe ops */
16472 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16473 o->op_private |= OPpASSIGN_COMMON_AGG;
16475 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16476 if (lr & AAS_LEX_SCALAR_COMM)
16477 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16478 else if ( !(l & AAS_LEX_SCALAR)
16479 && (r & AAS_DEFAV))
16483 * as scalar-safe for performance reasons.
16484 * (it will still have been marked _AGG if necessary */
16487 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16488 /* if there are only lexicals on the LHS and no
16489 * common ones on the RHS, then we assume that the
16490 * only way those lexicals could also get
16491 * on the RHS is via some sort of dereffing or
16494 * ($lex, $x) = (1, $$r)
16495 * and in this case we assume the var must have
16496 * a bumped ref count. So if its ref count is 1,
16497 * it must only be on the LHS.
16499 o->op_private |= OPpASSIGN_COMMON_RC1;
16504 * may have to handle aggregate on LHS, but we can't
16505 * have common scalars. */
16508 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16510 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16511 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16516 /* see if ref() is used in boolean context */
16517 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16518 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16522 /* see if the op is used in known boolean context,
16523 * but not if OA_TARGLEX optimisation is enabled */
16524 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16525 && !(o->op_private & OPpTARGET_MY)
16527 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16531 /* see if the op is used in known boolean context */
16532 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16533 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16537 Perl_cpeep_t cpeep =
16538 XopENTRYCUSTOM(o, xop_peep);
16540 cpeep(aTHX_ o, oldop);
16545 /* did we just null the current op? If so, re-process it to handle
16546 * eliding "empty" ops from the chain */
16547 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16560 Perl_peep(pTHX_ OP *o)
16566 =head1 Custom Operators
16568 =for apidoc Ao||custom_op_xop
16569 Return the XOP structure for a given custom op. This macro should be
16570 considered internal to C<OP_NAME> and the other access macros: use them instead.
16571 This macro does call a function. Prior
16572 to 5.19.6, this was implemented as a
16579 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16585 static const XOP xop_null = { 0, 0, 0, 0, 0 };
16587 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16588 assert(o->op_type == OP_CUSTOM);
16590 /* This is wrong. It assumes a function pointer can be cast to IV,
16591 * which isn't guaranteed, but this is what the old custom OP code
16592 * did. In principle it should be safer to Copy the bytes of the
16593 * pointer into a PV: since the new interface is hidden behind
16594 * functions, this can be changed later if necessary. */
16595 /* Change custom_op_xop if this ever happens */
16596 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16599 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16601 /* assume noone will have just registered a desc */
16602 if (!he && PL_custom_op_names &&
16603 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16608 /* XXX does all this need to be shared mem? */
16609 Newxz(xop, 1, XOP);
16610 pv = SvPV(HeVAL(he), l);
16611 XopENTRY_set(xop, xop_name, savepvn(pv, l));
16612 if (PL_custom_op_descs &&
16613 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16615 pv = SvPV(HeVAL(he), l);
16616 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16618 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16622 xop = (XOP *)&xop_null;
16624 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16628 if(field == XOPe_xop_ptr) {
16631 const U32 flags = XopFLAGS(xop);
16632 if(flags & field) {
16634 case XOPe_xop_name:
16635 any.xop_name = xop->xop_name;
16637 case XOPe_xop_desc:
16638 any.xop_desc = xop->xop_desc;
16640 case XOPe_xop_class:
16641 any.xop_class = xop->xop_class;
16643 case XOPe_xop_peep:
16644 any.xop_peep = xop->xop_peep;
16647 NOT_REACHED; /* NOTREACHED */
16652 case XOPe_xop_name:
16653 any.xop_name = XOPd_xop_name;
16655 case XOPe_xop_desc:
16656 any.xop_desc = XOPd_xop_desc;
16658 case XOPe_xop_class:
16659 any.xop_class = XOPd_xop_class;
16661 case XOPe_xop_peep:
16662 any.xop_peep = XOPd_xop_peep;
16665 NOT_REACHED; /* NOTREACHED */
16670 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16671 * op.c: In function 'Perl_custom_op_get_field':
16672 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16673 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16674 * expands to assert(0), which expands to ((0) ? (void)0 :
16675 * __assert(...)), and gcc doesn't know that __assert can never return. */
16681 =for apidoc Ao||custom_op_register
16682 Register a custom op. See L<perlguts/"Custom Operators">.
16688 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16692 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16694 /* see the comment in custom_op_xop */
16695 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16697 if (!PL_custom_ops)
16698 PL_custom_ops = newHV();
16700 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16701 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16706 =for apidoc core_prototype
16708 This function assigns the prototype of the named core function to C<sv>, or
16709 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
16710 C<NULL> if the core function has no prototype. C<code> is a code as returned
16711 by C<keyword()>. It must not be equal to 0.
16717 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16720 int i = 0, n = 0, seen_question = 0, defgv = 0;
16722 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16723 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16724 bool nullret = FALSE;
16726 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16730 if (!sv) sv = sv_newmortal();
16732 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16734 switch (code < 0 ? -code : code) {
16735 case KEY_and : case KEY_chop: case KEY_chomp:
16736 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
16737 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
16738 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
16739 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
16740 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
16741 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
16742 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
16743 case KEY_x : case KEY_xor :
16744 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16745 case KEY_glob: retsetpvs("_;", OP_GLOB);
16746 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
16747 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
16748 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
16749 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
16750 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16752 case KEY_evalbytes:
16753 name = "entereval"; break;
16761 while (i < MAXO) { /* The slow way. */
16762 if (strEQ(name, PL_op_name[i])
16763 || strEQ(name, PL_op_desc[i]))
16765 if (nullret) { assert(opnum); *opnum = i; return NULL; }
16772 defgv = PL_opargs[i] & OA_DEFGV;
16773 oa = PL_opargs[i] >> OASHIFT;
16775 if (oa & OA_OPTIONAL && !seen_question && (
16776 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16781 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16782 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16783 /* But globs are already references (kinda) */
16784 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16788 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16789 && !scalar_mod_type(NULL, i)) {
16794 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16798 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16799 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16800 str[n-1] = '_'; defgv = 0;
16804 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16806 sv_setpvn(sv, str, n - 1);
16807 if (opnum) *opnum = i;
16812 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16815 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16818 PERL_ARGS_ASSERT_CORESUB_OP;
16822 return op_append_elem(OP_LINESEQ,
16825 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16832 o = newUNOP(OP_AVHVSWITCH,0,argop);
16833 o->op_private = opnum-OP_EACH;
16835 case OP_SELECT: /* which represents OP_SSELECT as well */
16840 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16841 newSVOP(OP_CONST, 0, newSVuv(1))
16843 coresub_op(newSVuv((UV)OP_SSELECT), 0,
16845 coresub_op(coreargssv, 0, OP_SELECT)
16849 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16851 return op_append_elem(
16854 opnum == OP_WANTARRAY || opnum == OP_RUNCV
16855 ? OPpOFFBYONE << 8 : 0)
16857 case OA_BASEOP_OR_UNOP:
16858 if (opnum == OP_ENTEREVAL) {
16859 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16860 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16862 else o = newUNOP(opnum,0,argop);
16863 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16866 if (is_handle_constructor(o, 1))
16867 argop->op_private |= OPpCOREARGS_DEREF1;
16868 if (scalar_mod_type(NULL, opnum))
16869 argop->op_private |= OPpCOREARGS_SCALARMOD;
16873 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16874 if (is_handle_constructor(o, 2))
16875 argop->op_private |= OPpCOREARGS_DEREF2;
16876 if (opnum == OP_SUBSTR) {
16877 o->op_private |= OPpMAYBE_LVSUB;
16886 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16887 SV * const *new_const_svp)
16889 const char *hvname;
16890 bool is_const = !!CvCONST(old_cv);
16891 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16893 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16895 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16897 /* They are 2 constant subroutines generated from
16898 the same constant. This probably means that
16899 they are really the "same" proxy subroutine
16900 instantiated in 2 places. Most likely this is
16901 when a constant is exported twice. Don't warn.
16904 (ckWARN(WARN_REDEFINE)
16906 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16907 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16908 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16909 strEQ(hvname, "autouse"))
16913 && ckWARN_d(WARN_REDEFINE)
16914 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16917 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16919 ? "Constant subroutine %" SVf " redefined"
16920 : "Subroutine %" SVf " redefined",
16925 =head1 Hook manipulation
16927 These functions provide convenient and thread-safe means of manipulating
16934 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16936 Puts a C function into the chain of check functions for a specified op
16937 type. This is the preferred way to manipulate the L</PL_check> array.
16938 C<opcode> specifies which type of op is to be affected. C<new_checker>
16939 is a pointer to the C function that is to be added to that opcode's
16940 check chain, and C<old_checker_p> points to the storage location where a
16941 pointer to the next function in the chain will be stored. The value of
16942 C<new_checker> is written into the L</PL_check> array, while the value
16943 previously stored there is written to C<*old_checker_p>.
16945 L</PL_check> is global to an entire process, and a module wishing to
16946 hook op checking may find itself invoked more than once per process,
16947 typically in different threads. To handle that situation, this function
16948 is idempotent. The location C<*old_checker_p> must initially (once
16949 per process) contain a null pointer. A C variable of static duration
16950 (declared at file scope, typically also marked C<static> to give
16951 it internal linkage) will be implicitly initialised appropriately,
16952 if it does not have an explicit initialiser. This function will only
16953 actually modify the check chain if it finds C<*old_checker_p> to be null.
16954 This function is also thread safe on the small scale. It uses appropriate
16955 locking to avoid race conditions in accessing L</PL_check>.
16957 When this function is called, the function referenced by C<new_checker>
16958 must be ready to be called, except for C<*old_checker_p> being unfilled.
16959 In a threading situation, C<new_checker> may be called immediately,
16960 even before this function has returned. C<*old_checker_p> will always
16961 be appropriately set before C<new_checker> is called. If C<new_checker>
16962 decides not to do anything special with an op that it is given (which
16963 is the usual case for most uses of op check hooking), it must chain the
16964 check function referenced by C<*old_checker_p>.
16966 Taken all together, XS code to hook an op checker should typically look
16967 something like this:
16969 static Perl_check_t nxck_frob;
16970 static OP *myck_frob(pTHX_ OP *op) {
16972 op = nxck_frob(aTHX_ op);
16977 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16979 If you want to influence compilation of calls to a specific subroutine,
16980 then use L</cv_set_call_checker_flags> rather than hooking checking of
16981 all C<entersub> ops.
16987 Perl_wrap_op_checker(pTHX_ Optype opcode,
16988 Perl_check_t new_checker, Perl_check_t *old_checker_p)
16992 PERL_UNUSED_CONTEXT;
16993 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16994 if (*old_checker_p) return;
16995 OP_CHECK_MUTEX_LOCK;
16996 if (!*old_checker_p) {
16997 *old_checker_p = PL_check[opcode];
16998 PL_check[opcode] = new_checker;
17000 OP_CHECK_MUTEX_UNLOCK;
17005 /* Efficient sub that returns a constant scalar value. */
17007 const_sv_xsub(pTHX_ CV* cv)
17010 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17011 PERL_UNUSED_ARG(items);
17021 const_av_xsub(pTHX_ CV* cv)
17024 AV * const av = MUTABLE_AV(XSANY.any_ptr);
17032 if (SvRMAGICAL(av))
17033 Perl_croak(aTHX_ "Magical list constants are not supported");
17034 if (GIMME_V != G_ARRAY) {
17036 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17039 EXTEND(SP, AvFILLp(av)+1);
17040 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17041 XSRETURN(AvFILLp(av)+1);
17046 * ex: set ts=8 sts=4 sw=4 et: