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);
1446 cLISTOPx(parent)->op_first = insert;
1448 parent->op_flags |= OPf_KIDS;
1450 parent->op_flags &= ~OPf_KIDS;
1454 /* update op_last etc */
1461 /* ought to use OP_CLASS(parent) here, but that can't handle
1462 * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1464 type = parent->op_type;
1465 if (type == OP_CUSTOM) {
1467 type = XopENTRYCUSTOM(parent, xop_class);
1470 if (type == OP_NULL)
1471 type = parent->op_targ;
1472 type = PL_opargs[type] & OA_CLASS_MASK;
1475 lastop = last_ins ? last_ins : start ? start : NULL;
1476 if ( type == OA_BINOP
1477 || type == OA_LISTOP
1481 cLISTOPx(parent)->op_last = lastop;
1484 OpLASTSIB_set(lastop, parent);
1486 return last_del ? first : NULL;
1489 Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1493 =for apidoc op_parent
1495 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1501 Perl_op_parent(OP *o)
1503 PERL_ARGS_ASSERT_OP_PARENT;
1504 while (OpHAS_SIBLING(o))
1506 return o->op_sibparent;
1509 /* replace the sibling following start with a new UNOP, which becomes
1510 * the parent of the original sibling; e.g.
1512 * op_sibling_newUNOP(P, A, unop-args...)
1520 * where U is the new UNOP.
1522 * parent and start args are the same as for op_sibling_splice();
1523 * type and flags args are as newUNOP().
1525 * Returns the new UNOP.
1529 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1533 kid = op_sibling_splice(parent, start, 1, NULL);
1534 newop = newUNOP(type, flags, kid);
1535 op_sibling_splice(parent, start, 0, newop);
1540 /* lowest-level newLOGOP-style function - just allocates and populates
1541 * the struct. Higher-level stuff should be done by S_new_logop() /
1542 * newLOGOP(). This function exists mainly to avoid op_first assignment
1543 * being spread throughout this file.
1547 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1552 NewOp(1101, logop, 1, LOGOP);
1553 OpTYPE_set(logop, type);
1554 logop->op_first = first;
1555 logop->op_other = other;
1557 logop->op_flags = OPf_KIDS;
1558 while (kid && OpHAS_SIBLING(kid))
1559 kid = OpSIBLING(kid);
1561 OpLASTSIB_set(kid, (OP*)logop);
1566 /* Contextualizers */
1569 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1571 Applies a syntactic context to an op tree representing an expression.
1572 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1573 or C<G_VOID> to specify the context to apply. The modified op tree
1580 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1582 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1584 case G_SCALAR: return scalar(o);
1585 case G_ARRAY: return list(o);
1586 case G_VOID: return scalarvoid(o);
1588 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1595 =for apidoc Am|OP*|op_linklist|OP *o
1596 This function is the implementation of the L</LINKLIST> macro. It should
1597 not be called directly.
1603 Perl_op_linklist(pTHX_ OP *o)
1607 PERL_ARGS_ASSERT_OP_LINKLIST;
1612 /* establish postfix order */
1613 first = cUNOPo->op_first;
1616 o->op_next = LINKLIST(first);
1619 OP *sibl = OpSIBLING(kid);
1621 kid->op_next = LINKLIST(sibl);
1636 S_scalarkids(pTHX_ OP *o)
1638 if (o && o->op_flags & OPf_KIDS) {
1640 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1647 S_scalarboolean(pTHX_ OP *o)
1649 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1651 if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1652 !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1653 (o->op_type == OP_NOT && cUNOPo->op_first->op_type == OP_SASSIGN &&
1654 cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1655 !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1656 if (ckWARN(WARN_SYNTAX)) {
1657 const line_t oldline = CopLINE(PL_curcop);
1659 if (PL_parser && PL_parser->copline != NOLINE) {
1660 /* This ensures that warnings are reported at the first line
1661 of the conditional, not the last. */
1662 CopLINE_set(PL_curcop, PL_parser->copline);
1664 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1665 CopLINE_set(PL_curcop, oldline);
1672 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1675 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1676 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1678 const char funny = o->op_type == OP_PADAV
1679 || o->op_type == OP_RV2AV ? '@' : '%';
1680 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1682 if (cUNOPo->op_first->op_type != OP_GV
1683 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1685 return varname(gv, funny, 0, NULL, 0, subscript_type);
1688 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1693 S_op_varname(pTHX_ const OP *o)
1695 return S_op_varname_subscript(aTHX_ o, 1);
1699 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1700 { /* or not so pretty :-) */
1701 if (o->op_type == OP_CONST) {
1703 if (SvPOK(*retsv)) {
1705 *retsv = sv_newmortal();
1706 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1707 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1709 else if (!SvOK(*retsv))
1712 else *retpv = "...";
1716 S_scalar_slice_warning(pTHX_ const OP *o)
1719 const bool h = o->op_type == OP_HSLICE
1720 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1726 SV *keysv = NULL; /* just to silence compiler warnings */
1727 const char *key = NULL;
1729 if (!(o->op_private & OPpSLICEWARNING))
1731 if (PL_parser && PL_parser->error_count)
1732 /* This warning can be nonsensical when there is a syntax error. */
1735 kid = cLISTOPo->op_first;
1736 kid = OpSIBLING(kid); /* get past pushmark */
1737 /* weed out false positives: any ops that can return lists */
1738 switch (kid->op_type) {
1764 /* Don't warn if we have a nulled list either. */
1765 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1768 assert(OpSIBLING(kid));
1769 name = S_op_varname(aTHX_ OpSIBLING(kid));
1770 if (!name) /* XS module fiddling with the op tree */
1772 S_op_pretty(aTHX_ kid, &keysv, &key);
1773 assert(SvPOK(name));
1774 sv_chop(name,SvPVX(name)+1);
1776 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1777 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1778 "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1780 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1781 lbrack, key, rbrack);
1783 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1784 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1785 "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1787 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1788 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1792 Perl_scalar(pTHX_ OP *o)
1796 /* assumes no premature commitment */
1797 if (!o || (PL_parser && PL_parser->error_count)
1798 || (o->op_flags & OPf_WANT)
1799 || o->op_type == OP_RETURN)
1804 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1806 switch (o->op_type) {
1808 scalar(cBINOPo->op_first);
1809 if (o->op_private & OPpREPEAT_DOLIST) {
1810 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1811 assert(kid->op_type == OP_PUSHMARK);
1812 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1813 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1814 o->op_private &=~ OPpREPEAT_DOLIST;
1821 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
1831 if (o->op_flags & OPf_KIDS) {
1832 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1838 kid = cLISTOPo->op_first;
1840 kid = OpSIBLING(kid);
1843 OP *sib = OpSIBLING(kid);
1844 if (sib && kid->op_type != OP_LEAVEWHEN
1845 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1846 || ( sib->op_targ != OP_NEXTSTATE
1847 && sib->op_targ != OP_DBSTATE )))
1853 PL_curcop = &PL_compiling;
1858 kid = cLISTOPo->op_first;
1861 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1866 /* Warn about scalar context */
1867 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1868 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1871 const char *key = NULL;
1873 /* This warning can be nonsensical when there is a syntax error. */
1874 if (PL_parser && PL_parser->error_count)
1877 if (!ckWARN(WARN_SYNTAX)) break;
1879 kid = cLISTOPo->op_first;
1880 kid = OpSIBLING(kid); /* get past pushmark */
1881 assert(OpSIBLING(kid));
1882 name = S_op_varname(aTHX_ OpSIBLING(kid));
1883 if (!name) /* XS module fiddling with the op tree */
1885 S_op_pretty(aTHX_ kid, &keysv, &key);
1886 assert(SvPOK(name));
1887 sv_chop(name,SvPVX(name)+1);
1889 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1890 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1891 "%%%" SVf "%c%s%c in scalar context better written "
1892 "as $%" SVf "%c%s%c",
1893 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1894 lbrack, key, rbrack);
1896 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1897 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1898 "%%%" SVf "%c%" SVf "%c in scalar context better "
1899 "written as $%" SVf "%c%" SVf "%c",
1900 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1901 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1908 Perl_scalarvoid(pTHX_ OP *arg)
1916 PERL_ARGS_ASSERT_SCALARVOID;
1920 SV *useless_sv = NULL;
1921 const char* useless = NULL;
1923 if (o->op_type == OP_NEXTSTATE
1924 || o->op_type == OP_DBSTATE
1925 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1926 || o->op_targ == OP_DBSTATE)))
1927 PL_curcop = (COP*)o; /* for warning below */
1929 /* assumes no premature commitment */
1930 want = o->op_flags & OPf_WANT;
1931 if ((want && want != OPf_WANT_SCALAR)
1932 || (PL_parser && PL_parser->error_count)
1933 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1938 if ((o->op_private & OPpTARGET_MY)
1939 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1941 /* newASSIGNOP has already applied scalar context, which we
1942 leave, as if this op is inside SASSIGN. */
1946 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1948 switch (o->op_type) {
1950 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1954 if (o->op_flags & OPf_STACKED)
1956 if (o->op_type == OP_REPEAT)
1957 scalar(cBINOPo->op_first);
1960 if ((o->op_flags & OPf_STACKED) &&
1961 !(o->op_private & OPpCONCAT_NESTED))
1965 if (o->op_private == 4)
2000 case OP_GETSOCKNAME:
2001 case OP_GETPEERNAME:
2006 case OP_GETPRIORITY:
2031 useless = OP_DESC(o);
2041 case OP_AELEMFAST_LEX:
2045 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2046 /* Otherwise it's "Useless use of grep iterator" */
2047 useless = OP_DESC(o);
2051 if (!(o->op_private & OPpSPLIT_ASSIGN))
2052 useless = OP_DESC(o);
2056 kid = cUNOPo->op_first;
2057 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2058 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2061 useless = "negative pattern binding (!~)";
2065 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2066 useless = "non-destructive substitution (s///r)";
2070 useless = "non-destructive transliteration (tr///r)";
2077 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2078 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2079 useless = "a variable";
2084 if (cSVOPo->op_private & OPpCONST_STRICT)
2085 no_bareword_allowed(o);
2087 if (ckWARN(WARN_VOID)) {
2089 /* don't warn on optimised away booleans, eg
2090 * use constant Foo, 5; Foo || print; */
2091 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2093 /* the constants 0 and 1 are permitted as they are
2094 conventionally used as dummies in constructs like
2095 1 while some_condition_with_side_effects; */
2096 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2098 else if (SvPOK(sv)) {
2099 SV * const dsv = newSVpvs("");
2101 = Perl_newSVpvf(aTHX_
2103 pv_pretty(dsv, SvPVX_const(sv),
2104 SvCUR(sv), 32, NULL, NULL,
2106 | PERL_PV_ESCAPE_NOCLEAR
2107 | PERL_PV_ESCAPE_UNI_DETECT));
2108 SvREFCNT_dec_NN(dsv);
2110 else if (SvOK(sv)) {
2111 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2114 useless = "a constant (undef)";
2117 op_null(o); /* don't execute or even remember it */
2121 OpTYPE_set(o, OP_PREINC); /* pre-increment is faster */
2125 OpTYPE_set(o, OP_PREDEC); /* pre-decrement is faster */
2129 OpTYPE_set(o, OP_I_PREINC); /* pre-increment is faster */
2133 OpTYPE_set(o, OP_I_PREDEC); /* pre-decrement is faster */
2138 UNOP *refgen, *rv2cv;
2141 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2144 rv2gv = ((BINOP *)o)->op_last;
2145 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2148 refgen = (UNOP *)((BINOP *)o)->op_first;
2150 if (!refgen || (refgen->op_type != OP_REFGEN
2151 && refgen->op_type != OP_SREFGEN))
2154 exlist = (LISTOP *)refgen->op_first;
2155 if (!exlist || exlist->op_type != OP_NULL
2156 || exlist->op_targ != OP_LIST)
2159 if (exlist->op_first->op_type != OP_PUSHMARK
2160 && exlist->op_first != exlist->op_last)
2163 rv2cv = (UNOP*)exlist->op_last;
2165 if (rv2cv->op_type != OP_RV2CV)
2168 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2169 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2170 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2172 o->op_private |= OPpASSIGN_CV_TO_GV;
2173 rv2gv->op_private |= OPpDONT_INIT_GV;
2174 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2186 kid = cLOGOPo->op_first;
2187 if (kid->op_type == OP_NOT
2188 && (kid->op_flags & OPf_KIDS)) {
2189 if (o->op_type == OP_AND) {
2190 OpTYPE_set(o, OP_OR);
2192 OpTYPE_set(o, OP_AND);
2202 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2203 if (!(kid->op_flags & OPf_KIDS))
2210 if (o->op_flags & OPf_STACKED)
2217 if (!(o->op_flags & OPf_KIDS))
2228 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2229 if (!(kid->op_flags & OPf_KIDS))
2235 /* If the first kid after pushmark is something that the padrange
2236 optimisation would reject, then null the list and the pushmark.
2238 if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2239 && ( !(kid = OpSIBLING(kid))
2240 || ( kid->op_type != OP_PADSV
2241 && kid->op_type != OP_PADAV
2242 && kid->op_type != OP_PADHV)
2243 || kid->op_private & ~OPpLVAL_INTRO
2244 || !(kid = OpSIBLING(kid))
2245 || ( kid->op_type != OP_PADSV
2246 && kid->op_type != OP_PADAV
2247 && kid->op_type != OP_PADHV)
2248 || kid->op_private & ~OPpLVAL_INTRO)
2250 op_null(cUNOPo->op_first); /* NULL the pushmark */
2251 op_null(o); /* NULL the list */
2263 /* mortalise it, in case warnings are fatal. */
2264 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2265 "Useless use of %" SVf " in void context",
2266 SVfARG(sv_2mortal(useless_sv)));
2269 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2270 "Useless use of %s in void context",
2273 } while ( (o = POP_DEFERRED_OP()) );
2281 S_listkids(pTHX_ OP *o)
2283 if (o && o->op_flags & OPf_KIDS) {
2285 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2292 Perl_list(pTHX_ OP *o)
2296 /* assumes no premature commitment */
2297 if (!o || (o->op_flags & OPf_WANT)
2298 || (PL_parser && PL_parser->error_count)
2299 || o->op_type == OP_RETURN)
2304 if ((o->op_private & OPpTARGET_MY)
2305 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2307 return o; /* As if inside SASSIGN */
2310 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2312 switch (o->op_type) {
2314 list(cBINOPo->op_first);
2317 if (o->op_private & OPpREPEAT_DOLIST
2318 && !(o->op_flags & OPf_STACKED))
2320 list(cBINOPo->op_first);
2321 kid = cBINOPo->op_last;
2322 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2323 && SvIVX(kSVOP_sv) == 1)
2325 op_null(o); /* repeat */
2326 op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2328 op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2335 for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
2343 if (!(o->op_flags & OPf_KIDS))
2345 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2346 list(cBINOPo->op_first);
2347 return gen_constant_list(o);
2353 if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2354 op_null(cUNOPo->op_first); /* NULL the pushmark */
2355 op_null(o); /* NULL the list */
2360 kid = cLISTOPo->op_first;
2362 kid = OpSIBLING(kid);
2365 OP *sib = OpSIBLING(kid);
2366 if (sib && kid->op_type != OP_LEAVEWHEN)
2372 PL_curcop = &PL_compiling;
2376 kid = cLISTOPo->op_first;
2383 S_scalarseq(pTHX_ OP *o)
2386 const OPCODE type = o->op_type;
2388 if (type == OP_LINESEQ || type == OP_SCOPE ||
2389 type == OP_LEAVE || type == OP_LEAVETRY)
2392 for (kid = cLISTOPo->op_first; kid; kid = sib) {
2393 if ((sib = OpSIBLING(kid))
2394 && ( OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2395 || ( sib->op_targ != OP_NEXTSTATE
2396 && sib->op_targ != OP_DBSTATE )))
2401 PL_curcop = &PL_compiling;
2403 o->op_flags &= ~OPf_PARENS;
2404 if (PL_hints & HINT_BLOCK_SCOPE)
2405 o->op_flags |= OPf_PARENS;
2408 o = newOP(OP_STUB, 0);
2413 S_modkids(pTHX_ OP *o, I32 type)
2415 if (o && o->op_flags & OPf_KIDS) {
2417 for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2418 op_lvalue(kid, type);
2424 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2425 * const fields. Also, convert CONST keys to HEK-in-SVs.
2426 * rop is the op that retrieves the hash;
2427 * key_op is the first key
2431 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op)
2437 /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2439 if (rop->op_first->op_type == OP_PADSV)
2440 /* @$hash{qw(keys here)} */
2441 rop = (UNOP*)rop->op_first;
2443 /* @{$hash}{qw(keys here)} */
2444 if (rop->op_first->op_type == OP_SCOPE
2445 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2447 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2454 lexname = NULL; /* just to silence compiler warnings */
2455 fields = NULL; /* just to silence compiler warnings */
2459 && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2460 SvPAD_TYPED(lexname))
2461 && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2462 && isGV(*fields) && GvHV(*fields);
2464 for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2466 if (key_op->op_type != OP_CONST)
2468 svp = cSVOPx_svp(key_op);
2470 /* make sure it's not a bareword under strict subs */
2471 if (key_op->op_private & OPpCONST_BARE &&
2472 key_op->op_private & OPpCONST_STRICT)
2474 no_bareword_allowed((OP*)key_op);
2477 /* Make the CONST have a shared SV */
2478 if ( !SvIsCOW_shared_hash(sv = *svp)
2479 && SvTYPE(sv) < SVt_PVMG
2484 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2485 SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2486 SvREFCNT_dec_NN(sv);
2491 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2493 Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2494 "in variable %" PNf " of type %" HEKf,
2495 SVfARG(*svp), PNfARG(lexname),
2496 HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2501 /* info returned by S_sprintf_is_multiconcatable() */
2503 struct sprintf_ismc_info {
2504 SSize_t nargs; /* num of args to sprintf (not including the format) */
2505 char *start; /* start of raw format string */
2506 char *end; /* bytes after end of raw format string */
2507 STRLEN total_len; /* total length (in bytes) of format string, not
2508 including '%s' and half of '%%' */
2509 STRLEN variant; /* number of bytes by which total_len_p would grow
2510 if upgraded to utf8 */
2511 bool utf8; /* whether the format is utf8 */
2515 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2516 * i.e. its format argument is a const string with only '%s' and '%%'
2517 * formats, and the number of args is known, e.g.
2518 * sprintf "a=%s f=%s", $a[0], scalar(f());
2520 * sprintf "i=%d a=%s f=%s", $i, @a, f();
2522 * If successful, the sprintf_ismc_info struct pointed to by info will be
2527 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2529 OP *pm, *constop, *kid;
2532 SSize_t nargs, nformats;
2533 STRLEN cur, total_len, variant;
2536 /* if sprintf's behaviour changes, die here so that someone
2537 * can decide whether to enhance this function or skip optimising
2538 * under those new circumstances */
2539 assert(!(o->op_flags & OPf_STACKED));
2540 assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2541 assert(!(o->op_private & ~OPpARG4_MASK));
2543 pm = cUNOPo->op_first;
2544 if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2546 constop = OpSIBLING(pm);
2547 if (!constop || constop->op_type != OP_CONST)
2549 sv = cSVOPx_sv(constop);
2550 if (SvMAGICAL(sv) || !SvPOK(sv))
2556 /* Scan format for %% and %s and work out how many %s there are.
2557 * Abandon if other format types are found.
2564 for (p = s; p < e; p++) {
2567 if (!UTF8_IS_INVARIANT(*p))
2573 return FALSE; /* lone % at end gives "Invalid conversion" */
2582 if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2585 utf8 = cBOOL(SvUTF8(sv));
2589 /* scan args; they must all be in scalar cxt */
2592 kid = OpSIBLING(constop);
2595 if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2598 kid = OpSIBLING(kid);
2601 if (nargs != nformats)
2602 return FALSE; /* e.g. sprintf("%s%s", $a); */
2605 info->nargs = nargs;
2608 info->total_len = total_len;
2609 info->variant = variant;
2617 /* S_maybe_multiconcat():
2619 * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2620 * convert it (and its children) into an OP_MULTICONCAT. See the code
2621 * comments just before pp_multiconcat() for the full details of what
2622 * OP_MULTICONCAT supports.
2624 * Basically we're looking for an optree with a chain of OP_CONCATS down
2625 * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2626 * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2634 * STRINGIFY -- PADSV[$x]
2637 * ex-PUSHMARK -- CONCAT/S
2639 * CONCAT/S -- PADSV[$d]
2641 * CONCAT -- CONST["-"]
2643 * PADSV[$a] -- PADSV[$b]
2645 * Note that at this stage the OP_SASSIGN may have already been optimised
2646 * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2650 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(pTHX_ 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)
7826 const PADOFFSET target = padop->op_targ;
7827 OP *const other = newOP(OP_PADSV,
7829 | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
7830 OP *const first = newOP(OP_NULL, 0);
7831 OP *const nullop = newCONDOP(0, first, initop, other);
7832 /* XXX targlex disabled for now; see ticket #124160
7833 newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
7835 OP *const condop = first->op_next;
7837 OpTYPE_set(condop, OP_ONCE);
7838 other->op_targ = target;
7839 nullop->op_flags |= OPf_WANT_SCALAR;
7841 /* Store the initializedness of state vars in a separate
7844 pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
7845 /* hijacking PADSTALE for uninitialized state variables */
7846 SvPADSTALE_on(PAD_SVl(condop->op_targ));
7852 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
7854 Constructs, checks, and returns an assignment op. C<left> and C<right>
7855 supply the parameters of the assignment; they are consumed by this
7856 function and become part of the constructed op tree.
7858 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
7859 a suitable conditional optree is constructed. If C<optype> is the opcode
7860 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
7861 performs the binary operation and assigns the result to the left argument.
7862 Either way, if C<optype> is non-zero then C<flags> has no effect.
7864 If C<optype> is zero, then a plain scalar or list assignment is
7865 constructed. Which type of assignment it is is automatically determined.
7866 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
7867 will be set automatically, and, shifted up eight bits, the eight bits
7868 of C<op_private>, except that the bit with value 1 or 2 is automatically
7875 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
7881 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
7882 right = scalar(right);
7883 return newLOGOP(optype, 0,
7884 op_lvalue(scalar(left), optype),
7885 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
7888 return newBINOP(optype, OPf_STACKED,
7889 op_lvalue(scalar(left), optype), scalar(right));
7893 if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
7894 OP *state_var_op = NULL;
7895 static const char no_list_state[] = "Initialization of state variables"
7896 " in list currently forbidden";
7899 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
7900 left->op_private &= ~ OPpSLICEWARNING;
7903 left = op_lvalue(left, OP_AASSIGN);
7904 curop = list(force_list(left, 1));
7905 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
7906 o->op_private = (U8)(0 | (flags >> 8));
7908 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
7910 OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
7911 if (!(left->op_flags & OPf_PARENS) &&
7912 lop->op_type == OP_PUSHMARK &&
7913 (vop = OpSIBLING(lop)) &&
7914 (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
7915 !(vop->op_flags & OPf_PARENS) &&
7916 (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
7917 (OPpLVAL_INTRO|OPpPAD_STATE) &&
7918 (eop = OpSIBLING(vop)) &&
7919 eop->op_type == OP_ENTERSUB &&
7920 !OpHAS_SIBLING(eop)) {
7924 if ((lop->op_type == OP_PADSV ||
7925 lop->op_type == OP_PADAV ||
7926 lop->op_type == OP_PADHV ||
7927 lop->op_type == OP_PADANY)
7928 && (lop->op_private & OPpPAD_STATE)
7930 yyerror(no_list_state);
7931 lop = OpSIBLING(lop);
7935 else if ( (left->op_private & OPpLVAL_INTRO)
7936 && (left->op_private & OPpPAD_STATE)
7937 && ( left->op_type == OP_PADSV
7938 || left->op_type == OP_PADAV
7939 || left->op_type == OP_PADHV
7940 || left->op_type == OP_PADANY)
7942 /* All single variable list context state assignments, hence
7952 if (left->op_flags & OPf_PARENS)
7953 yyerror(no_list_state);
7955 state_var_op = left;
7958 /* optimise @a = split(...) into:
7959 * @{expr}: split(..., @{expr}) (where @a is not flattened)
7960 * @a, my @a, local @a: split(...) (where @a is attached to
7961 * the split op itself)
7965 && right->op_type == OP_SPLIT
7966 /* don't do twice, e.g. @b = (@a = split) */
7967 && !(right->op_private & OPpSPLIT_ASSIGN))
7971 if ( ( left->op_type == OP_RV2AV
7972 && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV)
7973 || left->op_type == OP_PADAV)
7975 /* @pkg or @lex or local @pkg' or 'my @lex' */
7979 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff
7980 = cPADOPx(gvop)->op_padix;
7981 cPADOPx(gvop)->op_padix = 0; /* steal it */
7983 ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv
7984 = MUTABLE_GV(cSVOPx(gvop)->op_sv);
7985 cSVOPx(gvop)->op_sv = NULL; /* steal it */
7987 right->op_private |=
7988 left->op_private & OPpOUR_INTRO;
7991 ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
7992 left->op_targ = 0; /* steal it */
7993 right->op_private |= OPpSPLIT_LEX;
7995 right->op_private |= left->op_private & OPpLVAL_INTRO;
7998 tmpop = cUNOPo->op_first; /* to list (nulled) */
7999 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
8000 assert(OpSIBLING(tmpop) == right);
8001 assert(!OpHAS_SIBLING(right));
8002 /* detach the split subtreee from the o tree,
8003 * then free the residual o tree */
8004 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8005 op_free(o); /* blow off assign */
8006 right->op_private |= OPpSPLIT_ASSIGN;
8007 right->op_flags &= ~OPf_WANT;
8008 /* "I don't know and I don't care." */
8011 else if (left->op_type == OP_RV2AV) {
8014 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8015 assert(OpSIBLING(pushop) == left);
8016 /* Detach the array ... */
8017 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8018 /* ... and attach it to the split. */
8019 op_sibling_splice(right, cLISTOPx(right)->op_last,
8021 right->op_flags |= OPf_STACKED;
8022 /* Detach split and expunge aassign as above. */
8025 else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8026 ((LISTOP*)right)->op_last->op_type == OP_CONST)
8028 /* convert split(...,0) to split(..., PL_modcount+1) */
8030 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
8031 SV * const sv = *svp;
8032 if (SvIOK(sv) && SvIVX(sv) == 0)
8034 if (right->op_private & OPpSPLIT_IMPLIM) {
8035 /* our own SV, created in ck_split */
8037 sv_setiv(sv, PL_modcount+1);
8040 /* SV may belong to someone else */
8042 *svp = newSViv(PL_modcount+1);
8049 o = S_newONCEOP(aTHX_ o, state_var_op);
8052 if (assign_type == ASSIGN_REF)
8053 return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8055 right = newOP(OP_UNDEF, 0);
8056 if (right->op_type == OP_READLINE) {
8057 right->op_flags |= OPf_STACKED;
8058 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8062 o = newBINOP(OP_SASSIGN, flags,
8063 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8069 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
8071 Constructs a state op (COP). The state op is normally a C<nextstate> op,
8072 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8073 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8074 If C<label> is non-null, it supplies the name of a label to attach to
8075 the state op; this function takes ownership of the memory pointed at by
8076 C<label>, and will free it. C<flags> gives the eight bits of C<op_flags>
8079 If C<o> is null, the state op is returned. Otherwise the state op is
8080 combined with C<o> into a C<lineseq> list op, which is returned. C<o>
8081 is consumed by this function and becomes part of the returned op tree.
8087 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8090 const U32 seq = intro_my();
8091 const U32 utf8 = flags & SVf_UTF8;
8094 PL_parser->parsed_sub = 0;
8098 NewOp(1101, cop, 1, COP);
8099 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8100 OpTYPE_set(cop, OP_DBSTATE);
8103 OpTYPE_set(cop, OP_NEXTSTATE);
8105 cop->op_flags = (U8)flags;
8106 CopHINTS_set(cop, PL_hints);
8108 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8110 cop->op_next = (OP*)cop;
8113 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8114 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8116 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8118 PL_hints |= HINT_BLOCK_SCOPE;
8119 /* It seems that we need to defer freeing this pointer, as other parts
8120 of the grammar end up wanting to copy it after this op has been
8125 if (PL_parser->preambling != NOLINE) {
8126 CopLINE_set(cop, PL_parser->preambling);
8127 PL_parser->copline = NOLINE;
8129 else if (PL_parser->copline == NOLINE)
8130 CopLINE_set(cop, CopLINE(PL_curcop));
8132 CopLINE_set(cop, PL_parser->copline);
8133 PL_parser->copline = NOLINE;
8136 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
8138 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8140 CopSTASH_set(cop, PL_curstash);
8142 if (cop->op_type == OP_DBSTATE) {
8143 /* this line can have a breakpoint - store the cop in IV */
8144 AV *av = CopFILEAVx(PL_curcop);
8146 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8147 if (svp && *svp != &PL_sv_undef ) {
8148 (void)SvIOK_on(*svp);
8149 SvIV_set(*svp, PTR2IV(cop));
8154 if (flags & OPf_SPECIAL)
8156 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8160 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
8162 Constructs, checks, and returns a logical (flow control) op. C<type>
8163 is the opcode. C<flags> gives the eight bits of C<op_flags>, except
8164 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8165 the eight bits of C<op_private>, except that the bit with value 1 is
8166 automatically set. C<first> supplies the expression controlling the
8167 flow, and C<other> supplies the side (alternate) chain of ops; they are
8168 consumed by this function and become part of the constructed op tree.
8174 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8176 PERL_ARGS_ASSERT_NEWLOGOP;
8178 return new_logop(type, flags, &first, &other);
8182 S_search_const(pTHX_ OP *o)
8184 PERL_ARGS_ASSERT_SEARCH_CONST;
8186 switch (o->op_type) {
8190 if (o->op_flags & OPf_KIDS)
8191 return search_const(cUNOPo->op_first);
8198 if (!(o->op_flags & OPf_KIDS))
8200 kid = cLISTOPo->op_first;
8202 switch (kid->op_type) {
8206 kid = OpSIBLING(kid);
8209 if (kid != cLISTOPo->op_last)
8215 kid = cLISTOPo->op_last;
8217 return search_const(kid);
8225 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8233 int prepend_not = 0;
8235 PERL_ARGS_ASSERT_NEW_LOGOP;
8240 /* [perl #59802]: Warn about things like "return $a or $b", which
8241 is parsed as "(return $a) or $b" rather than "return ($a or
8242 $b)". NB: This also applies to xor, which is why we do it
8245 switch (first->op_type) {
8249 /* XXX: Perhaps we should emit a stronger warning for these.
8250 Even with the high-precedence operator they don't seem to do
8253 But until we do, fall through here.
8259 /* XXX: Currently we allow people to "shoot themselves in the
8260 foot" by explicitly writing "(return $a) or $b".
8262 Warn unless we are looking at the result from folding or if
8263 the programmer explicitly grouped the operators like this.
8264 The former can occur with e.g.
8266 use constant FEATURE => ( $] >= ... );
8267 sub { not FEATURE and return or do_stuff(); }
8269 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8270 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8271 "Possible precedence issue with control flow operator");
8272 /* XXX: Should we optimze this to "return $a;" (i.e. remove
8278 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
8279 return newBINOP(type, flags, scalar(first), scalar(other));
8281 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8282 || type == OP_CUSTOM);
8284 scalarboolean(first);
8286 /* search for a constant op that could let us fold the test */
8287 if ((cstop = search_const(first))) {
8288 if (cstop->op_private & OPpCONST_STRICT)
8289 no_bareword_allowed(cstop);
8290 else if ((cstop->op_private & OPpCONST_BARE))
8291 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8292 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
8293 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
8294 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
8295 /* Elide the (constant) lhs, since it can't affect the outcome */
8297 if (other->op_type == OP_CONST)
8298 other->op_private |= OPpCONST_SHORTCIRCUIT;
8300 if (other->op_type == OP_LEAVE)
8301 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8302 else if (other->op_type == OP_MATCH
8303 || other->op_type == OP_SUBST
8304 || other->op_type == OP_TRANSR
8305 || other->op_type == OP_TRANS)
8306 /* Mark the op as being unbindable with =~ */
8307 other->op_flags |= OPf_SPECIAL;
8309 other->op_folded = 1;
8313 /* Elide the rhs, since the outcome is entirely determined by
8314 * the (constant) lhs */
8316 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8317 const OP *o2 = other;
8318 if ( ! (o2->op_type == OP_LIST
8319 && (( o2 = cUNOPx(o2)->op_first))
8320 && o2->op_type == OP_PUSHMARK
8321 && (( o2 = OpSIBLING(o2))) )
8324 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8325 || o2->op_type == OP_PADHV)
8326 && o2->op_private & OPpLVAL_INTRO
8327 && !(o2->op_private & OPpPAD_STATE))
8329 Perl_croak(aTHX_ "This use of my() in false conditional is "
8330 "no longer allowed");
8334 if (cstop->op_type == OP_CONST)
8335 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8340 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8341 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8343 const OP * const k1 = ((UNOP*)first)->op_first;
8344 const OP * const k2 = OpSIBLING(k1);
8346 switch (first->op_type)
8349 if (k2 && k2->op_type == OP_READLINE
8350 && (k2->op_flags & OPf_STACKED)
8351 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8353 warnop = k2->op_type;
8358 if (k1->op_type == OP_READDIR
8359 || k1->op_type == OP_GLOB
8360 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8361 || k1->op_type == OP_EACH
8362 || k1->op_type == OP_AEACH)
8364 warnop = ((k1->op_type == OP_NULL)
8365 ? (OPCODE)k1->op_targ : k1->op_type);
8370 const line_t oldline = CopLINE(PL_curcop);
8371 /* This ensures that warnings are reported at the first line
8372 of the construction, not the last. */
8373 CopLINE_set(PL_curcop, PL_parser->copline);
8374 Perl_warner(aTHX_ packWARN(WARN_MISC),
8375 "Value of %s%s can be \"0\"; test with defined()",
8377 ((warnop == OP_READLINE || warnop == OP_GLOB)
8378 ? " construct" : "() operator"));
8379 CopLINE_set(PL_curcop, oldline);
8383 /* optimize AND and OR ops that have NOTs as children */
8384 if (first->op_type == OP_NOT
8385 && (first->op_flags & OPf_KIDS)
8386 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8387 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
8389 if (type == OP_AND || type == OP_OR) {
8395 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8397 prepend_not = 1; /* prepend a NOT op later */
8402 logop = alloc_LOGOP(type, first, LINKLIST(other));
8403 logop->op_flags |= (U8)flags;
8404 logop->op_private = (U8)(1 | (flags >> 8));
8406 /* establish postfix order */
8407 logop->op_next = LINKLIST(first);
8408 first->op_next = (OP*)logop;
8409 assert(!OpHAS_SIBLING(first));
8410 op_sibling_splice((OP*)logop, first, 0, other);
8412 CHECKOP(type,logop);
8414 o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8415 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8423 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
8425 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8426 op. C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8427 will be set automatically, and, shifted up eight bits, the eight bits of
8428 C<op_private>, except that the bit with value 1 is automatically set.
8429 C<first> supplies the expression selecting between the two branches,
8430 and C<trueop> and C<falseop> supply the branches; they are consumed by
8431 this function and become part of the constructed op tree.
8437 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8445 PERL_ARGS_ASSERT_NEWCONDOP;
8448 return newLOGOP(OP_AND, 0, first, trueop);
8450 return newLOGOP(OP_OR, 0, first, falseop);
8452 scalarboolean(first);
8453 if ((cstop = search_const(first))) {
8454 /* Left or right arm of the conditional? */
8455 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
8456 OP *live = left ? trueop : falseop;
8457 OP *const dead = left ? falseop : trueop;
8458 if (cstop->op_private & OPpCONST_BARE &&
8459 cstop->op_private & OPpCONST_STRICT) {
8460 no_bareword_allowed(cstop);
8464 if (live->op_type == OP_LEAVE)
8465 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8466 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8467 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8468 /* Mark the op as being unbindable with =~ */
8469 live->op_flags |= OPf_SPECIAL;
8470 live->op_folded = 1;
8473 logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8474 logop->op_flags |= (U8)flags;
8475 logop->op_private = (U8)(1 | (flags >> 8));
8476 logop->op_next = LINKLIST(falseop);
8478 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8481 /* establish postfix order */
8482 start = LINKLIST(first);
8483 first->op_next = (OP*)logop;
8485 /* make first, trueop, falseop siblings */
8486 op_sibling_splice((OP*)logop, first, 0, trueop);
8487 op_sibling_splice((OP*)logop, trueop, 0, falseop);
8489 o = newUNOP(OP_NULL, 0, (OP*)logop);
8491 trueop->op_next = falseop->op_next = o;
8498 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
8500 Constructs and returns a C<range> op, with subordinate C<flip> and
8501 C<flop> ops. C<flags> gives the eight bits of C<op_flags> for the
8502 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8503 for both the C<flip> and C<range> ops, except that the bit with value
8504 1 is automatically set. C<left> and C<right> supply the expressions
8505 controlling the endpoints of the range; they are consumed by this function
8506 and become part of the constructed op tree.
8512 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8520 PERL_ARGS_ASSERT_NEWRANGE;
8522 range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8523 range->op_flags = OPf_KIDS;
8524 leftstart = LINKLIST(left);
8525 range->op_private = (U8)(1 | (flags >> 8));
8527 /* make left and right siblings */
8528 op_sibling_splice((OP*)range, left, 0, right);
8530 range->op_next = (OP*)range;
8531 flip = newUNOP(OP_FLIP, flags, (OP*)range);
8532 flop = newUNOP(OP_FLOP, 0, flip);
8533 o = newUNOP(OP_NULL, 0, flop);
8535 range->op_next = leftstart;
8537 left->op_next = flip;
8538 right->op_next = flop;
8541 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
8542 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
8544 pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
8545 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
8546 SvPADTMP_on(PAD_SV(flip->op_targ));
8548 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8549 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
8551 /* check barewords before they might be optimized aways */
8552 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
8553 no_bareword_allowed(left);
8554 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
8555 no_bareword_allowed(right);
8558 if (!flip->op_private || !flop->op_private)
8559 LINKLIST(o); /* blow off optimizer unless constant */
8565 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
8567 Constructs, checks, and returns an op tree expressing a loop. This is
8568 only a loop in the control flow through the op tree; it does not have
8569 the heavyweight loop structure that allows exiting the loop by C<last>
8570 and suchlike. C<flags> gives the eight bits of C<op_flags> for the
8571 top-level op, except that some bits will be set automatically as required.
8572 C<expr> supplies the expression controlling loop iteration, and C<block>
8573 supplies the body of the loop; they are consumed by this function and
8574 become part of the constructed op tree. C<debuggable> is currently
8575 unused and should always be 1.
8581 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
8585 const bool once = block && block->op_flags & OPf_SPECIAL &&
8586 block->op_type == OP_NULL;
8588 PERL_UNUSED_ARG(debuggable);
8592 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
8593 || ( expr->op_type == OP_NOT
8594 && cUNOPx(expr)->op_first->op_type == OP_CONST
8595 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
8598 /* Return the block now, so that S_new_logop does not try to
8600 return block; /* do {} while 0 does once */
8601 if (expr->op_type == OP_READLINE
8602 || expr->op_type == OP_READDIR
8603 || expr->op_type == OP_GLOB
8604 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8605 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8606 expr = newUNOP(OP_DEFINED, 0,
8607 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8608 } else if (expr->op_flags & OPf_KIDS) {
8609 const OP * const k1 = ((UNOP*)expr)->op_first;
8610 const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
8611 switch (expr->op_type) {
8613 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8614 && (k2->op_flags & OPf_STACKED)
8615 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8616 expr = newUNOP(OP_DEFINED, 0, expr);
8620 if (k1 && (k1->op_type == OP_READDIR
8621 || k1->op_type == OP_GLOB
8622 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8623 || k1->op_type == OP_EACH
8624 || k1->op_type == OP_AEACH))
8625 expr = newUNOP(OP_DEFINED, 0, expr);
8631 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
8632 * op, in listop. This is wrong. [perl #27024] */
8634 block = newOP(OP_NULL, 0);
8635 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
8636 o = new_logop(OP_AND, 0, &expr, &listop);
8643 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
8645 if (once && o != listop)
8647 assert(cUNOPo->op_first->op_type == OP_AND
8648 || cUNOPo->op_first->op_type == OP_OR);
8649 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
8653 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
8655 o->op_flags |= flags;
8657 o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/
8662 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
8664 Constructs, checks, and returns an op tree expressing a C<while> loop.
8665 This is a heavyweight loop, with structure that allows exiting the loop
8666 by C<last> and suchlike.
8668 C<loop> is an optional preconstructed C<enterloop> op to use in the
8669 loop; if it is null then a suitable op will be constructed automatically.
8670 C<expr> supplies the loop's controlling expression. C<block> supplies the
8671 main body of the loop, and C<cont> optionally supplies a C<continue> block
8672 that operates as a second half of the body. All of these optree inputs
8673 are consumed by this function and become part of the constructed op tree.
8675 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8676 op and, shifted up eight bits, the eight bits of C<op_private> for
8677 the C<leaveloop> op, except that (in both cases) some bits will be set
8678 automatically. C<debuggable> is currently unused and should always be 1.
8679 C<has_my> can be supplied as true to force the
8680 loop body to be enclosed in its own scope.
8686 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
8687 OP *expr, OP *block, OP *cont, I32 has_my)
8696 PERL_UNUSED_ARG(debuggable);
8699 if (expr->op_type == OP_READLINE
8700 || expr->op_type == OP_READDIR
8701 || expr->op_type == OP_GLOB
8702 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
8703 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
8704 expr = newUNOP(OP_DEFINED, 0,
8705 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
8706 } else if (expr->op_flags & OPf_KIDS) {
8707 const OP * const k1 = ((UNOP*)expr)->op_first;
8708 const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
8709 switch (expr->op_type) {
8711 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
8712 && (k2->op_flags & OPf_STACKED)
8713 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8714 expr = newUNOP(OP_DEFINED, 0, expr);
8718 if (k1 && (k1->op_type == OP_READDIR
8719 || k1->op_type == OP_GLOB
8720 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8721 || k1->op_type == OP_EACH
8722 || k1->op_type == OP_AEACH))
8723 expr = newUNOP(OP_DEFINED, 0, expr);
8730 block = newOP(OP_NULL, 0);
8731 else if (cont || has_my) {
8732 block = op_scope(block);
8736 next = LINKLIST(cont);
8739 OP * const unstack = newOP(OP_UNSTACK, 0);
8742 cont = op_append_elem(OP_LINESEQ, cont, unstack);
8746 listop = op_append_list(OP_LINESEQ, block, cont);
8748 redo = LINKLIST(listop);
8752 o = new_logop(OP_AND, 0, &expr, &listop);
8753 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
8755 return expr; /* listop already freed by new_logop */
8758 ((LISTOP*)listop)->op_last->op_next =
8759 (o == listop ? redo : LINKLIST(o));
8765 NewOp(1101,loop,1,LOOP);
8766 OpTYPE_set(loop, OP_ENTERLOOP);
8767 loop->op_private = 0;
8768 loop->op_next = (OP*)loop;
8771 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
8773 loop->op_redoop = redo;
8774 loop->op_lastop = o;
8775 o->op_private |= loopflags;
8778 loop->op_nextop = next;
8780 loop->op_nextop = o;
8782 o->op_flags |= flags;
8783 o->op_private |= (flags >> 8);
8788 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
8790 Constructs, checks, and returns an op tree expressing a C<foreach>
8791 loop (iteration through a list of values). This is a heavyweight loop,
8792 with structure that allows exiting the loop by C<last> and suchlike.
8794 C<sv> optionally supplies the variable that will be aliased to each
8795 item in turn; if null, it defaults to C<$_>.
8796 C<expr> supplies the list of values to iterate over. C<block> supplies
8797 the main body of the loop, and C<cont> optionally supplies a C<continue>
8798 block that operates as a second half of the body. All of these optree
8799 inputs are consumed by this function and become part of the constructed
8802 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
8803 op and, shifted up eight bits, the eight bits of C<op_private> for
8804 the C<leaveloop> op, except that (in both cases) some bits will be set
8811 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
8816 PADOFFSET padoff = 0;
8820 PERL_ARGS_ASSERT_NEWFOROP;
8823 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
8824 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
8825 OpTYPE_set(sv, OP_RV2GV);
8827 /* The op_type check is needed to prevent a possible segfault
8828 * if the loop variable is undeclared and 'strict vars' is in
8829 * effect. This is illegal but is nonetheless parsed, so we
8830 * may reach this point with an OP_CONST where we're expecting
8833 if (cUNOPx(sv)->op_first->op_type == OP_GV
8834 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
8835 iterpflags |= OPpITER_DEF;
8837 else if (sv->op_type == OP_PADSV) { /* private variable */
8838 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
8839 padoff = sv->op_targ;
8843 PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
8845 else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
8848 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
8850 PADNAME * const pn = PAD_COMPNAME(padoff);
8851 const char * const name = PadnamePV(pn);
8853 if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
8854 iterpflags |= OPpITER_DEF;
8858 sv = newGVOP(OP_GV, 0, PL_defgv);
8859 iterpflags |= OPpITER_DEF;
8862 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
8863 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
8864 iterflags |= OPf_STACKED;
8866 else if (expr->op_type == OP_NULL &&
8867 (expr->op_flags & OPf_KIDS) &&
8868 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
8870 /* Basically turn for($x..$y) into the same as for($x,$y), but we
8871 * set the STACKED flag to indicate that these values are to be
8872 * treated as min/max values by 'pp_enteriter'.
8874 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
8875 LOGOP* const range = (LOGOP*) flip->op_first;
8876 OP* const left = range->op_first;
8877 OP* const right = OpSIBLING(left);
8880 range->op_flags &= ~OPf_KIDS;
8881 /* detach range's children */
8882 op_sibling_splice((OP*)range, NULL, -1, NULL);
8884 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
8885 listop->op_first->op_next = range->op_next;
8886 left->op_next = range->op_other;
8887 right->op_next = (OP*)listop;
8888 listop->op_next = listop->op_first;
8891 expr = (OP*)(listop);
8893 iterflags |= OPf_STACKED;
8896 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
8899 loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
8900 op_append_elem(OP_LIST, list(expr),
8902 assert(!loop->op_next);
8903 /* for my $x () sets OPpLVAL_INTRO;
8904 * for our $x () sets OPpOUR_INTRO */
8905 loop->op_private = (U8)iterpflags;
8906 if (loop->op_slabbed
8907 && DIFF(loop, OpSLOT(loop)->opslot_next)
8908 < SIZE_TO_PSIZE(sizeof(LOOP)))
8911 NewOp(1234,tmp,1,LOOP);
8912 Copy(loop,tmp,1,LISTOP);
8913 assert(loop->op_last->op_sibparent == (OP*)loop);
8914 OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
8915 S_op_destroy(aTHX_ (OP*)loop);
8918 else if (!loop->op_slabbed)
8920 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
8921 OpLASTSIB_set(loop->op_last, (OP*)loop);
8923 loop->op_targ = padoff;
8924 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
8929 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
8931 Constructs, checks, and returns a loop-exiting op (such as C<goto>
8932 or C<last>). C<type> is the opcode. C<label> supplies the parameter
8933 determining the target of the op; it is consumed by this function and
8934 becomes part of the constructed op tree.
8940 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
8944 PERL_ARGS_ASSERT_NEWLOOPEX;
8946 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
8947 || type == OP_CUSTOM);
8949 if (type != OP_GOTO) {
8950 /* "last()" means "last" */
8951 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
8952 o = newOP(type, OPf_SPECIAL);
8956 /* Check whether it's going to be a goto &function */
8957 if (label->op_type == OP_ENTERSUB
8958 && !(label->op_flags & OPf_STACKED))
8959 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
8962 /* Check for a constant argument */
8963 if (label->op_type == OP_CONST) {
8964 SV * const sv = ((SVOP *)label)->op_sv;
8966 const char *s = SvPV_const(sv,l);
8967 if (l == strlen(s)) {
8969 SvUTF8(((SVOP*)label)->op_sv),
8971 SvPV_nolen_const(((SVOP*)label)->op_sv)));
8975 /* If we have already created an op, we do not need the label. */
8978 else o = newUNOP(type, OPf_STACKED, label);
8980 PL_hints |= HINT_BLOCK_SCOPE;
8984 /* if the condition is a literal array or hash
8985 (or @{ ... } etc), make a reference to it.
8988 S_ref_array_or_hash(pTHX_ OP *cond)
8991 && (cond->op_type == OP_RV2AV
8992 || cond->op_type == OP_PADAV
8993 || cond->op_type == OP_RV2HV
8994 || cond->op_type == OP_PADHV))
8996 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
8999 && (cond->op_type == OP_ASLICE
9000 || cond->op_type == OP_KVASLICE
9001 || cond->op_type == OP_HSLICE
9002 || cond->op_type == OP_KVHSLICE)) {
9004 /* anonlist now needs a list from this op, was previously used in
9006 cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9007 cond->op_flags |= OPf_WANT_LIST;
9009 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9016 /* These construct the optree fragments representing given()
9019 entergiven and enterwhen are LOGOPs; the op_other pointer
9020 points up to the associated leave op. We need this so we
9021 can put it in the context and make break/continue work.
9022 (Also, of course, pp_enterwhen will jump straight to
9023 op_other if the match fails.)
9027 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9028 I32 enter_opcode, I32 leave_opcode,
9029 PADOFFSET entertarg)
9035 PERL_ARGS_ASSERT_NEWGIVWHENOP;
9036 PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9038 enterop = alloc_LOGOP(enter_opcode, block, NULL);
9039 enterop->op_targ = 0;
9040 enterop->op_private = 0;
9042 o = newUNOP(leave_opcode, 0, (OP *) enterop);
9045 /* prepend cond if we have one */
9046 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9048 o->op_next = LINKLIST(cond);
9049 cond->op_next = (OP *) enterop;
9052 /* This is a default {} block */
9053 enterop->op_flags |= OPf_SPECIAL;
9054 o ->op_flags |= OPf_SPECIAL;
9056 o->op_next = (OP *) enterop;
9059 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9060 entergiven and enterwhen both
9063 enterop->op_next = LINKLIST(block);
9064 block->op_next = enterop->op_other = o;
9069 /* Does this look like a boolean operation? For these purposes
9070 a boolean operation is:
9071 - a subroutine call [*]
9072 - a logical connective
9073 - a comparison operator
9074 - a filetest operator, with the exception of -s -M -A -C
9075 - defined(), exists() or eof()
9076 - /$re/ or $foo =~ /$re/
9078 [*] possibly surprising
9081 S_looks_like_bool(pTHX_ const OP *o)
9083 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9085 switch(o->op_type) {
9088 return looks_like_bool(cLOGOPo->op_first);
9092 OP* sibl = OpSIBLING(cLOGOPo->op_first);
9095 looks_like_bool(cLOGOPo->op_first)
9096 && looks_like_bool(sibl));
9102 o->op_flags & OPf_KIDS
9103 && looks_like_bool(cUNOPo->op_first));
9107 case OP_NOT: case OP_XOR:
9109 case OP_EQ: case OP_NE: case OP_LT:
9110 case OP_GT: case OP_LE: case OP_GE:
9112 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
9113 case OP_I_GT: case OP_I_LE: case OP_I_GE:
9115 case OP_SEQ: case OP_SNE: case OP_SLT:
9116 case OP_SGT: case OP_SLE: case OP_SGE:
9120 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
9121 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
9122 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
9123 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
9124 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
9125 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
9126 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
9127 case OP_FTTEXT: case OP_FTBINARY:
9129 case OP_DEFINED: case OP_EXISTS:
9130 case OP_MATCH: case OP_EOF:
9138 /* optimised-away (index() != -1) or similar comparison */
9139 if (o->op_private & OPpTRUEBOOL)
9144 /* Detect comparisons that have been optimized away */
9145 if (cSVOPo->op_sv == &PL_sv_yes
9146 || cSVOPo->op_sv == &PL_sv_no)
9158 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
9160 Constructs, checks, and returns an op tree expressing a C<given> block.
9161 C<cond> supplies the expression to whose value C<$_> will be locally
9162 aliased, and C<block> supplies the body of the C<given> construct; they
9163 are consumed by this function and become part of the constructed op tree.
9164 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9170 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9172 PERL_ARGS_ASSERT_NEWGIVENOP;
9173 PERL_UNUSED_ARG(defsv_off);
9176 return newGIVWHENOP(
9177 ref_array_or_hash(cond),
9179 OP_ENTERGIVEN, OP_LEAVEGIVEN,
9184 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
9186 Constructs, checks, and returns an op tree expressing a C<when> block.
9187 C<cond> supplies the test expression, and C<block> supplies the block
9188 that will be executed if the test evaluates to true; they are consumed
9189 by this function and become part of the constructed op tree. C<cond>
9190 will be interpreted DWIMically, often as a comparison against C<$_>,
9191 and may be null to generate a C<default> block.
9197 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9199 const bool cond_llb = (!cond || looks_like_bool(cond));
9202 PERL_ARGS_ASSERT_NEWWHENOP;
9207 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9209 scalar(ref_array_or_hash(cond)));
9212 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9215 /* must not conflict with SVf_UTF8 */
9216 #define CV_CKPROTO_CURSTASH 0x1
9219 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9220 const STRLEN len, const U32 flags)
9222 SV *name = NULL, *msg;
9223 const char * cvp = SvROK(cv)
9224 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9225 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9228 STRLEN clen = CvPROTOLEN(cv), plen = len;
9230 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9232 if (p == NULL && cvp == NULL)
9235 if (!ckWARN_d(WARN_PROTOTYPE))
9239 p = S_strip_spaces(aTHX_ p, &plen);
9240 cvp = S_strip_spaces(aTHX_ cvp, &clen);
9241 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9242 if (plen == clen && memEQ(cvp, p, plen))
9245 if (flags & SVf_UTF8) {
9246 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9250 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9256 msg = sv_newmortal();
9261 gv_efullname3(name = sv_newmortal(), gv, NULL);
9262 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9263 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9264 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9265 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
9266 sv_catpvs(name, "::");
9268 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9269 assert (CvNAMED(SvRV_const(gv)));
9270 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9272 else sv_catsv(name, (SV *)gv);
9274 else name = (SV *)gv;
9276 sv_setpvs(msg, "Prototype mismatch:");
9278 Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9280 Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9281 UTF8fARG(SvUTF8(cv),clen,cvp)
9284 sv_catpvs(msg, ": none");
9285 sv_catpvs(msg, " vs ");
9287 Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9289 sv_catpvs(msg, "none");
9290 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9293 static void const_sv_xsub(pTHX_ CV* cv);
9294 static void const_av_xsub(pTHX_ CV* cv);
9298 =head1 Optree Manipulation Functions
9300 =for apidoc cv_const_sv
9302 If C<cv> is a constant sub eligible for inlining, returns the constant
9303 value returned by the sub. Otherwise, returns C<NULL>.
9305 Constant subs can be created with C<newCONSTSUB> or as described in
9306 L<perlsub/"Constant Functions">.
9311 Perl_cv_const_sv(const CV *const cv)
9316 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9318 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9319 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9324 Perl_cv_const_sv_or_av(const CV * const cv)
9328 if (SvROK(cv)) return SvRV((SV *)cv);
9329 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9330 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9333 /* op_const_sv: examine an optree to determine whether it's in-lineable.
9334 * Can be called in 2 ways:
9337 * look for a single OP_CONST with attached value: return the value
9339 * allow_lex && !CvCONST(cv);
9341 * examine the clone prototype, and if contains only a single
9342 * OP_CONST, return the value; or if it contains a single PADSV ref-
9343 * erencing an outer lexical, turn on CvCONST to indicate the CV is
9344 * a candidate for "constizing" at clone time, and return NULL.
9348 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9356 for (; o; o = o->op_next) {
9357 const OPCODE type = o->op_type;
9359 if (type == OP_NEXTSTATE || type == OP_LINESEQ
9361 || type == OP_PUSHMARK)
9363 if (type == OP_DBSTATE)
9365 if (type == OP_LEAVESUB)
9369 if (type == OP_CONST && cSVOPo->op_sv)
9371 else if (type == OP_UNDEF && !o->op_private) {
9375 else if (allow_lex && type == OP_PADSV) {
9376 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEt_OUTER)
9378 sv = &PL_sv_undef; /* an arbitrary non-null value */
9396 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
9397 PADNAME * const name, SV ** const const_svp)
9403 if (CvFLAGS(PL_compcv)) {
9404 /* might have had built-in attrs applied */
9405 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
9406 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
9407 && ckWARN(WARN_MISC))
9409 /* protect against fatal warnings leaking compcv */
9410 SAVEFREESV(PL_compcv);
9411 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
9412 SvREFCNT_inc_simple_void_NN(PL_compcv);
9415 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
9416 & ~(CVf_LVALUE * pureperl));
9421 /* redundant check for speed: */
9422 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
9423 const line_t oldline = CopLINE(PL_curcop);
9426 : sv_2mortal(newSVpvn_utf8(
9427 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
9429 if (PL_parser && PL_parser->copline != NOLINE)
9430 /* This ensures that warnings are reported at the first
9431 line of a redefinition, not the last. */
9432 CopLINE_set(PL_curcop, PL_parser->copline);
9433 /* protect against fatal warnings leaking compcv */
9434 SAVEFREESV(PL_compcv);
9435 report_redefined_cv(namesv, cv, const_svp);
9436 SvREFCNT_inc_simple_void_NN(PL_compcv);
9437 CopLINE_set(PL_curcop, oldline);
9444 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
9449 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9452 CV *compcv = PL_compcv;
9455 PADOFFSET pax = o->op_targ;
9456 CV *outcv = CvOUTSIDE(PL_compcv);
9459 bool reusable = FALSE;
9461 #ifdef PERL_DEBUG_READONLY_OPS
9462 OPSLAB *slab = NULL;
9465 PERL_ARGS_ASSERT_NEWMYSUB;
9467 PL_hints |= HINT_BLOCK_SCOPE;
9469 /* Find the pad slot for storing the new sub.
9470 We cannot use PL_comppad, as it is the pad owned by the new sub. We
9471 need to look in CvOUTSIDE and find the pad belonging to the enclos-
9472 ing sub. And then we need to dig deeper if this is a lexical from
9474 my sub foo; sub { sub foo { } }
9477 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
9478 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
9479 pax = PARENT_PAD_INDEX(name);
9480 outcv = CvOUTSIDE(outcv);
9485 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
9486 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
9487 spot = (CV **)svspot;
9489 if (!(PL_parser && PL_parser->error_count))
9490 move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
9493 assert(proto->op_type == OP_CONST);
9494 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9495 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9505 if (PL_parser && PL_parser->error_count) {
9507 SvREFCNT_dec(PL_compcv);
9512 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9514 svspot = (SV **)(spot = &clonee);
9516 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
9519 assert (SvTYPE(*spot) == SVt_PVCV);
9521 hek = CvNAME_HEK(*spot);
9525 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9526 CvNAME_HEK_set(*spot, hek =
9529 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9533 CvLEXICAL_on(*spot);
9535 cv = PadnamePROTOCV(name);
9536 svspot = (SV **)(spot = &PadnamePROTOCV(name));
9540 /* This makes sub {}; work as expected. */
9541 if (block->op_type == OP_STUB) {
9542 const line_t l = PL_parser->copline;
9544 block = newSTATEOP(0, NULL, 0);
9545 PL_parser->copline = l;
9547 block = CvLVALUE(compcv)
9548 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
9549 ? newUNOP(OP_LEAVESUBLV, 0,
9550 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
9551 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
9552 start = LINKLIST(block);
9554 if (ps && !*ps && !attrs && !CvLVALUE(compcv))
9555 const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
9563 const bool exists = CvROOT(cv) || CvXSUB(cv);
9565 /* if the subroutine doesn't exist and wasn't pre-declared
9566 * with a prototype, assume it will be AUTOLOADed,
9567 * skipping the prototype check
9569 if (exists || SvPOK(cv))
9570 cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
9572 /* already defined? */
9574 S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
9580 /* just a "sub foo;" when &foo is already defined */
9585 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
9592 SvREFCNT_inc_simple_void_NN(const_sv);
9593 SvFLAGS(const_sv) |= SVs_PADTMP;
9595 assert(!CvROOT(cv) && !CvCONST(cv));
9599 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
9600 CvFILE_set_from_cop(cv, PL_curcop);
9601 CvSTASH_set(cv, PL_curstash);
9604 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
9605 CvXSUBANY(cv).any_ptr = const_sv;
9606 CvXSUB(cv) = const_sv_xsub;
9610 CvFLAGS(cv) |= CvMETHOD(compcv);
9612 SvREFCNT_dec(compcv);
9617 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
9618 determine whether this sub definition is in the same scope as its
9619 declaration. If this sub definition is inside an inner named pack-
9620 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
9621 the package sub. So check PadnameOUTER(name) too.
9623 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
9624 assert(!CvWEAKOUTSIDE(compcv));
9625 SvREFCNT_dec(CvOUTSIDE(compcv));
9626 CvWEAKOUTSIDE_on(compcv);
9628 /* XXX else do we have a circular reference? */
9630 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
9631 /* transfer PL_compcv to cv */
9633 cv_flags_t preserved_flags =
9634 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
9635 PADLIST *const temp_padl = CvPADLIST(cv);
9636 CV *const temp_cv = CvOUTSIDE(cv);
9637 const cv_flags_t other_flags =
9638 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
9639 OP * const cvstart = CvSTART(cv);
9643 CvFLAGS(compcv) | preserved_flags;
9644 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
9645 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
9646 CvPADLIST_set(cv, CvPADLIST(compcv));
9647 CvOUTSIDE(compcv) = temp_cv;
9648 CvPADLIST_set(compcv, temp_padl);
9649 CvSTART(cv) = CvSTART(compcv);
9650 CvSTART(compcv) = cvstart;
9651 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
9652 CvFLAGS(compcv) |= other_flags;
9654 if (CvFILE(cv) && CvDYNFILE(cv)) {
9655 Safefree(CvFILE(cv));
9658 /* inner references to compcv must be fixed up ... */
9659 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
9660 if (PERLDB_INTER)/* Advice debugger on the new sub. */
9661 ++PL_sub_generation;
9664 /* Might have had built-in attributes applied -- propagate them. */
9665 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
9667 /* ... before we throw it away */
9668 SvREFCNT_dec(compcv);
9669 PL_compcv = compcv = cv;
9678 if (!CvNAME_HEK(cv)) {
9679 if (hek) (void)share_hek_hek(hek);
9683 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
9684 hek = share_hek(PadnamePV(name)+1,
9685 (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
9688 CvNAME_HEK_set(cv, hek);
9694 CvFILE_set_from_cop(cv, PL_curcop);
9695 CvSTASH_set(cv, PL_curstash);
9698 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
9700 SvUTF8_on(MUTABLE_SV(cv));
9704 /* If we assign an optree to a PVCV, then we've defined a
9705 * subroutine that the debugger could be able to set a breakpoint
9706 * in, so signal to pp_entereval that it should not throw away any
9707 * saved lines at scope exit. */
9709 PL_breakable_sub_gen++;
9711 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
9712 itself has a refcount. */
9714 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
9715 #ifdef PERL_DEBUG_READONLY_OPS
9716 slab = (OPSLAB *)CvSTART(cv);
9718 S_process_optree(aTHX_ cv, block, start);
9723 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
9724 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
9728 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
9729 SV * const tmpstr = sv_newmortal();
9730 GV * const db_postponed = gv_fetchpvs("DB::postponed",
9731 GV_ADDMULTI, SVt_PVHV);
9733 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
9736 (long)CopLINE(PL_curcop));
9737 if (HvNAME_HEK(PL_curstash)) {
9738 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
9739 sv_catpvs(tmpstr, "::");
9742 sv_setpvs(tmpstr, "__ANON__::");
9744 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
9745 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
9746 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
9747 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
9748 hv = GvHVn(db_postponed);
9749 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
9750 CV * const pcv = GvCV(db_postponed);
9756 call_sv(MUTABLE_SV(pcv), G_DISCARD);
9764 assert(CvDEPTH(outcv));
9766 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
9768 cv_clone_into(clonee, *spot);
9769 else *spot = cv_clone(clonee);
9770 SvREFCNT_dec_NN(clonee);
9774 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
9775 PADOFFSET depth = CvDEPTH(outcv);
9778 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
9780 *svspot = SvREFCNT_inc_simple_NN(cv);
9781 SvREFCNT_dec(oldcv);
9787 PL_parser->copline = NOLINE;
9789 #ifdef PERL_DEBUG_READONLY_OPS
9798 =for apidoc m|CV *|newATTRSUB_x|I32 floor|OP *o|OP *proto|OP *attrs|OP *block|bool o_is_gv
9800 Construct a Perl subroutine, also performing some surrounding jobs.
9802 This function is expected to be called in a Perl compilation context,
9803 and some aspects of the subroutine are taken from global variables
9804 associated with compilation. In particular, C<PL_compcv> represents
9805 the subroutine that is currently being compiled. It must be non-null
9806 when this function is called, and some aspects of the subroutine being
9807 constructed are taken from it. The constructed subroutine may actually
9808 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
9810 If C<block> is null then the subroutine will have no body, and for the
9811 time being it will be an error to call it. This represents a forward
9812 subroutine declaration such as S<C<sub foo ($$);>>. If C<block> is
9813 non-null then it provides the Perl code of the subroutine body, which
9814 will be executed when the subroutine is called. This body includes
9815 any argument unwrapping code resulting from a subroutine signature or
9816 similar. The pad use of the code must correspond to the pad attached
9817 to C<PL_compcv>. The code is not expected to include a C<leavesub> or
9818 C<leavesublv> op; this function will add such an op. C<block> is consumed
9819 by this function and will become part of the constructed subroutine.
9821 C<proto> specifies the subroutine's prototype, unless one is supplied
9822 as an attribute (see below). If C<proto> is null, then the subroutine
9823 will not have a prototype. If C<proto> is non-null, it must point to a
9824 C<const> op whose value is a string, and the subroutine will have that
9825 string as its prototype. If a prototype is supplied as an attribute, the
9826 attribute takes precedence over C<proto>, but in that case C<proto> should
9827 preferably be null. In any case, C<proto> is consumed by this function.
9829 C<attrs> supplies attributes to be applied the subroutine. A handful of
9830 attributes take effect by built-in means, being applied to C<PL_compcv>
9831 immediately when seen. Other attributes are collected up and attached
9832 to the subroutine by this route. C<attrs> may be null to supply no
9833 attributes, or point to a C<const> op for a single attribute, or point
9834 to a C<list> op whose children apart from the C<pushmark> are C<const>
9835 ops for one or more attributes. Each C<const> op must be a string,
9836 giving the attribute name optionally followed by parenthesised arguments,
9837 in the manner in which attributes appear in Perl source. The attributes
9838 will be applied to the sub by this function. C<attrs> is consumed by
9841 If C<o_is_gv> is false and C<o> is null, then the subroutine will
9842 be anonymous. If C<o_is_gv> is false and C<o> is non-null, then C<o>
9843 must point to a C<const> op, which will be consumed by this function,
9844 and its string value supplies a name for the subroutine. The name may
9845 be qualified or unqualified, and if it is unqualified then a default
9846 stash will be selected in some manner. If C<o_is_gv> is true, then C<o>
9847 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
9848 by which the subroutine will be named.
9850 If there is already a subroutine of the specified name, then the new
9851 sub will either replace the existing one in the glob or be merged with
9852 the existing one. A warning may be generated about redefinition.
9854 If the subroutine has one of a few special names, such as C<BEGIN> or
9855 C<END>, then it will be claimed by the appropriate queue for automatic
9856 running of phase-related subroutines. In this case the relevant glob will
9857 be left not containing any subroutine, even if it did contain one before.
9858 In the case of C<BEGIN>, the subroutine will be executed and the reference
9859 to it disposed of before this function returns.
9861 The function returns a pointer to the constructed subroutine. If the sub
9862 is anonymous then ownership of one counted reference to the subroutine
9863 is transferred to the caller. If the sub is named then the caller does
9864 not get ownership of a reference. In most such cases, where the sub
9865 has a non-phase name, the sub will be alive at the point it is returned
9866 by virtue of being contained in the glob that names it. A phase-named
9867 subroutine will usually be alive by virtue of the reference owned by the
9868 phase's automatic run queue. But a C<BEGIN> subroutine, having already
9869 been executed, will quite likely have been destroyed already by the
9870 time this function returns, making it erroneous for the caller to make
9871 any use of the returned pointer. It is the caller's responsibility to
9872 ensure that it knows which of these situations applies.
9879 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
9880 OP *block, bool o_is_gv)
9884 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
9886 CV *cv = NULL; /* the previous CV with this name, if any */
9888 const bool ec = PL_parser && PL_parser->error_count;
9889 /* If the subroutine has no body, no attributes, and no builtin attributes
9890 then it's just a sub declaration, and we may be able to get away with
9891 storing with a placeholder scalar in the symbol table, rather than a
9892 full CV. If anything is present then it will take a full CV to
9894 const I32 gv_fetch_flags
9895 = ec ? GV_NOADD_NOINIT :
9896 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
9897 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
9899 const char * const name =
9900 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
9902 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
9903 bool evanescent = FALSE;
9905 #ifdef PERL_DEBUG_READONLY_OPS
9906 OPSLAB *slab = NULL;
9914 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
9915 hek and CvSTASH pointer together can imply the GV. If the name
9916 contains a package name, then GvSTASH(CvGV(cv)) may differ from
9917 CvSTASH, so forego the optimisation if we find any.
9918 Also, we may be called from load_module at run time, so
9919 PL_curstash (which sets CvSTASH) may not point to the stash the
9920 sub is stored in. */
9921 /* XXX This optimization is currently disabled for packages other
9922 than main, since there was too much CPAN breakage. */
9924 ec ? GV_NOADD_NOINIT
9925 : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
9926 || PL_curstash != PL_defstash
9927 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
9929 : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
9930 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
9932 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
9933 SV * const sv = sv_newmortal();
9934 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]",
9935 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
9936 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
9937 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
9939 } else if (PL_curstash) {
9940 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
9943 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
9949 move_proto_attr(&proto, &attrs, gv, 0);
9952 move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
9957 assert(proto->op_type == OP_CONST);
9958 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
9959 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
9975 SvREFCNT_dec(PL_compcv);
9980 if (name && block) {
9981 const char *s = (char *) my_memrchr(name, ':', namlen);
9983 if (strEQ(s, "BEGIN")) {
9984 if (PL_in_eval & EVAL_KEEPERR)
9985 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
9987 SV * const errsv = ERRSV;
9988 /* force display of errors found but not reported */
9989 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
9990 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
9997 if (!block && SvTYPE(gv) != SVt_PVGV) {
9998 /* If we are not defining a new sub and the existing one is not a
10000 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10001 /* We are applying attributes to an existing sub, so we need it
10002 upgraded if it is a constant. */
10003 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10004 gv_init_pvn(gv, PL_curstash, name, namlen,
10005 SVf_UTF8 * name_is_utf8);
10007 else { /* Maybe prototype now, and had at maximum
10008 a prototype or const/sub ref before. */
10009 if (SvTYPE(gv) > SVt_NULL) {
10010 cv_ckproto_len_flags((const CV *)gv,
10011 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10017 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10019 SvUTF8_on(MUTABLE_SV(gv));
10022 sv_setiv(MUTABLE_SV(gv), -1);
10025 SvREFCNT_dec(PL_compcv);
10026 cv = PL_compcv = NULL;
10031 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10035 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10041 /* This makes sub {}; work as expected. */
10042 if (block->op_type == OP_STUB) {
10043 const line_t l = PL_parser->copline;
10045 block = newSTATEOP(0, NULL, 0);
10046 PL_parser->copline = l;
10048 block = CvLVALUE(PL_compcv)
10049 || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10050 && (!isGV(gv) || !GvASSUMECV(gv)))
10051 ? newUNOP(OP_LEAVESUBLV, 0,
10052 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
10053 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
10054 start = LINKLIST(block);
10055 block->op_next = 0;
10056 if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10058 S_op_const_sv(aTHX_ start, PL_compcv,
10059 cBOOL(CvCLONE(PL_compcv)));
10066 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10067 cv_ckproto_len_flags((const CV *)gv,
10068 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10069 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10071 /* All the other code for sub redefinition warnings expects the
10072 clobbered sub to be a CV. Instead of making all those code
10073 paths more complex, just inline the RV version here. */
10074 const line_t oldline = CopLINE(PL_curcop);
10075 assert(IN_PERL_COMPILETIME);
10076 if (PL_parser && PL_parser->copline != NOLINE)
10077 /* This ensures that warnings are reported at the first
10078 line of a redefinition, not the last. */
10079 CopLINE_set(PL_curcop, PL_parser->copline);
10080 /* protect against fatal warnings leaking compcv */
10081 SAVEFREESV(PL_compcv);
10083 if (ckWARN(WARN_REDEFINE)
10084 || ( ckWARN_d(WARN_REDEFINE)
10085 && ( !const_sv || SvRV(gv) == const_sv
10086 || sv_cmp(SvRV(gv), const_sv) ))) {
10088 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10089 "Constant subroutine %" SVf " redefined",
10090 SVfARG(cSVOPo->op_sv));
10093 SvREFCNT_inc_simple_void_NN(PL_compcv);
10094 CopLINE_set(PL_curcop, oldline);
10095 SvREFCNT_dec(SvRV(gv));
10100 const bool exists = CvROOT(cv) || CvXSUB(cv);
10102 /* if the subroutine doesn't exist and wasn't pre-declared
10103 * with a prototype, assume it will be AUTOLOADed,
10104 * skipping the prototype check
10106 if (exists || SvPOK(cv))
10107 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10108 /* already defined (or promised)? */
10109 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10110 S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10116 /* just a "sub foo;" when &foo is already defined */
10117 SAVEFREESV(PL_compcv);
10124 SvREFCNT_inc_simple_void_NN(const_sv);
10125 SvFLAGS(const_sv) |= SVs_PADTMP;
10127 assert(!CvROOT(cv) && !CvCONST(cv));
10128 cv_forget_slab(cv);
10129 SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */
10130 CvXSUBANY(cv).any_ptr = const_sv;
10131 CvXSUB(cv) = const_sv_xsub;
10135 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10138 if (isGV(gv) || CvMETHOD(PL_compcv)) {
10139 if (name && isGV(gv))
10140 GvCV_set(gv, NULL);
10141 cv = newCONSTSUB_flags(
10142 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10146 assert(SvREFCNT((SV*)cv) != 0);
10147 CvFLAGS(cv) |= CvMETHOD(PL_compcv);
10151 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10152 prepare_SV_for_RV((SV *)gv);
10153 SvOK_off((SV *)gv);
10156 SvRV_set(gv, const_sv);
10160 SvREFCNT_dec(PL_compcv);
10165 /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10166 if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10169 if (cv) { /* must reuse cv if autoloaded */
10170 /* transfer PL_compcv to cv */
10172 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10173 PADLIST *const temp_av = CvPADLIST(cv);
10174 CV *const temp_cv = CvOUTSIDE(cv);
10175 const cv_flags_t other_flags =
10176 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10177 OP * const cvstart = CvSTART(cv);
10181 assert(!CvCVGV_RC(cv));
10182 assert(CvGV(cv) == gv);
10187 PERL_HASH(hash, name, namlen);
10197 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10199 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10200 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10201 CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10202 CvOUTSIDE(PL_compcv) = temp_cv;
10203 CvPADLIST_set(PL_compcv, temp_av);
10204 CvSTART(cv) = CvSTART(PL_compcv);
10205 CvSTART(PL_compcv) = cvstart;
10206 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10207 CvFLAGS(PL_compcv) |= other_flags;
10209 if (CvFILE(cv) && CvDYNFILE(cv)) {
10210 Safefree(CvFILE(cv));
10212 CvFILE_set_from_cop(cv, PL_curcop);
10213 CvSTASH_set(cv, PL_curstash);
10215 /* inner references to PL_compcv must be fixed up ... */
10216 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10217 if (PERLDB_INTER)/* Advice debugger on the new sub. */
10218 ++PL_sub_generation;
10221 /* Might have had built-in attributes applied -- propagate them. */
10222 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10224 /* ... before we throw it away */
10225 SvREFCNT_dec(PL_compcv);
10230 if (name && isGV(gv)) {
10233 if (HvENAME_HEK(GvSTASH(gv)))
10234 /* sub Foo::bar { (shift)+1 } */
10235 gv_method_changed(gv);
10239 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10240 prepare_SV_for_RV((SV *)gv);
10241 SvOK_off((SV *)gv);
10244 SvRV_set(gv, (SV *)cv);
10245 if (HvENAME_HEK(PL_curstash))
10246 mro_method_changed_in(PL_curstash);
10250 assert(SvREFCNT((SV*)cv) != 0);
10252 if (!CvHASGV(cv)) {
10258 PERL_HASH(hash, name, namlen);
10259 CvNAME_HEK_set(cv, share_hek(name,
10265 CvFILE_set_from_cop(cv, PL_curcop);
10266 CvSTASH_set(cv, PL_curstash);
10270 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10272 SvUTF8_on(MUTABLE_SV(cv));
10276 /* If we assign an optree to a PVCV, then we've defined a
10277 * subroutine that the debugger could be able to set a breakpoint
10278 * in, so signal to pp_entereval that it should not throw away any
10279 * saved lines at scope exit. */
10281 PL_breakable_sub_gen++;
10282 CvROOT(cv) = block;
10283 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10284 itself has a refcount. */
10286 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10287 #ifdef PERL_DEBUG_READONLY_OPS
10288 slab = (OPSLAB *)CvSTART(cv);
10290 S_process_optree(aTHX_ cv, block, start);
10295 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10296 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10297 ? GvSTASH(CvGV(cv))
10301 apply_attrs(stash, MUTABLE_SV(cv), attrs);
10303 SvREFCNT_inc_simple_void_NN(cv);
10306 if (block && has_name) {
10307 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10308 SV * const tmpstr = cv_name(cv,NULL,0);
10309 GV * const db_postponed = gv_fetchpvs("DB::postponed",
10310 GV_ADDMULTI, SVt_PVHV);
10312 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
10313 CopFILE(PL_curcop),
10315 (long)CopLINE(PL_curcop));
10316 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
10317 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
10318 hv = GvHVn(db_postponed);
10319 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
10320 CV * const pcv = GvCV(db_postponed);
10326 call_sv(MUTABLE_SV(pcv), G_DISCARD);
10332 if (PL_parser && PL_parser->error_count)
10333 clear_special_blocks(name, gv, cv);
10336 process_special_blocks(floor, name, gv, cv);
10342 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10344 PL_parser->copline = NOLINE;
10345 LEAVE_SCOPE(floor);
10347 assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10349 #ifdef PERL_DEBUG_READONLY_OPS
10353 if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
10354 pad_add_weakref(cv);
10360 S_clear_special_blocks(pTHX_ const char *const fullname,
10361 GV *const gv, CV *const cv) {
10365 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
10367 colon = strrchr(fullname,':');
10368 name = colon ? colon + 1 : fullname;
10370 if ((*name == 'B' && strEQ(name, "BEGIN"))
10371 || (*name == 'E' && strEQ(name, "END"))
10372 || (*name == 'U' && strEQ(name, "UNITCHECK"))
10373 || (*name == 'C' && strEQ(name, "CHECK"))
10374 || (*name == 'I' && strEQ(name, "INIT"))) {
10379 GvCV_set(gv, NULL);
10380 SvREFCNT_dec_NN(MUTABLE_SV(cv));
10384 /* Returns true if the sub has been freed. */
10386 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
10390 const char *const colon = strrchr(fullname,':');
10391 const char *const name = colon ? colon + 1 : fullname;
10393 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
10395 if (*name == 'B') {
10396 if (strEQ(name, "BEGIN")) {
10397 const I32 oldscope = PL_scopestack_ix;
10400 if (floor) LEAVE_SCOPE(floor);
10402 PUSHSTACKi(PERLSI_REQUIRE);
10403 SAVECOPFILE(&PL_compiling);
10404 SAVECOPLINE(&PL_compiling);
10405 SAVEVPTR(PL_curcop);
10407 DEBUG_x( dump_sub(gv) );
10408 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
10409 GvCV_set(gv,0); /* cv has been hijacked */
10410 call_list(oldscope, PL_beginav);
10414 return !PL_savebegin;
10419 if (*name == 'E') {
10420 if strEQ(name, "END") {
10421 DEBUG_x( dump_sub(gv) );
10422 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
10425 } else if (*name == 'U') {
10426 if (strEQ(name, "UNITCHECK")) {
10427 /* It's never too late to run a unitcheck block */
10428 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
10432 } else if (*name == 'C') {
10433 if (strEQ(name, "CHECK")) {
10435 /* diag_listed_as: Too late to run %s block */
10436 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10437 "Too late to run CHECK block");
10438 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
10442 } else if (*name == 'I') {
10443 if (strEQ(name, "INIT")) {
10445 /* diag_listed_as: Too late to run %s block */
10446 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
10447 "Too late to run INIT block");
10448 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
10454 DEBUG_x( dump_sub(gv) );
10456 GvCV_set(gv,0); /* cv has been hijacked */
10462 =for apidoc Am|CV *|newCONSTSUB|HV *stash|const char *name|SV *sv
10464 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
10465 rather than of counted length, and no flags are set. (This means that
10466 C<name> is always interpreted as Latin-1.)
10472 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
10474 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
10478 =for apidoc Am|CV *|newCONSTSUB_flags|HV *stash|const char *name|STRLEN len|U32 flags|SV *sv
10480 Construct a constant subroutine, also performing some surrounding
10481 jobs. A scalar constant-valued subroutine is eligible for inlining
10482 at compile-time, and in Perl code can be created by S<C<sub FOO () {
10483 123 }>>. Other kinds of constant subroutine have other treatment.
10485 The subroutine will have an empty prototype and will ignore any arguments
10486 when called. Its constant behaviour is determined by C<sv>. If C<sv>
10487 is null, the subroutine will yield an empty list. If C<sv> points to a
10488 scalar, the subroutine will always yield that scalar. If C<sv> points
10489 to an array, the subroutine will always yield a list of the elements of
10490 that array in list context, or the number of elements in the array in
10491 scalar context. This function takes ownership of one counted reference
10492 to the scalar or array, and will arrange for the object to live as long
10493 as the subroutine does. If C<sv> points to a scalar then the inlining
10494 assumes that the value of the scalar will never change, so the caller
10495 must ensure that the scalar is not subsequently written to. If C<sv>
10496 points to an array then no such assumption is made, so it is ostensibly
10497 safe to mutate the array or its elements, but whether this is really
10498 supported has not been determined.
10500 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
10501 Other aspects of the subroutine will be left in their default state.
10502 The caller is free to mutate the subroutine beyond its initial state
10503 after this function has returned.
10505 If C<name> is null then the subroutine will be anonymous, with its
10506 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10507 subroutine will be named accordingly, referenced by the appropriate glob.
10508 C<name> is a string of length C<len> bytes giving a sigilless symbol
10509 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
10510 otherwise. The name may be either qualified or unqualified. If the
10511 name is unqualified then it defaults to being in the stash specified by
10512 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
10513 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
10516 C<flags> should not have bits set other than C<SVf_UTF8>.
10518 If there is already a subroutine of the specified name, then the new sub
10519 will replace the existing one in the glob. A warning may be generated
10520 about the redefinition.
10522 If the subroutine has one of a few special names, such as C<BEGIN> or
10523 C<END>, then it will be claimed by the appropriate queue for automatic
10524 running of phase-related subroutines. In this case the relevant glob will
10525 be left not containing any subroutine, even if it did contain one before.
10526 Execution of the subroutine will likely be a no-op, unless C<sv> was
10527 a tied array or the caller modified the subroutine in some interesting
10528 way before it was executed. In the case of C<BEGIN>, the treatment is
10529 buggy: the sub will be executed when only half built, and may be deleted
10530 prematurely, possibly causing a crash.
10532 The function returns a pointer to the constructed subroutine. If the sub
10533 is anonymous then ownership of one counted reference to the subroutine
10534 is transferred to the caller. If the sub is named then the caller does
10535 not get ownership of a reference. In most such cases, where the sub
10536 has a non-phase name, the sub will be alive at the point it is returned
10537 by virtue of being contained in the glob that names it. A phase-named
10538 subroutine will usually be alive by virtue of the reference owned by
10539 the phase's automatic run queue. A C<BEGIN> subroutine may have been
10540 destroyed already by the time this function returns, but currently bugs
10541 occur in that case before the caller gets control. It is the caller's
10542 responsibility to ensure that it knows which of these situations applies.
10548 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
10552 const char *const file = CopFILE(PL_curcop);
10556 if (IN_PERL_RUNTIME) {
10557 /* at runtime, it's not safe to manipulate PL_curcop: it may be
10558 * an op shared between threads. Use a non-shared COP for our
10560 SAVEVPTR(PL_curcop);
10561 SAVECOMPILEWARNINGS();
10562 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
10563 PL_curcop = &PL_compiling;
10565 SAVECOPLINE(PL_curcop);
10566 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
10569 PL_hints &= ~HINT_BLOCK_SCOPE;
10572 SAVEGENERICSV(PL_curstash);
10573 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
10576 /* Protect sv against leakage caused by fatal warnings. */
10577 if (sv) SAVEFREESV(sv);
10579 /* file becomes the CvFILE. For an XS, it's usually static storage,
10580 and so doesn't get free()d. (It's expected to be from the C pre-
10581 processor __FILE__ directive). But we need a dynamically allocated one,
10582 and we need it to get freed. */
10583 cv = newXS_len_flags(name, len,
10584 sv && SvTYPE(sv) == SVt_PVAV
10587 file ? file : "", "",
10588 &sv, XS_DYNAMIC_FILENAME | flags);
10590 assert(SvREFCNT((SV*)cv) != 0);
10591 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
10600 =for apidoc U||newXS
10602 Used by C<xsubpp> to hook up XSUBs as Perl subs. C<filename> needs to be
10603 static storage, as it is used directly as CvFILE(), without a copy being made.
10609 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
10611 PERL_ARGS_ASSERT_NEWXS;
10612 return newXS_len_flags(
10613 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
10618 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
10619 const char *const filename, const char *const proto,
10622 PERL_ARGS_ASSERT_NEWXS_FLAGS;
10623 return newXS_len_flags(
10624 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
10629 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
10631 PERL_ARGS_ASSERT_NEWXS_DEFFILE;
10632 return newXS_len_flags(
10633 name, strlen(name), subaddr, NULL, NULL, NULL, 0
10638 =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
10640 Construct an XS subroutine, also performing some surrounding jobs.
10642 The subroutine will have the entry point C<subaddr>. It will have
10643 the prototype specified by the nul-terminated string C<proto>, or
10644 no prototype if C<proto> is null. The prototype string is copied;
10645 the caller can mutate the supplied string afterwards. If C<filename>
10646 is non-null, it must be a nul-terminated filename, and the subroutine
10647 will have its C<CvFILE> set accordingly. By default C<CvFILE> is set to
10648 point directly to the supplied string, which must be static. If C<flags>
10649 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
10652 Other aspects of the subroutine will be left in their default state.
10653 If anything else needs to be done to the subroutine for it to function
10654 correctly, it is the caller's responsibility to do that after this
10655 function has constructed it. However, beware of the subroutine
10656 potentially being destroyed before this function returns, as described
10659 If C<name> is null then the subroutine will be anonymous, with its
10660 C<CvGV> referring to an C<__ANON__> glob. If C<name> is non-null then the
10661 subroutine will be named accordingly, referenced by the appropriate glob.
10662 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
10663 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
10664 The name may be either qualified or unqualified, with the stash defaulting
10665 in the same manner as for C<gv_fetchpvn_flags>. C<flags> may contain
10666 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
10667 they have there, such as C<GV_ADDWARN>. The symbol is always added to
10668 the stash if necessary, with C<GV_ADDMULTI> semantics.
10670 If there is already a subroutine of the specified name, then the new sub
10671 will replace the existing one in the glob. A warning may be generated
10672 about the redefinition. If the old subroutine was C<CvCONST> then the
10673 decision about whether to warn is influenced by an expectation about
10674 whether the new subroutine will become a constant of similar value.
10675 That expectation is determined by C<const_svp>. (Note that the call to
10676 this function doesn't make the new subroutine C<CvCONST> in any case;
10677 that is left to the caller.) If C<const_svp> is null then it indicates
10678 that the new subroutine will not become a constant. If C<const_svp>
10679 is non-null then it indicates that the new subroutine will become a
10680 constant, and it points to an C<SV*> that provides the constant value
10681 that the subroutine will have.
10683 If the subroutine has one of a few special names, such as C<BEGIN> or
10684 C<END>, then it will be claimed by the appropriate queue for automatic
10685 running of phase-related subroutines. In this case the relevant glob will
10686 be left not containing any subroutine, even if it did contain one before.
10687 In the case of C<BEGIN>, the subroutine will be executed and the reference
10688 to it disposed of before this function returns, and also before its
10689 prototype is set. If a C<BEGIN> subroutine would not be sufficiently
10690 constructed by this function to be ready for execution then the caller
10691 must prevent this happening by giving the subroutine a different name.
10693 The function returns a pointer to the constructed subroutine. If the sub
10694 is anonymous then ownership of one counted reference to the subroutine
10695 is transferred to the caller. If the sub is named then the caller does
10696 not get ownership of a reference. In most such cases, where the sub
10697 has a non-phase name, the sub will be alive at the point it is returned
10698 by virtue of being contained in the glob that names it. A phase-named
10699 subroutine will usually be alive by virtue of the reference owned by the
10700 phase's automatic run queue. But a C<BEGIN> subroutine, having already
10701 been executed, will quite likely have been destroyed already by the
10702 time this function returns, making it erroneous for the caller to make
10703 any use of the returned pointer. It is the caller's responsibility to
10704 ensure that it knows which of these situations applies.
10710 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
10711 XSUBADDR_t subaddr, const char *const filename,
10712 const char *const proto, SV **const_svp,
10716 bool interleave = FALSE;
10717 bool evanescent = FALSE;
10719 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
10722 GV * const gv = gv_fetchpvn(
10723 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10724 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
10725 sizeof("__ANON__::__ANON__") - 1,
10726 GV_ADDMULTI | flags, SVt_PVCV);
10728 if ((cv = (name ? GvCV(gv) : NULL))) {
10730 /* just a cached method */
10734 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
10735 /* already defined (or promised) */
10736 /* Redundant check that allows us to avoid creating an SV
10737 most of the time: */
10738 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10739 report_redefined_cv(newSVpvn_flags(
10740 name,len,(flags&SVf_UTF8)|SVs_TEMP
10751 if (cv) /* must reuse cv if autoloaded */
10754 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10758 if (HvENAME_HEK(GvSTASH(gv)))
10759 gv_method_changed(gv); /* newXS */
10763 assert(SvREFCNT((SV*)cv) != 0);
10767 /* XSUBs can't be perl lang/perl5db.pl debugged
10768 if (PERLDB_LINE_OR_SAVESRC)
10769 (void)gv_fetchfile(filename); */
10770 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
10771 if (flags & XS_DYNAMIC_FILENAME) {
10773 CvFILE(cv) = savepv(filename);
10775 /* NOTE: not copied, as it is expected to be an external constant string */
10776 CvFILE(cv) = (char *)filename;
10779 assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
10780 CvFILE(cv) = (char*)PL_xsubfilename;
10783 CvXSUB(cv) = subaddr;
10784 #ifndef PERL_IMPLICIT_CONTEXT
10785 CvHSCXT(cv) = &PL_stack_sp;
10791 evanescent = process_special_blocks(0, name, gv, cv);
10794 } /* <- not a conditional branch */
10797 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10799 if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
10800 if (interleave) LEAVE;
10801 assert(evanescent || SvREFCNT((SV*)cv) != 0);
10806 Perl_newSTUB(pTHX_ GV *gv, bool fake)
10808 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10810 PERL_ARGS_ASSERT_NEWSTUB;
10811 assert(!GvCVu(gv));
10814 if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
10815 gv_method_changed(gv);
10817 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
10821 CvGV_set(cv, cvgv);
10822 CvFILE_set_from_cop(cv, PL_curcop);
10823 CvSTASH_set(cv, PL_curstash);
10829 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
10836 if (PL_parser && PL_parser->error_count) {
10842 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
10843 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
10846 if ((cv = GvFORM(gv))) {
10847 if (ckWARN(WARN_REDEFINE)) {
10848 const line_t oldline = CopLINE(PL_curcop);
10849 if (PL_parser && PL_parser->copline != NOLINE)
10850 CopLINE_set(PL_curcop, PL_parser->copline);
10852 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10853 "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
10855 /* diag_listed_as: Format %s redefined */
10856 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10857 "Format STDOUT redefined");
10859 CopLINE_set(PL_curcop, oldline);
10864 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
10866 CvFILE_set_from_cop(cv, PL_curcop);
10869 root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
10871 start = LINKLIST(root);
10873 S_process_optree(aTHX_ cv, root, start);
10874 cv_forget_slab(cv);
10879 PL_parser->copline = NOLINE;
10880 LEAVE_SCOPE(floor);
10881 PL_compiling.cop_seq = 0;
10885 Perl_newANONLIST(pTHX_ OP *o)
10887 return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
10891 Perl_newANONHASH(pTHX_ OP *o)
10893 return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
10897 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
10899 return newANONATTRSUB(floor, proto, NULL, block);
10903 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
10905 SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
10907 newSVOP(OP_ANONCODE, 0,
10909 if (CvANONCONST(cv))
10910 anoncode = newUNOP(OP_ANONCONST, 0,
10911 op_convert_list(OP_ENTERSUB,
10912 OPf_STACKED|OPf_WANT_SCALAR,
10914 return newUNOP(OP_REFGEN, 0, anoncode);
10918 Perl_oopsAV(pTHX_ OP *o)
10922 PERL_ARGS_ASSERT_OOPSAV;
10924 switch (o->op_type) {
10927 OpTYPE_set(o, OP_PADAV);
10928 return ref(o, OP_RV2AV);
10932 OpTYPE_set(o, OP_RV2AV);
10937 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
10944 Perl_oopsHV(pTHX_ OP *o)
10948 PERL_ARGS_ASSERT_OOPSHV;
10950 switch (o->op_type) {
10953 OpTYPE_set(o, OP_PADHV);
10954 return ref(o, OP_RV2HV);
10958 OpTYPE_set(o, OP_RV2HV);
10959 /* rv2hv steals the bottom bit for its own uses */
10960 o->op_private &= ~OPpARG1_MASK;
10965 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
10972 Perl_newAVREF(pTHX_ OP *o)
10976 PERL_ARGS_ASSERT_NEWAVREF;
10978 if (o->op_type == OP_PADANY) {
10979 OpTYPE_set(o, OP_PADAV);
10982 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
10983 Perl_croak(aTHX_ "Can't use an array as a reference");
10985 return newUNOP(OP_RV2AV, 0, scalar(o));
10989 Perl_newGVREF(pTHX_ I32 type, OP *o)
10991 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
10992 return newUNOP(OP_NULL, 0, o);
10993 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
10997 Perl_newHVREF(pTHX_ OP *o)
11001 PERL_ARGS_ASSERT_NEWHVREF;
11003 if (o->op_type == OP_PADANY) {
11004 OpTYPE_set(o, OP_PADHV);
11007 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11008 Perl_croak(aTHX_ "Can't use a hash as a reference");
11010 return newUNOP(OP_RV2HV, 0, scalar(o));
11014 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11016 if (o->op_type == OP_PADANY) {
11018 OpTYPE_set(o, OP_PADCV);
11020 return newUNOP(OP_RV2CV, flags, scalar(o));
11024 Perl_newSVREF(pTHX_ OP *o)
11028 PERL_ARGS_ASSERT_NEWSVREF;
11030 if (o->op_type == OP_PADANY) {
11031 OpTYPE_set(o, OP_PADSV);
11035 return newUNOP(OP_RV2SV, 0, scalar(o));
11038 /* Check routines. See the comments at the top of this file for details
11039 * on when these are called */
11042 Perl_ck_anoncode(pTHX_ OP *o)
11044 PERL_ARGS_ASSERT_CK_ANONCODE;
11046 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11047 cSVOPo->op_sv = NULL;
11052 S_io_hints(pTHX_ OP *o)
11054 #if O_BINARY != 0 || O_TEXT != 0
11056 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11058 SV **svp = hv_fetchs(table, "open_IN", FALSE);
11061 const char *d = SvPV_const(*svp, len);
11062 const I32 mode = mode_from_discipline(d, len);
11063 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11065 if (mode & O_BINARY)
11066 o->op_private |= OPpOPEN_IN_RAW;
11070 o->op_private |= OPpOPEN_IN_CRLF;
11074 svp = hv_fetchs(table, "open_OUT", FALSE);
11077 const char *d = SvPV_const(*svp, len);
11078 const I32 mode = mode_from_discipline(d, len);
11079 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11081 if (mode & O_BINARY)
11082 o->op_private |= OPpOPEN_OUT_RAW;
11086 o->op_private |= OPpOPEN_OUT_CRLF;
11091 PERL_UNUSED_CONTEXT;
11092 PERL_UNUSED_ARG(o);
11097 Perl_ck_backtick(pTHX_ OP *o)
11102 PERL_ARGS_ASSERT_CK_BACKTICK;
11104 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11105 if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11106 && (gv = gv_override("readpipe",8)))
11108 /* detach rest of siblings from o and its first child */
11109 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11110 newop = S_new_entersubop(aTHX_ gv, sibl);
11112 else if (!(o->op_flags & OPf_KIDS))
11113 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
11118 S_io_hints(aTHX_ o);
11123 Perl_ck_bitop(pTHX_ OP *o)
11125 PERL_ARGS_ASSERT_CK_BITOP;
11127 o->op_private = (U8)(PL_hints & HINT_INTEGER);
11129 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11130 && OP_IS_INFIX_BIT(o->op_type))
11132 const OP * const left = cBINOPo->op_first;
11133 const OP * const right = OpSIBLING(left);
11134 if ((OP_IS_NUMCOMPARE(left->op_type) &&
11135 (left->op_flags & OPf_PARENS) == 0) ||
11136 (OP_IS_NUMCOMPARE(right->op_type) &&
11137 (right->op_flags & OPf_PARENS) == 0))
11138 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11139 "Possible precedence problem on bitwise %s operator",
11140 o->op_type == OP_BIT_OR
11141 ||o->op_type == OP_NBIT_OR ? "|"
11142 : o->op_type == OP_BIT_AND
11143 ||o->op_type == OP_NBIT_AND ? "&"
11144 : o->op_type == OP_BIT_XOR
11145 ||o->op_type == OP_NBIT_XOR ? "^"
11146 : o->op_type == OP_SBIT_OR ? "|."
11147 : o->op_type == OP_SBIT_AND ? "&." : "^."
11153 PERL_STATIC_INLINE bool
11154 is_dollar_bracket(pTHX_ const OP * const o)
11157 PERL_UNUSED_CONTEXT;
11158 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11159 && (kid = cUNOPx(o)->op_first)
11160 && kid->op_type == OP_GV
11161 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11164 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11167 Perl_ck_cmp(pTHX_ OP *o)
11173 OP *indexop, *constop, *start;
11177 PERL_ARGS_ASSERT_CK_CMP;
11179 is_eq = ( o->op_type == OP_EQ
11180 || o->op_type == OP_NE
11181 || o->op_type == OP_I_EQ
11182 || o->op_type == OP_I_NE);
11184 if (!is_eq && ckWARN(WARN_SYNTAX)) {
11185 const OP *kid = cUNOPo->op_first;
11188 ( is_dollar_bracket(aTHX_ kid)
11189 && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11191 || ( kid->op_type == OP_CONST
11192 && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11196 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11197 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11200 /* convert (index(...) == -1) and variations into
11201 * (r)index/BOOL(,NEG)
11206 indexop = cUNOPo->op_first;
11207 constop = OpSIBLING(indexop);
11209 if (indexop->op_type == OP_CONST) {
11211 indexop = OpSIBLING(constop);
11216 if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11219 /* ($lex = index(....)) == -1 */
11220 if (indexop->op_private & OPpTARGET_MY)
11223 if (constop->op_type != OP_CONST)
11226 sv = cSVOPx_sv(constop);
11227 if (!(sv && SvIOK_notUV(sv)))
11231 if (iv != -1 && iv != 0)
11235 if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
11236 if (!(iv0 ^ reverse))
11240 else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
11245 else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
11246 if (!(iv0 ^ reverse))
11250 else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
11255 else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
11261 assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
11267 indexop->op_flags &= ~OPf_PARENS;
11268 indexop->op_flags |= (o->op_flags & OPf_PARENS);
11269 indexop->op_private |= OPpTRUEBOOL;
11271 indexop->op_private |= OPpINDEX_BOOLNEG;
11272 /* cut out the index op and free the eq,const ops */
11273 (void)op_sibling_splice(o, start, 1, NULL);
11281 Perl_ck_concat(pTHX_ OP *o)
11283 const OP * const kid = cUNOPo->op_first;
11285 PERL_ARGS_ASSERT_CK_CONCAT;
11286 PERL_UNUSED_CONTEXT;
11288 /* reuse the padtmp returned by the concat child */
11289 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
11290 !(kUNOP->op_first->op_flags & OPf_MOD))
11292 o->op_flags |= OPf_STACKED;
11293 o->op_private |= OPpCONCAT_NESTED;
11299 Perl_ck_spair(pTHX_ OP *o)
11303 PERL_ARGS_ASSERT_CK_SPAIR;
11305 if (o->op_flags & OPf_KIDS) {
11309 const OPCODE type = o->op_type;
11310 o = modkids(ck_fun(o), type);
11311 kid = cUNOPo->op_first;
11312 kidkid = kUNOP->op_first;
11313 newop = OpSIBLING(kidkid);
11315 const OPCODE type = newop->op_type;
11316 if (OpHAS_SIBLING(newop))
11318 if (o->op_type == OP_REFGEN
11319 && ( type == OP_RV2CV
11320 || ( !(newop->op_flags & OPf_PARENS)
11321 && ( type == OP_RV2AV || type == OP_PADAV
11322 || type == OP_RV2HV || type == OP_PADHV))))
11323 NOOP; /* OK (allow srefgen for \@a and \%h) */
11324 else if (OP_GIMME(newop,0) != G_SCALAR)
11327 /* excise first sibling */
11328 op_sibling_splice(kid, NULL, 1, NULL);
11331 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
11332 * and OP_CHOMP into OP_SCHOMP */
11333 o->op_ppaddr = PL_ppaddr[++o->op_type];
11338 Perl_ck_delete(pTHX_ OP *o)
11340 PERL_ARGS_ASSERT_CK_DELETE;
11344 if (o->op_flags & OPf_KIDS) {
11345 OP * const kid = cUNOPo->op_first;
11346 switch (kid->op_type) {
11348 o->op_flags |= OPf_SPECIAL;
11351 o->op_private |= OPpSLICE;
11354 o->op_flags |= OPf_SPECIAL;
11359 o->op_flags |= OPf_SPECIAL;
11362 o->op_private |= OPpKVSLICE;
11365 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
11366 "element or slice");
11368 if (kid->op_private & OPpLVAL_INTRO)
11369 o->op_private |= OPpLVAL_INTRO;
11376 Perl_ck_eof(pTHX_ OP *o)
11378 PERL_ARGS_ASSERT_CK_EOF;
11380 if (o->op_flags & OPf_KIDS) {
11382 if (cLISTOPo->op_first->op_type == OP_STUB) {
11384 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
11389 kid = cLISTOPo->op_first;
11390 if (kid->op_type == OP_RV2GV)
11391 kid->op_private |= OPpALLOW_FAKE;
11398 Perl_ck_eval(pTHX_ OP *o)
11402 PERL_ARGS_ASSERT_CK_EVAL;
11404 PL_hints |= HINT_BLOCK_SCOPE;
11405 if (o->op_flags & OPf_KIDS) {
11406 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11409 if (o->op_type == OP_ENTERTRY) {
11412 /* cut whole sibling chain free from o */
11413 op_sibling_splice(o, NULL, -1, NULL);
11416 enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
11418 /* establish postfix order */
11419 enter->op_next = (OP*)enter;
11421 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
11422 OpTYPE_set(o, OP_LEAVETRY);
11423 enter->op_other = o;
11428 S_set_haseval(aTHX);
11432 const U8 priv = o->op_private;
11434 /* the newUNOP will recursively call ck_eval(), which will handle
11435 * all the stuff at the end of this function, like adding
11438 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
11440 o->op_targ = (PADOFFSET)PL_hints;
11441 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
11442 if ((PL_hints & HINT_LOCALIZE_HH) != 0
11443 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
11444 /* Store a copy of %^H that pp_entereval can pick up. */
11445 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
11446 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
11447 /* append hhop to only child */
11448 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
11450 o->op_private |= OPpEVAL_HAS_HH;
11452 if (!(o->op_private & OPpEVAL_BYTES)
11453 && FEATURE_UNIEVAL_IS_ENABLED)
11454 o->op_private |= OPpEVAL_UNICODE;
11459 Perl_ck_exec(pTHX_ OP *o)
11461 PERL_ARGS_ASSERT_CK_EXEC;
11463 if (o->op_flags & OPf_STACKED) {
11466 kid = OpSIBLING(cUNOPo->op_first);
11467 if (kid->op_type == OP_RV2GV)
11476 Perl_ck_exists(pTHX_ OP *o)
11478 PERL_ARGS_ASSERT_CK_EXISTS;
11481 if (o->op_flags & OPf_KIDS) {
11482 OP * const kid = cUNOPo->op_first;
11483 if (kid->op_type == OP_ENTERSUB) {
11484 (void) ref(kid, o->op_type);
11485 if (kid->op_type != OP_RV2CV
11486 && !(PL_parser && PL_parser->error_count))
11488 "exists argument is not a subroutine name");
11489 o->op_private |= OPpEXISTS_SUB;
11491 else if (kid->op_type == OP_AELEM)
11492 o->op_flags |= OPf_SPECIAL;
11493 else if (kid->op_type != OP_HELEM)
11494 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
11495 "element or a subroutine");
11502 Perl_ck_rvconst(pTHX_ OP *o)
11505 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11507 PERL_ARGS_ASSERT_CK_RVCONST;
11509 if (o->op_type == OP_RV2HV)
11510 /* rv2hv steals the bottom bit for its own uses */
11511 o->op_private &= ~OPpARG1_MASK;
11513 o->op_private |= (PL_hints & HINT_STRICT_REFS);
11515 if (kid->op_type == OP_CONST) {
11518 SV * const kidsv = kid->op_sv;
11520 /* Is it a constant from cv_const_sv()? */
11521 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
11524 if (SvTYPE(kidsv) == SVt_PVAV) return o;
11525 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
11526 const char *badthing;
11527 switch (o->op_type) {
11529 badthing = "a SCALAR";
11532 badthing = "an ARRAY";
11535 badthing = "a HASH";
11543 "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
11544 SVfARG(kidsv), badthing);
11547 * This is a little tricky. We only want to add the symbol if we
11548 * didn't add it in the lexer. Otherwise we get duplicate strict
11549 * warnings. But if we didn't add it in the lexer, we must at
11550 * least pretend like we wanted to add it even if it existed before,
11551 * or we get possible typo warnings. OPpCONST_ENTERED says
11552 * whether the lexer already added THIS instance of this symbol.
11554 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
11555 gv = gv_fetchsv(kidsv,
11556 o->op_type == OP_RV2CV
11557 && o->op_private & OPpMAY_RETURN_CONSTANT
11559 : iscv | !(kid->op_private & OPpCONST_ENTERED),
11562 : o->op_type == OP_RV2SV
11564 : o->op_type == OP_RV2AV
11566 : o->op_type == OP_RV2HV
11573 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
11574 && SvTYPE(SvRV(gv)) != SVt_PVCV)
11575 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
11577 OpTYPE_set(kid, OP_GV);
11578 SvREFCNT_dec(kid->op_sv);
11579 #ifdef USE_ITHREADS
11580 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
11581 STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
11582 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
11583 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
11584 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
11586 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
11588 kid->op_private = 0;
11589 /* FAKE globs in the symbol table cause weird bugs (#77810) */
11597 Perl_ck_ftst(pTHX_ OP *o)
11600 const I32 type = o->op_type;
11602 PERL_ARGS_ASSERT_CK_FTST;
11604 if (o->op_flags & OPf_REF) {
11607 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
11608 SVOP * const kid = (SVOP*)cUNOPo->op_first;
11609 const OPCODE kidtype = kid->op_type;
11611 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
11612 && !kid->op_folded) {
11613 OP * const newop = newGVOP(type, OPf_REF,
11614 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
11619 if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
11620 SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
11622 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11623 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
11624 array_passed_to_stat, name);
11627 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
11628 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
11631 scalar((OP *) kid);
11632 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
11633 o->op_private |= OPpFT_ACCESS;
11634 if (type != OP_STAT && type != OP_LSTAT
11635 && PL_check[kidtype] == Perl_ck_ftst
11636 && kidtype != OP_STAT && kidtype != OP_LSTAT
11638 o->op_private |= OPpFT_STACKED;
11639 kid->op_private |= OPpFT_STACKING;
11640 if (kidtype == OP_FTTTY && (
11641 !(kid->op_private & OPpFT_STACKED)
11642 || kid->op_private & OPpFT_AFTER_t
11644 o->op_private |= OPpFT_AFTER_t;
11649 if (type == OP_FTTTY)
11650 o = newGVOP(type, OPf_REF, PL_stdingv);
11652 o = newUNOP(type, 0, newDEFSVOP());
11658 Perl_ck_fun(pTHX_ OP *o)
11660 const int type = o->op_type;
11661 I32 oa = PL_opargs[type] >> OASHIFT;
11663 PERL_ARGS_ASSERT_CK_FUN;
11665 if (o->op_flags & OPf_STACKED) {
11666 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
11667 oa &= ~OA_OPTIONAL;
11669 return no_fh_allowed(o);
11672 if (o->op_flags & OPf_KIDS) {
11673 OP *prev_kid = NULL;
11674 OP *kid = cLISTOPo->op_first;
11676 bool seen_optional = FALSE;
11678 if (kid->op_type == OP_PUSHMARK ||
11679 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
11682 kid = OpSIBLING(kid);
11684 if (kid && kid->op_type == OP_COREARGS) {
11685 bool optional = FALSE;
11688 if (oa & OA_OPTIONAL) optional = TRUE;
11691 if (optional) o->op_private |= numargs;
11696 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
11697 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
11698 kid = newDEFSVOP();
11699 /* append kid to chain */
11700 op_sibling_splice(o, prev_kid, 0, kid);
11702 seen_optional = TRUE;
11709 /* list seen where single (scalar) arg expected? */
11710 if (numargs == 1 && !(oa >> 4)
11711 && kid->op_type == OP_LIST && type != OP_SCALAR)
11713 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11715 if (type != OP_DELETE) scalar(kid);
11726 if ((type == OP_PUSH || type == OP_UNSHIFT)
11727 && !OpHAS_SIBLING(kid))
11728 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11729 "Useless use of %s with no values",
11732 if (kid->op_type == OP_CONST
11733 && ( !SvROK(cSVOPx_sv(kid))
11734 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
11736 bad_type_pv(numargs, "array", o, kid);
11737 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
11738 || kid->op_type == OP_RV2GV) {
11739 bad_type_pv(1, "array", o, kid);
11741 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
11742 yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
11743 PL_op_desc[type]), 0);
11746 op_lvalue(kid, type);
11750 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
11751 bad_type_pv(numargs, "hash", o, kid);
11752 op_lvalue(kid, type);
11756 /* replace kid with newop in chain */
11758 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
11759 newop->op_next = newop;
11764 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
11765 if (kid->op_type == OP_CONST &&
11766 (kid->op_private & OPpCONST_BARE))
11768 OP * const newop = newGVOP(OP_GV, 0,
11769 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
11770 /* replace kid with newop in chain */
11771 op_sibling_splice(o, prev_kid, 1, newop);
11775 else if (kid->op_type == OP_READLINE) {
11776 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
11777 bad_type_pv(numargs, "HANDLE", o, kid);
11780 I32 flags = OPf_SPECIAL;
11782 PADOFFSET targ = 0;
11784 /* is this op a FH constructor? */
11785 if (is_handle_constructor(o,numargs)) {
11786 const char *name = NULL;
11789 bool want_dollar = TRUE;
11792 /* Set a flag to tell rv2gv to vivify
11793 * need to "prove" flag does not mean something
11794 * else already - NI-S 1999/05/07
11797 if (kid->op_type == OP_PADSV) {
11799 = PAD_COMPNAME_SV(kid->op_targ);
11800 name = PadnamePV (pn);
11801 len = PadnameLEN(pn);
11802 name_utf8 = PadnameUTF8(pn);
11804 else if (kid->op_type == OP_RV2SV
11805 && kUNOP->op_first->op_type == OP_GV)
11807 GV * const gv = cGVOPx_gv(kUNOP->op_first);
11809 len = GvNAMELEN(gv);
11810 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
11812 else if (kid->op_type == OP_AELEM
11813 || kid->op_type == OP_HELEM)
11816 OP *op = ((BINOP*)kid)->op_first;
11820 const char * const a =
11821 kid->op_type == OP_AELEM ?
11823 if (((op->op_type == OP_RV2AV) ||
11824 (op->op_type == OP_RV2HV)) &&
11825 (firstop = ((UNOP*)op)->op_first) &&
11826 (firstop->op_type == OP_GV)) {
11827 /* packagevar $a[] or $h{} */
11828 GV * const gv = cGVOPx_gv(firstop);
11831 Perl_newSVpvf(aTHX_
11836 else if (op->op_type == OP_PADAV
11837 || op->op_type == OP_PADHV) {
11838 /* lexicalvar $a[] or $h{} */
11839 const char * const padname =
11840 PAD_COMPNAME_PV(op->op_targ);
11843 Perl_newSVpvf(aTHX_
11849 name = SvPV_const(tmpstr, len);
11850 name_utf8 = SvUTF8(tmpstr);
11851 sv_2mortal(tmpstr);
11855 name = "__ANONIO__";
11857 want_dollar = FALSE;
11859 op_lvalue(kid, type);
11863 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
11864 namesv = PAD_SVl(targ);
11865 if (want_dollar && *name != '$')
11866 sv_setpvs(namesv, "$");
11869 sv_catpvn(namesv, name, len);
11870 if ( name_utf8 ) SvUTF8_on(namesv);
11874 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
11876 kid->op_targ = targ;
11877 kid->op_private |= priv;
11883 if ((type == OP_UNDEF || type == OP_POS)
11884 && numargs == 1 && !(oa >> 4)
11885 && kid->op_type == OP_LIST)
11886 return too_many_arguments_pv(o,PL_op_desc[type], 0);
11887 op_lvalue(scalar(kid), type);
11892 kid = OpSIBLING(kid);
11894 /* FIXME - should the numargs or-ing move after the too many
11895 * arguments check? */
11896 o->op_private |= numargs;
11898 return too_many_arguments_pv(o,OP_DESC(o), 0);
11901 else if (PL_opargs[type] & OA_DEFGV) {
11902 /* Ordering of these two is important to keep f_map.t passing. */
11904 return newUNOP(type, 0, newDEFSVOP());
11908 while (oa & OA_OPTIONAL)
11910 if (oa && oa != OA_LIST)
11911 return too_few_arguments_pv(o,OP_DESC(o), 0);
11917 Perl_ck_glob(pTHX_ OP *o)
11921 PERL_ARGS_ASSERT_CK_GLOB;
11924 if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
11925 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
11927 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
11931 * \ null - const(wildcard)
11936 * \ mark - glob - rv2cv
11937 * | \ gv(CORE::GLOBAL::glob)
11939 * \ null - const(wildcard)
11941 o->op_flags |= OPf_SPECIAL;
11942 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
11943 o = S_new_entersubop(aTHX_ gv, o);
11944 o = newUNOP(OP_NULL, 0, o);
11945 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
11948 else o->op_flags &= ~OPf_SPECIAL;
11949 #if !defined(PERL_EXTERNAL_GLOB)
11950 if (!PL_globhook) {
11952 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
11953 newSVpvs("File::Glob"), NULL, NULL, NULL);
11956 #endif /* !PERL_EXTERNAL_GLOB */
11957 gv = (GV *)newSV(0);
11958 gv_init(gv, 0, "", 0, 0);
11960 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
11961 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
11967 Perl_ck_grep(pTHX_ OP *o)
11971 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
11973 PERL_ARGS_ASSERT_CK_GREP;
11975 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
11977 if (o->op_flags & OPf_STACKED) {
11978 kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
11979 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
11980 return no_fh_allowed(o);
11981 o->op_flags &= ~OPf_STACKED;
11983 kid = OpSIBLING(cLISTOPo->op_first);
11984 if (type == OP_MAPWHILE)
11989 if (PL_parser && PL_parser->error_count)
11991 kid = OpSIBLING(cLISTOPo->op_first);
11992 if (kid->op_type != OP_NULL)
11993 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
11994 kid = kUNOP->op_first;
11996 gwop = alloc_LOGOP(type, o, LINKLIST(kid));
11997 kid->op_next = (OP*)gwop;
11998 o->op_private = gwop->op_private = 0;
11999 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12001 kid = OpSIBLING(cLISTOPo->op_first);
12002 for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12003 op_lvalue(kid, OP_GREPSTART);
12009 Perl_ck_index(pTHX_ OP *o)
12011 PERL_ARGS_ASSERT_CK_INDEX;
12013 if (o->op_flags & OPf_KIDS) {
12014 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12016 kid = OpSIBLING(kid); /* get past "big" */
12017 if (kid && kid->op_type == OP_CONST) {
12018 const bool save_taint = TAINT_get;
12019 SV *sv = kSVOP->op_sv;
12020 if ( (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12021 && SvOK(sv) && !SvROK(sv))
12024 sv_copypv(sv, kSVOP->op_sv);
12025 SvREFCNT_dec_NN(kSVOP->op_sv);
12028 if (SvOK(sv)) fbm_compile(sv, 0);
12029 TAINT_set(save_taint);
12030 #ifdef NO_TAINT_SUPPORT
12031 PERL_UNUSED_VAR(save_taint);
12039 Perl_ck_lfun(pTHX_ OP *o)
12041 const OPCODE type = o->op_type;
12043 PERL_ARGS_ASSERT_CK_LFUN;
12045 return modkids(ck_fun(o), type);
12049 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
12051 PERL_ARGS_ASSERT_CK_DEFINED;
12053 if ((o->op_flags & OPf_KIDS)) {
12054 switch (cUNOPo->op_first->op_type) {
12057 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12058 " (Maybe you should just omit the defined()?)");
12059 NOT_REACHED; /* NOTREACHED */
12063 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12064 " (Maybe you should just omit the defined()?)");
12065 NOT_REACHED; /* NOTREACHED */
12076 Perl_ck_readline(pTHX_ OP *o)
12078 PERL_ARGS_ASSERT_CK_READLINE;
12080 if (o->op_flags & OPf_KIDS) {
12081 OP *kid = cLISTOPo->op_first;
12082 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12086 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12094 Perl_ck_rfun(pTHX_ OP *o)
12096 const OPCODE type = o->op_type;
12098 PERL_ARGS_ASSERT_CK_RFUN;
12100 return refkids(ck_fun(o), type);
12104 Perl_ck_listiob(pTHX_ OP *o)
12108 PERL_ARGS_ASSERT_CK_LISTIOB;
12110 kid = cLISTOPo->op_first;
12112 o = force_list(o, 1);
12113 kid = cLISTOPo->op_first;
12115 if (kid->op_type == OP_PUSHMARK)
12116 kid = OpSIBLING(kid);
12117 if (kid && o->op_flags & OPf_STACKED)
12118 kid = OpSIBLING(kid);
12119 else if (kid && !OpHAS_SIBLING(kid)) { /* print HANDLE; */
12120 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12121 && !kid->op_folded) {
12122 o->op_flags |= OPf_STACKED; /* make it a filehandle */
12124 /* replace old const op with new OP_RV2GV parent */
12125 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
12126 OP_RV2GV, OPf_REF);
12127 kid = OpSIBLING(kid);
12132 op_append_elem(o->op_type, o, newDEFSVOP());
12134 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
12135 return listkids(o);
12139 Perl_ck_smartmatch(pTHX_ OP *o)
12142 PERL_ARGS_ASSERT_CK_SMARTMATCH;
12143 if (0 == (o->op_flags & OPf_SPECIAL)) {
12144 OP *first = cBINOPo->op_first;
12145 OP *second = OpSIBLING(first);
12147 /* Implicitly take a reference to an array or hash */
12149 /* remove the original two siblings, then add back the
12150 * (possibly different) first and second sibs.
12152 op_sibling_splice(o, NULL, 1, NULL);
12153 op_sibling_splice(o, NULL, 1, NULL);
12154 first = ref_array_or_hash(first);
12155 second = ref_array_or_hash(second);
12156 op_sibling_splice(o, NULL, 0, second);
12157 op_sibling_splice(o, NULL, 0, first);
12159 /* Implicitly take a reference to a regular expression */
12160 if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
12161 OpTYPE_set(first, OP_QR);
12163 if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
12164 OpTYPE_set(second, OP_QR);
12173 S_maybe_targlex(pTHX_ OP *o)
12175 OP * const kid = cLISTOPo->op_first;
12176 /* has a disposable target? */
12177 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
12178 && !(kid->op_flags & OPf_STACKED)
12179 /* Cannot steal the second time! */
12180 && !(kid->op_private & OPpTARGET_MY)
12183 OP * const kkid = OpSIBLING(kid);
12185 /* Can just relocate the target. */
12186 if (kkid && kkid->op_type == OP_PADSV
12187 && (!(kkid->op_private & OPpLVAL_INTRO)
12188 || kkid->op_private & OPpPAD_STATE))
12190 kid->op_targ = kkid->op_targ;
12192 /* Now we do not need PADSV and SASSIGN.
12193 * Detach kid and free the rest. */
12194 op_sibling_splice(o, NULL, 1, NULL);
12196 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
12204 Perl_ck_sassign(pTHX_ OP *o)
12207 OP * const kid = cBINOPo->op_first;
12209 PERL_ARGS_ASSERT_CK_SASSIGN;
12211 if (OpHAS_SIBLING(kid)) {
12212 OP *kkid = OpSIBLING(kid);
12213 /* For state variable assignment with attributes, kkid is a list op
12214 whose op_last is a padsv. */
12215 if ((kkid->op_type == OP_PADSV ||
12216 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
12217 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
12220 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
12221 == (OPpLVAL_INTRO|OPpPAD_STATE)) {
12222 return S_newONCEOP(aTHX_ o, kkid);
12225 return S_maybe_targlex(aTHX_ o);
12230 Perl_ck_match(pTHX_ OP *o)
12232 PERL_UNUSED_CONTEXT;
12233 PERL_ARGS_ASSERT_CK_MATCH;
12239 Perl_ck_method(pTHX_ OP *o)
12241 SV *sv, *methsv, *rclass;
12242 const char* method;
12245 STRLEN len, nsplit = 0, i;
12247 OP * const kid = cUNOPo->op_first;
12249 PERL_ARGS_ASSERT_CK_METHOD;
12250 if (kid->op_type != OP_CONST) return o;
12254 /* replace ' with :: */
12255 while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
12256 SvEND(sv) - SvPVX(sv) )))
12259 sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
12262 method = SvPVX_const(sv);
12264 utf8 = SvUTF8(sv) ? -1 : 1;
12266 for (i = len - 1; i > 0; --i) if (method[i] == ':') {
12271 methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
12273 if (!nsplit) { /* $proto->method() */
12275 return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
12278 if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
12280 return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
12283 /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
12284 if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
12285 rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
12286 new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
12288 rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
12289 new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
12291 #ifdef USE_ITHREADS
12292 op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
12294 cMETHOPx(new_op)->op_rclass_sv = rclass;
12301 Perl_ck_null(pTHX_ OP *o)
12303 PERL_ARGS_ASSERT_CK_NULL;
12304 PERL_UNUSED_CONTEXT;
12309 Perl_ck_open(pTHX_ OP *o)
12311 PERL_ARGS_ASSERT_CK_OPEN;
12313 S_io_hints(aTHX_ o);
12315 /* In case of three-arg dup open remove strictness
12316 * from the last arg if it is a bareword. */
12317 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
12318 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
12322 if ((last->op_type == OP_CONST) && /* The bareword. */
12323 (last->op_private & OPpCONST_BARE) &&
12324 (last->op_private & OPpCONST_STRICT) &&
12325 (oa = OpSIBLING(first)) && /* The fh. */
12326 (oa = OpSIBLING(oa)) && /* The mode. */
12327 (oa->op_type == OP_CONST) &&
12328 SvPOK(((SVOP*)oa)->op_sv) &&
12329 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
12330 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
12331 (last == OpSIBLING(oa))) /* The bareword. */
12332 last->op_private &= ~OPpCONST_STRICT;
12338 Perl_ck_prototype(pTHX_ OP *o)
12340 PERL_ARGS_ASSERT_CK_PROTOTYPE;
12341 if (!(o->op_flags & OPf_KIDS)) {
12343 return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
12349 Perl_ck_refassign(pTHX_ OP *o)
12351 OP * const right = cLISTOPo->op_first;
12352 OP * const left = OpSIBLING(right);
12353 OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
12356 PERL_ARGS_ASSERT_CK_REFASSIGN;
12358 assert (left->op_type == OP_SREFGEN);
12361 /* we use OPpPAD_STATE in refassign to mean either of those things,
12362 * and the code assumes the two flags occupy the same bit position
12363 * in the various ops below */
12364 assert(OPpPAD_STATE == OPpOUR_INTRO);
12366 switch (varop->op_type) {
12368 o->op_private |= OPpLVREF_AV;
12371 o->op_private |= OPpLVREF_HV;
12375 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
12376 o->op_targ = varop->op_targ;
12377 varop->op_targ = 0;
12378 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
12382 o->op_private |= OPpLVREF_AV;
12384 NOT_REACHED; /* NOTREACHED */
12386 o->op_private |= OPpLVREF_HV;
12390 o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
12391 if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
12393 /* Point varop to its GV kid, detached. */
12394 varop = op_sibling_splice(varop, NULL, -1, NULL);
12398 OP * const kidparent =
12399 OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
12400 OP * const kid = cUNOPx(kidparent)->op_first;
12401 o->op_private |= OPpLVREF_CV;
12402 if (kid->op_type == OP_GV) {
12404 goto detach_and_stack;
12406 if (kid->op_type != OP_PADCV) goto bad;
12407 o->op_targ = kid->op_targ;
12413 o->op_private |= (varop->op_private & OPpLVAL_INTRO);
12414 o->op_private |= OPpLVREF_ELEM;
12417 /* Detach varop. */
12418 op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
12422 /* diag_listed_as: Can't modify reference to %s in %s assignment */
12423 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
12428 if (!FEATURE_REFALIASING_IS_ENABLED)
12430 "Experimental aliasing via reference not enabled");
12431 Perl_ck_warner_d(aTHX_
12432 packWARN(WARN_EXPERIMENTAL__REFALIASING),
12433 "Aliasing via reference is experimental");
12435 o->op_flags |= OPf_STACKED;
12436 op_sibling_splice(o, right, 1, varop);
12439 o->op_flags &=~ OPf_STACKED;
12440 op_sibling_splice(o, right, 1, NULL);
12447 Perl_ck_repeat(pTHX_ OP *o)
12449 PERL_ARGS_ASSERT_CK_REPEAT;
12451 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
12453 o->op_private |= OPpREPEAT_DOLIST;
12454 kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
12455 kids = force_list(kids, 1); /* promote it to a list */
12456 op_sibling_splice(o, NULL, 0, kids); /* and add back */
12464 Perl_ck_require(pTHX_ OP *o)
12468 PERL_ARGS_ASSERT_CK_REQUIRE;
12470 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
12471 SVOP * const kid = (SVOP*)cUNOPo->op_first;
12475 if (kid->op_type == OP_CONST) {
12476 SV * const sv = kid->op_sv;
12477 U32 const was_readonly = SvREADONLY(sv);
12478 if (kid->op_private & OPpCONST_BARE) {
12483 if (was_readonly) {
12484 SvREADONLY_off(sv);
12486 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
12491 /* treat ::foo::bar as foo::bar */
12492 if (len >= 2 && s[0] == ':' && s[1] == ':')
12493 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
12495 DIE(aTHX_ "Bareword in require maps to empty filename");
12497 for (; s < end; s++) {
12498 if (*s == ':' && s[1] == ':') {
12500 Move(s+2, s+1, end - s - 1, char);
12504 SvEND_set(sv, end);
12505 sv_catpvs(sv, ".pm");
12506 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
12507 hek = share_hek(SvPVX(sv),
12508 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
12510 sv_sethek(sv, hek);
12512 SvFLAGS(sv) |= was_readonly;
12514 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
12517 if (SvREFCNT(sv) > 1) {
12518 kid->op_sv = newSVpvn_share(
12519 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
12520 SvREFCNT_dec_NN(sv);
12525 if (was_readonly) SvREADONLY_off(sv);
12526 PERL_HASH(hash, s, len);
12528 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
12530 sv_sethek(sv, hek);
12532 SvFLAGS(sv) |= was_readonly;
12538 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
12539 /* handle override, if any */
12540 && (gv = gv_override("require", 7))) {
12542 if (o->op_flags & OPf_KIDS) {
12543 kid = cUNOPo->op_first;
12544 op_sibling_splice(o, NULL, -1, NULL);
12547 kid = newDEFSVOP();
12550 newop = S_new_entersubop(aTHX_ gv, kid);
12558 Perl_ck_return(pTHX_ OP *o)
12562 PERL_ARGS_ASSERT_CK_RETURN;
12564 kid = OpSIBLING(cLISTOPo->op_first);
12565 if (PL_compcv && CvLVALUE(PL_compcv)) {
12566 for (; kid; kid = OpSIBLING(kid))
12567 op_lvalue(kid, OP_LEAVESUBLV);
12574 Perl_ck_select(pTHX_ OP *o)
12579 PERL_ARGS_ASSERT_CK_SELECT;
12581 if (o->op_flags & OPf_KIDS) {
12582 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12583 if (kid && OpHAS_SIBLING(kid)) {
12584 OpTYPE_set(o, OP_SSELECT);
12586 return fold_constants(op_integerize(op_std_init(o)));
12590 kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12591 if (kid && kid->op_type == OP_RV2GV)
12592 kid->op_private &= ~HINT_STRICT_REFS;
12597 Perl_ck_shift(pTHX_ OP *o)
12599 const I32 type = o->op_type;
12601 PERL_ARGS_ASSERT_CK_SHIFT;
12603 if (!(o->op_flags & OPf_KIDS)) {
12606 if (!CvUNIQUE(PL_compcv)) {
12607 o->op_flags |= OPf_SPECIAL;
12611 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
12613 return newUNOP(type, 0, scalar(argop));
12615 return scalar(ck_fun(o));
12619 Perl_ck_sort(pTHX_ OP *o)
12623 HV * const hinthv =
12624 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
12627 PERL_ARGS_ASSERT_CK_SORT;
12630 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
12632 const I32 sorthints = (I32)SvIV(*svp);
12633 if ((sorthints & HINT_SORT_STABLE) != 0)
12634 o->op_private |= OPpSORT_STABLE;
12635 if ((sorthints & HINT_SORT_UNSTABLE) != 0)
12636 o->op_private |= OPpSORT_UNSTABLE;
12640 if (o->op_flags & OPf_STACKED)
12642 firstkid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12644 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
12645 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
12647 /* if the first arg is a code block, process it and mark sort as
12649 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
12651 if (kid->op_type == OP_LEAVE)
12652 op_null(kid); /* wipe out leave */
12653 /* Prevent execution from escaping out of the sort block. */
12656 /* provide scalar context for comparison function/block */
12657 kid = scalar(firstkid);
12658 kid->op_next = kid;
12659 o->op_flags |= OPf_SPECIAL;
12661 else if (kid->op_type == OP_CONST
12662 && kid->op_private & OPpCONST_BARE) {
12666 const char * const name = SvPV(kSVOP_sv, len);
12668 assert (len < 256);
12669 Copy(name, tmpbuf+1, len, char);
12670 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
12671 if (off != NOT_IN_PAD) {
12672 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
12674 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
12675 sv_catpvs(fq, "::");
12676 sv_catsv(fq, kSVOP_sv);
12677 SvREFCNT_dec_NN(kSVOP_sv);
12681 OP * const padop = newOP(OP_PADCV, 0);
12682 padop->op_targ = off;
12683 /* replace the const op with the pad op */
12684 op_sibling_splice(firstkid, NULL, 1, padop);
12690 firstkid = OpSIBLING(firstkid);
12693 for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
12694 /* provide list context for arguments */
12697 op_lvalue(kid, OP_GREPSTART);
12703 /* for sort { X } ..., where X is one of
12704 * $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
12705 * elide the second child of the sort (the one containing X),
12706 * and set these flags as appropriate
12710 * Also, check and warn on lexical $a, $b.
12714 S_simplify_sort(pTHX_ OP *o)
12716 OP *kid = OpSIBLING(cLISTOPo->op_first); /* get past pushmark */
12720 const char *gvname;
12723 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
12725 kid = kUNOP->op_first; /* get past null */
12726 if (!(have_scopeop = kid->op_type == OP_SCOPE)
12727 && kid->op_type != OP_LEAVE)
12729 kid = kLISTOP->op_last; /* get past scope */
12730 switch(kid->op_type) {
12734 if (!have_scopeop) goto padkids;
12739 k = kid; /* remember this node*/
12740 if (kBINOP->op_first->op_type != OP_RV2SV
12741 || kBINOP->op_last ->op_type != OP_RV2SV)
12744 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
12745 then used in a comparison. This catches most, but not
12746 all cases. For instance, it catches
12747 sort { my($a); $a <=> $b }
12749 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
12750 (although why you'd do that is anyone's guess).
12754 if (!ckWARN(WARN_SYNTAX)) return;
12755 kid = kBINOP->op_first;
12757 if (kid->op_type == OP_PADSV) {
12758 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
12759 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
12760 && ( PadnamePV(name)[1] == 'a'
12761 || PadnamePV(name)[1] == 'b' ))
12762 /* diag_listed_as: "my %s" used in sort comparison */
12763 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12764 "\"%s %s\" used in sort comparison",
12765 PadnameIsSTATE(name)
12770 } while ((kid = OpSIBLING(kid)));
12773 kid = kBINOP->op_first; /* get past cmp */
12774 if (kUNOP->op_first->op_type != OP_GV)
12776 kid = kUNOP->op_first; /* get past rv2sv */
12778 if (GvSTASH(gv) != PL_curstash)
12780 gvname = GvNAME(gv);
12781 if (*gvname == 'a' && gvname[1] == '\0')
12783 else if (*gvname == 'b' && gvname[1] == '\0')
12788 kid = k; /* back to cmp */
12789 /* already checked above that it is rv2sv */
12790 kid = kBINOP->op_last; /* down to 2nd arg */
12791 if (kUNOP->op_first->op_type != OP_GV)
12793 kid = kUNOP->op_first; /* get past rv2sv */
12795 if (GvSTASH(gv) != PL_curstash)
12797 gvname = GvNAME(gv);
12799 ? !(*gvname == 'a' && gvname[1] == '\0')
12800 : !(*gvname == 'b' && gvname[1] == '\0'))
12802 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
12804 o->op_private |= OPpSORT_DESCEND;
12805 if (k->op_type == OP_NCMP)
12806 o->op_private |= OPpSORT_NUMERIC;
12807 if (k->op_type == OP_I_NCMP)
12808 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
12809 kid = OpSIBLING(cLISTOPo->op_first);
12810 /* cut out and delete old block (second sibling) */
12811 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
12816 Perl_ck_split(pTHX_ OP *o)
12822 PERL_ARGS_ASSERT_CK_SPLIT;
12824 assert(o->op_type == OP_LIST);
12826 if (o->op_flags & OPf_STACKED)
12827 return no_fh_allowed(o);
12829 kid = cLISTOPo->op_first;
12830 /* delete leading NULL node, then add a CONST if no other nodes */
12831 assert(kid->op_type == OP_NULL);
12832 op_sibling_splice(o, NULL, 1,
12833 OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
12835 kid = cLISTOPo->op_first;
12837 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
12838 /* remove match expression, and replace with new optree with
12839 * a match op at its head */
12840 op_sibling_splice(o, NULL, 1, NULL);
12841 /* pmruntime will handle split " " behavior with flag==2 */
12842 kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
12843 op_sibling_splice(o, NULL, 0, kid);
12846 assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
12848 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
12849 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
12850 "Use of /g modifier is meaningless in split");
12853 /* eliminate the split op, and move the match op (plus any children)
12854 * into its place, then convert the match op into a split op. i.e.
12856 * SPLIT MATCH SPLIT(ex-MATCH)
12858 * MATCH - A - B - C => R - A - B - C => R - A - B - C
12864 * (R, if it exists, will be a regcomp op)
12867 op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
12868 sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
12869 op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
12870 OpTYPE_set(kid, OP_SPLIT);
12871 kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS));
12872 kid->op_private = o->op_private;
12875 kid = sibs; /* kid is now the string arg of the split */
12878 kid = newDEFSVOP();
12879 op_append_elem(OP_SPLIT, o, kid);
12883 kid = OpSIBLING(kid);
12885 kid = newSVOP(OP_CONST, 0, newSViv(0));
12886 op_append_elem(OP_SPLIT, o, kid);
12887 o->op_private |= OPpSPLIT_IMPLIM;
12891 if (OpHAS_SIBLING(kid))
12892 return too_many_arguments_pv(o,OP_DESC(o), 0);
12898 Perl_ck_stringify(pTHX_ OP *o)
12900 OP * const kid = OpSIBLING(cUNOPo->op_first);
12901 PERL_ARGS_ASSERT_CK_STRINGIFY;
12902 if (( kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
12903 || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
12904 || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
12905 && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
12907 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
12915 Perl_ck_join(pTHX_ OP *o)
12917 OP * const kid = OpSIBLING(cLISTOPo->op_first);
12919 PERL_ARGS_ASSERT_CK_JOIN;
12921 if (kid && kid->op_type == OP_MATCH) {
12922 if (ckWARN(WARN_SYNTAX)) {
12923 const REGEXP *re = PM_GETRE(kPMOP);
12925 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
12926 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
12927 : newSVpvs_flags( "STRING", SVs_TEMP );
12928 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12929 "/%" SVf "/ should probably be written as \"%" SVf "\"",
12930 SVfARG(msg), SVfARG(msg));
12934 && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
12935 || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
12936 || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
12937 && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
12939 const OP * const bairn = OpSIBLING(kid); /* the list */
12940 if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
12941 && OP_GIMME(bairn,0) == G_SCALAR)
12943 OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
12944 op_sibling_splice(o, kid, 1, NULL));
12954 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
12956 Examines an op, which is expected to identify a subroutine at runtime,
12957 and attempts to determine at compile time which subroutine it identifies.
12958 This is normally used during Perl compilation to determine whether
12959 a prototype can be applied to a function call. C<cvop> is the op
12960 being considered, normally an C<rv2cv> op. A pointer to the identified
12961 subroutine is returned, if it could be determined statically, and a null
12962 pointer is returned if it was not possible to determine statically.
12964 Currently, the subroutine can be identified statically if the RV that the
12965 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
12966 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
12967 suitable if the constant value must be an RV pointing to a CV. Details of
12968 this process may change in future versions of Perl. If the C<rv2cv> op
12969 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
12970 the subroutine statically: this flag is used to suppress compile-time
12971 magic on a subroutine call, forcing it to use default runtime behaviour.
12973 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
12974 of a GV reference is modified. If a GV was examined and its CV slot was
12975 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
12976 If the op is not optimised away, and the CV slot is later populated with
12977 a subroutine having a prototype, that flag eventually triggers the warning
12978 "called too early to check prototype".
12980 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
12981 of returning a pointer to the subroutine it returns a pointer to the
12982 GV giving the most appropriate name for the subroutine in this context.
12983 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
12984 (C<CvANON>) subroutine that is referenced through a GV it will be the
12985 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
12986 A null pointer is returned as usual if there is no statically-determinable
12992 /* shared by toke.c:yylex */
12994 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
12996 PADNAME *name = PAD_COMPNAME(off);
12997 CV *compcv = PL_compcv;
12998 while (PadnameOUTER(name)) {
12999 assert(PARENT_PAD_INDEX(name));
13000 compcv = CvOUTSIDE(compcv);
13001 name = PadlistNAMESARRAY(CvPADLIST(compcv))
13002 [off = PARENT_PAD_INDEX(name)];
13004 assert(!PadnameIsOUR(name));
13005 if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13006 return PadnamePROTOCV(name);
13008 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13012 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13017 PERL_ARGS_ASSERT_RV2CV_OP_CV;
13018 if (flags & ~RV2CVOPCV_FLAG_MASK)
13019 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13020 if (cvop->op_type != OP_RV2CV)
13022 if (cvop->op_private & OPpENTERSUB_AMPER)
13024 if (!(cvop->op_flags & OPf_KIDS))
13026 rvop = cUNOPx(cvop)->op_first;
13027 switch (rvop->op_type) {
13029 gv = cGVOPx_gv(rvop);
13031 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13032 cv = MUTABLE_CV(SvRV(gv));
13036 if (flags & RV2CVOPCV_RETURN_STUB)
13042 if (flags & RV2CVOPCV_MARK_EARLY)
13043 rvop->op_private |= OPpEARLY_CV;
13048 SV *rv = cSVOPx_sv(rvop);
13051 cv = (CV*)SvRV(rv);
13055 cv = find_lexical_cv(rvop->op_targ);
13060 } NOT_REACHED; /* NOTREACHED */
13062 if (SvTYPE((SV*)cv) != SVt_PVCV)
13064 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13065 if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13069 else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13070 if (CvLEXICAL(cv) || CvNAMED(cv))
13072 if (!CvANON(cv) || !gv)
13082 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
13084 Performs the default fixup of the arguments part of an C<entersub>
13085 op tree. This consists of applying list context to each of the
13086 argument ops. This is the standard treatment used on a call marked
13087 with C<&>, or a method call, or a call through a subroutine reference,
13088 or any other call where the callee can't be identified at compile time,
13089 or a call where the callee has no prototype.
13095 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13099 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
13101 aop = cUNOPx(entersubop)->op_first;
13102 if (!OpHAS_SIBLING(aop))
13103 aop = cUNOPx(aop)->op_first;
13104 for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
13105 /* skip the extra attributes->import() call implicitly added in
13106 * something like foo(my $x : bar)
13108 if ( aop->op_type == OP_ENTERSUB
13109 && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
13113 op_lvalue(aop, OP_ENTERSUB);
13119 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
13121 Performs the fixup of the arguments part of an C<entersub> op tree
13122 based on a subroutine prototype. This makes various modifications to
13123 the argument ops, from applying context up to inserting C<refgen> ops,
13124 and checking the number and syntactic types of arguments, as directed by
13125 the prototype. This is the standard treatment used on a subroutine call,
13126 not marked with C<&>, where the callee can be identified at compile time
13127 and has a prototype.
13129 C<protosv> supplies the subroutine prototype to be applied to the call.
13130 It may be a normal defined scalar, of which the string value will be used.
13131 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13132 that has been cast to C<SV*>) which has a prototype. The prototype
13133 supplied, in whichever form, does not need to match the actual callee
13134 referenced by the op tree.
13136 If the argument ops disagree with the prototype, for example by having
13137 an unacceptable number of arguments, a valid op tree is returned anyway.
13138 The error is reflected in the parser state, normally resulting in a single
13139 exception at the top level of parsing which covers all the compilation
13140 errors that occurred. In the error message, the callee is referred to
13141 by the name defined by the C<namegv> parameter.
13147 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13150 const char *proto, *proto_end;
13151 OP *aop, *prev, *cvop, *parent;
13154 I32 contextclass = 0;
13155 const char *e = NULL;
13156 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
13157 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
13158 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
13159 "flags=%lx", (unsigned long) SvFLAGS(protosv));
13160 if (SvTYPE(protosv) == SVt_PVCV)
13161 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
13162 else proto = SvPV(protosv, proto_len);
13163 proto = S_strip_spaces(aTHX_ proto, &proto_len);
13164 proto_end = proto + proto_len;
13165 parent = entersubop;
13166 aop = cUNOPx(entersubop)->op_first;
13167 if (!OpHAS_SIBLING(aop)) {
13169 aop = cUNOPx(aop)->op_first;
13172 aop = OpSIBLING(aop);
13173 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13174 while (aop != cvop) {
13177 if (proto >= proto_end)
13179 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13180 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13181 SVfARG(namesv)), SvUTF8(namesv));
13191 /* _ must be at the end */
13192 if (proto[1] && !strchr(";@%", proto[1]))
13208 if ( o3->op_type != OP_UNDEF
13209 && (o3->op_type != OP_SREFGEN
13210 || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13212 && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
13214 bad_type_gv(arg, namegv, o3,
13215 arg == 1 ? "block or sub {}" : "sub {}");
13218 /* '*' allows any scalar type, including bareword */
13221 if (o3->op_type == OP_RV2GV)
13222 goto wrapref; /* autoconvert GLOB -> GLOBref */
13223 else if (o3->op_type == OP_CONST)
13224 o3->op_private &= ~OPpCONST_STRICT;
13230 if (o3->op_type == OP_RV2AV ||
13231 o3->op_type == OP_PADAV ||
13232 o3->op_type == OP_RV2HV ||
13233 o3->op_type == OP_PADHV
13239 case '[': case ']':
13246 switch (*proto++) {
13248 if (contextclass++ == 0) {
13249 e = (char *) memchr(proto, ']', proto_end - proto);
13250 if (!e || e == proto)
13258 if (contextclass) {
13259 const char *p = proto;
13260 const char *const end = proto;
13262 while (*--p != '[')
13263 /* \[$] accepts any scalar lvalue */
13265 && Perl_op_lvalue_flags(aTHX_
13267 OP_READ, /* not entersub */
13270 bad_type_gv(arg, namegv, o3,
13271 Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
13276 if (o3->op_type == OP_RV2GV)
13279 bad_type_gv(arg, namegv, o3, "symbol");
13282 if (o3->op_type == OP_ENTERSUB
13283 && !(o3->op_flags & OPf_STACKED))
13286 bad_type_gv(arg, namegv, o3, "subroutine");
13289 if (o3->op_type == OP_RV2SV ||
13290 o3->op_type == OP_PADSV ||
13291 o3->op_type == OP_HELEM ||
13292 o3->op_type == OP_AELEM)
13294 if (!contextclass) {
13295 /* \$ accepts any scalar lvalue */
13296 if (Perl_op_lvalue_flags(aTHX_
13298 OP_READ, /* not entersub */
13301 bad_type_gv(arg, namegv, o3, "scalar");
13305 if (o3->op_type == OP_RV2AV ||
13306 o3->op_type == OP_PADAV)
13308 o3->op_flags &=~ OPf_PARENS;
13312 bad_type_gv(arg, namegv, o3, "array");
13315 if (o3->op_type == OP_RV2HV ||
13316 o3->op_type == OP_PADHV)
13318 o3->op_flags &=~ OPf_PARENS;
13322 bad_type_gv(arg, namegv, o3, "hash");
13325 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
13327 if (contextclass && e) {
13332 default: goto oops;
13342 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
13343 SVfARG(cv_name((CV *)namegv, NULL, 0)),
13348 op_lvalue(aop, OP_ENTERSUB);
13350 aop = OpSIBLING(aop);
13352 if (aop == cvop && *proto == '_') {
13353 /* generate an access to $_ */
13354 op_sibling_splice(parent, prev, 0, newDEFSVOP());
13356 if (!optional && proto_end > proto &&
13357 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
13359 SV * const namesv = cv_name((CV *)namegv, NULL, 0);
13360 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
13361 SVfARG(namesv)), SvUTF8(namesv));
13367 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
13369 Performs the fixup of the arguments part of an C<entersub> op tree either
13370 based on a subroutine prototype or using default list-context processing.
13371 This is the standard treatment used on a subroutine call, not marked
13372 with C<&>, where the callee can be identified at compile time.
13374 C<protosv> supplies the subroutine prototype to be applied to the call,
13375 or indicates that there is no prototype. It may be a normal scalar,
13376 in which case if it is defined then the string value will be used
13377 as a prototype, and if it is undefined then there is no prototype.
13378 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
13379 that has been cast to C<SV*>), of which the prototype will be used if it
13380 has one. The prototype (or lack thereof) supplied, in whichever form,
13381 does not need to match the actual callee referenced by the op tree.
13383 If the argument ops disagree with the prototype, for example by having
13384 an unacceptable number of arguments, a valid op tree is returned anyway.
13385 The error is reflected in the parser state, normally resulting in a single
13386 exception at the top level of parsing which covers all the compilation
13387 errors that occurred. In the error message, the callee is referred to
13388 by the name defined by the C<namegv> parameter.
13394 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
13395 GV *namegv, SV *protosv)
13397 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
13398 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
13399 return ck_entersub_args_proto(entersubop, namegv, protosv);
13401 return ck_entersub_args_list(entersubop);
13405 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
13407 IV cvflags = SvIVX(protosv);
13408 int opnum = cvflags & 0xffff;
13409 OP *aop = cUNOPx(entersubop)->op_first;
13411 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
13415 if (!OpHAS_SIBLING(aop))
13416 aop = cUNOPx(aop)->op_first;
13417 aop = OpSIBLING(aop);
13418 for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13420 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13421 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13422 SVfARG(namesv)), SvUTF8(namesv));
13425 op_free(entersubop);
13426 switch(cvflags >> 16) {
13427 case 'F': return newSVOP(OP_CONST, 0,
13428 newSVpv(CopFILE(PL_curcop),0));
13429 case 'L': return newSVOP(
13431 Perl_newSVpvf(aTHX_
13432 "%" IVdf, (IV)CopLINE(PL_curcop)
13435 case 'P': return newSVOP(OP_CONST, 0,
13437 ? newSVhek(HvNAME_HEK(PL_curstash))
13442 NOT_REACHED; /* NOTREACHED */
13445 OP *prev, *cvop, *first, *parent;
13448 parent = entersubop;
13449 if (!OpHAS_SIBLING(aop)) {
13451 aop = cUNOPx(aop)->op_first;
13454 first = prev = aop;
13455 aop = OpSIBLING(aop);
13456 /* find last sibling */
13458 OpHAS_SIBLING(cvop);
13459 prev = cvop, cvop = OpSIBLING(cvop))
13461 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
13462 /* Usually, OPf_SPECIAL on an op with no args means that it had
13463 * parens, but these have their own meaning for that flag: */
13464 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
13465 && opnum != OP_DELETE && opnum != OP_EXISTS)
13466 flags |= OPf_SPECIAL;
13467 /* excise cvop from end of sibling chain */
13468 op_sibling_splice(parent, prev, 1, NULL);
13470 if (aop == cvop) aop = NULL;
13472 /* detach remaining siblings from the first sibling, then
13473 * dispose of original optree */
13476 op_sibling_splice(parent, first, -1, NULL);
13477 op_free(entersubop);
13479 if (cvflags == (OP_ENTEREVAL | (1<<16)))
13480 flags |= OPpEVAL_BYTES <<8;
13482 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
13484 case OA_BASEOP_OR_UNOP:
13485 case OA_FILESTATOP:
13486 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
13489 SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
13490 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
13491 SVfARG(namesv)), SvUTF8(namesv));
13494 return opnum == OP_RUNCV
13495 ? newPVOP(OP_RUNCV,0,NULL)
13498 return op_convert_list(opnum,0,aop);
13501 NOT_REACHED; /* NOTREACHED */
13506 =for apidoc Am|void|cv_get_call_checker_flags|CV *cv|U32 gflags|Perl_call_checker *ckfun_p|SV **ckobj_p|U32 *ckflags_p
13508 Retrieves the function that will be used to fix up a call to C<cv>.
13509 Specifically, the function is applied to an C<entersub> op tree for a
13510 subroutine call, not marked with C<&>, where the callee can be identified
13511 at compile time as C<cv>.
13513 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
13514 for it is returned in C<*ckobj_p>, and control flags are returned in
13515 C<*ckflags_p>. The function is intended to be called in this manner:
13517 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
13519 In this call, C<entersubop> is a pointer to the C<entersub> op,
13520 which may be replaced by the check function, and C<namegv> supplies
13521 the name that should be used by the check function to refer
13522 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13523 It is permitted to apply the check function in non-standard situations,
13524 such as to a call to a different subroutine or to a method call.
13526 C<namegv> may not actually be a GV. If the C<CALL_CHECKER_REQUIRE_GV>
13527 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
13528 instead, anything that can be used as the first argument to L</cv_name>.
13529 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
13530 check function requires C<namegv> to be a genuine GV.
13532 By default, the check function is
13533 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
13534 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
13535 flag is clear. This implements standard prototype processing. It can
13536 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
13538 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
13539 indicates that the caller only knows about the genuine GV version of
13540 C<namegv>, and accordingly the corresponding bit will always be set in
13541 C<*ckflags_p>, regardless of the check function's recorded requirements.
13542 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
13543 indicates the caller knows about the possibility of passing something
13544 other than a GV as C<namegv>, and accordingly the corresponding bit may
13545 be either set or clear in C<*ckflags_p>, indicating the check function's
13546 recorded requirements.
13548 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
13549 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
13550 (for which see above). All other bits should be clear.
13552 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
13554 The original form of L</cv_get_call_checker_flags>, which does not return
13555 checker flags. When using a checker function returned by this function,
13556 it is only safe to call it with a genuine GV as its C<namegv> argument.
13562 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
13563 Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
13566 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
13567 PERL_UNUSED_CONTEXT;
13568 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
13570 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
13571 *ckobj_p = callmg->mg_obj;
13572 *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
13574 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
13575 *ckobj_p = (SV*)cv;
13576 *ckflags_p = gflags & MGf_REQUIRE_GV;
13581 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
13584 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
13585 PERL_UNUSED_CONTEXT;
13586 cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
13591 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 ckflags
13593 Sets the function that will be used to fix up a call to C<cv>.
13594 Specifically, the function is applied to an C<entersub> op tree for a
13595 subroutine call, not marked with C<&>, where the callee can be identified
13596 at compile time as C<cv>.
13598 The C-level function pointer is supplied in C<ckfun>, an SV argument for
13599 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
13600 The function should be defined like this:
13602 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
13604 It is intended to be called in this manner:
13606 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
13608 In this call, C<entersubop> is a pointer to the C<entersub> op,
13609 which may be replaced by the check function, and C<namegv> supplies
13610 the name that should be used by the check function to refer
13611 to the callee of the C<entersub> op if it needs to emit any diagnostics.
13612 It is permitted to apply the check function in non-standard situations,
13613 such as to a call to a different subroutine or to a method call.
13615 C<namegv> may not actually be a GV. For efficiency, perl may pass a
13616 CV or other SV instead. Whatever is passed can be used as the first
13617 argument to L</cv_name>. You can force perl to pass a GV by including
13618 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
13620 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
13621 bit currently has a defined meaning (for which see above). All other
13622 bits should be clear.
13624 The current setting for a particular CV can be retrieved by
13625 L</cv_get_call_checker_flags>.
13627 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
13629 The original form of L</cv_set_call_checker_flags>, which passes it the
13630 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility. The effect
13631 of that flag setting is that the check function is guaranteed to get a
13632 genuine GV as its C<namegv> argument.
13638 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
13640 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
13641 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
13645 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
13646 SV *ckobj, U32 ckflags)
13648 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
13649 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
13650 if (SvMAGICAL((SV*)cv))
13651 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
13654 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
13655 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
13657 if (callmg->mg_flags & MGf_REFCOUNTED) {
13658 SvREFCNT_dec(callmg->mg_obj);
13659 callmg->mg_flags &= ~MGf_REFCOUNTED;
13661 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
13662 callmg->mg_obj = ckobj;
13663 if (ckobj != (SV*)cv) {
13664 SvREFCNT_inc_simple_void_NN(ckobj);
13665 callmg->mg_flags |= MGf_REFCOUNTED;
13667 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
13668 | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
13673 S_entersub_alloc_targ(pTHX_ OP * const o)
13675 o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
13676 o->op_private |= OPpENTERSUB_HASTARG;
13680 Perl_ck_subr(pTHX_ OP *o)
13685 SV **const_class = NULL;
13687 PERL_ARGS_ASSERT_CK_SUBR;
13689 aop = cUNOPx(o)->op_first;
13690 if (!OpHAS_SIBLING(aop))
13691 aop = cUNOPx(aop)->op_first;
13692 aop = OpSIBLING(aop);
13693 for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
13694 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
13695 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
13697 o->op_private &= ~1;
13698 o->op_private |= (PL_hints & HINT_STRICT_REFS);
13699 if (PERLDB_SUB && PL_curstash != PL_debstash)
13700 o->op_private |= OPpENTERSUB_DB;
13701 switch (cvop->op_type) {
13703 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
13707 case OP_METHOD_NAMED:
13708 case OP_METHOD_SUPER:
13709 case OP_METHOD_REDIR:
13710 case OP_METHOD_REDIR_SUPER:
13711 o->op_flags |= OPf_REF;
13712 if (aop->op_type == OP_CONST) {
13713 aop->op_private &= ~OPpCONST_STRICT;
13714 const_class = &cSVOPx(aop)->op_sv;
13716 else if (aop->op_type == OP_LIST) {
13717 OP * const sib = OpSIBLING(((UNOP*)aop)->op_first);
13718 if (sib && sib->op_type == OP_CONST) {
13719 sib->op_private &= ~OPpCONST_STRICT;
13720 const_class = &cSVOPx(sib)->op_sv;
13723 /* make class name a shared cow string to speedup method calls */
13724 /* constant string might be replaced with object, f.e. bigint */
13725 if (const_class && SvPOK(*const_class)) {
13727 const char* str = SvPV(*const_class, len);
13729 SV* const shared = newSVpvn_share(
13730 str, SvUTF8(*const_class)
13731 ? -(SSize_t)len : (SSize_t)len,
13734 if (SvREADONLY(*const_class))
13735 SvREADONLY_on(shared);
13736 SvREFCNT_dec(*const_class);
13737 *const_class = shared;
13744 S_entersub_alloc_targ(aTHX_ o);
13745 return ck_entersub_args_list(o);
13747 Perl_call_checker ckfun;
13750 cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
13751 if (CvISXSUB(cv) || !CvROOT(cv))
13752 S_entersub_alloc_targ(aTHX_ o);
13754 /* The original call checker API guarantees that a GV will be
13755 be provided with the right name. So, if the old API was
13756 used (or the REQUIRE_GV flag was passed), we have to reify
13757 the CV’s GV, unless this is an anonymous sub. This is not
13758 ideal for lexical subs, as its stringification will include
13759 the package. But it is the best we can do. */
13760 if (ckflags & CALL_CHECKER_REQUIRE_GV) {
13761 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
13764 else namegv = MUTABLE_GV(cv);
13765 /* After a syntax error in a lexical sub, the cv that
13766 rv2cv_op_cv returns may be a nameless stub. */
13767 if (!namegv) return ck_entersub_args_list(o);
13770 return ckfun(aTHX_ o, namegv, ckobj);
13775 Perl_ck_svconst(pTHX_ OP *o)
13777 SV * const sv = cSVOPo->op_sv;
13778 PERL_ARGS_ASSERT_CK_SVCONST;
13779 PERL_UNUSED_CONTEXT;
13780 #ifdef PERL_COPY_ON_WRITE
13781 /* Since the read-only flag may be used to protect a string buffer, we
13782 cannot do copy-on-write with existing read-only scalars that are not
13783 already copy-on-write scalars. To allow $_ = "hello" to do COW with
13784 that constant, mark the constant as COWable here, if it is not
13785 already read-only. */
13786 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
13789 # ifdef PERL_DEBUG_READONLY_COW
13799 Perl_ck_trunc(pTHX_ OP *o)
13801 PERL_ARGS_ASSERT_CK_TRUNC;
13803 if (o->op_flags & OPf_KIDS) {
13804 SVOP *kid = (SVOP*)cUNOPo->op_first;
13806 if (kid->op_type == OP_NULL)
13807 kid = (SVOP*)OpSIBLING(kid);
13808 if (kid && kid->op_type == OP_CONST &&
13809 (kid->op_private & OPpCONST_BARE) &&
13812 o->op_flags |= OPf_SPECIAL;
13813 kid->op_private &= ~OPpCONST_STRICT;
13820 Perl_ck_substr(pTHX_ OP *o)
13822 PERL_ARGS_ASSERT_CK_SUBSTR;
13825 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
13826 OP *kid = cLISTOPo->op_first;
13828 if (kid->op_type == OP_NULL)
13829 kid = OpSIBLING(kid);
13831 /* Historically, substr(delete $foo{bar},...) has been allowed
13832 with 4-arg substr. Keep it working by applying entersub
13834 op_lvalue(kid, OP_ENTERSUB);
13841 Perl_ck_tell(pTHX_ OP *o)
13843 PERL_ARGS_ASSERT_CK_TELL;
13845 if (o->op_flags & OPf_KIDS) {
13846 OP *kid = cLISTOPo->op_first;
13847 if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
13848 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
13854 Perl_ck_each(pTHX_ OP *o)
13857 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
13858 const unsigned orig_type = o->op_type;
13860 PERL_ARGS_ASSERT_CK_EACH;
13863 switch (kid->op_type) {
13869 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
13870 : orig_type == OP_KEYS ? OP_AKEYS
13874 if (kid->op_private == OPpCONST_BARE
13875 || !SvROK(cSVOPx_sv(kid))
13876 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
13877 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
13882 qerror(Perl_mess(aTHX_
13883 "Experimental %s on scalar is now forbidden",
13884 PL_op_desc[orig_type]));
13886 bad_type_pv(1, "hash or array", o, kid);
13894 Perl_ck_length(pTHX_ OP *o)
13896 PERL_ARGS_ASSERT_CK_LENGTH;
13900 if (ckWARN(WARN_SYNTAX)) {
13901 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
13905 const bool hash = kid->op_type == OP_PADHV
13906 || kid->op_type == OP_RV2HV;
13907 switch (kid->op_type) {
13912 name = S_op_varname(aTHX_ kid);
13918 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13919 "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
13921 SVfARG(name), hash ? "keys " : "", SVfARG(name)
13924 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13925 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13926 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
13928 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
13929 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13930 "length() used on @array (did you mean \"scalar(@array)\"?)");
13940 ---------------------------------------------------------
13942 Common vars in list assignment
13944 There now follows some enums and static functions for detecting
13945 common variables in list assignments. Here is a little essay I wrote
13946 for myself when trying to get my head around this. DAPM.
13950 First some random observations:
13952 * If a lexical var is an alias of something else, e.g.
13953 for my $x ($lex, $pkg, $a[0]) {...}
13954 then the act of aliasing will increase the reference count of the SV
13956 * If a package var is an alias of something else, it may still have a
13957 reference count of 1, depending on how the alias was created, e.g.
13958 in *a = *b, $a may have a refcount of 1 since the GP is shared
13959 with a single GvSV pointer to the SV. So If it's an alias of another
13960 package var, then RC may be 1; if it's an alias of another scalar, e.g.
13961 a lexical var or an array element, then it will have RC > 1.
13963 * There are many ways to create a package alias; ultimately, XS code
13964 may quite legally do GvSV(gv) = SvREFCNT_inc(sv) for example, so
13965 run-time tracing mechanisms are unlikely to be able to catch all cases.
13967 * When the LHS is all my declarations, the same vars can't appear directly
13968 on the RHS, but they can indirectly via closures, aliasing and lvalue
13969 subs. But those techniques all involve an increase in the lexical
13970 scalar's ref count.
13972 * When the LHS is all lexical vars (but not necessarily my declarations),
13973 it is possible for the same lexicals to appear directly on the RHS, and
13974 without an increased ref count, since the stack isn't refcounted.
13975 This case can be detected at compile time by scanning for common lex
13976 vars with PL_generation.
13978 * lvalue subs defeat common var detection, but they do at least
13979 return vars with a temporary ref count increment. Also, you can't
13980 tell at compile time whether a sub call is lvalue.
13985 A: There are a few circumstances where there definitely can't be any
13988 LHS empty: () = (...);
13989 RHS empty: (....) = ();
13990 RHS contains only constants or other 'can't possibly be shared'
13991 elements (e.g. ops that return PADTMPs): (...) = (1,2, length)
13992 i.e. they only contain ops not marked as dangerous, whose children
13993 are also not dangerous;
13995 LHS contains a single scalar element: e.g. ($x) = (....); because
13996 after $x has been modified, it won't be used again on the RHS;
13997 RHS contains a single element with no aggregate on LHS: e.g.
13998 ($a,$b,$c) = ($x); again, once $a has been modified, its value
13999 won't be used again.
14001 B: If LHS are all 'my' lexical var declarations (or safe ops, which
14004 my ($a, $b, @c) = ...;
14006 Due to closure and goto tricks, these vars may already have content.
14007 For the same reason, an element on the RHS may be a lexical or package
14008 alias of one of the vars on the left, or share common elements, for
14011 my ($x,$y) = f(); # $x and $y on both sides
14012 sub f : lvalue { ($x,$y) = (1,2); $y, $x }
14017 my @a = @$ra; # elements of @a on both sides
14018 sub f { @a = 1..4; \@a }
14021 First, just consider scalar vars on LHS:
14023 RHS is safe only if (A), or in addition,
14024 * contains only lexical *scalar* vars, where neither side's
14025 lexicals have been flagged as aliases
14027 If RHS is not safe, then it's always legal to check LHS vars for
14028 RC==1, since the only RHS aliases will always be associated
14031 Note that in particular, RHS is not safe if:
14033 * it contains package scalar vars; e.g.:
14036 my ($x, $y) = (2, $x_alias);
14037 sub f { $x = 1; *x_alias = \$x; }
14039 * It contains other general elements, such as flattened or
14040 * spliced or single array or hash elements, e.g.
14043 my ($x,$y) = @a; # or $a[0] or @a{@b} etc
14047 use feature 'refaliasing';
14048 \($a[0], $a[1]) = \($y,$x);
14051 It doesn't matter if the array/hash is lexical or package.
14053 * it contains a function call that happens to be an lvalue
14054 sub which returns one or more of the above, e.g.
14065 (so a sub call on the RHS should be treated the same
14066 as having a package var on the RHS).
14068 * any other "dangerous" thing, such an op or built-in that
14069 returns one of the above, e.g. pp_preinc
14072 If RHS is not safe, what we can do however is at compile time flag
14073 that the LHS are all my declarations, and at run time check whether
14074 all the LHS have RC == 1, and if so skip the full scan.
14076 Now consider array and hash vars on LHS: e.g. my (...,@a) = ...;
14078 Here the issue is whether there can be elements of @a on the RHS
14079 which will get prematurely freed when @a is cleared prior to
14080 assignment. This is only a problem if the aliasing mechanism
14081 is one which doesn't increase the refcount - only if RC == 1
14082 will the RHS element be prematurely freed.
14084 Because the array/hash is being INTROed, it or its elements
14085 can't directly appear on the RHS:
14087 my (@a) = ($a[0], @a, etc) # NOT POSSIBLE
14089 but can indirectly, e.g.:
14093 sub f { @a = 1..3; \@a }
14095 So if the RHS isn't safe as defined by (A), we must always
14096 mortalise and bump the ref count of any remaining RHS elements
14097 when assigning to a non-empty LHS aggregate.
14099 Lexical scalars on the RHS aren't safe if they've been involved in
14102 use feature 'refaliasing';
14105 \(my $lex) = \$pkg;
14106 my @a = ($lex,3); # equivalent to ($a[0],3)
14113 Similarly with lexical arrays and hashes on the RHS:
14127 C: As (B), but in addition the LHS may contain non-intro lexicals, e.g.
14128 my $a; ($a, my $b) = (....);
14130 The difference between (B) and (C) is that it is now physically
14131 possible for the LHS vars to appear on the RHS too, where they
14132 are not reference counted; but in this case, the compile-time
14133 PL_generation sweep will detect such common vars.
14135 So the rules for (C) differ from (B) in that if common vars are
14136 detected, the runtime "test RC==1" optimisation can no longer be used,
14137 and a full mark and sweep is required
14139 D: As (C), but in addition the LHS may contain package vars.
14141 Since package vars can be aliased without a corresponding refcount
14142 increase, all bets are off. It's only safe if (A). E.g.
14144 my ($x, $y) = (1,2);
14146 for $x_alias ($x) {
14147 ($x_alias, $y) = (3, $x); # whoops
14150 Ditto for LHS aggregate package vars.
14152 E: Any other dangerous ops on LHS, e.g.
14153 (f(), $a[0], @$r) = (...);
14155 this is similar to (E) in that all bets are off. In addition, it's
14156 impossible to determine at compile time whether the LHS
14157 contains a scalar or an aggregate, e.g.
14159 sub f : lvalue { @a }
14162 * ---------------------------------------------------------
14166 /* A set of bit flags returned by S_aassign_scan(). Each flag indicates
14167 * that at least one of the things flagged was seen.
14171 AAS_MY_SCALAR = 0x001, /* my $scalar */
14172 AAS_MY_AGG = 0x002, /* aggregate: my @array or my %hash */
14173 AAS_LEX_SCALAR = 0x004, /* $lexical */
14174 AAS_LEX_AGG = 0x008, /* @lexical or %lexical aggregate */
14175 AAS_LEX_SCALAR_COMM = 0x010, /* $lexical seen on both sides */
14176 AAS_PKG_SCALAR = 0x020, /* $scalar (where $scalar is pkg var) */
14177 AAS_PKG_AGG = 0x040, /* package @array or %hash aggregate */
14178 AAS_DANGEROUS = 0x080, /* an op (other than the above)
14179 that's flagged OA_DANGEROUS */
14180 AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's
14181 not in any of the categories above */
14182 AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */
14187 /* helper function for S_aassign_scan().
14188 * check a PAD-related op for commonality and/or set its generation number.
14189 * Returns a boolean indicating whether its shared */
14192 S_aassign_padcheck(pTHX_ OP* o, bool rhs)
14194 if (PAD_COMPNAME_GEN(o->op_targ) == PERL_INT_MAX)
14195 /* lexical used in aliasing */
14199 return cBOOL(PAD_COMPNAME_GEN(o->op_targ) == (STRLEN)PL_generation);
14201 PAD_COMPNAME_GEN_set(o->op_targ, PL_generation);
14208 Helper function for OPpASSIGN_COMMON* detection in rpeep().
14209 It scans the left or right hand subtree of the aassign op, and returns a
14210 set of flags indicating what sorts of things it found there.
14211 'rhs' indicates whether we're scanning the LHS or RHS. If the former, we
14212 set PL_generation on lexical vars; if the latter, we see if
14213 PL_generation matches.
14214 'top' indicates whether we're recursing or at the top level.
14215 'scalars_p' is a pointer to a counter of the number of scalar SVs seen.
14216 This fn will increment it by the number seen. It's not intended to
14217 be an accurate count (especially as many ops can push a variable
14218 number of SVs onto the stack); rather it's used as to test whether there
14219 can be at most 1 SV pushed; so it's only meanings are "0, 1, many".
14223 S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p)
14226 bool kid_top = FALSE;
14228 /* first, look for a solitary @_ on the RHS */
14231 && (o->op_flags & OPf_KIDS)
14232 && OP_TYPE_IS_OR_WAS(o, OP_LIST)
14234 OP *kid = cUNOPo->op_first;
14235 if ( ( kid->op_type == OP_PUSHMARK
14236 || kid->op_type == OP_PADRANGE) /* ex-pushmark */
14237 && ((kid = OpSIBLING(kid)))
14238 && !OpHAS_SIBLING(kid)
14239 && kid->op_type == OP_RV2AV
14240 && !(kid->op_flags & OPf_REF)
14241 && !(kid->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
14242 && ((kid->op_flags & OPf_WANT) == OPf_WANT_LIST)
14243 && ((kid = cUNOPx(kid)->op_first))
14244 && kid->op_type == OP_GV
14245 && cGVOPx_gv(kid) == PL_defgv
14247 flags |= AAS_DEFAV;
14250 switch (o->op_type) {
14253 return AAS_PKG_SCALAR;
14258 /* if !top, could be e.g. @a[0,1] */
14259 if (top && (o->op_flags & OPf_REF))
14260 return (o->op_private & OPpLVAL_INTRO)
14261 ? AAS_MY_AGG : AAS_LEX_AGG;
14262 return AAS_DANGEROUS;
14266 int comm = S_aassign_padcheck(aTHX_ o, rhs)
14267 ? AAS_LEX_SCALAR_COMM : 0;
14269 return (o->op_private & OPpLVAL_INTRO)
14270 ? (AAS_MY_SCALAR|comm) : (AAS_LEX_SCALAR|comm);
14276 if (cUNOPx(o)->op_first->op_type != OP_GV)
14277 return AAS_DANGEROUS; /* @{expr}, %{expr} */
14279 /* if !top, could be e.g. @a[0,1] */
14280 if (top && (o->op_flags & OPf_REF))
14281 return AAS_PKG_AGG;
14282 return AAS_DANGEROUS;
14286 if (cUNOPx(o)->op_first->op_type != OP_GV) {
14288 return AAS_DANGEROUS; /* ${expr} */
14290 return AAS_PKG_SCALAR; /* $pkg */
14293 if (o->op_private & OPpSPLIT_ASSIGN) {
14294 /* the assign in @a = split() has been optimised away
14295 * and the @a attached directly to the split op
14296 * Treat the array as appearing on the RHS, i.e.
14297 * ... = (@a = split)
14302 if (o->op_flags & OPf_STACKED)
14303 /* @{expr} = split() - the array expression is tacked
14304 * on as an extra child to split - process kid */
14305 return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs,
14308 /* ... else array is directly attached to split op */
14310 if (PL_op->op_private & OPpSPLIT_LEX)
14311 return (o->op_private & OPpLVAL_INTRO)
14312 ? AAS_MY_AGG : AAS_LEX_AGG;
14314 return AAS_PKG_AGG;
14317 /* other args of split can't be returned */
14318 return AAS_SAFE_SCALAR;
14321 /* undef counts as a scalar on the RHS:
14322 * (undef, $x) = ...; # only 1 scalar on LHS: always safe
14323 * ($x, $y) = (undef, $x); # 2 scalars on RHS: unsafe
14327 flags = AAS_SAFE_SCALAR;
14332 /* these are all no-ops; they don't push a potentially common SV
14333 * onto the stack, so they are neither AAS_DANGEROUS nor
14334 * AAS_SAFE_SCALAR */
14337 case OP_PADRANGE: /* Ignore padrange; checking its siblings is enough */
14342 /* these do nothing but may have children; but their children
14343 * should also be treated as top-level */
14348 if (PL_opargs[o->op_type] & OA_DANGEROUS) {
14350 flags = AAS_DANGEROUS;
14354 if ( (PL_opargs[o->op_type] & OA_TARGLEX)
14355 && (o->op_private & OPpTARGET_MY))
14358 return S_aassign_padcheck(aTHX_ o, rhs)
14359 ? AAS_LEX_SCALAR_COMM : AAS_LEX_SCALAR;
14362 /* if its an unrecognised, non-dangerous op, assume that it
14363 * it the cause of at least one safe scalar */
14365 flags = AAS_SAFE_SCALAR;
14369 /* XXX this assumes that all other ops are "transparent" - i.e. that
14370 * they can return some of their children. While this true for e.g.
14371 * sort and grep, it's not true for e.g. map. We really need a
14372 * 'transparent' flag added to regen/opcodes
14374 if (o->op_flags & OPf_KIDS) {
14376 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
14377 flags |= S_aassign_scan(aTHX_ kid, rhs, kid_top, scalars_p);
14383 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14384 and modify the optree to make them work inplace */
14387 S_inplace_aassign(pTHX_ OP *o) {
14389 OP *modop, *modop_pushmark;
14391 OP *oleft, *oleft_pushmark;
14393 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14395 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14397 assert(cUNOPo->op_first->op_type == OP_NULL);
14398 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14399 assert(modop_pushmark->op_type == OP_PUSHMARK);
14400 modop = OpSIBLING(modop_pushmark);
14402 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14405 /* no other operation except sort/reverse */
14406 if (OpHAS_SIBLING(modop))
14409 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14410 if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14412 if (modop->op_flags & OPf_STACKED) {
14413 /* skip sort subroutine/block */
14414 assert(oright->op_type == OP_NULL);
14415 oright = OpSIBLING(oright);
14418 assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14419 oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14420 assert(oleft_pushmark->op_type == OP_PUSHMARK);
14421 oleft = OpSIBLING(oleft_pushmark);
14423 /* Check the lhs is an array */
14425 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14426 || OpHAS_SIBLING(oleft)
14427 || (oleft->op_private & OPpLVAL_INTRO)
14431 /* Only one thing on the rhs */
14432 if (OpHAS_SIBLING(oright))
14435 /* check the array is the same on both sides */
14436 if (oleft->op_type == OP_RV2AV) {
14437 if (oright->op_type != OP_RV2AV
14438 || !cUNOPx(oright)->op_first
14439 || cUNOPx(oright)->op_first->op_type != OP_GV
14440 || cUNOPx(oleft )->op_first->op_type != OP_GV
14441 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
14442 cGVOPx_gv(cUNOPx(oright)->op_first)
14446 else if (oright->op_type != OP_PADAV
14447 || oright->op_targ != oleft->op_targ
14451 /* This actually is an inplace assignment */
14453 modop->op_private |= OPpSORT_INPLACE;
14455 /* transfer MODishness etc from LHS arg to RHS arg */
14456 oright->op_flags = oleft->op_flags;
14458 /* remove the aassign op and the lhs */
14460 op_null(oleft_pushmark);
14461 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
14462 op_null(cUNOPx(oleft)->op_first);
14468 /* S_maybe_multideref(): given an op_next chain of ops beginning at 'start'
14469 * that potentially represent a series of one or more aggregate derefs
14470 * (such as $a->[1]{$key}), examine the chain, and if appropriate, convert
14471 * the whole chain to a single OP_MULTIDEREF op (maybe with a few
14472 * additional ops left in too).
14474 * The caller will have already verified that the first few ops in the
14475 * chain following 'start' indicate a multideref candidate, and will have
14476 * set 'orig_o' to the point further on in the chain where the first index
14477 * expression (if any) begins. 'orig_action' specifies what type of
14478 * beginning has already been determined by the ops between start..orig_o
14479 * (e.g. $lex_ary[], $pkg_ary->{}, expr->[], etc).
14481 * 'hints' contains any hints flags that need adding (currently just
14482 * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller.
14486 S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints)
14490 UNOP_AUX_item *arg_buf = NULL;
14491 bool reset_start_targ = FALSE; /* start->op_targ needs zeroing */
14492 int index_skip = -1; /* don't output index arg on this action */
14494 /* similar to regex compiling, do two passes; the first pass
14495 * determines whether the op chain is convertible and calculates the
14496 * buffer size; the second pass populates the buffer and makes any
14497 * changes necessary to ops (such as moving consts to the pad on
14498 * threaded builds).
14500 * NB: for things like Coverity, note that both passes take the same
14501 * path through the logic tree (except for 'if (pass)' bits), since
14502 * both passes are following the same op_next chain; and in
14503 * particular, if it would return early on the second pass, it would
14504 * already have returned early on the first pass.
14506 for (pass = 0; pass < 2; pass++) {
14508 UV action = orig_action;
14509 OP *first_elem_op = NULL; /* first seen aelem/helem */
14510 OP *top_op = NULL; /* highest [ah]elem/exists/del/rv2[ah]v */
14511 int action_count = 0; /* number of actions seen so far */
14512 int action_ix = 0; /* action_count % (actions per IV) */
14513 bool next_is_hash = FALSE; /* is the next lookup to be a hash? */
14514 bool is_last = FALSE; /* no more derefs to follow */
14515 bool maybe_aelemfast = FALSE; /* we can replace with aelemfast? */
14516 UNOP_AUX_item *arg = arg_buf;
14517 UNOP_AUX_item *action_ptr = arg_buf;
14520 action_ptr->uv = 0;
14524 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
14525 case MDEREF_HV_gvhv_helem:
14526 next_is_hash = TRUE;
14528 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
14529 case MDEREF_AV_gvav_aelem:
14531 #ifdef USE_ITHREADS
14532 arg->pad_offset = cPADOPx(start)->op_padix;
14533 /* stop it being swiped when nulled */
14534 cPADOPx(start)->op_padix = 0;
14536 arg->sv = cSVOPx(start)->op_sv;
14537 cSVOPx(start)->op_sv = NULL;
14543 case MDEREF_HV_padhv_helem:
14544 case MDEREF_HV_padsv_vivify_rv2hv_helem:
14545 next_is_hash = TRUE;
14547 case MDEREF_AV_padav_aelem:
14548 case MDEREF_AV_padsv_vivify_rv2av_aelem:
14550 arg->pad_offset = start->op_targ;
14551 /* we skip setting op_targ = 0 for now, since the intact
14552 * OP_PADXV is needed by S_check_hash_fields_and_hekify */
14553 reset_start_targ = TRUE;
14558 case MDEREF_HV_pop_rv2hv_helem:
14559 next_is_hash = TRUE;
14561 case MDEREF_AV_pop_rv2av_aelem:
14565 NOT_REACHED; /* NOTREACHED */
14570 /* look for another (rv2av/hv; get index;
14571 * aelem/helem/exists/delele) sequence */
14576 UV index_type = MDEREF_INDEX_none;
14578 if (action_count) {
14579 /* if this is not the first lookup, consume the rv2av/hv */
14581 /* for N levels of aggregate lookup, we normally expect
14582 * that the first N-1 [ah]elem ops will be flagged as
14583 * /DEREF (so they autovivifiy if necessary), and the last
14584 * lookup op not to be.
14585 * For other things (like @{$h{k1}{k2}}) extra scope or
14586 * leave ops can appear, so abandon the effort in that
14588 if (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
14591 /* rv2av or rv2hv sKR/1 */
14593 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14594 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14595 if (o->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
14598 /* at this point, we wouldn't expect any of these
14599 * possible private flags:
14600 * OPpMAYBE_LVSUB, OPpOUR_INTRO, OPpLVAL_INTRO
14601 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL (rv2hv only)
14603 ASSUME(!(o->op_private &
14604 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING)));
14606 hints = (o->op_private & OPpHINT_STRICT_REFS);
14608 /* make sure the type of the previous /DEREF matches the
14609 * type of the next lookup */
14610 ASSUME(o->op_type == (next_is_hash ? OP_RV2HV : OP_RV2AV));
14613 action = next_is_hash
14614 ? MDEREF_HV_vivify_rv2hv_helem
14615 : MDEREF_AV_vivify_rv2av_aelem;
14619 /* if this is the second pass, and we're at the depth where
14620 * previously we encountered a non-simple index expression,
14621 * stop processing the index at this point */
14622 if (action_count != index_skip) {
14624 /* look for one or more simple ops that return an array
14625 * index or hash key */
14627 switch (o->op_type) {
14629 /* it may be a lexical var index */
14630 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS
14631 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14632 ASSUME(!(o->op_private &
14633 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
14635 if ( OP_GIMME(o,0) == G_SCALAR
14636 && !(o->op_flags & (OPf_REF|OPf_MOD))
14637 && o->op_private == 0)
14640 arg->pad_offset = o->op_targ;
14642 index_type = MDEREF_INDEX_padsv;
14648 if (next_is_hash) {
14649 /* it's a constant hash index */
14650 if (!(SvFLAGS(cSVOPo_sv) & (SVf_IOK|SVf_NOK|SVf_POK)))
14651 /* "use constant foo => FOO; $h{+foo}" for
14652 * some weird FOO, can leave you with constants
14653 * that aren't simple strings. It's not worth
14654 * the extra hassle for those edge cases */
14659 OP * helem_op = o->op_next;
14661 ASSUME( helem_op->op_type == OP_HELEM
14662 || helem_op->op_type == OP_NULL);
14663 if (helem_op->op_type == OP_HELEM) {
14664 rop = (UNOP*)(((BINOP*)helem_op)->op_first);
14665 if ( helem_op->op_private & OPpLVAL_INTRO
14666 || rop->op_type != OP_RV2HV
14670 S_check_hash_fields_and_hekify(aTHX_ rop, cSVOPo);
14672 #ifdef USE_ITHREADS
14673 /* Relocate sv to the pad for thread safety */
14674 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
14675 arg->pad_offset = o->op_targ;
14678 arg->sv = cSVOPx_sv(o);
14683 /* it's a constant array index */
14685 SV *ix_sv = cSVOPo->op_sv;
14690 if ( action_count == 0
14693 && ( action == MDEREF_AV_padav_aelem
14694 || action == MDEREF_AV_gvav_aelem)
14696 maybe_aelemfast = TRUE;
14700 SvREFCNT_dec_NN(cSVOPo->op_sv);
14704 /* we've taken ownership of the SV */
14705 cSVOPo->op_sv = NULL;
14707 index_type = MDEREF_INDEX_const;
14712 /* it may be a package var index */
14714 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_PARENS|OPf_SPECIAL)));
14715 ASSUME(!(o->op_private & ~(OPpEARLY_CV)));
14716 if ( (o->op_flags & ~(OPf_PARENS|OPf_SPECIAL)) != OPf_WANT_SCALAR
14717 || o->op_private != 0
14722 if (kid->op_type != OP_RV2SV)
14725 ASSUME(!(kid->op_flags &
14726 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_REF
14727 |OPf_SPECIAL|OPf_PARENS)));
14728 ASSUME(!(kid->op_private &
14730 |OPpHINT_STRICT_REFS|OPpOUR_INTRO
14731 |OPpDEREF|OPpLVAL_INTRO)));
14732 if( (kid->op_flags &~ OPf_PARENS)
14733 != (OPf_WANT_SCALAR|OPf_KIDS)
14734 || (kid->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS))
14739 #ifdef USE_ITHREADS
14740 arg->pad_offset = cPADOPx(o)->op_padix;
14741 /* stop it being swiped when nulled */
14742 cPADOPx(o)->op_padix = 0;
14744 arg->sv = cSVOPx(o)->op_sv;
14745 cSVOPo->op_sv = NULL;
14749 index_type = MDEREF_INDEX_gvsv;
14754 } /* action_count != index_skip */
14756 action |= index_type;
14759 /* at this point we have either:
14760 * * detected what looks like a simple index expression,
14761 * and expect the next op to be an [ah]elem, or
14762 * an nulled [ah]elem followed by a delete or exists;
14763 * * found a more complex expression, so something other
14764 * than the above follows.
14767 /* possibly an optimised away [ah]elem (where op_next is
14768 * exists or delete) */
14769 if (o->op_type == OP_NULL)
14772 /* at this point we're looking for an OP_AELEM, OP_HELEM,
14773 * OP_EXISTS or OP_DELETE */
14775 /* if a custom array/hash access checker is in scope,
14776 * abandon optimisation attempt */
14777 if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14778 && PL_check[o->op_type] != Perl_ck_null)
14780 /* similarly for customised exists and delete */
14781 if ( (o->op_type == OP_EXISTS)
14782 && PL_check[o->op_type] != Perl_ck_exists)
14784 if ( (o->op_type == OP_DELETE)
14785 && PL_check[o->op_type] != Perl_ck_delete)
14788 if ( o->op_type != OP_AELEM
14789 || (o->op_private &
14790 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB))
14792 maybe_aelemfast = FALSE;
14794 /* look for aelem/helem/exists/delete. If it's not the last elem
14795 * lookup, it *must* have OPpDEREF_AV/HV, but not many other
14796 * flags; if it's the last, then it mustn't have
14797 * OPpDEREF_AV/HV, but may have lots of other flags, like
14798 * OPpLVAL_INTRO etc
14801 if ( index_type == MDEREF_INDEX_none
14802 || ( o->op_type != OP_AELEM && o->op_type != OP_HELEM
14803 && o->op_type != OP_EXISTS && o->op_type != OP_DELETE)
14807 /* we have aelem/helem/exists/delete with valid simple index */
14809 is_deref = (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
14810 && ( (o->op_private & OPpDEREF) == OPpDEREF_AV
14811 || (o->op_private & OPpDEREF) == OPpDEREF_HV);
14813 /* This doesn't make much sense but is legal:
14814 * @{ local $x[0][0] } = 1
14815 * Since scope exit will undo the autovivification,
14816 * don't bother in the first place. The OP_LEAVE
14817 * assertion is in case there are other cases of both
14818 * OPpLVAL_INTRO and OPpDEREF which don't include a scope
14819 * exit that would undo the local - in which case this
14820 * block of code would need rethinking.
14822 if (is_deref && (o->op_private & OPpLVAL_INTRO)) {
14824 OP *n = o->op_next;
14825 while (n && ( n->op_type == OP_NULL
14826 || n->op_type == OP_LIST))
14828 assert(n && n->op_type == OP_LEAVE);
14830 o->op_private &= ~OPpDEREF;
14835 ASSUME(!(o->op_flags &
14836 ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS)));
14837 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpDEREF)));
14839 ok = (o->op_flags &~ OPf_PARENS)
14840 == (OPf_WANT_SCALAR|OPf_KIDS|OPf_MOD)
14841 && !(o->op_private & ~(OPpDEREF|OPpARG2_MASK));
14843 else if (o->op_type == OP_EXISTS) {
14844 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14845 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14846 ASSUME(!(o->op_private & ~(OPpARG1_MASK|OPpEXISTS_SUB)));
14847 ok = !(o->op_private & ~OPpARG1_MASK);
14849 else if (o->op_type == OP_DELETE) {
14850 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
14851 |OPf_REF|OPf_MOD|OPf_SPECIAL)));
14852 ASSUME(!(o->op_private &
14853 ~(OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO)));
14854 /* don't handle slices or 'local delete'; the latter
14855 * is fairly rare, and has a complex runtime */
14856 ok = !(o->op_private & ~OPpARG1_MASK);
14857 if (OP_TYPE_IS_OR_WAS(cUNOPo->op_first, OP_AELEM))
14858 /* skip handling run-tome error */
14859 ok = (ok && cBOOL(o->op_flags & OPf_SPECIAL));
14862 ASSUME(o->op_type == OP_AELEM || o->op_type == OP_HELEM);
14863 ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD
14864 |OPf_PARENS|OPf_REF|OPf_SPECIAL)));
14865 ASSUME(!(o->op_private & ~(OPpARG2_MASK|OPpMAYBE_LVSUB
14866 |OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO)));
14867 ok = (o->op_private & OPpDEREF) != OPpDEREF_SV;
14872 if (!first_elem_op)
14876 next_is_hash = cBOOL((o->op_private & OPpDEREF) == OPpDEREF_HV);
14881 action |= MDEREF_FLAG_last;
14885 /* at this point we have something that started
14886 * promisingly enough (with rv2av or whatever), but failed
14887 * to find a simple index followed by an
14888 * aelem/helem/exists/delete. If this is the first action,
14889 * give up; but if we've already seen at least one
14890 * aelem/helem, then keep them and add a new action with
14891 * MDEREF_INDEX_none, which causes it to do the vivify
14892 * from the end of the previous lookup, and do the deref,
14893 * but stop at that point. So $a[0][expr] will do one
14894 * av_fetch, vivify and deref, then continue executing at
14899 index_skip = action_count;
14900 action |= MDEREF_FLAG_last;
14901 if (index_type != MDEREF_INDEX_none)
14906 action_ptr->uv |= (action << (action_ix * MDEREF_SHIFT));
14909 /* if there's no space for the next action, create a new slot
14910 * for it *before* we start adding args for that action */
14911 if ((action_ix + 1) * MDEREF_SHIFT > UVSIZE*8) {
14918 } /* while !is_last */
14926 mderef = newUNOP_AUX(OP_MULTIDEREF, 0, NULL, arg_buf);
14927 if (index_skip == -1) {
14928 mderef->op_flags = o->op_flags
14929 & (OPf_WANT|OPf_MOD|(next_is_hash ? OPf_SPECIAL : 0));
14930 if (o->op_type == OP_EXISTS)
14931 mderef->op_private = OPpMULTIDEREF_EXISTS;
14932 else if (o->op_type == OP_DELETE)
14933 mderef->op_private = OPpMULTIDEREF_DELETE;
14935 mderef->op_private = o->op_private
14936 & (OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpLVAL_INTRO);
14938 /* accumulate strictness from every level (although I don't think
14939 * they can actually vary) */
14940 mderef->op_private |= hints;
14942 /* integrate the new multideref op into the optree and the
14945 * In general an op like aelem or helem has two child
14946 * sub-trees: the aggregate expression (a_expr) and the
14947 * index expression (i_expr):
14953 * The a_expr returns an AV or HV, while the i-expr returns an
14954 * index. In general a multideref replaces most or all of a
14955 * multi-level tree, e.g.
14971 * With multideref, all the i_exprs will be simple vars or
14972 * constants, except that i_expr1 may be arbitrary in the case
14973 * of MDEREF_INDEX_none.
14975 * The bottom-most a_expr will be either:
14976 * 1) a simple var (so padXv or gv+rv2Xv);
14977 * 2) a simple scalar var dereferenced (e.g. $r->[0]):
14978 * so a simple var with an extra rv2Xv;
14979 * 3) or an arbitrary expression.
14981 * 'start', the first op in the execution chain, will point to
14982 * 1),2): the padXv or gv op;
14983 * 3): the rv2Xv which forms the last op in the a_expr
14984 * execution chain, and the top-most op in the a_expr
14987 * For all cases, the 'start' node is no longer required,
14988 * but we can't free it since one or more external nodes
14989 * may point to it. E.g. consider
14990 * $h{foo} = $a ? $b : $c
14991 * Here, both the op_next and op_other branches of the
14992 * cond_expr point to the gv[*h] of the hash expression, so
14993 * we can't free the 'start' op.
14995 * For expr->[...], we need to save the subtree containing the
14996 * expression; for the other cases, we just need to save the
14998 * So in all cases, we null the start op and keep it around by
14999 * making it the child of the multideref op; for the expr->
15000 * case, the expr will be a subtree of the start node.
15002 * So in the simple 1,2 case the optree above changes to
15008 * ex-gv (or ex-padxv)
15010 * with the op_next chain being
15012 * -> ex-gv -> multideref -> op-following-ex-exists ->
15014 * In the 3 case, we have
15027 * -> rest-of-a_expr subtree ->
15028 * ex-rv2xv -> multideref -> op-following-ex-exists ->
15031 * Where the last i_expr is non-simple (i.e. MDEREF_INDEX_none,
15032 * e.g. $a[0]{foo}[$x+1], the next rv2xv is nulled and the
15033 * multideref attached as the child, e.g.
15039 * ex-rv2av - i_expr1
15047 /* if we free this op, don't free the pad entry */
15048 if (reset_start_targ)
15049 start->op_targ = 0;
15052 /* Cut the bit we need to save out of the tree and attach to
15053 * the multideref op, then free the rest of the tree */
15055 /* find parent of node to be detached (for use by splice) */
15057 if ( orig_action == MDEREF_AV_pop_rv2av_aelem
15058 || orig_action == MDEREF_HV_pop_rv2hv_helem)
15060 /* there is an arbitrary expression preceding us, e.g.
15061 * expr->[..]? so we need to save the 'expr' subtree */
15062 if (p->op_type == OP_EXISTS || p->op_type == OP_DELETE)
15063 p = cUNOPx(p)->op_first;
15064 ASSUME( start->op_type == OP_RV2AV
15065 || start->op_type == OP_RV2HV);
15068 /* either a padXv or rv2Xv+gv, maybe with an ex-Xelem
15069 * above for exists/delete. */
15070 while ( (p->op_flags & OPf_KIDS)
15071 && cUNOPx(p)->op_first != start
15073 p = cUNOPx(p)->op_first;
15075 ASSUME(cUNOPx(p)->op_first == start);
15077 /* detach from main tree, and re-attach under the multideref */
15078 op_sibling_splice(mderef, NULL, 0,
15079 op_sibling_splice(p, NULL, 1, NULL));
15082 start->op_next = mderef;
15084 mderef->op_next = index_skip == -1 ? o->op_next : o;
15086 /* excise and free the original tree, and replace with
15087 * the multideref op */
15088 p = op_sibling_splice(top_op, NULL, -1, mderef);
15097 Size_t size = arg - arg_buf;
15099 if (maybe_aelemfast && action_count == 1)
15102 arg_buf = (UNOP_AUX_item*)PerlMemShared_malloc(
15103 sizeof(UNOP_AUX_item) * (size + 1));
15104 /* for dumping etc: store the length in a hidden first slot;
15105 * we set the op_aux pointer to the second slot */
15106 arg_buf->uv = size;
15109 } /* for (pass = ...) */
15112 /* See if the ops following o are such that o will always be executed in
15113 * boolean context: that is, the SV which o pushes onto the stack will
15114 * only ever be consumed by later ops via SvTRUE(sv) or similar.
15115 * If so, set a suitable private flag on o. Normally this will be
15116 * bool_flag; but see below why maybe_flag is needed too.
15118 * Typically the two flags you pass will be the generic OPpTRUEBOOL and
15119 * OPpMAYBE_TRUEBOOL, buts it's possible that for some ops those bits may
15120 * already be taken, so you'll have to give that op two different flags.
15122 * More explanation of 'maybe_flag' and 'safe_and' parameters.
15123 * The binary logical ops &&, ||, // (plus 'if' and 'unless' which use
15124 * those underlying ops) short-circuit, which means that rather than
15125 * necessarily returning a truth value, they may return the LH argument,
15126 * which may not be boolean. For example in $x = (keys %h || -1), keys
15127 * should return a key count rather than a boolean, even though its
15128 * sort-of being used in boolean context.
15130 * So we only consider such logical ops to provide boolean context to
15131 * their LH argument if they themselves are in void or boolean context.
15132 * However, sometimes the context isn't known until run-time. In this
15133 * case the op is marked with the maybe_flag flag it.
15135 * Consider the following.
15137 * sub f { ....; if (%h) { .... } }
15139 * This is actually compiled as
15141 * sub f { ....; %h && do { .... } }
15143 * Here we won't know until runtime whether the final statement (and hence
15144 * the &&) is in void context and so is safe to return a boolean value.
15145 * So mark o with maybe_flag rather than the bool_flag.
15146 * Note that there is cost associated with determining context at runtime
15147 * (e.g. a call to block_gimme()), so it may not be worth setting (at
15148 * compile time) and testing (at runtime) maybe_flag if the scalar verses
15149 * boolean costs savings are marginal.
15151 * However, we can do slightly better with && (compared to || and //):
15152 * this op only returns its LH argument when that argument is false. In
15153 * this case, as long as the op promises to return a false value which is
15154 * valid in both boolean and scalar contexts, we can mark an op consumed
15155 * by && with bool_flag rather than maybe_flag.
15156 * For example as long as pp_padhv and pp_rv2hv return &PL_sv_zero rather
15157 * than &PL_sv_no for a false result in boolean context, then it's safe. An
15158 * op which promises to handle this case is indicated by setting safe_and
15163 S_check_for_bool_cxt(OP*o, bool safe_and, U8 bool_flag, U8 maybe_flag)
15168 assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR);
15170 /* OPpTARGET_MY and boolean context probably don't mix well.
15171 * If someone finds a valid use case, maybe add an extra flag to this
15172 * function which indicates its safe to do so for this op? */
15173 assert(!( (PL_opargs[o->op_type] & OA_TARGLEX)
15174 && (o->op_private & OPpTARGET_MY)));
15179 switch (lop->op_type) {
15184 /* these two consume the stack argument in the scalar case,
15185 * and treat it as a boolean in the non linenumber case */
15188 if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST)
15189 || (lop->op_private & OPpFLIP_LINENUM))
15195 /* these never leave the original value on the stack */
15204 /* OR DOR and AND evaluate their arg as a boolean, but then may
15205 * leave the original scalar value on the stack when following the
15206 * op_next route. If not in void context, we need to ensure
15207 * that whatever follows consumes the arg only in boolean context
15219 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
15223 else if (!(lop->op_flags & OPf_WANT)) {
15224 /* unknown context - decide at runtime */
15236 lop = lop->op_next;
15239 o->op_private |= flag;
15244 /* mechanism for deferring recursion in rpeep() */
15246 #define MAX_DEFERRED 4
15250 if (defer_ix == (MAX_DEFERRED-1)) { \
15251 OP **defer = defer_queue[defer_base]; \
15252 CALL_RPEEP(*defer); \
15253 S_prune_chain_head(defer); \
15254 defer_base = (defer_base + 1) % MAX_DEFERRED; \
15257 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
15260 #define IS_AND_OP(o) (o->op_type == OP_AND)
15261 #define IS_OR_OP(o) (o->op_type == OP_OR)
15264 /* A peephole optimizer. We visit the ops in the order they're to execute.
15265 * See the comments at the top of this file for more details about when
15266 * peep() is called */
15269 Perl_rpeep(pTHX_ OP *o)
15273 OP* oldoldop = NULL;
15274 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
15275 int defer_base = 0;
15278 if (!o || o->op_opt)
15281 assert(o->op_type != OP_FREED);
15285 SAVEVPTR(PL_curcop);
15286 for (;; o = o->op_next) {
15287 if (o && o->op_opt)
15290 while (defer_ix >= 0) {
15292 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
15293 CALL_RPEEP(*defer);
15294 S_prune_chain_head(defer);
15301 /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */
15302 assert(!oldoldop || oldoldop->op_next == oldop);
15303 assert(!oldop || oldop->op_next == o);
15305 /* By default, this op has now been optimised. A couple of cases below
15306 clear this again. */
15310 /* look for a series of 1 or more aggregate derefs, e.g.
15311 * $a[1]{foo}[$i]{$k}
15312 * and replace with a single OP_MULTIDEREF op.
15313 * Each index must be either a const, or a simple variable,
15315 * First, look for likely combinations of starting ops,
15316 * corresponding to (global and lexical variants of)
15318 * $r->[...] $r->{...}
15319 * (preceding expression)->[...]
15320 * (preceding expression)->{...}
15321 * and if so, call maybe_multideref() to do a full inspection
15322 * of the op chain and if appropriate, replace with an
15330 switch (o2->op_type) {
15332 /* $pkg[..] : gv[*pkg]
15333 * $pkg->[...]: gv[*pkg]; rv2sv sKM/DREFAV */
15335 /* Fail if there are new op flag combinations that we're
15336 * not aware of, rather than:
15337 * * silently failing to optimise, or
15338 * * silently optimising the flag away.
15339 * If this ASSUME starts failing, examine what new flag
15340 * has been added to the op, and decide whether the
15341 * optimisation should still occur with that flag, then
15342 * update the code accordingly. This applies to all the
15343 * other ASSUMEs in the block of code too.
15345 ASSUME(!(o2->op_flags &
15346 ~(OPf_WANT|OPf_MOD|OPf_PARENS|OPf_SPECIAL)));
15347 ASSUME(!(o2->op_private & ~OPpEARLY_CV));
15351 if (o2->op_type == OP_RV2AV) {
15352 action = MDEREF_AV_gvav_aelem;
15356 if (o2->op_type == OP_RV2HV) {
15357 action = MDEREF_HV_gvhv_helem;
15361 if (o2->op_type != OP_RV2SV)
15364 /* at this point we've seen gv,rv2sv, so the only valid
15365 * construct left is $pkg->[] or $pkg->{} */
15367 ASSUME(!(o2->op_flags & OPf_STACKED));
15368 if ((o2->op_flags & (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15369 != (OPf_WANT_SCALAR|OPf_MOD))
15372 ASSUME(!(o2->op_private & ~(OPpARG1_MASK|HINT_STRICT_REFS
15373 |OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO)));
15374 if (o2->op_private & (OPpOUR_INTRO|OPpLVAL_INTRO))
15376 if ( (o2->op_private & OPpDEREF) != OPpDEREF_AV
15377 && (o2->op_private & OPpDEREF) != OPpDEREF_HV)
15381 if (o2->op_type == OP_RV2AV) {
15382 action = MDEREF_AV_gvsv_vivify_rv2av_aelem;
15385 if (o2->op_type == OP_RV2HV) {
15386 action = MDEREF_HV_gvsv_vivify_rv2hv_helem;
15392 /* $lex->[...]: padsv[$lex] sM/DREFAV */
15394 ASSUME(!(o2->op_flags &
15395 ~(OPf_WANT|OPf_PARENS|OPf_REF|OPf_MOD|OPf_SPECIAL)));
15396 if ((o2->op_flags &
15397 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15398 != (OPf_WANT_SCALAR|OPf_MOD))
15401 ASSUME(!(o2->op_private &
15402 ~(OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO)));
15403 /* skip if state or intro, or not a deref */
15404 if ( o2->op_private != OPpDEREF_AV
15405 && o2->op_private != OPpDEREF_HV)
15409 if (o2->op_type == OP_RV2AV) {
15410 action = MDEREF_AV_padsv_vivify_rv2av_aelem;
15413 if (o2->op_type == OP_RV2HV) {
15414 action = MDEREF_HV_padsv_vivify_rv2hv_helem;
15421 /* $lex[..]: padav[@lex:1,2] sR *
15422 * or $lex{..}: padhv[%lex:1,2] sR */
15423 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_MOD|OPf_PARENS|
15424 OPf_REF|OPf_SPECIAL)));
15425 if ((o2->op_flags &
15426 (OPf_WANT|OPf_REF|OPf_MOD|OPf_SPECIAL))
15427 != (OPf_WANT_SCALAR|OPf_REF))
15429 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_REF))
15431 /* OPf_PARENS isn't currently used in this case;
15432 * if that changes, let us know! */
15433 ASSUME(!(o2->op_flags & OPf_PARENS));
15435 /* at this point, we wouldn't expect any of the remaining
15436 * possible private flags:
15437 * OPpPAD_STATE, OPpLVAL_INTRO, OPpTRUEBOOL,
15438 * OPpMAYBE_TRUEBOOL, OPpMAYBE_LVSUB
15440 * OPpSLICEWARNING shouldn't affect runtime
15442 ASSUME(!(o2->op_private & ~(OPpSLICEWARNING)));
15444 action = o2->op_type == OP_PADAV
15445 ? MDEREF_AV_padav_aelem
15446 : MDEREF_HV_padhv_helem;
15448 S_maybe_multideref(aTHX_ o, o2, action, 0);
15454 action = o2->op_type == OP_RV2AV
15455 ? MDEREF_AV_pop_rv2av_aelem
15456 : MDEREF_HV_pop_rv2hv_helem;
15459 /* (expr)->[...]: rv2av sKR/1;
15460 * (expr)->{...}: rv2hv sKR/1; */
15462 ASSUME(o2->op_type == OP_RV2AV || o2->op_type == OP_RV2HV);
15464 ASSUME(!(o2->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_PARENS
15465 |OPf_REF|OPf_MOD|OPf_STACKED|OPf_SPECIAL)));
15466 if (o2->op_flags != (OPf_WANT_SCALAR|OPf_KIDS|OPf_REF))
15469 /* at this point, we wouldn't expect any of these
15470 * possible private flags:
15471 * OPpMAYBE_LVSUB, OPpLVAL_INTRO
15472 * OPpTRUEBOOL, OPpMAYBE_TRUEBOOL, (rv2hv only)
15474 ASSUME(!(o2->op_private &
15475 ~(OPpHINT_STRICT_REFS|OPpARG1_MASK|OPpSLICEWARNING
15477 hints |= (o2->op_private & OPpHINT_STRICT_REFS);
15481 S_maybe_multideref(aTHX_ o, o2, action, hints);
15490 switch (o->op_type) {
15492 PL_curcop = ((COP*)o); /* for warnings */
15495 PL_curcop = ((COP*)o); /* for warnings */
15497 /* Optimise a "return ..." at the end of a sub to just be "...".
15498 * This saves 2 ops. Before:
15499 * 1 <;> nextstate(main 1 -e:1) v ->2
15500 * 4 <@> return K ->5
15501 * 2 <0> pushmark s ->3
15502 * - <1> ex-rv2sv sK/1 ->4
15503 * 3 <#> gvsv[*cat] s ->4
15506 * - <@> return K ->-
15507 * - <0> pushmark s ->2
15508 * - <1> ex-rv2sv sK/1 ->-
15509 * 2 <$> gvsv(*cat) s ->3
15512 OP *next = o->op_next;
15513 OP *sibling = OpSIBLING(o);
15514 if ( OP_TYPE_IS(next, OP_PUSHMARK)
15515 && OP_TYPE_IS(sibling, OP_RETURN)
15516 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
15517 && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
15518 ||OP_TYPE_IS(sibling->op_next->op_next,
15520 && cUNOPx(sibling)->op_first == next
15521 && OpHAS_SIBLING(next) && OpSIBLING(next)->op_next
15524 /* Look through the PUSHMARK's siblings for one that
15525 * points to the RETURN */
15526 OP *top = OpSIBLING(next);
15527 while (top && top->op_next) {
15528 if (top->op_next == sibling) {
15529 top->op_next = sibling->op_next;
15530 o->op_next = next->op_next;
15533 top = OpSIBLING(top);
15538 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
15540 * This latter form is then suitable for conversion into padrange
15541 * later on. Convert:
15543 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
15547 * nextstate1 -> listop -> nextstate3
15549 * pushmark -> padop1 -> padop2
15551 if (o->op_next && (
15552 o->op_next->op_type == OP_PADSV
15553 || o->op_next->op_type == OP_PADAV
15554 || o->op_next->op_type == OP_PADHV
15556 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
15557 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
15558 && o->op_next->op_next->op_next && (
15559 o->op_next->op_next->op_next->op_type == OP_PADSV
15560 || o->op_next->op_next->op_next->op_type == OP_PADAV
15561 || o->op_next->op_next->op_next->op_type == OP_PADHV
15563 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
15564 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
15565 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
15566 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
15568 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
15571 ns2 = pad1->op_next;
15572 pad2 = ns2->op_next;
15573 ns3 = pad2->op_next;
15575 /* we assume here that the op_next chain is the same as
15576 * the op_sibling chain */
15577 assert(OpSIBLING(o) == pad1);
15578 assert(OpSIBLING(pad1) == ns2);
15579 assert(OpSIBLING(ns2) == pad2);
15580 assert(OpSIBLING(pad2) == ns3);
15582 /* excise and delete ns2 */
15583 op_sibling_splice(NULL, pad1, 1, NULL);
15586 /* excise pad1 and pad2 */
15587 op_sibling_splice(NULL, o, 2, NULL);
15589 /* create new listop, with children consisting of:
15590 * a new pushmark, pad1, pad2. */
15591 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
15592 newop->op_flags |= OPf_PARENS;
15593 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
15595 /* insert newop between o and ns3 */
15596 op_sibling_splice(NULL, o, 0, newop);
15598 /*fixup op_next chain */
15599 newpm = cUNOPx(newop)->op_first; /* pushmark */
15600 o ->op_next = newpm;
15601 newpm->op_next = pad1;
15602 pad1 ->op_next = pad2;
15603 pad2 ->op_next = newop; /* listop */
15604 newop->op_next = ns3;
15606 /* Ensure pushmark has this flag if padops do */
15607 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
15608 newpm->op_flags |= OPf_MOD;
15614 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
15615 to carry two labels. For now, take the easier option, and skip
15616 this optimisation if the first NEXTSTATE has a label. */
15617 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
15618 OP *nextop = o->op_next;
15619 while (nextop && nextop->op_type == OP_NULL)
15620 nextop = nextop->op_next;
15622 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
15625 oldop->op_next = nextop;
15627 /* Skip (old)oldop assignment since the current oldop's
15628 op_next already points to the next op. */
15635 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
15636 if (o->op_next->op_private & OPpTARGET_MY) {
15637 if (o->op_flags & OPf_STACKED) /* chained concats */
15638 break; /* ignore_optimization */
15640 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
15641 o->op_targ = o->op_next->op_targ;
15642 o->op_next->op_targ = 0;
15643 o->op_private |= OPpTARGET_MY;
15646 op_null(o->op_next);
15650 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
15651 break; /* Scalar stub must produce undef. List stub is noop */
15655 if (o->op_targ == OP_NEXTSTATE
15656 || o->op_targ == OP_DBSTATE)
15658 PL_curcop = ((COP*)o);
15660 /* XXX: We avoid setting op_seq here to prevent later calls
15661 to rpeep() from mistakenly concluding that optimisation
15662 has already occurred. This doesn't fix the real problem,
15663 though (See 20010220.007 (#5874)). AMS 20010719 */
15664 /* op_seq functionality is now replaced by op_opt */
15672 oldop->op_next = o->op_next;
15686 convert repeat into a stub with no kids.
15688 if (o->op_next->op_type == OP_CONST
15689 || ( o->op_next->op_type == OP_PADSV
15690 && !(o->op_next->op_private & OPpLVAL_INTRO))
15691 || ( o->op_next->op_type == OP_GV
15692 && o->op_next->op_next->op_type == OP_RV2SV
15693 && !(o->op_next->op_next->op_private
15694 & (OPpLVAL_INTRO|OPpOUR_INTRO))))
15696 const OP *kid = o->op_next->op_next;
15697 if (o->op_next->op_type == OP_GV)
15698 kid = kid->op_next;
15699 /* kid is now the ex-list. */
15700 if (kid->op_type == OP_NULL
15701 && (kid = kid->op_next)->op_type == OP_CONST
15702 /* kid is now the repeat count. */
15703 && kid->op_next->op_type == OP_REPEAT
15704 && kid->op_next->op_private & OPpREPEAT_DOLIST
15705 && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
15706 && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0
15709 o = kid->op_next; /* repeat */
15710 oldop->op_next = o;
15711 op_free(cBINOPo->op_first);
15712 op_free(cBINOPo->op_last );
15713 o->op_flags &=~ OPf_KIDS;
15714 /* stub is a baseop; repeat is a binop */
15715 STATIC_ASSERT_STMT(sizeof(OP) <= sizeof(BINOP));
15716 OpTYPE_set(o, OP_STUB);
15722 /* Convert a series of PAD ops for my vars plus support into a
15723 * single padrange op. Basically
15725 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
15727 * becomes, depending on circumstances, one of
15729 * padrange ----------------------------------> (list) -> rest
15730 * padrange --------------------------------------------> rest
15732 * where all the pad indexes are sequential and of the same type
15734 * We convert the pushmark into a padrange op, then skip
15735 * any other pad ops, and possibly some trailing ops.
15736 * Note that we don't null() the skipped ops, to make it
15737 * easier for Deparse to undo this optimisation (and none of
15738 * the skipped ops are holding any resourses). It also makes
15739 * it easier for find_uninit_var(), as it can just ignore
15740 * padrange, and examine the original pad ops.
15744 OP *followop = NULL; /* the op that will follow the padrange op */
15747 PADOFFSET base = 0; /* init only to stop compiler whining */
15748 bool gvoid = 0; /* init only to stop compiler whining */
15749 bool defav = 0; /* seen (...) = @_ */
15750 bool reuse = 0; /* reuse an existing padrange op */
15752 /* look for a pushmark -> gv[_] -> rv2av */
15757 if ( p->op_type == OP_GV
15758 && cGVOPx_gv(p) == PL_defgv
15759 && (rv2av = p->op_next)
15760 && rv2av->op_type == OP_RV2AV
15761 && !(rv2av->op_flags & OPf_REF)
15762 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
15763 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
15765 q = rv2av->op_next;
15766 if (q->op_type == OP_NULL)
15768 if (q->op_type == OP_PUSHMARK) {
15778 /* scan for PAD ops */
15780 for (p = p->op_next; p; p = p->op_next) {
15781 if (p->op_type == OP_NULL)
15784 if (( p->op_type != OP_PADSV
15785 && p->op_type != OP_PADAV
15786 && p->op_type != OP_PADHV
15788 /* any private flag other than INTRO? e.g. STATE */
15789 || (p->op_private & ~OPpLVAL_INTRO)
15793 /* let $a[N] potentially be optimised into AELEMFAST_LEX
15795 if ( p->op_type == OP_PADAV
15797 && p->op_next->op_type == OP_CONST
15798 && p->op_next->op_next
15799 && p->op_next->op_next->op_type == OP_AELEM
15803 /* for 1st padop, note what type it is and the range
15804 * start; for the others, check that it's the same type
15805 * and that the targs are contiguous */
15807 intro = (p->op_private & OPpLVAL_INTRO);
15809 gvoid = OP_GIMME(p,0) == G_VOID;
15812 if ((p->op_private & OPpLVAL_INTRO) != intro)
15814 /* Note that you'd normally expect targs to be
15815 * contiguous in my($a,$b,$c), but that's not the case
15816 * when external modules start doing things, e.g.
15817 * Function::Parameters */
15818 if (p->op_targ != base + count)
15820 assert(p->op_targ == base + count);
15821 /* Either all the padops or none of the padops should
15822 be in void context. Since we only do the optimisa-
15823 tion for av/hv when the aggregate itself is pushed
15824 on to the stack (one item), there is no need to dis-
15825 tinguish list from scalar context. */
15826 if (gvoid != (OP_GIMME(p,0) == G_VOID))
15830 /* for AV, HV, only when we're not flattening */
15831 if ( p->op_type != OP_PADSV
15833 && !(p->op_flags & OPf_REF)
15837 if (count >= OPpPADRANGE_COUNTMASK)
15840 /* there's a biggest base we can fit into a
15841 * SAVEt_CLEARPADRANGE in pp_padrange.
15842 * (The sizeof() stuff will be constant-folded, and is
15843 * intended to avoid getting "comparison is always false"
15844 * compiler warnings. See the comments above
15845 * MEM_WRAP_CHECK for more explanation on why we do this
15846 * in a weird way to avoid compiler warnings.)
15849 && (8*sizeof(base) >
15850 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT
15852 : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15854 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
15858 /* Success! We've got another valid pad op to optimise away */
15860 followop = p->op_next;
15863 if (count < 1 || (count == 1 && !defav))
15866 /* pp_padrange in specifically compile-time void context
15867 * skips pushing a mark and lexicals; in all other contexts
15868 * (including unknown till runtime) it pushes a mark and the
15869 * lexicals. We must be very careful then, that the ops we
15870 * optimise away would have exactly the same effect as the
15872 * In particular in void context, we can only optimise to
15873 * a padrange if we see the complete sequence
15874 * pushmark, pad*v, ...., list
15875 * which has the net effect of leaving the markstack as it
15876 * was. Not pushing onto the stack (whereas padsv does touch
15877 * the stack) makes no difference in void context.
15881 if (followop->op_type == OP_LIST
15882 && OP_GIMME(followop,0) == G_VOID
15885 followop = followop->op_next; /* skip OP_LIST */
15887 /* consolidate two successive my(...);'s */
15890 && oldoldop->op_type == OP_PADRANGE
15891 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
15892 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
15893 && !(oldoldop->op_flags & OPf_SPECIAL)
15896 assert(oldoldop->op_next == oldop);
15897 assert( oldop->op_type == OP_NEXTSTATE
15898 || oldop->op_type == OP_DBSTATE);
15899 assert(oldop->op_next == o);
15902 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
15904 /* Do not assume pad offsets for $c and $d are con-
15909 if ( oldoldop->op_targ + old_count == base
15910 && old_count < OPpPADRANGE_COUNTMASK - count) {
15911 base = oldoldop->op_targ;
15912 count += old_count;
15917 /* if there's any immediately following singleton
15918 * my var's; then swallow them and the associated
15920 * my ($a,$b); my $c; my $d;
15922 * my ($a,$b,$c,$d);
15925 while ( ((p = followop->op_next))
15926 && ( p->op_type == OP_PADSV
15927 || p->op_type == OP_PADAV
15928 || p->op_type == OP_PADHV)
15929 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
15930 && (p->op_private & OPpLVAL_INTRO) == intro
15931 && !(p->op_private & ~OPpLVAL_INTRO)
15933 && ( p->op_next->op_type == OP_NEXTSTATE
15934 || p->op_next->op_type == OP_DBSTATE)
15935 && count < OPpPADRANGE_COUNTMASK
15936 && base + count == p->op_targ
15939 followop = p->op_next;
15947 assert(oldoldop->op_type == OP_PADRANGE);
15948 oldoldop->op_next = followop;
15949 oldoldop->op_private = (intro | count);
15955 /* Convert the pushmark into a padrange.
15956 * To make Deparse easier, we guarantee that a padrange was
15957 * *always* formerly a pushmark */
15958 assert(o->op_type == OP_PUSHMARK);
15959 o->op_next = followop;
15960 OpTYPE_set(o, OP_PADRANGE);
15962 /* bit 7: INTRO; bit 6..0: count */
15963 o->op_private = (intro | count);
15964 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
15965 | gvoid * OPf_WANT_VOID
15966 | (defav ? OPf_SPECIAL : 0));
15972 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
15973 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
15978 /*'keys %h' in void or scalar context: skip the OP_KEYS
15979 * and perform the functionality directly in the RV2HV/PADHV
15982 if (o->op_flags & OPf_REF) {
15983 OP *k = o->op_next;
15984 U8 want = (k->op_flags & OPf_WANT);
15986 && k->op_type == OP_KEYS
15987 && ( want == OPf_WANT_VOID
15988 || want == OPf_WANT_SCALAR)
15989 && !(k->op_private & OPpMAYBE_LVSUB)
15990 && !(k->op_flags & OPf_MOD)
15992 o->op_next = k->op_next;
15993 o->op_flags &= ~(OPf_REF|OPf_WANT);
15994 o->op_flags |= want;
15995 o->op_private |= (o->op_type == OP_PADHV ?
15996 OPpPADHV_ISKEYS : OPpRV2HV_ISKEYS);
15997 /* for keys(%lex), hold onto the OP_KEYS's targ
15998 * since padhv doesn't have its own targ to return
16000 if (!(o->op_type ==OP_PADHV && want == OPf_WANT_SCALAR))
16005 /* see if %h is used in boolean context */
16006 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16007 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16010 if (o->op_type != OP_PADHV)
16014 if ( o->op_type == OP_PADAV
16015 && (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16017 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16020 /* Skip over state($x) in void context. */
16021 if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
16022 && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
16024 oldop->op_next = o->op_next;
16025 goto redo_nextstate;
16027 if (o->op_type != OP_PADAV)
16031 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
16032 OP* const pop = (o->op_type == OP_PADAV) ?
16033 o->op_next : o->op_next->op_next;
16035 if (pop && pop->op_type == OP_CONST &&
16036 ((PL_op = pop->op_next)) &&
16037 pop->op_next->op_type == OP_AELEM &&
16038 !(pop->op_next->op_private &
16039 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
16040 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
16043 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
16044 no_bareword_allowed(pop);
16045 if (o->op_type == OP_GV)
16046 op_null(o->op_next);
16047 op_null(pop->op_next);
16049 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
16050 o->op_next = pop->op_next->op_next;
16051 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
16052 o->op_private = (U8)i;
16053 if (o->op_type == OP_GV) {
16056 o->op_type = OP_AELEMFAST;
16059 o->op_type = OP_AELEMFAST_LEX;
16061 if (o->op_type != OP_GV)
16065 /* Remove $foo from the op_next chain in void context. */
16067 && ( o->op_next->op_type == OP_RV2SV
16068 || o->op_next->op_type == OP_RV2AV
16069 || o->op_next->op_type == OP_RV2HV )
16070 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16071 && !(o->op_next->op_private & OPpLVAL_INTRO))
16073 oldop->op_next = o->op_next->op_next;
16074 /* Reprocess the previous op if it is a nextstate, to
16075 allow double-nextstate optimisation. */
16077 if (oldop->op_type == OP_NEXTSTATE) {
16084 o = oldop->op_next;
16087 else if (o->op_next->op_type == OP_RV2SV) {
16088 if (!(o->op_next->op_private & OPpDEREF)) {
16089 op_null(o->op_next);
16090 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
16092 o->op_next = o->op_next->op_next;
16093 OpTYPE_set(o, OP_GVSV);
16096 else if (o->op_next->op_type == OP_READLINE
16097 && o->op_next->op_next->op_type == OP_CONCAT
16098 && (o->op_next->op_next->op_flags & OPf_STACKED))
16100 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
16101 OpTYPE_set(o, OP_RCATLINE);
16102 o->op_flags |= OPf_STACKED;
16103 op_null(o->op_next->op_next);
16104 op_null(o->op_next);
16115 while (cLOGOP->op_other->op_type == OP_NULL)
16116 cLOGOP->op_other = cLOGOP->op_other->op_next;
16117 while (o->op_next && ( o->op_type == o->op_next->op_type
16118 || o->op_next->op_type == OP_NULL))
16119 o->op_next = o->op_next->op_next;
16121 /* If we're an OR and our next is an AND in void context, we'll
16122 follow its op_other on short circuit, same for reverse.
16123 We can't do this with OP_DOR since if it's true, its return
16124 value is the underlying value which must be evaluated
16128 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
16129 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
16131 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
16133 o->op_next = ((LOGOP*)o->op_next)->op_other;
16135 DEFER(cLOGOP->op_other);
16140 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16141 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16150 case OP_ARGDEFELEM:
16151 while (cLOGOP->op_other->op_type == OP_NULL)
16152 cLOGOP->op_other = cLOGOP->op_other->op_next;
16153 DEFER(cLOGOP->op_other);
16158 while (cLOOP->op_redoop->op_type == OP_NULL)
16159 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
16160 while (cLOOP->op_nextop->op_type == OP_NULL)
16161 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
16162 while (cLOOP->op_lastop->op_type == OP_NULL)
16163 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
16164 /* a while(1) loop doesn't have an op_next that escapes the
16165 * loop, so we have to explicitly follow the op_lastop to
16166 * process the rest of the code */
16167 DEFER(cLOOP->op_lastop);
16171 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
16172 DEFER(cLOGOPo->op_other);
16176 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16177 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16178 assert(!(cPMOP->op_pmflags & PMf_ONCE));
16179 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
16180 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
16181 cPMOP->op_pmstashstartu.op_pmreplstart
16182 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
16183 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
16189 if (o->op_flags & OPf_SPECIAL) {
16190 /* first arg is a code block */
16191 OP * const nullop = OpSIBLING(cLISTOP->op_first);
16192 OP * kid = cUNOPx(nullop)->op_first;
16194 assert(nullop->op_type == OP_NULL);
16195 assert(kid->op_type == OP_SCOPE
16196 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
16197 /* since OP_SORT doesn't have a handy op_other-style
16198 * field that can point directly to the start of the code
16199 * block, store it in the otherwise-unused op_next field
16200 * of the top-level OP_NULL. This will be quicker at
16201 * run-time, and it will also allow us to remove leading
16202 * OP_NULLs by just messing with op_nexts without
16203 * altering the basic op_first/op_sibling layout. */
16204 kid = kLISTOP->op_first;
16206 (kid->op_type == OP_NULL
16207 && ( kid->op_targ == OP_NEXTSTATE
16208 || kid->op_targ == OP_DBSTATE ))
16209 || kid->op_type == OP_STUB
16210 || kid->op_type == OP_ENTER
16211 || (PL_parser && PL_parser->error_count));
16212 nullop->op_next = kid->op_next;
16213 DEFER(nullop->op_next);
16216 /* check that RHS of sort is a single plain array */
16217 oright = cUNOPo->op_first;
16218 if (!oright || oright->op_type != OP_PUSHMARK)
16221 if (o->op_private & OPpSORT_INPLACE)
16224 /* reverse sort ... can be optimised. */
16225 if (!OpHAS_SIBLING(cUNOPo)) {
16226 /* Nothing follows us on the list. */
16227 OP * const reverse = o->op_next;
16229 if (reverse->op_type == OP_REVERSE &&
16230 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
16231 OP * const pushmark = cUNOPx(reverse)->op_first;
16232 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
16233 && (OpSIBLING(cUNOPx(pushmark)) == o)) {
16234 /* reverse -> pushmark -> sort */
16235 o->op_private |= OPpSORT_REVERSE;
16237 pushmark->op_next = oright->op_next;
16247 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
16249 LISTOP *enter, *exlist;
16251 if (o->op_private & OPpSORT_INPLACE)
16254 enter = (LISTOP *) o->op_next;
16257 if (enter->op_type == OP_NULL) {
16258 enter = (LISTOP *) enter->op_next;
16262 /* for $a (...) will have OP_GV then OP_RV2GV here.
16263 for (...) just has an OP_GV. */
16264 if (enter->op_type == OP_GV) {
16265 gvop = (OP *) enter;
16266 enter = (LISTOP *) enter->op_next;
16269 if (enter->op_type == OP_RV2GV) {
16270 enter = (LISTOP *) enter->op_next;
16276 if (enter->op_type != OP_ENTERITER)
16279 iter = enter->op_next;
16280 if (!iter || iter->op_type != OP_ITER)
16283 expushmark = enter->op_first;
16284 if (!expushmark || expushmark->op_type != OP_NULL
16285 || expushmark->op_targ != OP_PUSHMARK)
16288 exlist = (LISTOP *) OpSIBLING(expushmark);
16289 if (!exlist || exlist->op_type != OP_NULL
16290 || exlist->op_targ != OP_LIST)
16293 if (exlist->op_last != o) {
16294 /* Mmm. Was expecting to point back to this op. */
16297 theirmark = exlist->op_first;
16298 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
16301 if (OpSIBLING(theirmark) != o) {
16302 /* There's something between the mark and the reverse, eg
16303 for (1, reverse (...))
16308 ourmark = ((LISTOP *)o)->op_first;
16309 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
16312 ourlast = ((LISTOP *)o)->op_last;
16313 if (!ourlast || ourlast->op_next != o)
16316 rv2av = OpSIBLING(ourmark);
16317 if (rv2av && rv2av->op_type == OP_RV2AV && !OpHAS_SIBLING(rv2av)
16318 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
16319 /* We're just reversing a single array. */
16320 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
16321 enter->op_flags |= OPf_STACKED;
16324 /* We don't have control over who points to theirmark, so sacrifice
16326 theirmark->op_next = ourmark->op_next;
16327 theirmark->op_flags = ourmark->op_flags;
16328 ourlast->op_next = gvop ? gvop : (OP *) enter;
16331 enter->op_private |= OPpITER_REVERSED;
16332 iter->op_private |= OPpITER_REVERSED;
16336 o = oldop->op_next;
16338 NOT_REACHED; /* NOTREACHED */
16344 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
16345 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
16350 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
16351 && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
16354 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
16356 sv = newRV((SV *)PL_compcv);
16360 OpTYPE_set(o, OP_CONST);
16361 o->op_flags |= OPf_SPECIAL;
16362 cSVOPo->op_sv = sv;
16367 if (OP_GIMME(o,0) == G_VOID
16368 || ( o->op_next->op_type == OP_LINESEQ
16369 && ( o->op_next->op_next->op_type == OP_LEAVESUB
16370 || ( o->op_next->op_next->op_type == OP_RETURN
16371 && !CvLVALUE(PL_compcv)))))
16373 OP *right = cBINOP->op_first;
16392 OP *left = OpSIBLING(right);
16393 if (left->op_type == OP_SUBSTR
16394 && (left->op_private & 7) < 4) {
16396 /* cut out right */
16397 op_sibling_splice(o, NULL, 1, NULL);
16398 /* and insert it as second child of OP_SUBSTR */
16399 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
16401 left->op_private |= OPpSUBSTR_REPL_FIRST;
16403 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
16410 int l, r, lr, lscalars, rscalars;
16412 /* handle common vars detection, e.g. ($a,$b) = ($b,$a).
16413 Note that we do this now rather than in newASSIGNOP(),
16414 since only by now are aliased lexicals flagged as such
16416 See the essay "Common vars in list assignment" above for
16417 the full details of the rationale behind all the conditions
16420 PL_generation sorcery:
16421 To detect whether there are common vars, the global var
16422 PL_generation is incremented for each assign op we scan.
16423 Then we run through all the lexical variables on the LHS,
16424 of the assignment, setting a spare slot in each of them to
16425 PL_generation. Then we scan the RHS, and if any lexicals
16426 already have that value, we know we've got commonality.
16427 Also, if the generation number is already set to
16428 PERL_INT_MAX, then the variable is involved in aliasing, so
16429 we also have potential commonality in that case.
16435 l = S_aassign_scan(aTHX_ cLISTOPo->op_last, FALSE, 1, &lscalars);
16438 r = S_aassign_scan(aTHX_ cLISTOPo->op_first, TRUE, 1, &rscalars);
16442 /* After looking for things which are *always* safe, this main
16443 * if/else chain selects primarily based on the type of the
16444 * LHS, gradually working its way down from the more dangerous
16445 * to the more restrictive and thus safer cases */
16447 if ( !l /* () = ....; */
16448 || !r /* .... = (); */
16449 || !(l & ~AAS_SAFE_SCALAR) /* (undef, pos()) = ...; */
16450 || !(r & ~AAS_SAFE_SCALAR) /* ... = (1,2,length,undef); */
16451 || (lscalars < 2) /* ($x, undef) = ... */
16453 NOOP; /* always safe */
16455 else if (l & AAS_DANGEROUS) {
16456 /* always dangerous */
16457 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16458 o->op_private |= OPpASSIGN_COMMON_AGG;
16460 else if (l & (AAS_PKG_SCALAR|AAS_PKG_AGG)) {
16461 /* package vars are always dangerous - too many
16462 * aliasing possibilities */
16463 if (l & AAS_PKG_SCALAR)
16464 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16465 if (l & AAS_PKG_AGG)
16466 o->op_private |= OPpASSIGN_COMMON_AGG;
16468 else if (l & ( AAS_MY_SCALAR|AAS_MY_AGG
16469 |AAS_LEX_SCALAR|AAS_LEX_AGG))
16471 /* LHS contains only lexicals and safe ops */
16473 if (l & (AAS_MY_AGG|AAS_LEX_AGG))
16474 o->op_private |= OPpASSIGN_COMMON_AGG;
16476 if (l & (AAS_MY_SCALAR|AAS_LEX_SCALAR)) {
16477 if (lr & AAS_LEX_SCALAR_COMM)
16478 o->op_private |= OPpASSIGN_COMMON_SCALAR;
16479 else if ( !(l & AAS_LEX_SCALAR)
16480 && (r & AAS_DEFAV))
16484 * as scalar-safe for performance reasons.
16485 * (it will still have been marked _AGG if necessary */
16488 else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS))
16489 /* if there are only lexicals on the LHS and no
16490 * common ones on the RHS, then we assume that the
16491 * only way those lexicals could also get
16492 * on the RHS is via some sort of dereffing or
16495 * ($lex, $x) = (1, $$r)
16496 * and in this case we assume the var must have
16497 * a bumped ref count. So if its ref count is 1,
16498 * it must only be on the LHS.
16500 o->op_private |= OPpASSIGN_COMMON_RC1;
16505 * may have to handle aggregate on LHS, but we can't
16506 * have common scalars. */
16509 ~(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1);
16511 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16512 S_check_for_bool_cxt(o, 1, OPpASSIGN_TRUEBOOL, 0);
16517 /* see if ref() is used in boolean context */
16518 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16519 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL);
16523 /* see if the op is used in known boolean context,
16524 * but not if OA_TARGLEX optimisation is enabled */
16525 if ( (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR
16526 && !(o->op_private & OPpTARGET_MY)
16528 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16532 /* see if the op is used in known boolean context */
16533 if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR)
16534 S_check_for_bool_cxt(o, 1, OPpTRUEBOOL, 0);
16538 Perl_cpeep_t cpeep =
16539 XopENTRYCUSTOM(o, xop_peep);
16541 cpeep(aTHX_ o, oldop);
16546 /* did we just null the current op? If so, re-process it to handle
16547 * eliding "empty" ops from the chain */
16548 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
16561 Perl_peep(pTHX_ OP *o)
16567 =head1 Custom Operators
16569 =for apidoc Ao||custom_op_xop
16570 Return the XOP structure for a given custom op. This macro should be
16571 considered internal to C<OP_NAME> and the other access macros: use them instead.
16572 This macro does call a function. Prior
16573 to 5.19.6, this was implemented as a
16580 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
16586 static const XOP xop_null = { 0, 0, 0, 0, 0 };
16588 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
16589 assert(o->op_type == OP_CUSTOM);
16591 /* This is wrong. It assumes a function pointer can be cast to IV,
16592 * which isn't guaranteed, but this is what the old custom OP code
16593 * did. In principle it should be safer to Copy the bytes of the
16594 * pointer into a PV: since the new interface is hidden behind
16595 * functions, this can be changed later if necessary. */
16596 /* Change custom_op_xop if this ever happens */
16597 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
16600 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
16602 /* assume noone will have just registered a desc */
16603 if (!he && PL_custom_op_names &&
16604 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
16609 /* XXX does all this need to be shared mem? */
16610 Newxz(xop, 1, XOP);
16611 pv = SvPV(HeVAL(he), l);
16612 XopENTRY_set(xop, xop_name, savepvn(pv, l));
16613 if (PL_custom_op_descs &&
16614 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
16616 pv = SvPV(HeVAL(he), l);
16617 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
16619 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
16623 xop = (XOP *)&xop_null;
16625 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
16629 if(field == XOPe_xop_ptr) {
16632 const U32 flags = XopFLAGS(xop);
16633 if(flags & field) {
16635 case XOPe_xop_name:
16636 any.xop_name = xop->xop_name;
16638 case XOPe_xop_desc:
16639 any.xop_desc = xop->xop_desc;
16641 case XOPe_xop_class:
16642 any.xop_class = xop->xop_class;
16644 case XOPe_xop_peep:
16645 any.xop_peep = xop->xop_peep;
16648 NOT_REACHED; /* NOTREACHED */
16653 case XOPe_xop_name:
16654 any.xop_name = XOPd_xop_name;
16656 case XOPe_xop_desc:
16657 any.xop_desc = XOPd_xop_desc;
16659 case XOPe_xop_class:
16660 any.xop_class = XOPd_xop_class;
16662 case XOPe_xop_peep:
16663 any.xop_peep = XOPd_xop_peep;
16666 NOT_REACHED; /* NOTREACHED */
16671 /* On some platforms (HP-UX, IA64) gcc emits a warning for this function:
16672 * op.c: In function 'Perl_custom_op_get_field':
16673 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
16674 * This is because on those platforms (with -DEBUGGING) NOT_REACHED
16675 * expands to assert(0), which expands to ((0) ? (void)0 :
16676 * __assert(...)), and gcc doesn't know that __assert can never return. */
16682 =for apidoc Ao||custom_op_register
16683 Register a custom op. See L<perlguts/"Custom Operators">.
16689 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
16693 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
16695 /* see the comment in custom_op_xop */
16696 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
16698 if (!PL_custom_ops)
16699 PL_custom_ops = newHV();
16701 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
16702 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
16707 =for apidoc core_prototype
16709 This function assigns the prototype of the named core function to C<sv>, or
16710 to a new mortal SV if C<sv> is C<NULL>. It returns the modified C<sv>, or
16711 C<NULL> if the core function has no prototype. C<code> is a code as returned
16712 by C<keyword()>. It must not be equal to 0.
16718 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
16721 int i = 0, n = 0, seen_question = 0, defgv = 0;
16723 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
16724 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
16725 bool nullret = FALSE;
16727 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
16731 if (!sv) sv = sv_newmortal();
16733 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
16735 switch (code < 0 ? -code : code) {
16736 case KEY_and : case KEY_chop: case KEY_chomp:
16737 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
16738 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
16739 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
16740 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
16741 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
16742 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
16743 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
16744 case KEY_x : case KEY_xor :
16745 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
16746 case KEY_glob: retsetpvs("_;", OP_GLOB);
16747 case KEY_keys: retsetpvs("\\[%@]", OP_KEYS);
16748 case KEY_values: retsetpvs("\\[%@]", OP_VALUES);
16749 case KEY_each: retsetpvs("\\[%@]", OP_EACH);
16750 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
16751 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
16753 case KEY_evalbytes:
16754 name = "entereval"; break;
16762 while (i < MAXO) { /* The slow way. */
16763 if (strEQ(name, PL_op_name[i])
16764 || strEQ(name, PL_op_desc[i]))
16766 if (nullret) { assert(opnum); *opnum = i; return NULL; }
16773 defgv = PL_opargs[i] & OA_DEFGV;
16774 oa = PL_opargs[i] >> OASHIFT;
16776 if (oa & OA_OPTIONAL && !seen_question && (
16777 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
16782 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
16783 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
16784 /* But globs are already references (kinda) */
16785 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
16789 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
16790 && !scalar_mod_type(NULL, i)) {
16795 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
16799 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
16800 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
16801 str[n-1] = '_'; defgv = 0;
16805 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
16807 sv_setpvn(sv, str, n - 1);
16808 if (opnum) *opnum = i;
16813 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
16816 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
16819 PERL_ARGS_ASSERT_CORESUB_OP;
16823 return op_append_elem(OP_LINESEQ,
16826 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
16833 o = newUNOP(OP_AVHVSWITCH,0,argop);
16834 o->op_private = opnum-OP_EACH;
16836 case OP_SELECT: /* which represents OP_SSELECT as well */
16841 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
16842 newSVOP(OP_CONST, 0, newSVuv(1))
16844 coresub_op(newSVuv((UV)OP_SSELECT), 0,
16846 coresub_op(coreargssv, 0, OP_SELECT)
16850 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
16852 return op_append_elem(
16855 opnum == OP_WANTARRAY || opnum == OP_RUNCV
16856 ? OPpOFFBYONE << 8 : 0)
16858 case OA_BASEOP_OR_UNOP:
16859 if (opnum == OP_ENTEREVAL) {
16860 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
16861 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
16863 else o = newUNOP(opnum,0,argop);
16864 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
16867 if (is_handle_constructor(o, 1))
16868 argop->op_private |= OPpCOREARGS_DEREF1;
16869 if (scalar_mod_type(NULL, opnum))
16870 argop->op_private |= OPpCOREARGS_SCALARMOD;
16874 o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
16875 if (is_handle_constructor(o, 2))
16876 argop->op_private |= OPpCOREARGS_DEREF2;
16877 if (opnum == OP_SUBSTR) {
16878 o->op_private |= OPpMAYBE_LVSUB;
16887 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
16888 SV * const *new_const_svp)
16890 const char *hvname;
16891 bool is_const = !!CvCONST(old_cv);
16892 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
16894 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
16896 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
16898 /* They are 2 constant subroutines generated from
16899 the same constant. This probably means that
16900 they are really the "same" proxy subroutine
16901 instantiated in 2 places. Most likely this is
16902 when a constant is exported twice. Don't warn.
16905 (ckWARN(WARN_REDEFINE)
16907 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
16908 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
16909 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
16910 strEQ(hvname, "autouse"))
16914 && ckWARN_d(WARN_REDEFINE)
16915 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
16918 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
16920 ? "Constant subroutine %" SVf " redefined"
16921 : "Subroutine %" SVf " redefined",
16926 =head1 Hook manipulation
16928 These functions provide convenient and thread-safe means of manipulating
16935 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
16937 Puts a C function into the chain of check functions for a specified op
16938 type. This is the preferred way to manipulate the L</PL_check> array.
16939 C<opcode> specifies which type of op is to be affected. C<new_checker>
16940 is a pointer to the C function that is to be added to that opcode's
16941 check chain, and C<old_checker_p> points to the storage location where a
16942 pointer to the next function in the chain will be stored. The value of
16943 C<new_checker> is written into the L</PL_check> array, while the value
16944 previously stored there is written to C<*old_checker_p>.
16946 L</PL_check> is global to an entire process, and a module wishing to
16947 hook op checking may find itself invoked more than once per process,
16948 typically in different threads. To handle that situation, this function
16949 is idempotent. The location C<*old_checker_p> must initially (once
16950 per process) contain a null pointer. A C variable of static duration
16951 (declared at file scope, typically also marked C<static> to give
16952 it internal linkage) will be implicitly initialised appropriately,
16953 if it does not have an explicit initialiser. This function will only
16954 actually modify the check chain if it finds C<*old_checker_p> to be null.
16955 This function is also thread safe on the small scale. It uses appropriate
16956 locking to avoid race conditions in accessing L</PL_check>.
16958 When this function is called, the function referenced by C<new_checker>
16959 must be ready to be called, except for C<*old_checker_p> being unfilled.
16960 In a threading situation, C<new_checker> may be called immediately,
16961 even before this function has returned. C<*old_checker_p> will always
16962 be appropriately set before C<new_checker> is called. If C<new_checker>
16963 decides not to do anything special with an op that it is given (which
16964 is the usual case for most uses of op check hooking), it must chain the
16965 check function referenced by C<*old_checker_p>.
16967 Taken all together, XS code to hook an op checker should typically look
16968 something like this:
16970 static Perl_check_t nxck_frob;
16971 static OP *myck_frob(pTHX_ OP *op) {
16973 op = nxck_frob(aTHX_ op);
16978 wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
16980 If you want to influence compilation of calls to a specific subroutine,
16981 then use L</cv_set_call_checker_flags> rather than hooking checking of
16982 all C<entersub> ops.
16988 Perl_wrap_op_checker(pTHX_ Optype opcode,
16989 Perl_check_t new_checker, Perl_check_t *old_checker_p)
16993 PERL_UNUSED_CONTEXT;
16994 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
16995 if (*old_checker_p) return;
16996 OP_CHECK_MUTEX_LOCK;
16997 if (!*old_checker_p) {
16998 *old_checker_p = PL_check[opcode];
16999 PL_check[opcode] = new_checker;
17001 OP_CHECK_MUTEX_UNLOCK;
17006 /* Efficient sub that returns a constant scalar value. */
17008 const_sv_xsub(pTHX_ CV* cv)
17011 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
17012 PERL_UNUSED_ARG(items);
17022 const_av_xsub(pTHX_ CV* cv)
17025 AV * const av = MUTABLE_AV(XSANY.any_ptr);
17033 if (SvRMAGICAL(av))
17034 Perl_croak(aTHX_ "Magical list constants are not supported");
17035 if (GIMME_V != G_ARRAY) {
17037 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
17040 EXTEND(SP, AvFILLp(av)+1);
17041 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
17042 XSRETURN(AvFILLp(av)+1);
17045 /* Copy an existing cop->cop_warnings field.
17046 * If it's one of the standard addresses, just re-use the address.
17047 * This is the e implementation for the DUP_WARNINGS() macro
17051 Perl_dup_warnings(pTHX_ STRLEN* warnings)
17054 STRLEN *new_warnings;
17056 if (warnings == NULL || specialWARN(warnings))
17059 size = sizeof(*warnings) + *warnings;
17061 new_warnings = (STRLEN*)PerlMemShared_malloc(size);
17062 Copy(warnings, new_warnings, size, char);
17063 return new_warnings;
17067 * ex: set ts=8 sts=4 sw=4 et:
https://perl5.git.perl.org / perl5.git / blob