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 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
112 /* remove any leading "empty" ops from the op_next chain whose first
113 * node's address is stored in op_p. Store the updated address of the
114 * first node in op_p.
118 S_prune_chain_head(OP** op_p)
121 && ( (*op_p)->op_type == OP_NULL
122 || (*op_p)->op_type == OP_SCOPE
123 || (*op_p)->op_type == OP_SCALAR
124 || (*op_p)->op_type == OP_LINESEQ)
126 *op_p = (*op_p)->op_next;
130 /* See the explanatory comments above struct opslab in op.h. */
132 #ifdef PERL_DEBUG_READONLY_OPS
133 # define PERL_SLAB_SIZE 128
134 # define PERL_MAX_SLAB_SIZE 4096
135 # include <sys/mman.h>
138 #ifndef PERL_SLAB_SIZE
139 # define PERL_SLAB_SIZE 64
141 #ifndef PERL_MAX_SLAB_SIZE
142 # define PERL_MAX_SLAB_SIZE 2048
145 /* rounds up to nearest pointer */
146 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
147 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
150 S_new_slab(pTHX_ size_t sz)
152 #ifdef PERL_DEBUG_READONLY_OPS
153 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
154 PROT_READ|PROT_WRITE,
155 MAP_ANON|MAP_PRIVATE, -1, 0);
156 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
157 (unsigned long) sz, slab));
158 if (slab == MAP_FAILED) {
159 perror("mmap failed");
162 slab->opslab_size = (U16)sz;
164 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
167 /* The context is unused in non-Windows */
170 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
174 /* requires double parens and aTHX_ */
175 #define DEBUG_S_warn(args) \
177 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
181 Perl_Slab_Alloc(pTHX_ size_t sz)
189 /* We only allocate ops from the slab during subroutine compilation.
190 We find the slab via PL_compcv, hence that must be non-NULL. It could
191 also be pointing to a subroutine which is now fully set up (CvROOT()
192 pointing to the top of the optree for that sub), or a subroutine
193 which isn't using the slab allocator. If our sanity checks aren't met,
194 don't use a slab, but allocate the OP directly from the heap. */
195 if (!PL_compcv || CvROOT(PL_compcv)
196 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
198 o = (OP*)PerlMemShared_calloc(1, sz);
202 /* While the subroutine is under construction, the slabs are accessed via
203 CvSTART(), to avoid needing to expand PVCV by one pointer for something
204 unneeded at runtime. Once a subroutine is constructed, the slabs are
205 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
206 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
208 if (!CvSTART(PL_compcv)) {
210 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
211 CvSLABBED_on(PL_compcv);
212 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
214 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
216 opsz = SIZE_TO_PSIZE(sz);
217 sz = opsz + OPSLOT_HEADER_P;
219 /* The slabs maintain a free list of OPs. In particular, constant folding
220 will free up OPs, so it makes sense to re-use them where possible. A
221 freed up slot is used in preference to a new allocation. */
222 if (slab->opslab_freed) {
223 OP **too = &slab->opslab_freed;
225 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
226 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
227 DEBUG_S_warn((aTHX_ "Alas! too small"));
228 o = *(too = &o->op_next);
229 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
233 Zero(o, opsz, I32 *);
239 #define INIT_OPSLOT \
240 slot->opslot_slab = slab; \
241 slot->opslot_next = slab2->opslab_first; \
242 slab2->opslab_first = slot; \
243 o = &slot->opslot_op; \
246 /* The partially-filled slab is next in the chain. */
247 slab2 = slab->opslab_next ? slab->opslab_next : slab;
248 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
249 /* Remaining space is too small. */
251 /* If we can fit a BASEOP, add it to the free chain, so as not
253 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
254 slot = &slab2->opslab_slots;
256 o->op_type = OP_FREED;
257 o->op_next = slab->opslab_freed;
258 slab->opslab_freed = o;
261 /* Create a new slab. Make this one twice as big. */
262 slot = slab2->opslab_first;
263 while (slot->opslot_next) slot = slot->opslot_next;
264 slab2 = S_new_slab(aTHX_
265 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
267 : (DIFF(slab2, slot)+1)*2);
268 slab2->opslab_next = slab->opslab_next;
269 slab->opslab_next = slab2;
271 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
273 /* Create a new op slot */
274 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
275 assert(slot >= &slab2->opslab_slots);
276 if (DIFF(&slab2->opslab_slots, slot)
277 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
278 slot = &slab2->opslab_slots;
280 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
283 /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
285 assert(!o->op_sibling);
292 #ifdef PERL_DEBUG_READONLY_OPS
294 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
296 PERL_ARGS_ASSERT_SLAB_TO_RO;
298 if (slab->opslab_readonly) return;
299 slab->opslab_readonly = 1;
300 for (; slab; slab = slab->opslab_next) {
301 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
302 (unsigned long) slab->opslab_size, slab));*/
303 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
304 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
305 (unsigned long)slab->opslab_size, errno);
310 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
314 PERL_ARGS_ASSERT_SLAB_TO_RW;
316 if (!slab->opslab_readonly) return;
318 for (; slab2; slab2 = slab2->opslab_next) {
319 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
320 (unsigned long) size, slab2));*/
321 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
322 PROT_READ|PROT_WRITE)) {
323 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
324 (unsigned long)slab2->opslab_size, errno);
327 slab->opslab_readonly = 0;
331 # define Slab_to_rw(op) NOOP
334 /* This cannot possibly be right, but it was copied from the old slab
335 allocator, to which it was originally added, without explanation, in
338 # define PerlMemShared PerlMem
342 Perl_Slab_Free(pTHX_ void *op)
344 OP * const o = (OP *)op;
347 PERL_ARGS_ASSERT_SLAB_FREE;
349 if (!o->op_slabbed) {
351 PerlMemShared_free(op);
356 /* If this op is already freed, our refcount will get screwy. */
357 assert(o->op_type != OP_FREED);
358 o->op_type = OP_FREED;
359 o->op_next = slab->opslab_freed;
360 slab->opslab_freed = o;
361 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
362 OpslabREFCNT_dec_padok(slab);
366 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
368 const bool havepad = !!PL_comppad;
369 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
372 PAD_SAVE_SETNULLPAD();
379 Perl_opslab_free(pTHX_ OPSLAB *slab)
382 PERL_ARGS_ASSERT_OPSLAB_FREE;
384 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
385 assert(slab->opslab_refcnt == 1);
386 for (; slab; slab = slab2) {
387 slab2 = slab->opslab_next;
389 slab->opslab_refcnt = ~(size_t)0;
391 #ifdef PERL_DEBUG_READONLY_OPS
392 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
394 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
395 perror("munmap failed");
399 PerlMemShared_free(slab);
405 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
410 size_t savestack_count = 0;
412 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
415 for (slot = slab2->opslab_first;
417 slot = slot->opslot_next) {
418 if (slot->opslot_op.op_type != OP_FREED
419 && !(slot->opslot_op.op_savefree
425 assert(slot->opslot_op.op_slabbed);
426 op_free(&slot->opslot_op);
427 if (slab->opslab_refcnt == 1) goto free;
430 } while ((slab2 = slab2->opslab_next));
431 /* > 1 because the CV still holds a reference count. */
432 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
434 assert(savestack_count == slab->opslab_refcnt-1);
436 /* Remove the CV’s reference count. */
437 slab->opslab_refcnt--;
444 #ifdef PERL_DEBUG_READONLY_OPS
446 Perl_op_refcnt_inc(pTHX_ OP *o)
449 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
450 if (slab && slab->opslab_readonly) {
463 Perl_op_refcnt_dec(pTHX_ OP *o)
466 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
468 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
470 if (slab && slab->opslab_readonly) {
472 result = --o->op_targ;
475 result = --o->op_targ;
481 * In the following definition, the ", (OP*)0" is just to make the compiler
482 * think the expression is of the right type: croak actually does a Siglongjmp.
484 #define CHECKOP(type,o) \
485 ((PL_op_mask && PL_op_mask[type]) \
486 ? ( op_free((OP*)o), \
487 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
489 : PL_check[type](aTHX_ (OP*)o))
491 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
493 #define CHANGE_TYPE(o,type) \
495 o->op_type = (OPCODE)type; \
496 o->op_ppaddr = PL_ppaddr[type]; \
500 S_no_fh_allowed(pTHX_ OP *o)
502 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
504 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
510 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
512 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
513 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
518 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
520 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
522 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
527 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
529 PERL_ARGS_ASSERT_BAD_TYPE_PV;
531 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
532 (int)n, name, t, OP_DESC(kid)), flags);
536 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
538 SV * const namesv = cv_name((CV *)gv, NULL);
539 PERL_ARGS_ASSERT_BAD_TYPE_GV;
541 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
542 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
546 S_no_bareword_allowed(pTHX_ OP *o)
548 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
550 qerror(Perl_mess(aTHX_
551 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
553 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
556 /* "register" allocation */
559 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
562 const bool is_our = (PL_parser->in_my == KEY_our);
564 PERL_ARGS_ASSERT_ALLOCMY;
566 if (flags & ~SVf_UTF8)
567 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
570 /* Until we're using the length for real, cross check that we're being
572 assert(strlen(name) == len);
574 /* complain about "my $<special_var>" etc etc */
578 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
579 (name[1] == '_' && (*name == '$' || len > 2))))
581 /* name[2] is true if strlen(name) > 2 */
582 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
583 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
584 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
585 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
586 PL_parser->in_my == KEY_state ? "state" : "my"));
588 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
589 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
592 else if (len == 2 && name[1] == '_' && !is_our)
593 /* diag_listed_as: Use of my $_ is experimental */
594 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
595 "Use of %s $_ is experimental",
596 PL_parser->in_my == KEY_state
600 /* allocate a spare slot and store the name in that slot */
602 off = pad_add_name_pvn(name, len,
603 (is_our ? padadd_OUR :
604 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
605 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
606 PL_parser->in_my_stash,
608 /* $_ is always in main::, even with our */
609 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
613 /* anon sub prototypes contains state vars should always be cloned,
614 * otherwise the state var would be shared between anon subs */
616 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
617 CvCLONE_on(PL_compcv);
623 =head1 Optree Manipulation Functions
625 =for apidoc alloccopstash
627 Available only under threaded builds, this function allocates an entry in
628 C<PL_stashpad> for the stash passed to it.
635 Perl_alloccopstash(pTHX_ HV *hv)
637 PADOFFSET off = 0, o = 1;
638 bool found_slot = FALSE;
640 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
642 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
644 for (; o < PL_stashpadmax; ++o) {
645 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
646 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
647 found_slot = TRUE, off = o;
650 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
651 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
652 off = PL_stashpadmax;
653 PL_stashpadmax += 10;
656 PL_stashpad[PL_stashpadix = off] = hv;
661 /* free the body of an op without examining its contents.
662 * Always use this rather than FreeOp directly */
665 S_op_destroy(pTHX_ OP *o)
673 =for apidoc Am|void|op_free|OP *o
675 Free an op. Only use this when an op is no longer linked to from any
682 Perl_op_free(pTHX_ OP *o)
689 /* Though ops may be freed twice, freeing the op after its slab is a
691 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
692 /* During the forced freeing of ops after compilation failure, kidops
693 may be freed before their parents. */
694 if (!o || o->op_type == OP_FREED)
699 /* an op should only ever acquire op_private flags that we know about.
700 * If this fails, you may need to fix something in regen/op_private */
701 assert(!(o->op_private & ~PL_op_private_valid[type]));
703 if (o->op_private & OPpREFCOUNTED) {
714 refcnt = OpREFCNT_dec(o);
717 /* Need to find and remove any pattern match ops from the list
718 we maintain for reset(). */
719 find_and_forget_pmops(o);
729 /* Call the op_free hook if it has been set. Do it now so that it's called
730 * at the right time for refcounted ops, but still before all of the kids
734 if (o->op_flags & OPf_KIDS) {
736 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
737 nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
742 type = (OPCODE)o->op_targ;
745 Slab_to_rw(OpSLAB(o));
747 /* COP* is not cleared by op_clear() so that we may track line
748 * numbers etc even after null() */
749 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
755 #ifdef DEBUG_LEAKING_SCALARS
762 Perl_op_clear(pTHX_ OP *o)
767 PERL_ARGS_ASSERT_OP_CLEAR;
769 switch (o->op_type) {
770 case OP_NULL: /* Was holding old type, if any. */
773 case OP_ENTEREVAL: /* Was holding hints. */
777 if (!(o->op_flags & OPf_REF)
778 || (PL_check[o->op_type] != Perl_ck_ftst))
785 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
790 /* It's possible during global destruction that the GV is freed
791 before the optree. Whilst the SvREFCNT_inc is happy to bump from
792 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
793 will trigger an assertion failure, because the entry to sv_clear
794 checks that the scalar is not already freed. A check of for
795 !SvIS_FREED(gv) turns out to be invalid, because during global
796 destruction the reference count can be forced down to zero
797 (with SVf_BREAK set). In which case raising to 1 and then
798 dropping to 0 triggers cleanup before it should happen. I
799 *think* that this might actually be a general, systematic,
800 weakness of the whole idea of SVf_BREAK, in that code *is*
801 allowed to raise and lower references during global destruction,
802 so any *valid* code that happens to do this during global
803 destruction might well trigger premature cleanup. */
804 bool still_valid = gv && SvREFCNT(gv);
807 SvREFCNT_inc_simple_void(gv);
809 if (cPADOPo->op_padix > 0) {
810 pad_swipe(cPADOPo->op_padix, TRUE);
811 cPADOPo->op_padix = 0;
814 SvREFCNT_dec(cSVOPo->op_sv);
815 cSVOPo->op_sv = NULL;
818 int try_downgrade = SvREFCNT(gv) == 2;
821 gv_try_downgrade(gv);
825 case OP_METHOD_NAMED:
828 SvREFCNT_dec(cSVOPo->op_sv);
829 cSVOPo->op_sv = NULL;
832 Even if op_clear does a pad_free for the target of the op,
833 pad_free doesn't actually remove the sv that exists in the pad;
834 instead it lives on. This results in that it could be reused as
835 a target later on when the pad was reallocated.
838 pad_swipe(o->op_targ,1);
848 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
853 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
854 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
856 if (cPADOPo->op_padix > 0) {
857 pad_swipe(cPADOPo->op_padix, TRUE);
858 cPADOPo->op_padix = 0;
861 SvREFCNT_dec(cSVOPo->op_sv);
862 cSVOPo->op_sv = NULL;
866 PerlMemShared_free(cPVOPo->op_pv);
867 cPVOPo->op_pv = NULL;
871 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
875 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
876 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
879 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
885 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
886 op_free(cPMOPo->op_code_list);
887 cPMOPo->op_code_list = NULL;
889 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
890 /* we use the same protection as the "SAFE" version of the PM_ macros
891 * here since sv_clean_all might release some PMOPs
892 * after PL_regex_padav has been cleared
893 * and the clearing of PL_regex_padav needs to
894 * happen before sv_clean_all
897 if(PL_regex_pad) { /* We could be in destruction */
898 const IV offset = (cPMOPo)->op_pmoffset;
899 ReREFCNT_dec(PM_GETRE(cPMOPo));
900 PL_regex_pad[offset] = &PL_sv_undef;
901 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
905 ReREFCNT_dec(PM_GETRE(cPMOPo));
906 PM_SETRE(cPMOPo, NULL);
912 if (o->op_targ > 0) {
913 pad_free(o->op_targ);
919 S_cop_free(pTHX_ COP* cop)
921 PERL_ARGS_ASSERT_COP_FREE;
924 if (! specialWARN(cop->cop_warnings))
925 PerlMemShared_free(cop->cop_warnings);
926 cophh_free(CopHINTHASH_get(cop));
927 if (PL_curcop == cop)
932 S_forget_pmop(pTHX_ PMOP *const o
935 HV * const pmstash = PmopSTASH(o);
937 PERL_ARGS_ASSERT_FORGET_PMOP;
939 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
940 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
942 PMOP **const array = (PMOP**) mg->mg_ptr;
943 U32 count = mg->mg_len / sizeof(PMOP**);
948 /* Found it. Move the entry at the end to overwrite it. */
949 array[i] = array[--count];
950 mg->mg_len = count * sizeof(PMOP**);
951 /* Could realloc smaller at this point always, but probably
952 not worth it. Probably worth free()ing if we're the
955 Safefree(mg->mg_ptr);
968 S_find_and_forget_pmops(pTHX_ OP *o)
970 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
972 if (o->op_flags & OPf_KIDS) {
973 OP *kid = cUNOPo->op_first;
975 switch (kid->op_type) {
980 forget_pmop((PMOP*)kid);
982 find_and_forget_pmops(kid);
983 kid = OP_SIBLING(kid);
989 =for apidoc Am|void|op_null|OP *o
991 Neutralizes an op when it is no longer needed, but is still linked to from
998 Perl_op_null(pTHX_ OP *o)
1002 PERL_ARGS_ASSERT_OP_NULL;
1004 if (o->op_type == OP_NULL)
1007 o->op_targ = o->op_type;
1008 o->op_type = OP_NULL;
1009 o->op_ppaddr = PL_ppaddr[OP_NULL];
1013 Perl_op_refcnt_lock(pTHX)
1018 PERL_UNUSED_CONTEXT;
1023 Perl_op_refcnt_unlock(pTHX)
1028 PERL_UNUSED_CONTEXT;
1034 =for apidoc op_sibling_splice
1036 A general function for editing the structure of an existing chain of
1037 op_sibling nodes. By analogy with the perl-level splice() function, allows
1038 you to delete zero or more sequential nodes, replacing them with zero or
1039 more different nodes. Performs the necessary op_first/op_last
1040 housekeeping on the parent node and op_sibling manipulation on the
1041 children. The last deleted node will be marked as as the last node by
1042 updating the op_sibling or op_lastsib field as appropriate.
1044 Note that op_next is not manipulated, and nodes are not freed; that is the
1045 responsibility of the caller. It also won't create a new list op for an
1046 empty list etc; use higher-level functions like op_append_elem() for that.
1048 parent is the parent node of the sibling chain.
1050 start is the node preceding the first node to be spliced. Node(s)
1051 following it will be deleted, and ops will be inserted after it. If it is
1052 NULL, the first node onwards is deleted, and nodes are inserted at the
1055 del_count is the number of nodes to delete. If zero, no nodes are deleted.
1056 If -1 or greater than or equal to the number of remaining kids, all
1057 remaining kids are deleted.
1059 insert is the first of a chain of nodes to be inserted in place of the nodes.
1060 If NULL, no nodes are inserted.
1062 The head of the chain of deleted ops is returned, or NULL if no ops were
1067 action before after returns
1068 ------ ----- ----- -------
1071 splice(P, A, 2, X-Y-Z) | | B-C
1075 splice(P, NULL, 1, X-Y) | | A
1079 splice(P, NULL, 3, NULL) | | A-B-C
1083 splice(P, B, 0, X-Y) | | NULL
1090 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1092 OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1094 OP *last_del = NULL;
1095 OP *last_ins = NULL;
1097 PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1099 assert(del_count >= -1);
1101 if (del_count && first) {
1103 while (--del_count && OP_HAS_SIBLING(last_del))
1104 last_del = OP_SIBLING(last_del);
1105 rest = OP_SIBLING(last_del);
1106 OP_SIBLING_set(last_del, NULL);
1107 last_del->op_lastsib = 1;
1114 while (OP_HAS_SIBLING(last_ins))
1115 last_ins = OP_SIBLING(last_ins);
1116 OP_SIBLING_set(last_ins, rest);
1117 last_ins->op_lastsib = rest ? 0 : 1;
1123 OP_SIBLING_set(start, insert);
1124 start->op_lastsib = insert ? 0 : 1;
1127 cLISTOPx(parent)->op_first = insert;
1130 /* update op_last etc */
1131 U32 type = parent->op_type;
1134 if (type == OP_NULL)
1135 type = parent->op_targ;
1136 type = PL_opargs[type] & OA_CLASS_MASK;
1138 lastop = last_ins ? last_ins : start ? start : NULL;
1139 if ( type == OA_BINOP
1140 || type == OA_LISTOP
1144 cLISTOPx(parent)->op_last = lastop;
1147 lastop->op_lastsib = 1;
1148 #ifdef PERL_OP_PARENT
1149 lastop->op_sibling = parent;
1153 return last_del ? first : NULL;
1157 =for apidoc op_parent
1159 returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1160 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1167 Perl_op_parent(OP *o)
1169 PERL_ARGS_ASSERT_OP_PARENT;
1170 #ifdef PERL_OP_PARENT
1171 while (OP_HAS_SIBLING(o))
1173 return o->op_sibling;
1181 /* replace the sibling following start with a new UNOP, which becomes
1182 * the parent of the original sibling; e.g.
1184 * op_sibling_newUNOP(P, A, unop-args...)
1192 * where U is the new UNOP.
1194 * parent and start args are the same as for op_sibling_splice();
1195 * type and flags args are as newUNOP().
1197 * Returns the new UNOP.
1201 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1205 kid = op_sibling_splice(parent, start, 1, NULL);
1206 newop = newUNOP(type, flags, kid);
1207 op_sibling_splice(parent, start, 0, newop);
1212 /* lowest-level newLOGOP-style function - just allocates and populates
1213 * the struct. Higher-level stuff should be done by S_new_logop() /
1214 * newLOGOP(). This function exists mainly to avoid op_first assignment
1215 * being spread throughout this file.
1219 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1223 NewOp(1101, logop, 1, LOGOP);
1224 logop->op_type = (OPCODE)type;
1225 logop->op_first = first;
1226 logop->op_other = other;
1227 logop->op_flags = OPf_KIDS;
1228 while (kid && OP_HAS_SIBLING(kid))
1229 kid = OP_SIBLING(kid);
1231 kid->op_lastsib = 1;
1232 #ifdef PERL_OP_PARENT
1233 kid->op_sibling = (OP*)logop;
1240 /* Contextualizers */
1243 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1245 Applies a syntactic context to an op tree representing an expression.
1246 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1247 or C<G_VOID> to specify the context to apply. The modified op tree
1254 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1256 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1258 case G_SCALAR: return scalar(o);
1259 case G_ARRAY: return list(o);
1260 case G_VOID: return scalarvoid(o);
1262 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1269 =for apidoc Am|OP*|op_linklist|OP *o
1270 This function is the implementation of the L</LINKLIST> macro. It should
1271 not be called directly.
1277 Perl_op_linklist(pTHX_ OP *o)
1281 PERL_ARGS_ASSERT_OP_LINKLIST;
1286 /* establish postfix order */
1287 first = cUNOPo->op_first;
1290 o->op_next = LINKLIST(first);
1293 OP *sibl = OP_SIBLING(kid);
1295 kid->op_next = LINKLIST(sibl);
1310 S_scalarkids(pTHX_ OP *o)
1312 if (o && o->op_flags & OPf_KIDS) {
1314 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1321 S_scalarboolean(pTHX_ OP *o)
1323 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1325 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1326 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1327 if (ckWARN(WARN_SYNTAX)) {
1328 const line_t oldline = CopLINE(PL_curcop);
1330 if (PL_parser && PL_parser->copline != NOLINE) {
1331 /* This ensures that warnings are reported at the first line
1332 of the conditional, not the last. */
1333 CopLINE_set(PL_curcop, PL_parser->copline);
1335 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1336 CopLINE_set(PL_curcop, oldline);
1343 S_op_varname(pTHX_ const OP *o)
1346 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1347 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1349 const char funny = o->op_type == OP_PADAV
1350 || o->op_type == OP_RV2AV ? '@' : '%';
1351 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1353 if (cUNOPo->op_first->op_type != OP_GV
1354 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1356 return varname(gv, funny, 0, NULL, 0, 1);
1359 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1364 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1365 { /* or not so pretty :-) */
1366 if (o->op_type == OP_CONST) {
1368 if (SvPOK(*retsv)) {
1370 *retsv = sv_newmortal();
1371 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1372 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1374 else if (!SvOK(*retsv))
1377 else *retpv = "...";
1381 S_scalar_slice_warning(pTHX_ const OP *o)
1385 o->op_type == OP_HSLICE ? '{' : '[';
1387 o->op_type == OP_HSLICE ? '}' : ']';
1389 SV *keysv = NULL; /* just to silence compiler warnings */
1390 const char *key = NULL;
1392 if (!(o->op_private & OPpSLICEWARNING))
1394 if (PL_parser && PL_parser->error_count)
1395 /* This warning can be nonsensical when there is a syntax error. */
1398 kid = cLISTOPo->op_first;
1399 kid = OP_SIBLING(kid); /* get past pushmark */
1400 /* weed out false positives: any ops that can return lists */
1401 switch (kid->op_type) {
1430 /* Don't warn if we have a nulled list either. */
1431 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1434 assert(OP_SIBLING(kid));
1435 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1436 if (!name) /* XS module fiddling with the op tree */
1438 S_op_pretty(aTHX_ kid, &keysv, &key);
1439 assert(SvPOK(name));
1440 sv_chop(name,SvPVX(name)+1);
1442 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1443 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1444 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1446 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1447 lbrack, key, rbrack);
1449 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1450 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1451 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1453 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1454 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1458 Perl_scalar(pTHX_ OP *o)
1462 /* assumes no premature commitment */
1463 if (!o || (PL_parser && PL_parser->error_count)
1464 || (o->op_flags & OPf_WANT)
1465 || o->op_type == OP_RETURN)
1470 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1472 switch (o->op_type) {
1474 scalar(cBINOPo->op_first);
1479 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1489 if (o->op_flags & OPf_KIDS) {
1490 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1496 kid = cLISTOPo->op_first;
1498 kid = OP_SIBLING(kid);
1501 OP *sib = OP_SIBLING(kid);
1502 if (sib && kid->op_type != OP_LEAVEWHEN)
1508 PL_curcop = &PL_compiling;
1513 kid = cLISTOPo->op_first;
1516 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1521 /* Warn about scalar context */
1522 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1523 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1526 const char *key = NULL;
1528 /* This warning can be nonsensical when there is a syntax error. */
1529 if (PL_parser && PL_parser->error_count)
1532 if (!ckWARN(WARN_SYNTAX)) break;
1534 kid = cLISTOPo->op_first;
1535 kid = OP_SIBLING(kid); /* get past pushmark */
1536 assert(OP_SIBLING(kid));
1537 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1538 if (!name) /* XS module fiddling with the op tree */
1540 S_op_pretty(aTHX_ kid, &keysv, &key);
1541 assert(SvPOK(name));
1542 sv_chop(name,SvPVX(name)+1);
1544 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1545 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1546 "%%%"SVf"%c%s%c in scalar context better written "
1548 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1549 lbrack, key, rbrack);
1551 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1552 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1553 "%%%"SVf"%c%"SVf"%c in scalar context better "
1554 "written as $%"SVf"%c%"SVf"%c",
1555 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1556 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1563 Perl_scalarvoid(pTHX_ OP *o)
1567 SV *useless_sv = NULL;
1568 const char* useless = NULL;
1572 PERL_ARGS_ASSERT_SCALARVOID;
1574 if (o->op_type == OP_NEXTSTATE
1575 || o->op_type == OP_DBSTATE
1576 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1577 || o->op_targ == OP_DBSTATE)))
1578 PL_curcop = (COP*)o; /* for warning below */
1580 /* assumes no premature commitment */
1581 want = o->op_flags & OPf_WANT;
1582 if ((want && want != OPf_WANT_SCALAR)
1583 || (PL_parser && PL_parser->error_count)
1584 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1589 if ((o->op_private & OPpTARGET_MY)
1590 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1592 return scalar(o); /* As if inside SASSIGN */
1595 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1597 switch (o->op_type) {
1599 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1603 if (o->op_flags & OPf_STACKED)
1607 if (o->op_private == 4)
1632 case OP_AELEMFAST_LEX:
1653 case OP_GETSOCKNAME:
1654 case OP_GETPEERNAME:
1659 case OP_GETPRIORITY:
1684 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1685 /* Otherwise it's "Useless use of grep iterator" */
1686 useless = OP_DESC(o);
1690 kid = cLISTOPo->op_first;
1691 if (kid && kid->op_type == OP_PUSHRE
1693 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1695 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1697 useless = OP_DESC(o);
1701 kid = cUNOPo->op_first;
1702 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1703 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1706 useless = "negative pattern binding (!~)";
1710 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1711 useless = "non-destructive substitution (s///r)";
1715 useless = "non-destructive transliteration (tr///r)";
1722 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1723 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1724 useless = "a variable";
1729 if (cSVOPo->op_private & OPpCONST_STRICT)
1730 no_bareword_allowed(o);
1732 if (ckWARN(WARN_VOID)) {
1733 /* don't warn on optimised away booleans, eg
1734 * use constant Foo, 5; Foo || print; */
1735 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1737 /* the constants 0 and 1 are permitted as they are
1738 conventionally used as dummies in constructs like
1739 1 while some_condition_with_side_effects; */
1740 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1742 else if (SvPOK(sv)) {
1743 SV * const dsv = newSVpvs("");
1745 = Perl_newSVpvf(aTHX_
1747 pv_pretty(dsv, SvPVX_const(sv),
1748 SvCUR(sv), 32, NULL, NULL,
1750 | PERL_PV_ESCAPE_NOCLEAR
1751 | PERL_PV_ESCAPE_UNI_DETECT));
1752 SvREFCNT_dec_NN(dsv);
1754 else if (SvOK(sv)) {
1755 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1758 useless = "a constant (undef)";
1761 op_null(o); /* don't execute or even remember it */
1765 o->op_type = OP_PREINC; /* pre-increment is faster */
1766 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1770 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1771 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1775 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1776 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1780 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1781 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1786 UNOP *refgen, *rv2cv;
1789 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1792 rv2gv = ((BINOP *)o)->op_last;
1793 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1796 refgen = (UNOP *)((BINOP *)o)->op_first;
1798 if (!refgen || refgen->op_type != OP_REFGEN)
1801 exlist = (LISTOP *)refgen->op_first;
1802 if (!exlist || exlist->op_type != OP_NULL
1803 || exlist->op_targ != OP_LIST)
1806 if (exlist->op_first->op_type != OP_PUSHMARK)
1809 rv2cv = (UNOP*)exlist->op_last;
1811 if (rv2cv->op_type != OP_RV2CV)
1814 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1815 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1816 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1818 o->op_private |= OPpASSIGN_CV_TO_GV;
1819 rv2gv->op_private |= OPpDONT_INIT_GV;
1820 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1832 kid = cLOGOPo->op_first;
1833 if (kid->op_type == OP_NOT
1834 && (kid->op_flags & OPf_KIDS)) {
1835 if (o->op_type == OP_AND) {
1837 o->op_ppaddr = PL_ppaddr[OP_OR];
1839 o->op_type = OP_AND;
1840 o->op_ppaddr = PL_ppaddr[OP_AND];
1850 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1855 if (o->op_flags & OPf_STACKED)
1862 if (!(o->op_flags & OPf_KIDS))
1873 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1884 /* mortalise it, in case warnings are fatal. */
1885 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1886 "Useless use of %"SVf" in void context",
1887 SVfARG(sv_2mortal(useless_sv)));
1890 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1891 "Useless use of %s in void context",
1898 S_listkids(pTHX_ OP *o)
1900 if (o && o->op_flags & OPf_KIDS) {
1902 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1909 Perl_list(pTHX_ OP *o)
1913 /* assumes no premature commitment */
1914 if (!o || (o->op_flags & OPf_WANT)
1915 || (PL_parser && PL_parser->error_count)
1916 || o->op_type == OP_RETURN)
1921 if ((o->op_private & OPpTARGET_MY)
1922 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1924 return o; /* As if inside SASSIGN */
1927 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1929 switch (o->op_type) {
1932 list(cBINOPo->op_first);
1937 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1945 if (!(o->op_flags & OPf_KIDS))
1947 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1948 list(cBINOPo->op_first);
1949 return gen_constant_list(o);
1956 kid = cLISTOPo->op_first;
1958 kid = OP_SIBLING(kid);
1961 OP *sib = OP_SIBLING(kid);
1962 if (sib && kid->op_type != OP_LEAVEWHEN)
1968 PL_curcop = &PL_compiling;
1972 kid = cLISTOPo->op_first;
1979 S_scalarseq(pTHX_ OP *o)
1982 const OPCODE type = o->op_type;
1984 if (type == OP_LINESEQ || type == OP_SCOPE ||
1985 type == OP_LEAVE || type == OP_LEAVETRY)
1988 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
1989 if (OP_HAS_SIBLING(kid)) {
1993 PL_curcop = &PL_compiling;
1995 o->op_flags &= ~OPf_PARENS;
1996 if (PL_hints & HINT_BLOCK_SCOPE)
1997 o->op_flags |= OPf_PARENS;
2000 o = newOP(OP_STUB, 0);
2005 S_modkids(pTHX_ OP *o, I32 type)
2007 if (o && o->op_flags & OPf_KIDS) {
2009 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2010 op_lvalue(kid, type);
2016 =for apidoc finalize_optree
2018 This function finalizes the optree. Should be called directly after
2019 the complete optree is built. It does some additional
2020 checking which can't be done in the normal ck_xxx functions and makes
2021 the tree thread-safe.
2026 Perl_finalize_optree(pTHX_ OP* o)
2028 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2031 SAVEVPTR(PL_curcop);
2039 S_finalize_op(pTHX_ OP* o)
2041 PERL_ARGS_ASSERT_FINALIZE_OP;
2044 switch (o->op_type) {
2047 PL_curcop = ((COP*)o); /* for warnings */
2050 if (OP_HAS_SIBLING(o)) {
2051 OP *sib = OP_SIBLING(o);
2052 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2053 && ckWARN(WARN_EXEC)
2054 && OP_HAS_SIBLING(sib))
2056 const OPCODE type = OP_SIBLING(sib)->op_type;
2057 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2058 const line_t oldline = CopLINE(PL_curcop);
2059 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2060 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2061 "Statement unlikely to be reached");
2062 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2063 "\t(Maybe you meant system() when you said exec()?)\n");
2064 CopLINE_set(PL_curcop, oldline);
2071 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2072 GV * const gv = cGVOPo_gv;
2073 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2074 /* XXX could check prototype here instead of just carping */
2075 SV * const sv = sv_newmortal();
2076 gv_efullname3(sv, gv, NULL);
2077 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2078 "%"SVf"() called too early to check prototype",
2085 if (cSVOPo->op_private & OPpCONST_STRICT)
2086 no_bareword_allowed(o);
2090 case OP_METHOD_NAMED:
2091 /* Relocate sv to the pad for thread safety.
2092 * Despite being a "constant", the SV is written to,
2093 * for reference counts, sv_upgrade() etc. */
2094 if (cSVOPo->op_sv) {
2095 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
2096 SvREFCNT_dec(PAD_SVl(ix));
2097 PAD_SETSV(ix, cSVOPo->op_sv);
2098 /* XXX I don't know how this isn't readonly already. */
2099 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2100 cSVOPo->op_sv = NULL;
2114 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2117 rop = (UNOP*)((BINOP*)o)->op_first;
2122 S_scalar_slice_warning(aTHX_ o);
2126 kid = OP_SIBLING(cLISTOPo->op_first);
2127 if (/* I bet there's always a pushmark... */
2128 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2129 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2134 key_op = (SVOP*)(kid->op_type == OP_CONST
2136 : OP_SIBLING(kLISTOP->op_first));
2138 rop = (UNOP*)((LISTOP*)o)->op_last;
2141 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2143 else if (rop->op_first->op_type == OP_PADSV)
2144 /* @$hash{qw(keys here)} */
2145 rop = (UNOP*)rop->op_first;
2147 /* @{$hash}{qw(keys here)} */
2148 if (rop->op_first->op_type == OP_SCOPE
2149 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2151 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2157 lexname = NULL; /* just to silence compiler warnings */
2158 fields = NULL; /* just to silence compiler warnings */
2162 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2163 SvPAD_TYPED(lexname))
2164 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2165 && isGV(*fields) && GvHV(*fields);
2167 key_op = (SVOP*)OP_SIBLING(key_op)) {
2169 if (key_op->op_type != OP_CONST)
2171 svp = cSVOPx_svp(key_op);
2173 /* Make the CONST have a shared SV */
2174 if ((!SvIsCOW_shared_hash(sv = *svp))
2175 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2177 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2178 SV *nsv = newSVpvn_share(key,
2179 SvUTF8(sv) ? -keylen : keylen, 0);
2180 SvREFCNT_dec_NN(sv);
2185 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2186 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2187 "in variable %"SVf" of type %"HEKf,
2188 SVfARG(*svp), SVfARG(lexname),
2189 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2195 S_scalar_slice_warning(aTHX_ o);
2199 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2200 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2207 if (o->op_flags & OPf_KIDS) {
2211 /* check that op_last points to the last sibling, and that
2212 * the last op_sibling field points back to the parent, and
2213 * that the only ops with KIDS are those which are entitled to
2215 U32 type = o->op_type;
2219 if (type == OP_NULL) {
2221 /* ck_glob creates a null UNOP with ex-type GLOB
2222 * (which is a list op. So pretend it wasn't a listop */
2223 if (type == OP_GLOB)
2226 family = PL_opargs[type] & OA_CLASS_MASK;
2228 has_last = ( family == OA_BINOP
2229 || family == OA_LISTOP
2230 || family == OA_PMOP
2231 || family == OA_LOOP
2233 assert( has_last /* has op_first and op_last, or ...
2234 ... has (or may have) op_first: */
2235 || family == OA_UNOP
2236 || family == OA_LOGOP
2237 || family == OA_BASEOP_OR_UNOP
2238 || family == OA_FILESTATOP
2239 || family == OA_LOOPEXOP
2240 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2241 || type == OP_SASSIGN
2242 || type == OP_CUSTOM
2243 || type == OP_NULL /* new_logop does this */
2245 /* XXX list form of 'x' is has a null op_last. This is wrong,
2246 * but requires too much hacking (e.g. in Deparse) to fix for
2248 if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2253 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2254 # ifdef PERL_OP_PARENT
2255 if (!OP_HAS_SIBLING(kid)) {
2257 assert(kid == cLISTOPo->op_last);
2258 assert(kid->op_sibling == o);
2261 if (OP_HAS_SIBLING(kid)) {
2262 assert(!kid->op_lastsib);
2265 assert(kid->op_lastsib);
2267 assert(kid == cLISTOPo->op_last);
2273 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2279 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2281 Propagate lvalue ("modifiable") context to an op and its children.
2282 I<type> represents the context type, roughly based on the type of op that
2283 would do the modifying, although C<local()> is represented by OP_NULL,
2284 because it has no op type of its own (it is signalled by a flag on
2287 This function detects things that can't be modified, such as C<$x+1>, and
2288 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2289 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2291 It also flags things that need to behave specially in an lvalue context,
2292 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2298 S_vivifies(const OPCODE type)
2301 case OP_RV2AV: case OP_ASLICE:
2302 case OP_RV2HV: case OP_KVASLICE:
2303 case OP_RV2SV: case OP_HSLICE:
2304 case OP_AELEMFAST: case OP_KVHSLICE:
2313 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2317 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2320 if (!o || (PL_parser && PL_parser->error_count))
2323 if ((o->op_private & OPpTARGET_MY)
2324 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2329 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2331 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2333 switch (o->op_type) {
2338 if ((o->op_flags & OPf_PARENS))
2342 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2343 !(o->op_flags & OPf_STACKED)) {
2344 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2345 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2346 assert(cUNOPo->op_first->op_type == OP_NULL);
2347 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2350 else { /* lvalue subroutine call */
2351 o->op_private |= OPpLVAL_INTRO
2352 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2353 PL_modcount = RETURN_UNLIMITED_NUMBER;
2354 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2355 /* Potential lvalue context: */
2356 o->op_private |= OPpENTERSUB_INARGS;
2359 else { /* Compile-time error message: */
2360 OP *kid = cUNOPo->op_first;
2364 if (kid->op_type != OP_PUSHMARK) {
2365 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2367 "panic: unexpected lvalue entersub "
2368 "args: type/targ %ld:%"UVuf,
2369 (long)kid->op_type, (UV)kid->op_targ);
2370 kid = kLISTOP->op_first;
2372 while (OP_HAS_SIBLING(kid))
2373 kid = OP_SIBLING(kid);
2374 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2375 break; /* Postpone until runtime */
2378 kid = kUNOP->op_first;
2379 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2380 kid = kUNOP->op_first;
2381 if (kid->op_type == OP_NULL)
2383 "Unexpected constant lvalue entersub "
2384 "entry via type/targ %ld:%"UVuf,
2385 (long)kid->op_type, (UV)kid->op_targ);
2386 if (kid->op_type != OP_GV) {
2393 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2394 ? MUTABLE_CV(SvRV(gv))
2405 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2406 /* grep, foreach, subcalls, refgen */
2407 if (type == OP_GREPSTART || type == OP_ENTERSUB
2408 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2410 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2411 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2413 : (o->op_type == OP_ENTERSUB
2414 ? "non-lvalue subroutine call"
2416 type ? PL_op_desc[type] : "local"));
2430 case OP_RIGHT_SHIFT:
2439 if (!(o->op_flags & OPf_STACKED))
2446 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2447 op_lvalue(kid, type);
2452 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2453 PL_modcount = RETURN_UNLIMITED_NUMBER;
2454 return o; /* Treat \(@foo) like ordinary list. */
2458 if (scalar_mod_type(o, type))
2460 ref(cUNOPo->op_first, o->op_type);
2467 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2468 if (type == OP_LEAVESUBLV && (
2469 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2470 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2472 o->op_private |= OPpMAYBE_LVSUB;
2476 PL_modcount = RETURN_UNLIMITED_NUMBER;
2480 if (type == OP_LEAVESUBLV)
2481 o->op_private |= OPpMAYBE_LVSUB;
2484 PL_hints |= HINT_BLOCK_SCOPE;
2485 if (type == OP_LEAVESUBLV)
2486 o->op_private |= OPpMAYBE_LVSUB;
2490 ref(cUNOPo->op_first, o->op_type);
2494 PL_hints |= HINT_BLOCK_SCOPE;
2504 case OP_AELEMFAST_LEX:
2511 PL_modcount = RETURN_UNLIMITED_NUMBER;
2512 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2513 return o; /* Treat \(@foo) like ordinary list. */
2514 if (scalar_mod_type(o, type))
2516 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2517 && type == OP_LEAVESUBLV)
2518 o->op_private |= OPpMAYBE_LVSUB;
2522 if (!type) /* local() */
2523 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2524 PAD_COMPNAME_SV(o->op_targ));
2533 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2537 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2543 if (type == OP_LEAVESUBLV)
2544 o->op_private |= OPpMAYBE_LVSUB;
2545 if (o->op_flags & OPf_KIDS)
2546 op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2551 ref(cBINOPo->op_first, o->op_type);
2552 if (type == OP_ENTERSUB &&
2553 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2554 o->op_private |= OPpLVAL_DEFER;
2555 if (type == OP_LEAVESUBLV)
2556 o->op_private |= OPpMAYBE_LVSUB;
2563 o->op_private |= OPpLVALUE;
2569 if (o->op_flags & OPf_KIDS)
2570 op_lvalue(cLISTOPo->op_last, type);
2575 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2577 else if (!(o->op_flags & OPf_KIDS))
2579 if (o->op_targ != OP_LIST) {
2580 op_lvalue(cBINOPo->op_first, type);
2586 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2587 /* elements might be in void context because the list is
2588 in scalar context or because they are attribute sub calls */
2589 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2590 op_lvalue(kid, type);
2594 if (type != OP_LEAVESUBLV)
2596 break; /* op_lvalue()ing was handled by ck_return() */
2603 if (type == OP_LEAVESUBLV
2604 || !S_vivifies(cLOGOPo->op_first->op_type))
2605 op_lvalue(cLOGOPo->op_first, type);
2606 if (type == OP_LEAVESUBLV
2607 || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2608 op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2612 /* [20011101.069] File test operators interpret OPf_REF to mean that
2613 their argument is a filehandle; thus \stat(".") should not set
2615 if (type == OP_REFGEN &&
2616 PL_check[o->op_type] == Perl_ck_ftst)
2619 if (type != OP_LEAVESUBLV)
2620 o->op_flags |= OPf_MOD;
2622 if (type == OP_AASSIGN || type == OP_SASSIGN)
2623 o->op_flags |= OPf_SPECIAL|OPf_REF;
2624 else if (!type) { /* local() */
2627 o->op_private |= OPpLVAL_INTRO;
2628 o->op_flags &= ~OPf_SPECIAL;
2629 PL_hints |= HINT_BLOCK_SCOPE;
2634 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2635 "Useless localization of %s", OP_DESC(o));
2638 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2639 && type != OP_LEAVESUBLV)
2640 o->op_flags |= OPf_REF;
2645 S_scalar_mod_type(const OP *o, I32 type)
2650 if (o && o->op_type == OP_RV2GV)
2674 case OP_RIGHT_SHIFT:
2695 S_is_handle_constructor(const OP *o, I32 numargs)
2697 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2699 switch (o->op_type) {
2707 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2720 S_refkids(pTHX_ OP *o, I32 type)
2722 if (o && o->op_flags & OPf_KIDS) {
2724 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2731 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2736 PERL_ARGS_ASSERT_DOREF;
2738 if (!o || (PL_parser && PL_parser->error_count))
2741 switch (o->op_type) {
2743 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2744 !(o->op_flags & OPf_STACKED)) {
2745 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2746 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2747 assert(cUNOPo->op_first->op_type == OP_NULL);
2748 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2749 o->op_flags |= OPf_SPECIAL;
2751 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2752 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2753 : type == OP_RV2HV ? OPpDEREF_HV
2755 o->op_flags |= OPf_MOD;
2761 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2762 doref(kid, type, set_op_ref);
2765 if (type == OP_DEFINED)
2766 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2767 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2770 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2771 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2772 : type == OP_RV2HV ? OPpDEREF_HV
2774 o->op_flags |= OPf_MOD;
2781 o->op_flags |= OPf_REF;
2784 if (type == OP_DEFINED)
2785 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2786 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2792 o->op_flags |= OPf_REF;
2797 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2799 doref(cBINOPo->op_first, type, set_op_ref);
2803 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2804 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2805 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2806 : type == OP_RV2HV ? OPpDEREF_HV
2808 o->op_flags |= OPf_MOD;
2818 if (!(o->op_flags & OPf_KIDS))
2820 doref(cLISTOPo->op_last, type, set_op_ref);
2830 S_dup_attrlist(pTHX_ OP *o)
2834 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2836 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2837 * where the first kid is OP_PUSHMARK and the remaining ones
2838 * are OP_CONST. We need to push the OP_CONST values.
2840 if (o->op_type == OP_CONST)
2841 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2843 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2845 for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
2846 if (o->op_type == OP_CONST)
2847 rop = op_append_elem(OP_LIST, rop,
2848 newSVOP(OP_CONST, o->op_flags,
2849 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2856 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2858 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2860 PERL_ARGS_ASSERT_APPLY_ATTRS;
2862 /* fake up C<use attributes $pkg,$rv,@attrs> */
2864 #define ATTRSMODULE "attributes"
2865 #define ATTRSMODULE_PM "attributes.pm"
2867 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2868 newSVpvs(ATTRSMODULE),
2870 op_prepend_elem(OP_LIST,
2871 newSVOP(OP_CONST, 0, stashsv),
2872 op_prepend_elem(OP_LIST,
2873 newSVOP(OP_CONST, 0,
2875 dup_attrlist(attrs))));
2879 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2881 OP *pack, *imop, *arg;
2882 SV *meth, *stashsv, **svp;
2884 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2889 assert(target->op_type == OP_PADSV ||
2890 target->op_type == OP_PADHV ||
2891 target->op_type == OP_PADAV);
2893 /* Ensure that attributes.pm is loaded. */
2894 /* Don't force the C<use> if we don't need it. */
2895 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2896 if (svp && *svp != &PL_sv_undef)
2897 NOOP; /* already in %INC */
2899 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2900 newSVpvs(ATTRSMODULE), NULL);
2902 /* Need package name for method call. */
2903 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2905 /* Build up the real arg-list. */
2906 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2908 arg = newOP(OP_PADSV, 0);
2909 arg->op_targ = target->op_targ;
2910 arg = op_prepend_elem(OP_LIST,
2911 newSVOP(OP_CONST, 0, stashsv),
2912 op_prepend_elem(OP_LIST,
2913 newUNOP(OP_REFGEN, 0,
2914 op_lvalue(arg, OP_REFGEN)),
2915 dup_attrlist(attrs)));
2917 /* Fake up a method call to import */
2918 meth = newSVpvs_share("import");
2919 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2920 op_append_elem(OP_LIST,
2921 op_prepend_elem(OP_LIST, pack, list(arg)),
2922 newSVOP(OP_METHOD_NAMED, 0, meth)));
2924 /* Combine the ops. */
2925 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2929 =notfor apidoc apply_attrs_string
2931 Attempts to apply a list of attributes specified by the C<attrstr> and
2932 C<len> arguments to the subroutine identified by the C<cv> argument which
2933 is expected to be associated with the package identified by the C<stashpv>
2934 argument (see L<attributes>). It gets this wrong, though, in that it
2935 does not correctly identify the boundaries of the individual attribute
2936 specifications within C<attrstr>. This is not really intended for the
2937 public API, but has to be listed here for systems such as AIX which
2938 need an explicit export list for symbols. (It's called from XS code
2939 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2940 to respect attribute syntax properly would be welcome.
2946 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2947 const char *attrstr, STRLEN len)
2951 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2954 len = strlen(attrstr);
2958 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2960 const char * const sstr = attrstr;
2961 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2962 attrs = op_append_elem(OP_LIST, attrs,
2963 newSVOP(OP_CONST, 0,
2964 newSVpvn(sstr, attrstr-sstr)));
2968 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2969 newSVpvs(ATTRSMODULE),
2970 NULL, op_prepend_elem(OP_LIST,
2971 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2972 op_prepend_elem(OP_LIST,
2973 newSVOP(OP_CONST, 0,
2974 newRV(MUTABLE_SV(cv))),
2979 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2981 OP *new_proto = NULL;
2986 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2992 if (o->op_type == OP_CONST) {
2993 pv = SvPV(cSVOPo_sv, pvlen);
2994 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2995 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2996 SV ** const tmpo = cSVOPx_svp(o);
2997 SvREFCNT_dec(cSVOPo_sv);
3002 } else if (o->op_type == OP_LIST) {
3004 assert(o->op_flags & OPf_KIDS);
3005 lasto = cLISTOPo->op_first;
3006 assert(lasto->op_type == OP_PUSHMARK);
3007 for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3008 if (o->op_type == OP_CONST) {
3009 pv = SvPV(cSVOPo_sv, pvlen);
3010 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3011 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3012 SV ** const tmpo = cSVOPx_svp(o);
3013 SvREFCNT_dec(cSVOPo_sv);
3015 if (new_proto && ckWARN(WARN_MISC)) {
3017 const char * newp = SvPV(cSVOPo_sv, new_len);
3018 Perl_warner(aTHX_ packWARN(WARN_MISC),
3019 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3020 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3026 /* excise new_proto from the list */
3027 op_sibling_splice(*attrs, lasto, 1, NULL);
3034 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3035 would get pulled in with no real need */
3036 if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3045 svname = sv_newmortal();
3046 gv_efullname3(svname, name, NULL);
3048 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3049 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3051 svname = (SV *)name;
3052 if (ckWARN(WARN_ILLEGALPROTO))
3053 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3054 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3055 STRLEN old_len, new_len;
3056 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3057 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3059 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3060 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3062 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3063 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3073 S_cant_declare(pTHX_ OP *o)
3075 if (o->op_type == OP_NULL
3076 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3077 o = cUNOPo->op_first;
3078 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3079 o->op_type == OP_NULL
3080 && o->op_flags & OPf_SPECIAL
3083 PL_parser->in_my == KEY_our ? "our" :
3084 PL_parser->in_my == KEY_state ? "state" :
3089 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3092 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3094 PERL_ARGS_ASSERT_MY_KID;
3096 if (!o || (PL_parser && PL_parser->error_count))
3101 if (type == OP_LIST) {
3103 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3104 my_kid(kid, attrs, imopsp);
3106 } else if (type == OP_UNDEF || type == OP_STUB) {
3108 } else if (type == OP_RV2SV || /* "our" declaration */
3110 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3111 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3112 S_cant_declare(aTHX_ o);
3114 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3116 PL_parser->in_my = FALSE;
3117 PL_parser->in_my_stash = NULL;
3118 apply_attrs(GvSTASH(gv),
3119 (type == OP_RV2SV ? GvSV(gv) :
3120 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3121 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3124 o->op_private |= OPpOUR_INTRO;
3127 else if (type != OP_PADSV &&
3130 type != OP_PUSHMARK)
3132 S_cant_declare(aTHX_ o);
3135 else if (attrs && type != OP_PUSHMARK) {
3139 PL_parser->in_my = FALSE;
3140 PL_parser->in_my_stash = NULL;
3142 /* check for C<my Dog $spot> when deciding package */
3143 stash = PAD_COMPNAME_TYPE(o->op_targ);
3145 stash = PL_curstash;
3146 apply_attrs_my(stash, o, attrs, imopsp);
3148 o->op_flags |= OPf_MOD;
3149 o->op_private |= OPpLVAL_INTRO;
3151 o->op_private |= OPpPAD_STATE;
3156 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3159 int maybe_scalar = 0;
3161 PERL_ARGS_ASSERT_MY_ATTRS;
3163 /* [perl #17376]: this appears to be premature, and results in code such as
3164 C< our(%x); > executing in list mode rather than void mode */
3166 if (o->op_flags & OPf_PARENS)
3176 o = my_kid(o, attrs, &rops);
3178 if (maybe_scalar && o->op_type == OP_PADSV) {
3179 o = scalar(op_append_list(OP_LIST, rops, o));
3180 o->op_private |= OPpLVAL_INTRO;
3183 /* The listop in rops might have a pushmark at the beginning,
3184 which will mess up list assignment. */
3185 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3186 if (rops->op_type == OP_LIST &&
3187 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3189 OP * const pushmark = lrops->op_first;
3190 /* excise pushmark */
3191 op_sibling_splice(rops, NULL, 1, NULL);
3194 o = op_append_list(OP_LIST, o, rops);
3197 PL_parser->in_my = FALSE;
3198 PL_parser->in_my_stash = NULL;
3203 Perl_sawparens(pTHX_ OP *o)
3205 PERL_UNUSED_CONTEXT;
3207 o->op_flags |= OPf_PARENS;
3212 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3216 const OPCODE ltype = left->op_type;
3217 const OPCODE rtype = right->op_type;
3219 PERL_ARGS_ASSERT_BIND_MATCH;
3221 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3222 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3224 const char * const desc
3226 rtype == OP_SUBST || rtype == OP_TRANS
3227 || rtype == OP_TRANSR
3229 ? (int)rtype : OP_MATCH];
3230 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3232 S_op_varname(aTHX_ left);
3234 Perl_warner(aTHX_ packWARN(WARN_MISC),
3235 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3236 desc, SVfARG(name), SVfARG(name));
3238 const char * const sample = (isary
3239 ? "@array" : "%hash");
3240 Perl_warner(aTHX_ packWARN(WARN_MISC),
3241 "Applying %s to %s will act on scalar(%s)",
3242 desc, sample, sample);
3246 if (rtype == OP_CONST &&
3247 cSVOPx(right)->op_private & OPpCONST_BARE &&
3248 cSVOPx(right)->op_private & OPpCONST_STRICT)
3250 no_bareword_allowed(right);
3253 /* !~ doesn't make sense with /r, so error on it for now */
3254 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3256 /* diag_listed_as: Using !~ with %s doesn't make sense */
3257 yyerror("Using !~ with s///r doesn't make sense");
3258 if (rtype == OP_TRANSR && type == OP_NOT)
3259 /* diag_listed_as: Using !~ with %s doesn't make sense */
3260 yyerror("Using !~ with tr///r doesn't make sense");
3262 ismatchop = (rtype == OP_MATCH ||
3263 rtype == OP_SUBST ||
3264 rtype == OP_TRANS || rtype == OP_TRANSR)
3265 && !(right->op_flags & OPf_SPECIAL);
3266 if (ismatchop && right->op_private & OPpTARGET_MY) {
3268 right->op_private &= ~OPpTARGET_MY;
3270 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3273 right->op_flags |= OPf_STACKED;
3274 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3275 ! (rtype == OP_TRANS &&
3276 right->op_private & OPpTRANS_IDENTICAL) &&
3277 ! (rtype == OP_SUBST &&
3278 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3279 newleft = op_lvalue(left, rtype);
3282 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3283 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3285 o = op_prepend_elem(rtype, scalar(newleft), right);
3287 return newUNOP(OP_NOT, 0, scalar(o));
3291 return bind_match(type, left,
3292 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3296 Perl_invert(pTHX_ OP *o)
3300 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3304 =for apidoc Amx|OP *|op_scope|OP *o
3306 Wraps up an op tree with some additional ops so that at runtime a dynamic
3307 scope will be created. The original ops run in the new dynamic scope,
3308 and then, provided that they exit normally, the scope will be unwound.
3309 The additional ops used to create and unwind the dynamic scope will
3310 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3311 instead if the ops are simple enough to not need the full dynamic scope
3318 Perl_op_scope(pTHX_ OP *o)
3322 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3323 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3324 o->op_type = OP_LEAVE;
3325 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3327 else if (o->op_type == OP_LINESEQ) {
3329 o->op_type = OP_SCOPE;
3330 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3331 kid = ((LISTOP*)o)->op_first;
3332 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3335 /* The following deals with things like 'do {1 for 1}' */
3336 kid = OP_SIBLING(kid);
3338 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3343 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3349 Perl_op_unscope(pTHX_ OP *o)
3351 if (o && o->op_type == OP_LINESEQ) {
3352 OP *kid = cLISTOPo->op_first;
3353 for(; kid; kid = OP_SIBLING(kid))
3354 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3361 Perl_block_start(pTHX_ int full)
3363 const int retval = PL_savestack_ix;
3365 pad_block_start(full);
3367 PL_hints &= ~HINT_BLOCK_SCOPE;
3368 SAVECOMPILEWARNINGS();
3369 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3371 CALL_BLOCK_HOOKS(bhk_start, full);
3377 Perl_block_end(pTHX_ I32 floor, OP *seq)
3379 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3380 OP* retval = scalarseq(seq);
3383 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3387 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3391 /* pad_leavemy has created a sequence of introcv ops for all my
3392 subs declared in the block. We have to replicate that list with
3393 clonecv ops, to deal with this situation:
3398 sub s1 { state sub foo { \&s2 } }
3401 Originally, I was going to have introcv clone the CV and turn
3402 off the stale flag. Since &s1 is declared before &s2, the
3403 introcv op for &s1 is executed (on sub entry) before the one for
3404 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3405 cloned, since it is a state sub) closes over &s2 and expects
3406 to see it in its outer CV’s pad. If the introcv op clones &s1,
3407 then &s2 is still marked stale. Since &s1 is not active, and
3408 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3409 ble will not stay shared’ warning. Because it is the same stub
3410 that will be used when the introcv op for &s2 is executed, clos-
3411 ing over it is safe. Hence, we have to turn off the stale flag
3412 on all lexical subs in the block before we clone any of them.
3413 Hence, having introcv clone the sub cannot work. So we create a
3414 list of ops like this:
3438 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3439 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3440 for (;; kid = OP_SIBLING(kid)) {
3441 OP *newkid = newOP(OP_CLONECV, 0);
3442 newkid->op_targ = kid->op_targ;
3443 o = op_append_elem(OP_LINESEQ, o, newkid);
3444 if (kid == last) break;
3446 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3449 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3455 =head1 Compile-time scope hooks
3457 =for apidoc Aox||blockhook_register
3459 Register a set of hooks to be called when the Perl lexical scope changes
3460 at compile time. See L<perlguts/"Compile-time scope hooks">.
3466 Perl_blockhook_register(pTHX_ BHK *hk)
3468 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3470 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3476 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3477 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3478 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3481 OP * const o = newOP(OP_PADSV, 0);
3482 o->op_targ = offset;
3488 Perl_newPROG(pTHX_ OP *o)
3490 PERL_ARGS_ASSERT_NEWPROG;
3497 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3498 ((PL_in_eval & EVAL_KEEPERR)
3499 ? OPf_SPECIAL : 0), o);
3501 cx = &cxstack[cxstack_ix];
3502 assert(CxTYPE(cx) == CXt_EVAL);
3504 if ((cx->blk_gimme & G_WANT) == G_VOID)
3505 scalarvoid(PL_eval_root);
3506 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3509 scalar(PL_eval_root);
3511 PL_eval_start = op_linklist(PL_eval_root);
3512 PL_eval_root->op_private |= OPpREFCOUNTED;
3513 OpREFCNT_set(PL_eval_root, 1);
3514 PL_eval_root->op_next = 0;
3515 i = PL_savestack_ix;
3518 CALL_PEEP(PL_eval_start);
3519 finalize_optree(PL_eval_root);
3520 S_prune_chain_head(&PL_eval_start);
3522 PL_savestack_ix = i;
3525 if (o->op_type == OP_STUB) {
3526 /* This block is entered if nothing is compiled for the main
3527 program. This will be the case for an genuinely empty main
3528 program, or one which only has BEGIN blocks etc, so already
3531 Historically (5.000) the guard above was !o. However, commit
3532 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3533 c71fccf11fde0068, changed perly.y so that newPROG() is now
3534 called with the output of block_end(), which returns a new
3535 OP_STUB for the case of an empty optree. ByteLoader (and
3536 maybe other things) also take this path, because they set up
3537 PL_main_start and PL_main_root directly, without generating an
3540 If the parsing the main program aborts (due to parse errors,
3541 or due to BEGIN or similar calling exit), then newPROG()
3542 isn't even called, and hence this code path and its cleanups
3543 are skipped. This shouldn't make a make a difference:
3544 * a non-zero return from perl_parse is a failure, and
3545 perl_destruct() should be called immediately.
3546 * however, if exit(0) is called during the parse, then
3547 perl_parse() returns 0, and perl_run() is called. As
3548 PL_main_start will be NULL, perl_run() will return
3549 promptly, and the exit code will remain 0.
3552 PL_comppad_name = 0;
3554 S_op_destroy(aTHX_ o);
3557 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3558 PL_curcop = &PL_compiling;
3559 PL_main_start = LINKLIST(PL_main_root);
3560 PL_main_root->op_private |= OPpREFCOUNTED;
3561 OpREFCNT_set(PL_main_root, 1);
3562 PL_main_root->op_next = 0;
3563 CALL_PEEP(PL_main_start);
3564 finalize_optree(PL_main_root);
3565 S_prune_chain_head(&PL_main_start);
3566 cv_forget_slab(PL_compcv);
3569 /* Register with debugger */
3571 CV * const cv = get_cvs("DB::postponed", 0);
3575 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3577 call_sv(MUTABLE_SV(cv), G_DISCARD);
3584 Perl_localize(pTHX_ OP *o, I32 lex)
3586 PERL_ARGS_ASSERT_LOCALIZE;
3588 if (o->op_flags & OPf_PARENS)
3589 /* [perl #17376]: this appears to be premature, and results in code such as
3590 C< our(%x); > executing in list mode rather than void mode */
3597 if ( PL_parser->bufptr > PL_parser->oldbufptr
3598 && PL_parser->bufptr[-1] == ','
3599 && ckWARN(WARN_PARENTHESIS))
3601 char *s = PL_parser->bufptr;
3604 /* some heuristics to detect a potential error */
3605 while (*s && (strchr(", \t\n", *s)))
3609 if (*s && strchr("@$%*", *s) && *++s
3610 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3613 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3615 while (*s && (strchr(", \t\n", *s)))
3621 if (sigil && (*s == ';' || *s == '=')) {
3622 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3623 "Parentheses missing around \"%s\" list",
3625 ? (PL_parser->in_my == KEY_our
3627 : PL_parser->in_my == KEY_state
3637 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3638 PL_parser->in_my = FALSE;
3639 PL_parser->in_my_stash = NULL;
3644 Perl_jmaybe(pTHX_ OP *o)
3646 PERL_ARGS_ASSERT_JMAYBE;
3648 if (o->op_type == OP_LIST) {
3650 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3651 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3656 PERL_STATIC_INLINE OP *
3657 S_op_std_init(pTHX_ OP *o)
3659 I32 type = o->op_type;
3661 PERL_ARGS_ASSERT_OP_STD_INIT;
3663 if (PL_opargs[type] & OA_RETSCALAR)
3665 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3666 o->op_targ = pad_alloc(type, SVs_PADTMP);
3671 PERL_STATIC_INLINE OP *
3672 S_op_integerize(pTHX_ OP *o)
3674 I32 type = o->op_type;
3676 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3678 /* integerize op. */
3679 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3682 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3685 if (type == OP_NEGATE)
3686 /* XXX might want a ck_negate() for this */
3687 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3693 S_fold_constants(pTHX_ OP *o)
3698 VOL I32 type = o->op_type;
3703 SV * const oldwarnhook = PL_warnhook;
3704 SV * const olddiehook = PL_diehook;
3706 U8 oldwarn = PL_dowarn;
3709 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3711 if (!(PL_opargs[type] & OA_FOLDCONST))
3720 #ifdef USE_LOCALE_CTYPE
3721 if (IN_LC_COMPILETIME(LC_CTYPE))
3730 #ifdef USE_LOCALE_COLLATE
3731 if (IN_LC_COMPILETIME(LC_COLLATE))
3736 /* XXX what about the numeric ops? */
3737 #ifdef USE_LOCALE_NUMERIC
3738 if (IN_LC_COMPILETIME(LC_NUMERIC))
3743 if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3744 || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3747 SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3748 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3750 const char *s = SvPVX_const(sv);
3751 while (s < SvEND(sv)) {
3752 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
3759 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3762 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3763 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3767 if (PL_parser && PL_parser->error_count)
3768 goto nope; /* Don't try to run w/ errors */
3770 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3771 const OPCODE type = curop->op_type;
3772 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3774 type != OP_SCALAR &&
3776 type != OP_PUSHMARK)
3782 curop = LINKLIST(o);
3783 old_next = o->op_next;
3787 oldscope = PL_scopestack_ix;
3788 create_eval_scope(G_FAKINGEVAL);
3790 /* Verify that we don't need to save it: */
3791 assert(PL_curcop == &PL_compiling);
3792 StructCopy(&PL_compiling, ¬_compiling, COP);
3793 PL_curcop = ¬_compiling;
3794 /* The above ensures that we run with all the correct hints of the
3795 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3796 assert(IN_PERL_RUNTIME);
3797 PL_warnhook = PERL_WARNHOOK_FATAL;
3801 /* Effective $^W=1. */
3802 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
3803 PL_dowarn |= G_WARN_ON;
3808 sv = *(PL_stack_sp--);
3809 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3810 pad_swipe(o->op_targ, FALSE);
3812 else if (SvTEMP(sv)) { /* grab mortal temp? */
3813 SvREFCNT_inc_simple_void(sv);
3816 else { assert(SvIMMORTAL(sv)); }
3819 /* Something tried to die. Abandon constant folding. */
3820 /* Pretend the error never happened. */
3822 o->op_next = old_next;
3826 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3827 PL_warnhook = oldwarnhook;
3828 PL_diehook = olddiehook;
3829 /* XXX note that this croak may fail as we've already blown away
3830 * the stack - eg any nested evals */
3831 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3834 PL_dowarn = oldwarn;
3835 PL_warnhook = oldwarnhook;
3836 PL_diehook = olddiehook;
3837 PL_curcop = &PL_compiling;
3839 if (PL_scopestack_ix > oldscope)
3840 delete_eval_scope();
3847 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3848 else if (!SvIMMORTAL(sv)) {
3852 if (type == OP_RV2GV)
3853 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3856 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3857 if (type != OP_STRINGIFY) newop->op_folded = 1;
3866 S_gen_constant_list(pTHX_ OP *o)
3870 const SSize_t oldtmps_floor = PL_tmps_floor;
3875 if (PL_parser && PL_parser->error_count)
3876 return o; /* Don't attempt to run with errors */
3878 curop = LINKLIST(o);
3881 S_prune_chain_head(&curop);
3883 Perl_pp_pushmark(aTHX);
3886 assert (!(curop->op_flags & OPf_SPECIAL));
3887 assert(curop->op_type == OP_RANGE);
3888 Perl_pp_anonlist(aTHX);
3889 PL_tmps_floor = oldtmps_floor;
3891 o->op_type = OP_RV2AV;
3892 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3893 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3894 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3895 o->op_opt = 0; /* needs to be revisited in rpeep() */
3896 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3898 /* replace subtree with an OP_CONST */
3899 curop = ((UNOP*)o)->op_first;
3900 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
3903 if (AvFILLp(av) != -1)
3904 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3907 SvREADONLY_on(*svp);
3913 /* convert o (and any siblings) into a list if not already, then
3914 * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
3918 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3921 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3922 if (!o || o->op_type != OP_LIST)
3923 o = force_list(o, 0);
3925 o->op_flags &= ~OPf_WANT;
3927 if (!(PL_opargs[type] & OA_MARK))
3928 op_null(cLISTOPo->op_first);
3930 OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
3931 if (kid2 && kid2->op_type == OP_COREARGS) {
3932 op_null(cLISTOPo->op_first);
3933 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3937 o->op_type = (OPCODE)type;
3938 o->op_ppaddr = PL_ppaddr[type];
3939 o->op_flags |= flags;
3941 o = CHECKOP(type, o);
3942 if (o->op_type != (unsigned)type)
3945 return fold_constants(op_integerize(op_std_init(o)));
3949 =head1 Optree Manipulation Functions
3952 /* List constructors */
3955 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3957 Append an item to the list of ops contained directly within a list-type
3958 op, returning the lengthened list. I<first> is the list-type op,
3959 and I<last> is the op to append to the list. I<optype> specifies the
3960 intended opcode for the list. If I<first> is not already a list of the
3961 right type, it will be upgraded into one. If either I<first> or I<last>
3962 is null, the other is returned unchanged.
3968 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3976 if (first->op_type != (unsigned)type
3977 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3979 return newLISTOP(type, 0, first, last);
3982 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
3983 first->op_flags |= OPf_KIDS;
3988 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3990 Concatenate the lists of ops contained directly within two list-type ops,
3991 returning the combined list. I<first> and I<last> are the list-type ops
3992 to concatenate. I<optype> specifies the intended opcode for the list.
3993 If either I<first> or I<last> is not already a list of the right type,
3994 it will be upgraded into one. If either I<first> or I<last> is null,
3995 the other is returned unchanged.
4001 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4009 if (first->op_type != (unsigned)type)
4010 return op_prepend_elem(type, first, last);
4012 if (last->op_type != (unsigned)type)
4013 return op_append_elem(type, first, last);
4015 ((LISTOP*)first)->op_last->op_lastsib = 0;
4016 OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4017 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4018 ((LISTOP*)first)->op_last->op_lastsib = 1;
4019 #ifdef PERL_OP_PARENT
4020 ((LISTOP*)first)->op_last->op_sibling = first;
4022 first->op_flags |= (last->op_flags & OPf_KIDS);
4025 S_op_destroy(aTHX_ last);
4031 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4033 Prepend an item to the list of ops contained directly within a list-type
4034 op, returning the lengthened list. I<first> is the op to prepend to the
4035 list, and I<last> is the list-type op. I<optype> specifies the intended
4036 opcode for the list. If I<last> is not already a list of the right type,
4037 it will be upgraded into one. If either I<first> or I<last> is null,
4038 the other is returned unchanged.
4044 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4052 if (last->op_type == (unsigned)type) {
4053 if (type == OP_LIST) { /* already a PUSHMARK there */
4054 /* insert 'first' after pushmark */
4055 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4056 if (!(first->op_flags & OPf_PARENS))
4057 last->op_flags &= ~OPf_PARENS;
4060 op_sibling_splice(last, NULL, 0, first);
4061 last->op_flags |= OPf_KIDS;
4065 return newLISTOP(type, 0, first, last);
4072 =head1 Optree construction
4074 =for apidoc Am|OP *|newNULLLIST
4076 Constructs, checks, and returns a new C<stub> op, which represents an
4077 empty list expression.
4083 Perl_newNULLLIST(pTHX)
4085 return newOP(OP_STUB, 0);
4088 /* promote o and any siblings to be a list if its not already; i.e.
4096 * pushmark - o - A - B
4098 * If nullit it true, the list op is nulled.
4102 S_force_list(pTHX_ OP *o, bool nullit)
4104 if (!o || o->op_type != OP_LIST) {
4107 /* manually detach any siblings then add them back later */
4108 rest = OP_SIBLING(o);
4109 OP_SIBLING_set(o, NULL);
4112 o = newLISTOP(OP_LIST, 0, o, NULL);
4114 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4122 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4124 Constructs, checks, and returns an op of any list type. I<type> is
4125 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4126 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4127 supply up to two ops to be direct children of the list op; they are
4128 consumed by this function and become part of the constructed op tree.
4134 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4139 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4141 NewOp(1101, listop, 1, LISTOP);
4143 listop->op_type = (OPCODE)type;
4144 listop->op_ppaddr = PL_ppaddr[type];
4147 listop->op_flags = (U8)flags;
4151 else if (!first && last)
4154 OP_SIBLING_set(first, last);
4155 listop->op_first = first;
4156 listop->op_last = last;
4157 if (type == OP_LIST) {
4158 OP* const pushop = newOP(OP_PUSHMARK, 0);
4159 pushop->op_lastsib = 0;
4160 OP_SIBLING_set(pushop, first);
4161 listop->op_first = pushop;
4162 listop->op_flags |= OPf_KIDS;
4164 listop->op_last = pushop;
4167 first->op_lastsib = 0;
4168 if (listop->op_last) {
4169 listop->op_last->op_lastsib = 1;
4170 #ifdef PERL_OP_PARENT
4171 listop->op_last->op_sibling = (OP*)listop;
4175 return CHECKOP(type, listop);
4179 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4181 Constructs, checks, and returns an op of any base type (any type that
4182 has no extra fields). I<type> is the opcode. I<flags> gives the
4183 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4190 Perl_newOP(pTHX_ I32 type, I32 flags)
4195 if (type == -OP_ENTEREVAL) {
4196 type = OP_ENTEREVAL;
4197 flags |= OPpEVAL_BYTES<<8;
4200 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4201 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4202 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4203 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4205 NewOp(1101, o, 1, OP);
4206 o->op_type = (OPCODE)type;
4207 o->op_ppaddr = PL_ppaddr[type];
4208 o->op_flags = (U8)flags;
4211 o->op_private = (U8)(0 | (flags >> 8));
4212 if (PL_opargs[type] & OA_RETSCALAR)
4214 if (PL_opargs[type] & OA_TARGET)
4215 o->op_targ = pad_alloc(type, SVs_PADTMP);
4216 return CHECKOP(type, o);
4220 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4222 Constructs, checks, and returns an op of any unary type. I<type> is
4223 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4224 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4225 bits, the eight bits of C<op_private>, except that the bit with value 1
4226 is automatically set. I<first> supplies an optional op to be the direct
4227 child of the unary op; it is consumed by this function and become part
4228 of the constructed op tree.
4234 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4239 if (type == -OP_ENTEREVAL) {
4240 type = OP_ENTEREVAL;
4241 flags |= OPpEVAL_BYTES<<8;
4244 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4245 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4246 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4247 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4248 || type == OP_SASSIGN
4249 || type == OP_ENTERTRY
4250 || type == OP_NULL );
4253 first = newOP(OP_STUB, 0);
4254 if (PL_opargs[type] & OA_MARK)
4255 first = force_list(first, 1);
4257 NewOp(1101, unop, 1, UNOP);
4258 unop->op_type = (OPCODE)type;
4259 unop->op_ppaddr = PL_ppaddr[type];
4260 unop->op_first = first;
4261 unop->op_flags = (U8)(flags | OPf_KIDS);
4262 unop->op_private = (U8)(1 | (flags >> 8));
4264 #ifdef PERL_OP_PARENT
4265 if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4266 first->op_sibling = (OP*)unop;
4269 unop = (UNOP*) CHECKOP(type, unop);
4273 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4277 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4279 Constructs, checks, and returns an op of any binary type. I<type>
4280 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4281 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4282 the eight bits of C<op_private>, except that the bit with value 1 or
4283 2 is automatically set as required. I<first> and I<last> supply up to
4284 two ops to be the direct children of the binary op; they are consumed
4285 by this function and become part of the constructed op tree.
4291 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4296 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4297 || type == OP_SASSIGN || type == OP_NULL );
4299 NewOp(1101, binop, 1, BINOP);
4302 first = newOP(OP_NULL, 0);
4304 binop->op_type = (OPCODE)type;
4305 binop->op_ppaddr = PL_ppaddr[type];
4306 binop->op_first = first;
4307 binop->op_flags = (U8)(flags | OPf_KIDS);
4310 binop->op_private = (U8)(1 | (flags >> 8));
4313 binop->op_private = (U8)(2 | (flags >> 8));
4314 OP_SIBLING_set(first, last);
4315 first->op_lastsib = 0;
4318 #ifdef PERL_OP_PARENT
4319 if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4320 last->op_sibling = (OP*)binop;
4323 binop = (BINOP*)CHECKOP(type, binop);
4324 if (binop->op_next || binop->op_type != (OPCODE)type)
4327 binop->op_last = OP_SIBLING(binop->op_first);
4328 #ifdef PERL_OP_PARENT
4330 binop->op_last->op_sibling = (OP*)binop;
4333 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4336 static int uvcompare(const void *a, const void *b)
4337 __attribute__nonnull__(1)
4338 __attribute__nonnull__(2)
4339 __attribute__pure__;
4340 static int uvcompare(const void *a, const void *b)
4342 if (*((const UV *)a) < (*(const UV *)b))
4344 if (*((const UV *)a) > (*(const UV *)b))
4346 if (*((const UV *)a+1) < (*(const UV *)b+1))
4348 if (*((const UV *)a+1) > (*(const UV *)b+1))
4354 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4356 SV * const tstr = ((SVOP*)expr)->op_sv;
4358 ((SVOP*)repl)->op_sv;
4361 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4362 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4368 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4369 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4370 I32 del = o->op_private & OPpTRANS_DELETE;
4373 PERL_ARGS_ASSERT_PMTRANS;
4375 PL_hints |= HINT_BLOCK_SCOPE;
4378 o->op_private |= OPpTRANS_FROM_UTF;
4381 o->op_private |= OPpTRANS_TO_UTF;
4383 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4384 SV* const listsv = newSVpvs("# comment\n");
4386 const U8* tend = t + tlen;
4387 const U8* rend = r + rlen;
4401 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4402 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4405 const U32 flags = UTF8_ALLOW_DEFAULT;
4409 t = tsave = bytes_to_utf8(t, &len);
4412 if (!to_utf && rlen) {
4414 r = rsave = bytes_to_utf8(r, &len);
4418 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4419 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4423 U8 tmpbuf[UTF8_MAXBYTES+1];
4426 Newx(cp, 2*tlen, UV);
4428 transv = newSVpvs("");
4430 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4432 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4434 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4438 cp[2*i+1] = cp[2*i];
4442 qsort(cp, i, 2*sizeof(UV), uvcompare);
4443 for (j = 0; j < i; j++) {
4445 diff = val - nextmin;
4447 t = uvchr_to_utf8(tmpbuf,nextmin);
4448 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4450 U8 range_mark = ILLEGAL_UTF8_BYTE;
4451 t = uvchr_to_utf8(tmpbuf, val - 1);
4452 sv_catpvn(transv, (char *)&range_mark, 1);
4453 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4460 t = uvchr_to_utf8(tmpbuf,nextmin);
4461 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4463 U8 range_mark = ILLEGAL_UTF8_BYTE;
4464 sv_catpvn(transv, (char *)&range_mark, 1);
4466 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4467 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4468 t = (const U8*)SvPVX_const(transv);
4469 tlen = SvCUR(transv);
4473 else if (!rlen && !del) {
4474 r = t; rlen = tlen; rend = tend;
4477 if ((!rlen && !del) || t == r ||
4478 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4480 o->op_private |= OPpTRANS_IDENTICAL;
4484 while (t < tend || tfirst <= tlast) {
4485 /* see if we need more "t" chars */
4486 if (tfirst > tlast) {
4487 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4489 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4491 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4498 /* now see if we need more "r" chars */
4499 if (rfirst > rlast) {
4501 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4503 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4505 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4514 rfirst = rlast = 0xffffffff;
4518 /* now see which range will peter our first, if either. */
4519 tdiff = tlast - tfirst;
4520 rdiff = rlast - rfirst;
4527 if (rfirst == 0xffffffff) {
4528 diff = tdiff; /* oops, pretend rdiff is infinite */
4530 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4531 (long)tfirst, (long)tlast);
4533 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4537 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4538 (long)tfirst, (long)(tfirst + diff),
4541 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4542 (long)tfirst, (long)rfirst);
4544 if (rfirst + diff > max)
4545 max = rfirst + diff;
4547 grows = (tfirst < rfirst &&
4548 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4560 else if (max > 0xff)
4565 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4567 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4568 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4569 PAD_SETSV(cPADOPo->op_padix, swash);
4571 SvREADONLY_on(swash);
4573 cSVOPo->op_sv = swash;
4575 SvREFCNT_dec(listsv);
4576 SvREFCNT_dec(transv);
4578 if (!del && havefinal && rlen)
4579 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4580 newSVuv((UV)final), 0);
4583 o->op_private |= OPpTRANS_GROWS;
4593 tbl = (short*)PerlMemShared_calloc(
4594 (o->op_private & OPpTRANS_COMPLEMENT) &&
4595 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4597 cPVOPo->op_pv = (char*)tbl;
4599 for (i = 0; i < (I32)tlen; i++)
4601 for (i = 0, j = 0; i < 256; i++) {
4603 if (j >= (I32)rlen) {
4612 if (i < 128 && r[j] >= 128)
4622 o->op_private |= OPpTRANS_IDENTICAL;
4624 else if (j >= (I32)rlen)
4629 PerlMemShared_realloc(tbl,
4630 (0x101+rlen-j) * sizeof(short));
4631 cPVOPo->op_pv = (char*)tbl;
4633 tbl[0x100] = (short)(rlen - j);
4634 for (i=0; i < (I32)rlen - j; i++)
4635 tbl[0x101+i] = r[j+i];
4639 if (!rlen && !del) {
4642 o->op_private |= OPpTRANS_IDENTICAL;
4644 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4645 o->op_private |= OPpTRANS_IDENTICAL;
4647 for (i = 0; i < 256; i++)
4649 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4650 if (j >= (I32)rlen) {
4652 if (tbl[t[i]] == -1)
4658 if (tbl[t[i]] == -1) {
4659 if (t[i] < 128 && r[j] >= 128)
4666 if(del && rlen == tlen) {
4667 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4668 } else if(rlen > tlen && !complement) {
4669 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4673 o->op_private |= OPpTRANS_GROWS;
4681 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4683 Constructs, checks, and returns an op of any pattern matching type.
4684 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4685 and, shifted up eight bits, the eight bits of C<op_private>.
4691 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4696 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4698 NewOp(1101, pmop, 1, PMOP);
4699 pmop->op_type = (OPCODE)type;
4700 pmop->op_ppaddr = PL_ppaddr[type];
4701 pmop->op_flags = (U8)flags;
4702 pmop->op_private = (U8)(0 | (flags >> 8));
4704 if (PL_hints & HINT_RE_TAINT)
4705 pmop->op_pmflags |= PMf_RETAINT;
4706 #ifdef USE_LOCALE_CTYPE
4707 if (IN_LC_COMPILETIME(LC_CTYPE)) {
4708 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4713 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4715 if (PL_hints & HINT_RE_FLAGS) {
4716 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4717 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4719 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4720 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4721 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4723 if (reflags && SvOK(reflags)) {
4724 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4730 assert(SvPOK(PL_regex_pad[0]));
4731 if (SvCUR(PL_regex_pad[0])) {
4732 /* Pop off the "packed" IV from the end. */
4733 SV *const repointer_list = PL_regex_pad[0];
4734 const char *p = SvEND(repointer_list) - sizeof(IV);
4735 const IV offset = *((IV*)p);
4737 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4739 SvEND_set(repointer_list, p);
4741 pmop->op_pmoffset = offset;
4742 /* This slot should be free, so assert this: */
4743 assert(PL_regex_pad[offset] == &PL_sv_undef);
4745 SV * const repointer = &PL_sv_undef;
4746 av_push(PL_regex_padav, repointer);
4747 pmop->op_pmoffset = av_tindex(PL_regex_padav);
4748 PL_regex_pad = AvARRAY(PL_regex_padav);
4752 return CHECKOP(type, pmop);
4755 /* Given some sort of match op o, and an expression expr containing a
4756 * pattern, either compile expr into a regex and attach it to o (if it's
4757 * constant), or convert expr into a runtime regcomp op sequence (if it's
4760 * isreg indicates that the pattern is part of a regex construct, eg
4761 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4762 * split "pattern", which aren't. In the former case, expr will be a list
4763 * if the pattern contains more than one term (eg /a$b/) or if it contains
4764 * a replacement, ie s/// or tr///.
4766 * When the pattern has been compiled within a new anon CV (for
4767 * qr/(?{...})/ ), then floor indicates the savestack level just before
4768 * the new sub was created
4772 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4777 I32 repl_has_vars = 0;
4779 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4780 bool is_compiletime;
4783 PERL_ARGS_ASSERT_PMRUNTIME;
4785 /* for s/// and tr///, last element in list is the replacement; pop it */
4787 if (is_trans || o->op_type == OP_SUBST) {
4789 repl = cLISTOPx(expr)->op_last;
4790 kid = cLISTOPx(expr)->op_first;
4791 while (OP_SIBLING(kid) != repl)
4792 kid = OP_SIBLING(kid);
4793 op_sibling_splice(expr, kid, 1, NULL);
4796 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4801 assert(expr->op_type == OP_LIST);
4802 first = cLISTOPx(expr)->op_first;
4803 last = cLISTOPx(expr)->op_last;
4804 assert(first->op_type == OP_PUSHMARK);
4805 assert(OP_SIBLING(first) == last);
4807 /* cut 'last' from sibling chain, then free everything else */
4808 op_sibling_splice(expr, first, 1, NULL);
4811 return pmtrans(o, last, repl);
4814 /* find whether we have any runtime or code elements;
4815 * at the same time, temporarily set the op_next of each DO block;
4816 * then when we LINKLIST, this will cause the DO blocks to be excluded
4817 * from the op_next chain (and from having LINKLIST recursively
4818 * applied to them). We fix up the DOs specially later */
4822 if (expr->op_type == OP_LIST) {
4824 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4825 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4827 assert(!o->op_next && OP_HAS_SIBLING(o));
4828 o->op_next = OP_SIBLING(o);
4830 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4834 else if (expr->op_type != OP_CONST)
4839 /* fix up DO blocks; treat each one as a separate little sub;
4840 * also, mark any arrays as LIST/REF */
4842 if (expr->op_type == OP_LIST) {
4844 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4846 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4847 assert( !(o->op_flags & OPf_WANT));
4848 /* push the array rather than its contents. The regex
4849 * engine will retrieve and join the elements later */
4850 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4854 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4856 o->op_next = NULL; /* undo temporary hack from above */
4859 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4860 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4862 assert(leaveop->op_first->op_type == OP_ENTER);
4863 assert(OP_HAS_SIBLING(leaveop->op_first));
4864 o->op_next = OP_SIBLING(leaveop->op_first);
4866 assert(leaveop->op_flags & OPf_KIDS);
4867 assert(leaveop->op_last->op_next == (OP*)leaveop);
4868 leaveop->op_next = NULL; /* stop on last op */
4869 op_null((OP*)leaveop);
4873 OP *scope = cLISTOPo->op_first;
4874 assert(scope->op_type == OP_SCOPE);
4875 assert(scope->op_flags & OPf_KIDS);
4876 scope->op_next = NULL; /* stop on last op */
4879 /* have to peep the DOs individually as we've removed it from
4880 * the op_next chain */
4882 S_prune_chain_head(&(o->op_next));
4884 /* runtime finalizes as part of finalizing whole tree */
4888 else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4889 assert( !(expr->op_flags & OPf_WANT));
4890 /* push the array rather than its contents. The regex
4891 * engine will retrieve and join the elements later */
4892 expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4895 PL_hints |= HINT_BLOCK_SCOPE;
4897 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4899 if (is_compiletime) {
4900 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4901 regexp_engine const *eng = current_re_engine();
4903 if (o->op_flags & OPf_SPECIAL)
4904 rx_flags |= RXf_SPLIT;
4906 if (!has_code || !eng->op_comp) {
4907 /* compile-time simple constant pattern */
4909 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4910 /* whoops! we guessed that a qr// had a code block, but we
4911 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4912 * that isn't required now. Note that we have to be pretty
4913 * confident that nothing used that CV's pad while the
4914 * regex was parsed */
4915 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4916 /* But we know that one op is using this CV's slab. */
4917 cv_forget_slab(PL_compcv);
4919 pm->op_pmflags &= ~PMf_HAS_CV;
4924 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4925 rx_flags, pm->op_pmflags)
4926 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4927 rx_flags, pm->op_pmflags)
4932 /* compile-time pattern that includes literal code blocks */
4933 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4936 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4939 if (pm->op_pmflags & PMf_HAS_CV) {
4941 /* this QR op (and the anon sub we embed it in) is never
4942 * actually executed. It's just a placeholder where we can
4943 * squirrel away expr in op_code_list without the peephole
4944 * optimiser etc processing it for a second time */
4945 OP *qr = newPMOP(OP_QR, 0);
4946 ((PMOP*)qr)->op_code_list = expr;
4948 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4949 SvREFCNT_inc_simple_void(PL_compcv);
4950 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4951 ReANY(re)->qr_anoncv = cv;
4953 /* attach the anon CV to the pad so that
4954 * pad_fixup_inner_anons() can find it */
4955 (void)pad_add_anon(cv, o->op_type);
4956 SvREFCNT_inc_simple_void(cv);
4959 pm->op_code_list = expr;
4964 /* runtime pattern: build chain of regcomp etc ops */
4966 PADOFFSET cv_targ = 0;
4968 reglist = isreg && expr->op_type == OP_LIST;
4973 pm->op_code_list = expr;
4974 /* don't free op_code_list; its ops are embedded elsewhere too */
4975 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4978 if (o->op_flags & OPf_SPECIAL)
4979 pm->op_pmflags |= PMf_SPLIT;
4981 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4982 * to allow its op_next to be pointed past the regcomp and
4983 * preceding stacking ops;
4984 * OP_REGCRESET is there to reset taint before executing the
4986 if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
4987 expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4989 if (pm->op_pmflags & PMf_HAS_CV) {
4990 /* we have a runtime qr with literal code. This means
4991 * that the qr// has been wrapped in a new CV, which
4992 * means that runtime consts, vars etc will have been compiled
4993 * against a new pad. So... we need to execute those ops
4994 * within the environment of the new CV. So wrap them in a call
4995 * to a new anon sub. i.e. for
4999 * we build an anon sub that looks like
5001 * sub { "a", $b, '(?{...})' }
5003 * and call it, passing the returned list to regcomp.
5004 * Or to put it another way, the list of ops that get executed
5008 * ------ -------------------
5009 * pushmark (for regcomp)
5010 * pushmark (for entersub)
5011 * pushmark (for refgen)
5015 * regcreset regcreset
5017 * const("a") const("a")
5019 * const("(?{...})") const("(?{...})")
5024 SvREFCNT_inc_simple_void(PL_compcv);
5025 /* these lines are just an unrolled newANONATTRSUB */
5026 expr = newSVOP(OP_ANONCODE, 0,
5027 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5028 cv_targ = expr->op_targ;
5029 expr = newUNOP(OP_REFGEN, 0, expr);
5031 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5034 rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5035 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
5036 rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5037 | (reglist ? OPf_STACKED : 0);
5038 rcop->op_targ = cv_targ;
5040 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
5041 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
5043 /* establish postfix order */
5044 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5046 rcop->op_next = expr;
5047 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5050 rcop->op_next = LINKLIST(expr);
5051 expr->op_next = (OP*)rcop;
5054 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5060 /* If we are looking at s//.../e with a single statement, get past
5061 the implicit do{}. */
5062 if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5063 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5064 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5067 OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5068 if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
5069 && !OP_HAS_SIBLING(sib))
5072 if (curop->op_type == OP_CONST)
5074 else if (( (curop->op_type == OP_RV2SV ||
5075 curop->op_type == OP_RV2AV ||
5076 curop->op_type == OP_RV2HV ||
5077 curop->op_type == OP_RV2GV)
5078 && cUNOPx(curop)->op_first
5079 && cUNOPx(curop)->op_first->op_type == OP_GV )
5080 || curop->op_type == OP_PADSV
5081 || curop->op_type == OP_PADAV
5082 || curop->op_type == OP_PADHV
5083 || curop->op_type == OP_PADANY) {
5091 || !RX_PRELEN(PM_GETRE(pm))
5092 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5094 pm->op_pmflags |= PMf_CONST; /* const for long enough */
5095 op_prepend_elem(o->op_type, scalar(repl), o);
5098 rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5099 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
5100 rcop->op_private = 1;
5102 /* establish postfix order */
5103 rcop->op_next = LINKLIST(repl);
5104 repl->op_next = (OP*)rcop;
5106 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5107 assert(!(pm->op_pmflags & PMf_ONCE));
5108 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5117 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5119 Constructs, checks, and returns an op of any type that involves an
5120 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
5121 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
5122 takes ownership of one reference to it.
5128 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5133 PERL_ARGS_ASSERT_NEWSVOP;
5135 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5136 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5137 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5139 NewOp(1101, svop, 1, SVOP);
5140 svop->op_type = (OPCODE)type;
5141 svop->op_ppaddr = PL_ppaddr[type];
5143 svop->op_next = (OP*)svop;
5144 svop->op_flags = (U8)flags;
5145 svop->op_private = (U8)(0 | (flags >> 8));
5146 if (PL_opargs[type] & OA_RETSCALAR)
5148 if (PL_opargs[type] & OA_TARGET)
5149 svop->op_targ = pad_alloc(type, SVs_PADTMP);
5150 return CHECKOP(type, svop);
5156 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5158 Constructs, checks, and returns an op of any type that involves a
5159 reference to a pad element. I<type> is the opcode. I<flags> gives the
5160 eight bits of C<op_flags>. A pad slot is automatically allocated, and
5161 is populated with I<sv>; this function takes ownership of one reference
5164 This function only exists if Perl has been compiled to use ithreads.
5170 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5175 PERL_ARGS_ASSERT_NEWPADOP;
5177 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5178 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5179 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5181 NewOp(1101, padop, 1, PADOP);
5182 padop->op_type = (OPCODE)type;
5183 padop->op_ppaddr = PL_ppaddr[type];
5185 pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5186 SvREFCNT_dec(PAD_SVl(padop->op_padix));
5187 PAD_SETSV(padop->op_padix, sv);
5189 padop->op_next = (OP*)padop;
5190 padop->op_flags = (U8)flags;
5191 if (PL_opargs[type] & OA_RETSCALAR)
5193 if (PL_opargs[type] & OA_TARGET)
5194 padop->op_targ = pad_alloc(type, SVs_PADTMP);
5195 return CHECKOP(type, padop);
5198 #endif /* USE_ITHREADS */
5201 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5203 Constructs, checks, and returns an op of any type that involves an
5204 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
5205 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
5206 reference; calling this function does not transfer ownership of any
5213 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5215 PERL_ARGS_ASSERT_NEWGVOP;
5218 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5220 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5225 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5227 Constructs, checks, and returns an op of any type that involves an
5228 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
5229 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
5230 must have been allocated using C<PerlMemShared_malloc>; the memory will
5231 be freed when the op is destroyed.
5237 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5240 const bool utf8 = cBOOL(flags & SVf_UTF8);
5245 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5247 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5249 NewOp(1101, pvop, 1, PVOP);
5250 pvop->op_type = (OPCODE)type;
5251 pvop->op_ppaddr = PL_ppaddr[type];
5253 pvop->op_next = (OP*)pvop;
5254 pvop->op_flags = (U8)flags;
5255 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5256 if (PL_opargs[type] & OA_RETSCALAR)
5258 if (PL_opargs[type] & OA_TARGET)
5259 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5260 return CHECKOP(type, pvop);
5264 Perl_package(pTHX_ OP *o)
5266 SV *const sv = cSVOPo->op_sv;
5268 PERL_ARGS_ASSERT_PACKAGE;
5270 SAVEGENERICSV(PL_curstash);
5271 save_item(PL_curstname);
5273 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5275 sv_setsv(PL_curstname, sv);
5277 PL_hints |= HINT_BLOCK_SCOPE;
5278 PL_parser->copline = NOLINE;
5284 Perl_package_version( pTHX_ OP *v )
5286 U32 savehints = PL_hints;
5287 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5288 PL_hints &= ~HINT_STRICT_VARS;
5289 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5290 PL_hints = savehints;
5295 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5300 SV *use_version = NULL;
5302 PERL_ARGS_ASSERT_UTILIZE;
5304 if (idop->op_type != OP_CONST)
5305 Perl_croak(aTHX_ "Module name must be constant");
5310 SV * const vesv = ((SVOP*)version)->op_sv;
5312 if (!arg && !SvNIOKp(vesv)) {
5319 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5320 Perl_croak(aTHX_ "Version number must be a constant number");
5322 /* Make copy of idop so we don't free it twice */
5323 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5325 /* Fake up a method call to VERSION */
5326 meth = newSVpvs_share("VERSION");
5327 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5328 op_append_elem(OP_LIST,
5329 op_prepend_elem(OP_LIST, pack, list(version)),
5330 newSVOP(OP_METHOD_NAMED, 0, meth)));
5334 /* Fake up an import/unimport */
5335 if (arg && arg->op_type == OP_STUB) {
5336 imop = arg; /* no import on explicit () */
5338 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5339 imop = NULL; /* use 5.0; */
5341 use_version = ((SVOP*)idop)->op_sv;
5343 idop->op_private |= OPpCONST_NOVER;
5348 /* Make copy of idop so we don't free it twice */
5349 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5351 /* Fake up a method call to import/unimport */
5353 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5354 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5355 op_append_elem(OP_LIST,
5356 op_prepend_elem(OP_LIST, pack, list(arg)),
5357 newSVOP(OP_METHOD_NAMED, 0, meth)));
5360 /* Fake up the BEGIN {}, which does its thing immediately. */
5362 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5365 op_append_elem(OP_LINESEQ,
5366 op_append_elem(OP_LINESEQ,
5367 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5368 newSTATEOP(0, NULL, veop)),
5369 newSTATEOP(0, NULL, imop) ));
5373 * feature bundle that corresponds to the required version. */
5374 use_version = sv_2mortal(new_version(use_version));
5375 S_enable_feature_bundle(aTHX_ use_version);
5377 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5378 if (vcmp(use_version,
5379 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5380 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5381 PL_hints |= HINT_STRICT_REFS;
5382 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5383 PL_hints |= HINT_STRICT_SUBS;
5384 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5385 PL_hints |= HINT_STRICT_VARS;
5387 /* otherwise they are off */
5389 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5390 PL_hints &= ~HINT_STRICT_REFS;
5391 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5392 PL_hints &= ~HINT_STRICT_SUBS;
5393 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5394 PL_hints &= ~HINT_STRICT_VARS;
5398 /* The "did you use incorrect case?" warning used to be here.
5399 * The problem is that on case-insensitive filesystems one
5400 * might get false positives for "use" (and "require"):
5401 * "use Strict" or "require CARP" will work. This causes
5402 * portability problems for the script: in case-strict
5403 * filesystems the script will stop working.
5405 * The "incorrect case" warning checked whether "use Foo"
5406 * imported "Foo" to your namespace, but that is wrong, too:
5407 * there is no requirement nor promise in the language that
5408 * a Foo.pm should or would contain anything in package "Foo".
5410 * There is very little Configure-wise that can be done, either:
5411 * the case-sensitivity of the build filesystem of Perl does not
5412 * help in guessing the case-sensitivity of the runtime environment.
5415 PL_hints |= HINT_BLOCK_SCOPE;
5416 PL_parser->copline = NOLINE;
5417 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5418 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5424 =head1 Embedding Functions
5426 =for apidoc load_module
5428 Loads the module whose name is pointed to by the string part of name.
5429 Note that the actual module name, not its filename, should be given.
5430 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5431 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5432 (or 0 for no flags). ver, if specified
5433 and not NULL, provides version semantics
5434 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5435 arguments can be used to specify arguments to the module's import()
5436 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5437 terminated with a final NULL pointer. Note that this list can only
5438 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5439 Otherwise at least a single NULL pointer to designate the default
5440 import list is required.
5442 The reference count for each specified C<SV*> parameter is decremented.
5447 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5451 PERL_ARGS_ASSERT_LOAD_MODULE;
5453 va_start(args, ver);
5454 vload_module(flags, name, ver, &args);
5458 #ifdef PERL_IMPLICIT_CONTEXT
5460 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5464 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5465 va_start(args, ver);
5466 vload_module(flags, name, ver, &args);
5472 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5475 OP * const modname = newSVOP(OP_CONST, 0, name);
5477 PERL_ARGS_ASSERT_VLOAD_MODULE;
5479 modname->op_private |= OPpCONST_BARE;
5481 veop = newSVOP(OP_CONST, 0, ver);
5485 if (flags & PERL_LOADMOD_NOIMPORT) {
5486 imop = sawparens(newNULLLIST());
5488 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5489 imop = va_arg(*args, OP*);
5494 sv = va_arg(*args, SV*);
5496 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5497 sv = va_arg(*args, SV*);
5501 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5502 * that it has a PL_parser to play with while doing that, and also
5503 * that it doesn't mess with any existing parser, by creating a tmp
5504 * new parser with lex_start(). This won't actually be used for much,
5505 * since pp_require() will create another parser for the real work.
5506 * The ENTER/LEAVE pair protect callers from any side effects of use. */
5509 SAVEVPTR(PL_curcop);
5510 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5511 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5512 veop, modname, imop);
5516 PERL_STATIC_INLINE OP *
5517 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5519 return newUNOP(OP_ENTERSUB, OPf_STACKED,
5520 newLISTOP(OP_LIST, 0, arg,
5521 newUNOP(OP_RV2CV, 0,
5522 newGVOP(OP_GV, 0, gv))));
5526 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5531 PERL_ARGS_ASSERT_DOFILE;
5533 if (!force_builtin && (gv = gv_override("do", 2))) {
5534 doop = S_new_entersubop(aTHX_ gv, term);
5537 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5543 =head1 Optree construction
5545 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5547 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5548 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5549 be set automatically, and, shifted up eight bits, the eight bits of
5550 C<op_private>, except that the bit with value 1 or 2 is automatically
5551 set as required. I<listval> and I<subscript> supply the parameters of
5552 the slice; they are consumed by this function and become part of the
5553 constructed op tree.
5559 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5561 return newBINOP(OP_LSLICE, flags,
5562 list(force_list(subscript, 1)),
5563 list(force_list(listval, 1)) );
5567 S_is_list_assignment(pTHX_ const OP *o)
5575 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5576 o = cUNOPo->op_first;
5578 flags = o->op_flags;
5580 if (type == OP_COND_EXPR) {
5581 OP * const sib = OP_SIBLING(cLOGOPo->op_first);
5582 const I32 t = is_list_assignment(sib);
5583 const I32 f = is_list_assignment(OP_SIBLING(sib));
5588 yyerror("Assignment to both a list and a scalar");
5592 if (type == OP_LIST &&
5593 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5594 o->op_private & OPpLVAL_INTRO)
5597 if (type == OP_LIST || flags & OPf_PARENS ||
5598 type == OP_RV2AV || type == OP_RV2HV ||
5599 type == OP_ASLICE || type == OP_HSLICE ||
5600 type == OP_KVASLICE || type == OP_KVHSLICE)
5603 if (type == OP_PADAV || type == OP_PADHV)
5606 if (type == OP_RV2SV)
5613 Helper function for newASSIGNOP to detection commonality between the
5614 lhs and the rhs. Marks all variables with PL_generation. If it
5615 returns TRUE the assignment must be able to handle common variables.
5617 PERL_STATIC_INLINE bool
5618 S_aassign_common_vars(pTHX_ OP* o)
5621 for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
5622 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5623 if (curop->op_type == OP_GV) {
5624 GV *gv = cGVOPx_gv(curop);
5626 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5628 GvASSIGN_GENERATION_set(gv, PL_generation);
5630 else if (curop->op_type == OP_PADSV ||
5631 curop->op_type == OP_PADAV ||
5632 curop->op_type == OP_PADHV ||
5633 curop->op_type == OP_PADANY)
5635 if (PAD_COMPNAME_GEN(curop->op_targ)
5636 == (STRLEN)PL_generation)
5638 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5641 else if (curop->op_type == OP_RV2CV)
5643 else if (curop->op_type == OP_RV2SV ||
5644 curop->op_type == OP_RV2AV ||
5645 curop->op_type == OP_RV2HV ||
5646 curop->op_type == OP_RV2GV) {
5647 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5650 else if (curop->op_type == OP_PUSHRE) {
5653 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5654 ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5657 ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5661 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5663 GvASSIGN_GENERATION_set(gv, PL_generation);
5670 if (curop->op_flags & OPf_KIDS) {
5671 if (aassign_common_vars(curop))
5679 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5681 Constructs, checks, and returns an assignment op. I<left> and I<right>
5682 supply the parameters of the assignment; they are consumed by this
5683 function and become part of the constructed op tree.
5685 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5686 a suitable conditional optree is constructed. If I<optype> is the opcode
5687 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5688 performs the binary operation and assigns the result to the left argument.
5689 Either way, if I<optype> is non-zero then I<flags> has no effect.
5691 If I<optype> is zero, then a plain scalar or list assignment is
5692 constructed. Which type of assignment it is is automatically determined.
5693 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5694 will be set automatically, and, shifted up eight bits, the eight bits
5695 of C<op_private>, except that the bit with value 1 or 2 is automatically
5702 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5707 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5708 return newLOGOP(optype, 0,
5709 op_lvalue(scalar(left), optype),
5710 newUNOP(OP_SASSIGN, 0, scalar(right)));
5713 return newBINOP(optype, OPf_STACKED,
5714 op_lvalue(scalar(left), optype), scalar(right));
5718 if (is_list_assignment(left)) {
5719 static const char no_list_state[] = "Initialization of state variables"
5720 " in list context currently forbidden";
5722 bool maybe_common_vars = TRUE;
5724 if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5725 left->op_private &= ~ OPpSLICEWARNING;
5728 left = op_lvalue(left, OP_AASSIGN);
5729 curop = list(force_list(left, 1));
5730 o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
5731 o->op_private = (U8)(0 | (flags >> 8));
5733 if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
5735 OP* lop = ((LISTOP*)left)->op_first;
5736 maybe_common_vars = FALSE;
5738 if (lop->op_type == OP_PADSV ||
5739 lop->op_type == OP_PADAV ||
5740 lop->op_type == OP_PADHV ||
5741 lop->op_type == OP_PADANY) {
5742 if (!(lop->op_private & OPpLVAL_INTRO))
5743 maybe_common_vars = TRUE;
5745 if (lop->op_private & OPpPAD_STATE) {
5746 if (left->op_private & OPpLVAL_INTRO) {
5747 /* Each variable in state($a, $b, $c) = ... */
5750 /* Each state variable in
5751 (state $a, my $b, our $c, $d, undef) = ... */
5753 yyerror(no_list_state);
5755 /* Each my variable in
5756 (state $a, my $b, our $c, $d, undef) = ... */
5758 } else if (lop->op_type == OP_UNDEF ||
5759 OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
5760 /* undef may be interesting in
5761 (state $a, undef, state $c) */
5763 /* Other ops in the list. */
5764 maybe_common_vars = TRUE;
5766 lop = OP_SIBLING(lop);
5769 else if ((left->op_private & OPpLVAL_INTRO)
5770 && ( left->op_type == OP_PADSV
5771 || left->op_type == OP_PADAV
5772 || left->op_type == OP_PADHV
5773 || left->op_type == OP_PADANY))
5775 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5776 if (left->op_private & OPpPAD_STATE) {
5777 /* All single variable list context state assignments, hence
5787 yyerror(no_list_state);
5791 /* PL_generation sorcery:
5792 * an assignment like ($a,$b) = ($c,$d) is easier than
5793 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5794 * To detect whether there are common vars, the global var
5795 * PL_generation is incremented for each assign op we compile.
5796 * Then, while compiling the assign op, we run through all the
5797 * variables on both sides of the assignment, setting a spare slot
5798 * in each of them to PL_generation. If any of them already have
5799 * that value, we know we've got commonality. We could use a
5800 * single bit marker, but then we'd have to make 2 passes, first
5801 * to clear the flag, then to test and set it. To find somewhere
5802 * to store these values, evil chicanery is done with SvUVX().
5805 if (maybe_common_vars) {
5807 if (aassign_common_vars(o))
5808 o->op_private |= OPpASSIGN_COMMON;
5812 if (right && right->op_type == OP_SPLIT) {
5813 OP* tmpop = ((LISTOP*)right)->op_first;
5814 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5815 PMOP * const pm = (PMOP*)tmpop;
5816 if (left->op_type == OP_RV2AV &&
5817 !(left->op_private & OPpLVAL_INTRO) &&
5818 !(o->op_private & OPpASSIGN_COMMON) )
5820 tmpop = ((UNOP*)left)->op_first;
5821 if (tmpop->op_type == OP_GV
5823 && !pm->op_pmreplrootu.op_pmtargetoff
5825 && !pm->op_pmreplrootu.op_pmtargetgv
5829 pm->op_pmreplrootu.op_pmtargetoff
5830 = cPADOPx(tmpop)->op_padix;
5831 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5833 pm->op_pmreplrootu.op_pmtargetgv
5834 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5835 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5837 tmpop = cUNOPo->op_first; /* to list (nulled) */
5838 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5839 /* detach rest of siblings from o subtree,
5840 * and free subtree */
5841 op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
5842 right->op_next = tmpop->op_next; /* fix starting loc */
5843 op_free(o); /* blow off assign */
5844 right->op_flags &= ~OPf_WANT;
5845 /* "I don't know and I don't care." */
5850 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5851 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5854 &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5855 SV * const sv = *svp;
5856 if (SvIOK(sv) && SvIVX(sv) == 0)
5858 if (right->op_private & OPpSPLIT_IMPLIM) {
5859 /* our own SV, created in ck_split */
5861 sv_setiv(sv, PL_modcount+1);
5864 /* SV may belong to someone else */
5866 *svp = newSViv(PL_modcount+1);
5876 right = newOP(OP_UNDEF, 0);
5877 if (right->op_type == OP_READLINE) {
5878 right->op_flags |= OPf_STACKED;
5879 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5883 o = newBINOP(OP_SASSIGN, flags,
5884 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5890 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5892 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5893 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5894 code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5895 If I<label> is non-null, it supplies the name of a label to attach to
5896 the state op; this function takes ownership of the memory pointed at by
5897 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5900 If I<o> is null, the state op is returned. Otherwise the state op is
5901 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5902 is consumed by this function and becomes part of the returned op tree.
5908 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5911 const U32 seq = intro_my();
5912 const U32 utf8 = flags & SVf_UTF8;
5917 NewOp(1101, cop, 1, COP);
5918 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5919 cop->op_type = OP_DBSTATE;
5920 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5923 cop->op_type = OP_NEXTSTATE;
5924 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5926 cop->op_flags = (U8)flags;
5927 CopHINTS_set(cop, PL_hints);
5929 cop->op_private |= NATIVE_HINTS;
5932 if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
5934 cop->op_next = (OP*)cop;
5937 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5938 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5940 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5942 PL_hints |= HINT_BLOCK_SCOPE;
5943 /* It seems that we need to defer freeing this pointer, as other parts
5944 of the grammar end up wanting to copy it after this op has been
5949 if (PL_parser->preambling != NOLINE) {
5950 CopLINE_set(cop, PL_parser->preambling);
5951 PL_parser->copline = NOLINE;
5953 else if (PL_parser->copline == NOLINE)
5954 CopLINE_set(cop, CopLINE(PL_curcop));
5956 CopLINE_set(cop, PL_parser->copline);
5957 PL_parser->copline = NOLINE;
5960 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5962 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5964 CopSTASH_set(cop, PL_curstash);
5966 if (cop->op_type == OP_DBSTATE) {
5967 /* this line can have a breakpoint - store the cop in IV */
5968 AV *av = CopFILEAVx(PL_curcop);
5970 SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
5971 if (svp && *svp != &PL_sv_undef ) {
5972 (void)SvIOK_on(*svp);
5973 SvIV_set(*svp, PTR2IV(cop));
5978 if (flags & OPf_SPECIAL)
5980 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5984 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5986 Constructs, checks, and returns a logical (flow control) op. I<type>
5987 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5988 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5989 the eight bits of C<op_private>, except that the bit with value 1 is
5990 automatically set. I<first> supplies the expression controlling the
5991 flow, and I<other> supplies the side (alternate) chain of ops; they are
5992 consumed by this function and become part of the constructed op tree.
5998 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6000 PERL_ARGS_ASSERT_NEWLOGOP;
6002 return new_logop(type, flags, &first, &other);
6006 S_search_const(pTHX_ OP *o)
6008 PERL_ARGS_ASSERT_SEARCH_CONST;
6010 switch (o->op_type) {
6014 if (o->op_flags & OPf_KIDS)
6015 return search_const(cUNOPo->op_first);
6022 if (!(o->op_flags & OPf_KIDS))
6024 kid = cLISTOPo->op_first;
6026 switch (kid->op_type) {
6030 kid = OP_SIBLING(kid);
6033 if (kid != cLISTOPo->op_last)
6039 kid = cLISTOPo->op_last;
6041 return search_const(kid);
6049 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6057 int prepend_not = 0;
6059 PERL_ARGS_ASSERT_NEW_LOGOP;
6064 /* [perl #59802]: Warn about things like "return $a or $b", which
6065 is parsed as "(return $a) or $b" rather than "return ($a or
6066 $b)". NB: This also applies to xor, which is why we do it
6069 switch (first->op_type) {
6073 /* XXX: Perhaps we should emit a stronger warning for these.
6074 Even with the high-precedence operator they don't seem to do
6077 But until we do, fall through here.
6083 /* XXX: Currently we allow people to "shoot themselves in the
6084 foot" by explicitly writing "(return $a) or $b".
6086 Warn unless we are looking at the result from folding or if
6087 the programmer explicitly grouped the operators like this.
6088 The former can occur with e.g.
6090 use constant FEATURE => ( $] >= ... );
6091 sub { not FEATURE and return or do_stuff(); }
6093 if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6094 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6095 "Possible precedence issue with control flow operator");
6096 /* XXX: Should we optimze this to "return $a;" (i.e. remove
6102 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
6103 return newBINOP(type, flags, scalar(first), scalar(other));
6105 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6107 scalarboolean(first);
6108 /* optimize AND and OR ops that have NOTs as children */
6109 if (first->op_type == OP_NOT
6110 && (first->op_flags & OPf_KIDS)
6111 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6112 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
6114 if (type == OP_AND || type == OP_OR) {
6120 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6122 prepend_not = 1; /* prepend a NOT op later */
6126 /* search for a constant op that could let us fold the test */
6127 if ((cstop = search_const(first))) {
6128 if (cstop->op_private & OPpCONST_STRICT)
6129 no_bareword_allowed(cstop);
6130 else if ((cstop->op_private & OPpCONST_BARE))
6131 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6132 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
6133 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6134 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6136 if (other->op_type == OP_CONST)
6137 other->op_private |= OPpCONST_SHORTCIRCUIT;
6139 if (other->op_type == OP_LEAVE)
6140 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6141 else if (other->op_type == OP_MATCH
6142 || other->op_type == OP_SUBST
6143 || other->op_type == OP_TRANSR
6144 || other->op_type == OP_TRANS)
6145 /* Mark the op as being unbindable with =~ */
6146 other->op_flags |= OPf_SPECIAL;
6148 other->op_folded = 1;
6152 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6153 const OP *o2 = other;
6154 if ( ! (o2->op_type == OP_LIST
6155 && (( o2 = cUNOPx(o2)->op_first))
6156 && o2->op_type == OP_PUSHMARK
6157 && (( o2 = OP_SIBLING(o2))) )
6160 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6161 || o2->op_type == OP_PADHV)
6162 && o2->op_private & OPpLVAL_INTRO
6163 && !(o2->op_private & OPpPAD_STATE))
6165 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6166 "Deprecated use of my() in false conditional");
6170 if (cstop->op_type == OP_CONST)
6171 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6176 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6177 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6179 const OP * const k1 = ((UNOP*)first)->op_first;
6180 const OP * const k2 = OP_SIBLING(k1);
6182 switch (first->op_type)
6185 if (k2 && k2->op_type == OP_READLINE
6186 && (k2->op_flags & OPf_STACKED)
6187 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6189 warnop = k2->op_type;
6194 if (k1->op_type == OP_READDIR
6195 || k1->op_type == OP_GLOB
6196 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6197 || k1->op_type == OP_EACH
6198 || k1->op_type == OP_AEACH)
6200 warnop = ((k1->op_type == OP_NULL)
6201 ? (OPCODE)k1->op_targ : k1->op_type);
6206 const line_t oldline = CopLINE(PL_curcop);
6207 /* This ensures that warnings are reported at the first line
6208 of the construction, not the last. */
6209 CopLINE_set(PL_curcop, PL_parser->copline);
6210 Perl_warner(aTHX_ packWARN(WARN_MISC),
6211 "Value of %s%s can be \"0\"; test with defined()",
6213 ((warnop == OP_READLINE || warnop == OP_GLOB)
6214 ? " construct" : "() operator"));
6215 CopLINE_set(PL_curcop, oldline);
6222 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6223 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
6225 logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6226 logop->op_ppaddr = PL_ppaddr[type];
6227 logop->op_flags |= (U8)flags;
6228 logop->op_private = (U8)(1 | (flags >> 8));
6230 /* establish postfix order */
6231 logop->op_next = LINKLIST(first);
6232 first->op_next = (OP*)logop;
6233 assert(!OP_HAS_SIBLING(first));
6234 op_sibling_splice((OP*)logop, first, 0, other);
6236 CHECKOP(type,logop);
6238 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6245 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6247 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6248 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6249 will be set automatically, and, shifted up eight bits, the eight bits of
6250 C<op_private>, except that the bit with value 1 is automatically set.
6251 I<first> supplies the expression selecting between the two branches,
6252 and I<trueop> and I<falseop> supply the branches; they are consumed by
6253 this function and become part of the constructed op tree.
6259 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6267 PERL_ARGS_ASSERT_NEWCONDOP;
6270 return newLOGOP(OP_AND, 0, first, trueop);
6272 return newLOGOP(OP_OR, 0, first, falseop);
6274 scalarboolean(first);
6275 if ((cstop = search_const(first))) {
6276 /* Left or right arm of the conditional? */
6277 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6278 OP *live = left ? trueop : falseop;
6279 OP *const dead = left ? falseop : trueop;
6280 if (cstop->op_private & OPpCONST_BARE &&
6281 cstop->op_private & OPpCONST_STRICT) {
6282 no_bareword_allowed(cstop);
6286 if (live->op_type == OP_LEAVE)
6287 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6288 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6289 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6290 /* Mark the op as being unbindable with =~ */
6291 live->op_flags |= OPf_SPECIAL;
6292 live->op_folded = 1;
6295 logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6296 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6297 logop->op_flags |= (U8)flags;
6298 logop->op_private = (U8)(1 | (flags >> 8));
6299 logop->op_next = LINKLIST(falseop);
6301 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6304 /* establish postfix order */
6305 start = LINKLIST(first);
6306 first->op_next = (OP*)logop;
6308 /* make first, trueop, falseop siblings */
6309 op_sibling_splice((OP*)logop, first, 0, trueop);
6310 op_sibling_splice((OP*)logop, trueop, 0, falseop);
6312 o = newUNOP(OP_NULL, 0, (OP*)logop);
6314 trueop->op_next = falseop->op_next = o;
6321 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6323 Constructs and returns a C<range> op, with subordinate C<flip> and
6324 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6325 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6326 for both the C<flip> and C<range> ops, except that the bit with value
6327 1 is automatically set. I<left> and I<right> supply the expressions
6328 controlling the endpoints of the range; they are consumed by this function
6329 and become part of the constructed op tree.
6335 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6344 PERL_ARGS_ASSERT_NEWRANGE;
6346 range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
6347 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6348 range->op_flags = OPf_KIDS;
6349 leftstart = LINKLIST(left);
6350 range->op_private = (U8)(1 | (flags >> 8));
6352 /* make left and right siblings */
6353 op_sibling_splice((OP*)range, left, 0, right);
6355 range->op_next = (OP*)range;
6356 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6357 flop = newUNOP(OP_FLOP, 0, flip);
6358 o = newUNOP(OP_NULL, 0, flop);
6360 range->op_next = leftstart;
6362 left->op_next = flip;
6363 right->op_next = flop;
6365 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6366 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6367 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6368 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6370 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6371 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6373 /* check barewords before they might be optimized aways */
6374 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6375 no_bareword_allowed(left);
6376 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6377 no_bareword_allowed(right);
6380 if (!flip->op_private || !flop->op_private)
6381 LINKLIST(o); /* blow off optimizer unless constant */
6387 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6389 Constructs, checks, and returns an op tree expressing a loop. This is
6390 only a loop in the control flow through the op tree; it does not have
6391 the heavyweight loop structure that allows exiting the loop by C<last>
6392 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6393 top-level op, except that some bits will be set automatically as required.
6394 I<expr> supplies the expression controlling loop iteration, and I<block>
6395 supplies the body of the loop; they are consumed by this function and
6396 become part of the constructed op tree. I<debuggable> is currently
6397 unused and should always be 1.
6403 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6407 const bool once = block && block->op_flags & OPf_SPECIAL &&
6408 block->op_type == OP_NULL;
6410 PERL_UNUSED_ARG(debuggable);
6414 (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6415 || ( expr->op_type == OP_NOT
6416 && cUNOPx(expr)->op_first->op_type == OP_CONST
6417 && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6420 /* Return the block now, so that S_new_logop does not try to
6422 return block; /* do {} while 0 does once */
6423 if (expr->op_type == OP_READLINE
6424 || expr->op_type == OP_READDIR
6425 || expr->op_type == OP_GLOB
6426 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6427 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6428 expr = newUNOP(OP_DEFINED, 0,
6429 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6430 } else if (expr->op_flags & OPf_KIDS) {
6431 const OP * const k1 = ((UNOP*)expr)->op_first;
6432 const OP * const k2 = k1 ? OP_SIBLING(k1) : NULL;
6433 switch (expr->op_type) {
6435 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6436 && (k2->op_flags & OPf_STACKED)
6437 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6438 expr = newUNOP(OP_DEFINED, 0, expr);
6442 if (k1 && (k1->op_type == OP_READDIR
6443 || k1->op_type == OP_GLOB
6444 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6445 || k1->op_type == OP_EACH
6446 || k1->op_type == OP_AEACH))
6447 expr = newUNOP(OP_DEFINED, 0, expr);
6453 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6454 * op, in listop. This is wrong. [perl #27024] */
6456 block = newOP(OP_NULL, 0);
6457 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6458 o = new_logop(OP_AND, 0, &expr, &listop);
6465 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6467 if (once && o != listop)
6469 assert(cUNOPo->op_first->op_type == OP_AND
6470 || cUNOPo->op_first->op_type == OP_OR);
6471 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6475 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6477 o->op_flags |= flags;
6479 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6484 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6486 Constructs, checks, and returns an op tree expressing a C<while> loop.
6487 This is a heavyweight loop, with structure that allows exiting the loop
6488 by C<last> and suchlike.
6490 I<loop> is an optional preconstructed C<enterloop> op to use in the
6491 loop; if it is null then a suitable op will be constructed automatically.
6492 I<expr> supplies the loop's controlling expression. I<block> supplies the
6493 main body of the loop, and I<cont> optionally supplies a C<continue> block
6494 that operates as a second half of the body. All of these optree inputs
6495 are consumed by this function and become part of the constructed op tree.
6497 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6498 op and, shifted up eight bits, the eight bits of C<op_private> for
6499 the C<leaveloop> op, except that (in both cases) some bits will be set
6500 automatically. I<debuggable> is currently unused and should always be 1.
6501 I<has_my> can be supplied as true to force the
6502 loop body to be enclosed in its own scope.
6508 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6509 OP *expr, OP *block, OP *cont, I32 has_my)
6518 PERL_UNUSED_ARG(debuggable);
6521 if (expr->op_type == OP_READLINE
6522 || expr->op_type == OP_READDIR
6523 || expr->op_type == OP_GLOB
6524 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6525 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6526 expr = newUNOP(OP_DEFINED, 0,
6527 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6528 } else if (expr->op_flags & OPf_KIDS) {
6529 const OP * const k1 = ((UNOP*)expr)->op_first;
6530 const OP * const k2 = (k1) ? OP_SIBLING(k1) : NULL;
6531 switch (expr->op_type) {
6533 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6534 && (k2->op_flags & OPf_STACKED)
6535 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6536 expr = newUNOP(OP_DEFINED, 0, expr);
6540 if (k1 && (k1->op_type == OP_READDIR
6541 || k1->op_type == OP_GLOB
6542 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6543 || k1->op_type == OP_EACH
6544 || k1->op_type == OP_AEACH))
6545 expr = newUNOP(OP_DEFINED, 0, expr);
6552 block = newOP(OP_NULL, 0);
6553 else if (cont || has_my) {
6554 block = op_scope(block);
6558 next = LINKLIST(cont);
6561 OP * const unstack = newOP(OP_UNSTACK, 0);
6564 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6568 listop = op_append_list(OP_LINESEQ, block, cont);
6570 redo = LINKLIST(listop);
6574 o = new_logop(OP_AND, 0, &expr, &listop);
6575 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6577 return expr; /* listop already freed by new_logop */
6580 ((LISTOP*)listop)->op_last->op_next =
6581 (o == listop ? redo : LINKLIST(o));
6587 NewOp(1101,loop,1,LOOP);
6588 loop->op_type = OP_ENTERLOOP;
6589 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6590 loop->op_private = 0;
6591 loop->op_next = (OP*)loop;
6594 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6596 loop->op_redoop = redo;
6597 loop->op_lastop = o;
6598 o->op_private |= loopflags;
6601 loop->op_nextop = next;
6603 loop->op_nextop = o;
6605 o->op_flags |= flags;
6606 o->op_private |= (flags >> 8);
6611 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6613 Constructs, checks, and returns an op tree expressing a C<foreach>
6614 loop (iteration through a list of values). This is a heavyweight loop,
6615 with structure that allows exiting the loop by C<last> and suchlike.
6617 I<sv> optionally supplies the variable that will be aliased to each
6618 item in turn; if null, it defaults to C<$_> (either lexical or global).
6619 I<expr> supplies the list of values to iterate over. I<block> supplies
6620 the main body of the loop, and I<cont> optionally supplies a C<continue>
6621 block that operates as a second half of the body. All of these optree
6622 inputs are consumed by this function and become part of the constructed
6625 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6626 op and, shifted up eight bits, the eight bits of C<op_private> for
6627 the C<leaveloop> op, except that (in both cases) some bits will be set
6634 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6639 PADOFFSET padoff = 0;
6643 PERL_ARGS_ASSERT_NEWFOROP;
6646 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6647 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6648 sv->op_type = OP_RV2GV;
6649 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6651 /* The op_type check is needed to prevent a possible segfault
6652 * if the loop variable is undeclared and 'strict vars' is in
6653 * effect. This is illegal but is nonetheless parsed, so we
6654 * may reach this point with an OP_CONST where we're expecting
6657 if (cUNOPx(sv)->op_first->op_type == OP_GV
6658 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6659 iterpflags |= OPpITER_DEF;
6661 else if (sv->op_type == OP_PADSV) { /* private variable */
6662 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6663 padoff = sv->op_targ;
6669 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6671 SV *const namesv = PAD_COMPNAME_SV(padoff);
6673 const char *const name = SvPV_const(namesv, len);
6675 if (len == 2 && name[0] == '$' && name[1] == '_')
6676 iterpflags |= OPpITER_DEF;
6680 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6681 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6682 sv = newGVOP(OP_GV, 0, PL_defgv);
6687 iterpflags |= OPpITER_DEF;
6690 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6691 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER)), 1), OP_GREPSTART);
6692 iterflags |= OPf_STACKED;
6694 else if (expr->op_type == OP_NULL &&
6695 (expr->op_flags & OPf_KIDS) &&
6696 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6698 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6699 * set the STACKED flag to indicate that these values are to be
6700 * treated as min/max values by 'pp_enteriter'.
6702 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6703 LOGOP* const range = (LOGOP*) flip->op_first;
6704 OP* const left = range->op_first;
6705 OP* const right = OP_SIBLING(left);
6708 range->op_flags &= ~OPf_KIDS;
6709 /* detach range's children */
6710 op_sibling_splice((OP*)range, NULL, -1, NULL);
6712 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6713 listop->op_first->op_next = range->op_next;
6714 left->op_next = range->op_other;
6715 right->op_next = (OP*)listop;
6716 listop->op_next = listop->op_first;
6719 expr = (OP*)(listop);
6721 iterflags |= OPf_STACKED;
6724 expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
6727 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6728 op_append_elem(OP_LIST, expr, scalar(sv))));
6729 assert(!loop->op_next);
6730 /* for my $x () sets OPpLVAL_INTRO;
6731 * for our $x () sets OPpOUR_INTRO */
6732 loop->op_private = (U8)iterpflags;
6733 if (loop->op_slabbed
6734 && DIFF(loop, OpSLOT(loop)->opslot_next)
6735 < SIZE_TO_PSIZE(sizeof(LOOP)))
6738 NewOp(1234,tmp,1,LOOP);
6739 Copy(loop,tmp,1,LISTOP);
6740 #ifdef PERL_OP_PARENT
6741 assert(loop->op_last->op_sibling == (OP*)loop);
6742 loop->op_last->op_sibling = (OP*)tmp; /*point back to new parent */
6744 S_op_destroy(aTHX_ (OP*)loop);
6747 else if (!loop->op_slabbed)
6748 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6749 loop->op_targ = padoff;
6750 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6755 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6757 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6758 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6759 determining the target of the op; it is consumed by this function and
6760 becomes part of the constructed op tree.
6766 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6770 PERL_ARGS_ASSERT_NEWLOOPEX;
6772 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6774 if (type != OP_GOTO) {
6775 /* "last()" means "last" */
6776 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6777 o = newOP(type, OPf_SPECIAL);
6781 /* Check whether it's going to be a goto &function */
6782 if (label->op_type == OP_ENTERSUB
6783 && !(label->op_flags & OPf_STACKED))
6784 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6787 /* Check for a constant argument */
6788 if (label->op_type == OP_CONST) {
6789 SV * const sv = ((SVOP *)label)->op_sv;
6791 const char *s = SvPV_const(sv,l);
6792 if (l == strlen(s)) {
6794 SvUTF8(((SVOP*)label)->op_sv),
6796 SvPV_nolen_const(((SVOP*)label)->op_sv)));
6800 /* If we have already created an op, we do not need the label. */
6803 else o = newUNOP(type, OPf_STACKED, label);
6805 PL_hints |= HINT_BLOCK_SCOPE;
6809 /* if the condition is a literal array or hash
6810 (or @{ ... } etc), make a reference to it.
6813 S_ref_array_or_hash(pTHX_ OP *cond)
6816 && (cond->op_type == OP_RV2AV
6817 || cond->op_type == OP_PADAV
6818 || cond->op_type == OP_RV2HV
6819 || cond->op_type == OP_PADHV))
6821 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6824 && (cond->op_type == OP_ASLICE
6825 || cond->op_type == OP_KVASLICE
6826 || cond->op_type == OP_HSLICE
6827 || cond->op_type == OP_KVHSLICE)) {
6829 /* anonlist now needs a list from this op, was previously used in
6831 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6832 cond->op_flags |= OPf_WANT_LIST;
6834 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6841 /* These construct the optree fragments representing given()
6844 entergiven and enterwhen are LOGOPs; the op_other pointer
6845 points up to the associated leave op. We need this so we
6846 can put it in the context and make break/continue work.
6847 (Also, of course, pp_enterwhen will jump straight to
6848 op_other if the match fails.)
6852 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6853 I32 enter_opcode, I32 leave_opcode,
6854 PADOFFSET entertarg)
6860 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6862 enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
6863 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6864 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6865 enterop->op_private = 0;
6867 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6870 /* prepend cond if we have one */
6871 op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
6873 o->op_next = LINKLIST(cond);
6874 cond->op_next = (OP *) enterop;
6877 /* This is a default {} block */
6878 enterop->op_flags |= OPf_SPECIAL;
6879 o ->op_flags |= OPf_SPECIAL;
6881 o->op_next = (OP *) enterop;
6884 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6885 entergiven and enterwhen both
6888 enterop->op_next = LINKLIST(block);
6889 block->op_next = enterop->op_other = o;
6894 /* Does this look like a boolean operation? For these purposes
6895 a boolean operation is:
6896 - a subroutine call [*]
6897 - a logical connective
6898 - a comparison operator
6899 - a filetest operator, with the exception of -s -M -A -C
6900 - defined(), exists() or eof()
6901 - /$re/ or $foo =~ /$re/
6903 [*] possibly surprising
6906 S_looks_like_bool(pTHX_ const OP *o)
6908 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6910 switch(o->op_type) {
6913 return looks_like_bool(cLOGOPo->op_first);
6917 OP* sibl = OP_SIBLING(cLOGOPo->op_first);
6920 looks_like_bool(cLOGOPo->op_first)
6921 && looks_like_bool(sibl));
6927 o->op_flags & OPf_KIDS
6928 && looks_like_bool(cUNOPo->op_first));
6932 case OP_NOT: case OP_XOR:
6934 case OP_EQ: case OP_NE: case OP_LT:
6935 case OP_GT: case OP_LE: case OP_GE:
6937 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6938 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6940 case OP_SEQ: case OP_SNE: case OP_SLT:
6941 case OP_SGT: case OP_SLE: case OP_SGE:
6945 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6946 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6947 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6948 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6949 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6950 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6951 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6952 case OP_FTTEXT: case OP_FTBINARY:
6954 case OP_DEFINED: case OP_EXISTS:
6955 case OP_MATCH: case OP_EOF:
6962 /* Detect comparisons that have been optimized away */
6963 if (cSVOPo->op_sv == &PL_sv_yes
6964 || cSVOPo->op_sv == &PL_sv_no)
6977 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6979 Constructs, checks, and returns an op tree expressing a C<given> block.
6980 I<cond> supplies the expression that will be locally assigned to a lexical
6981 variable, and I<block> supplies the body of the C<given> construct; they
6982 are consumed by this function and become part of the constructed op tree.
6983 I<defsv_off> is the pad offset of the scalar lexical variable that will
6984 be affected. If it is 0, the global $_ will be used.
6990 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6992 PERL_ARGS_ASSERT_NEWGIVENOP;
6993 return newGIVWHENOP(
6994 ref_array_or_hash(cond),
6996 OP_ENTERGIVEN, OP_LEAVEGIVEN,
7001 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7003 Constructs, checks, and returns an op tree expressing a C<when> block.
7004 I<cond> supplies the test expression, and I<block> supplies the block
7005 that will be executed if the test evaluates to true; they are consumed
7006 by this function and become part of the constructed op tree. I<cond>
7007 will be interpreted DWIMically, often as a comparison against C<$_>,
7008 and may be null to generate a C<default> block.
7014 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7016 const bool cond_llb = (!cond || looks_like_bool(cond));
7019 PERL_ARGS_ASSERT_NEWWHENOP;
7024 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7026 scalar(ref_array_or_hash(cond)));
7029 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7032 /* must not conflict with SVf_UTF8 */
7033 #define CV_CKPROTO_CURSTASH 0x1
7036 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7037 const STRLEN len, const U32 flags)
7039 SV *name = NULL, *msg;
7040 const char * cvp = SvROK(cv)
7041 ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
7042 ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
7045 STRLEN clen = CvPROTOLEN(cv), plen = len;
7047 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7049 if (p == NULL && cvp == NULL)
7052 if (!ckWARN_d(WARN_PROTOTYPE))
7056 p = S_strip_spaces(aTHX_ p, &plen);
7057 cvp = S_strip_spaces(aTHX_ cvp, &clen);
7058 if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7059 if (plen == clen && memEQ(cvp, p, plen))
7062 if (flags & SVf_UTF8) {
7063 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7067 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7073 msg = sv_newmortal();
7078 gv_efullname3(name = sv_newmortal(), gv, NULL);
7079 else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7080 name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7081 else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
7082 name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash)));
7083 sv_catpvs(name, "::");
7085 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
7086 assert (CvNAMED(SvRV_const(gv)));
7087 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
7089 else sv_catsv(name, (SV *)gv);
7091 else name = (SV *)gv;
7093 sv_setpvs(msg, "Prototype mismatch:");
7095 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7097 Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7098 UTF8fARG(SvUTF8(cv),clen,cvp)
7101 sv_catpvs(msg, ": none");
7102 sv_catpvs(msg, " vs ");
7104 Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7106 sv_catpvs(msg, "none");
7107 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7110 static void const_sv_xsub(pTHX_ CV* cv);
7111 static void const_av_xsub(pTHX_ CV* cv);
7115 =head1 Optree Manipulation Functions
7117 =for apidoc cv_const_sv
7119 If C<cv> is a constant sub eligible for inlining, returns the constant
7120 value returned by the sub. Otherwise, returns NULL.
7122 Constant subs can be created with C<newCONSTSUB> or as described in
7123 L<perlsub/"Constant Functions">.
7128 Perl_cv_const_sv(const CV *const cv)
7133 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7135 sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7136 if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7141 Perl_cv_const_sv_or_av(const CV * const cv)
7145 if (SvROK(cv)) return SvRV((SV *)cv);
7146 assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7147 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7150 /* op_const_sv: examine an optree to determine whether it's in-lineable.
7151 * Can be called in 3 ways:
7154 * look for a single OP_CONST with attached value: return the value
7156 * cv && CvCLONE(cv) && !CvCONST(cv)
7158 * examine the clone prototype, and if contains only a single
7159 * OP_CONST referencing a pad const, or a single PADSV referencing
7160 * an outer lexical, return a non-zero value to indicate the CV is
7161 * a candidate for "constizing" at clone time
7165 * We have just cloned an anon prototype that was marked as a const
7166 * candidate. Try to grab the current value, and in the case of
7167 * PADSV, ignore it if it has multiple references. In this case we
7168 * return a newly created *copy* of the value.
7172 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
7179 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
7180 o = OP_SIBLING(cLISTOPo->op_first);
7182 for (; o; o = o->op_next) {
7183 const OPCODE type = o->op_type;
7185 if (sv && o->op_next == o)
7187 if (o->op_next != o) {
7188 if (type == OP_NEXTSTATE
7189 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7190 || type == OP_PUSHMARK)
7192 if (type == OP_DBSTATE)
7195 if (type == OP_LEAVESUB || type == OP_RETURN)
7199 if (type == OP_CONST && cSVOPo->op_sv)
7201 else if (type == OP_UNDEF && !o->op_private) {
7205 else if (cv && type == OP_CONST) {
7206 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7210 else if (cv && type == OP_PADSV) {
7211 if (CvCONST(cv)) { /* newly cloned anon */
7212 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7213 /* the candidate should have 1 ref from this pad and 1 ref
7214 * from the parent */
7215 if (!sv || SvREFCNT(sv) != 2)
7222 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
7223 sv = &PL_sv_undef; /* an arbitrary non-null value */
7234 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7235 PADNAME * const name, SV ** const const_svp)
7242 if (CvFLAGS(PL_compcv)) {
7243 /* might have had built-in attrs applied */
7244 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7245 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7246 && ckWARN(WARN_MISC))
7248 /* protect against fatal warnings leaking compcv */
7249 SAVEFREESV(PL_compcv);
7250 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7251 SvREFCNT_inc_simple_void_NN(PL_compcv);
7254 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7255 & ~(CVf_LVALUE * pureperl));
7260 /* redundant check for speed: */
7261 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7262 const line_t oldline = CopLINE(PL_curcop);
7265 : sv_2mortal(newSVpvn_utf8(
7266 PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7268 if (PL_parser && PL_parser->copline != NOLINE)
7269 /* This ensures that warnings are reported at the first
7270 line of a redefinition, not the last. */
7271 CopLINE_set(PL_curcop, PL_parser->copline);
7272 /* protect against fatal warnings leaking compcv */
7273 SAVEFREESV(PL_compcv);
7274 report_redefined_cv(namesv, cv, const_svp);
7275 SvREFCNT_inc_simple_void_NN(PL_compcv);
7276 CopLINE_set(PL_curcop, oldline);
7283 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7288 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7291 CV *compcv = PL_compcv;
7294 PADOFFSET pax = o->op_targ;
7295 CV *outcv = CvOUTSIDE(PL_compcv);
7298 bool reusable = FALSE;
7300 PERL_ARGS_ASSERT_NEWMYSUB;
7302 /* Find the pad slot for storing the new sub.
7303 We cannot use PL_comppad, as it is the pad owned by the new sub. We
7304 need to look in CvOUTSIDE and find the pad belonging to the enclos-
7305 ing sub. And then we need to dig deeper if this is a lexical from
7307 my sub foo; sub { sub foo { } }
7310 name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7311 if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7312 pax = PARENT_PAD_INDEX(name);
7313 outcv = CvOUTSIDE(outcv);
7318 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7319 [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7320 spot = (CV **)svspot;
7322 if (!(PL_parser && PL_parser->error_count))
7323 move_proto_attr(&proto, &attrs, (GV *)name);
7326 assert(proto->op_type == OP_CONST);
7327 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7328 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7338 if (PL_parser && PL_parser->error_count) {
7340 SvREFCNT_dec(PL_compcv);
7345 if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7347 svspot = (SV **)(spot = &clonee);
7349 else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7353 SvUPGRADE(name, SVt_PVMG);
7354 mg = mg_find(name, PERL_MAGIC_proto);
7355 assert (SvTYPE(*spot) == SVt_PVCV);
7357 hek = CvNAME_HEK(*spot);
7361 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7362 CvNAME_HEK_set(*spot, hek =
7365 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
7368 CvLEXICAL_on(*spot);
7372 cv = (CV *)mg->mg_obj;
7375 sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7376 mg = mg_find(name, PERL_MAGIC_proto);
7378 spot = (CV **)(svspot = &mg->mg_obj);
7381 if (!block || !ps || *ps || attrs
7382 || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7386 const_sv = op_const_sv(block, NULL);
7389 const bool exists = CvROOT(cv) || CvXSUB(cv);
7391 /* if the subroutine doesn't exist and wasn't pre-declared
7392 * with a prototype, assume it will be AUTOLOADed,
7393 * skipping the prototype check
7395 if (exists || SvPOK(cv))
7396 cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7397 /* already defined? */
7399 if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7402 if (attrs) goto attrs;
7403 /* just a "sub foo;" when &foo is already defined */
7408 else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7414 SvREFCNT_inc_simple_void_NN(const_sv);
7415 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7417 assert(!CvROOT(cv) && !CvCONST(cv));
7421 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7422 CvFILE_set_from_cop(cv, PL_curcop);
7423 CvSTASH_set(cv, PL_curstash);
7426 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7427 CvXSUBANY(cv).any_ptr = const_sv;
7428 CvXSUB(cv) = const_sv_xsub;
7432 SvREFCNT_dec(compcv);
7436 /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7437 determine whether this sub definition is in the same scope as its
7438 declaration. If this sub definition is inside an inner named pack-
7439 age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7440 the package sub. So check PadnameOUTER(name) too.
7442 if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7443 assert(!CvWEAKOUTSIDE(compcv));
7444 SvREFCNT_dec(CvOUTSIDE(compcv));
7445 CvWEAKOUTSIDE_on(compcv);
7447 /* XXX else do we have a circular reference? */
7448 if (cv) { /* must reuse cv in case stub is referenced elsewhere */
7449 /* transfer PL_compcv to cv */
7452 cv_flags_t preserved_flags =
7453 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7454 PADLIST *const temp_padl = CvPADLIST(cv);
7455 CV *const temp_cv = CvOUTSIDE(cv);
7456 const cv_flags_t other_flags =
7457 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7458 OP * const cvstart = CvSTART(cv);
7462 CvFLAGS(compcv) | preserved_flags;
7463 CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7464 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7465 CvPADLIST(cv) = CvPADLIST(compcv);
7466 CvOUTSIDE(compcv) = temp_cv;
7467 CvPADLIST(compcv) = temp_padl;
7468 CvSTART(cv) = CvSTART(compcv);
7469 CvSTART(compcv) = cvstart;
7470 CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7471 CvFLAGS(compcv) |= other_flags;
7473 if (CvFILE(cv) && CvDYNFILE(cv)) {
7474 Safefree(CvFILE(cv));
7477 /* inner references to compcv must be fixed up ... */
7478 pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7479 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7480 ++PL_sub_generation;
7483 /* Might have had built-in attributes applied -- propagate them. */
7484 CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7486 /* ... before we throw it away */
7487 SvREFCNT_dec(compcv);
7488 PL_compcv = compcv = cv;
7496 if (!CvNAME_HEK(cv)) {
7497 if (hek) (void)share_hek_hek(hek);
7501 PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
7502 hek = share_hek(PadnamePV(name)+1,
7503 PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7506 CvNAME_HEK_set(cv, hek);
7508 if (const_sv) goto clone;
7510 CvFILE_set_from_cop(cv, PL_curcop);
7511 CvSTASH_set(cv, PL_curstash);
7514 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7515 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7521 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7522 the debugger could be able to set a breakpoint in, so signal to
7523 pp_entereval that it should not throw away any saved lines at scope
7526 PL_breakable_sub_gen++;
7527 /* This makes sub {}; work as expected. */
7528 if (block->op_type == OP_STUB) {
7529 OP* const newblock = newSTATEOP(0, NULL, 0);
7533 CvROOT(cv) = CvLVALUE(cv)
7534 ? newUNOP(OP_LEAVESUBLV, 0,
7535 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7536 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7537 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7538 OpREFCNT_set(CvROOT(cv), 1);
7539 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7540 itself has a refcount. */
7542 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7543 CvSTART(cv) = LINKLIST(CvROOT(cv));
7544 CvROOT(cv)->op_next = 0;
7545 CALL_PEEP(CvSTART(cv));
7546 finalize_optree(CvROOT(cv));
7547 S_prune_chain_head(&CvSTART(cv));
7549 /* now that optimizer has done its work, adjust pad values */
7551 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7554 assert(!CvCONST(cv));
7555 if (ps && !*ps && op_const_sv(block, cv))
7561 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7562 apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7566 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7567 SV * const tmpstr = sv_newmortal();
7568 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7569 GV_ADDMULTI, SVt_PVHV);
7571 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7574 (long)CopLINE(PL_curcop));
7575 if (HvNAME_HEK(PL_curstash)) {
7576 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7577 sv_catpvs(tmpstr, "::");
7579 else sv_setpvs(tmpstr, "__ANON__::");
7580 sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7581 PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7582 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7583 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7584 hv = GvHVn(db_postponed);
7585 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7586 CV * const pcv = GvCV(db_postponed);
7592 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7600 assert(CvDEPTH(outcv));
7602 &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7603 if (reusable) cv_clone_into(clonee, *spot);
7604 else *spot = cv_clone(clonee);
7605 SvREFCNT_dec_NN(clonee);
7609 if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7610 PADOFFSET depth = CvDEPTH(outcv);
7613 svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7615 *svspot = SvREFCNT_inc_simple_NN(cv);
7616 SvREFCNT_dec(oldcv);
7622 PL_parser->copline = NOLINE;
7630 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7631 OP *block, bool o_is_gv)
7635 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7639 const bool ec = PL_parser && PL_parser->error_count;
7640 /* If the subroutine has no body, no attributes, and no builtin attributes
7641 then it's just a sub declaration, and we may be able to get away with
7642 storing with a placeholder scalar in the symbol table, rather than a
7643 full CV. If anything is present then it will take a full CV to
7645 const I32 gv_fetch_flags
7646 = ec ? GV_NOADD_NOINIT :
7647 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
7648 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7650 const char * const name =
7651 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7653 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7654 #ifdef PERL_DEBUG_READONLY_OPS
7655 OPSLAB *slab = NULL;
7656 bool special = FALSE;
7664 /* Try to optimise and avoid creating a GV. Instead, the CV’s name
7665 hek and CvSTASH pointer together can imply the GV. If the name
7666 contains a package name, then GvSTASH(CvGV(cv)) may differ from
7667 CvSTASH, so forego the optimisation if we find any.
7668 Also, we may be called from load_module at run time, so
7669 PL_curstash (which sets CvSTASH) may not point to the stash the
7670 sub is stored in. */
7672 ec ? GV_NOADD_NOINIT
7673 : PL_curstash != CopSTASH(PL_curcop)
7674 || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
7676 : GV_ADDMULTI | GV_NOINIT;
7677 gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
7679 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7680 SV * const sv = sv_newmortal();
7681 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7682 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7683 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7684 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7686 } else if (PL_curstash) {
7687 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7690 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7694 move_proto_attr(&proto, &attrs,
7695 isGV(gv) ? gv : (GV *)cSVOPo->op_sv);
7698 assert(proto->op_type == OP_CONST);
7699 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7700 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7714 if (name) SvREFCNT_dec(PL_compcv);
7715 else cv = PL_compcv;
7717 if (name && block) {
7718 const char *s = strrchr(name, ':');
7720 if (strEQ(s, "BEGIN")) {
7721 if (PL_in_eval & EVAL_KEEPERR)
7722 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7724 SV * const errsv = ERRSV;
7725 /* force display of errors found but not reported */
7726 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7727 Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7734 if (!block && SvTYPE(gv) != SVt_PVGV) {
7735 /* If we are not defining a new sub and the existing one is not a
7737 if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
7738 /* We are applying attributes to an existing sub, so we need it
7739 upgraded if it is a constant. */
7740 if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
7741 gv_init_pvn(gv, PL_curstash, name, namlen,
7742 SVf_UTF8 * name_is_utf8);
7744 else { /* Maybe prototype now, and had at maximum
7745 a prototype or const/sub ref before. */
7746 if (SvTYPE(gv) > SVt_NULL) {
7747 cv_ckproto_len_flags((const CV *)gv,
7748 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7753 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7754 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7757 sv_setiv(MUTABLE_SV(gv), -1);
7760 SvREFCNT_dec(PL_compcv);
7761 cv = PL_compcv = NULL;
7766 cv = (!name || (isGV(gv) && GvCVGEN(gv)))
7770 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
7775 if (!block || !ps || *ps || attrs
7776 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7780 const_sv = op_const_sv(block, NULL);
7782 if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
7784 cv_ckproto_len_flags((const CV *)gv,
7785 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7786 ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
7788 /* All the other code for sub redefinition warnings expects the
7789 clobbered sub to be a CV. Instead of making all those code
7790 paths more complex, just inline the RV version here. */
7791 const line_t oldline = CopLINE(PL_curcop);
7792 assert(IN_PERL_COMPILETIME);
7793 if (PL_parser && PL_parser->copline != NOLINE)
7794 /* This ensures that warnings are reported at the first
7795 line of a redefinition, not the last. */
7796 CopLINE_set(PL_curcop, PL_parser->copline);
7797 /* protect against fatal warnings leaking compcv */
7798 SAVEFREESV(PL_compcv);
7800 if (ckWARN(WARN_REDEFINE)
7801 || ( ckWARN_d(WARN_REDEFINE)
7802 && ( !const_sv || SvRV(gv) == const_sv
7803 || sv_cmp(SvRV(gv), const_sv) )))
7804 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7805 "Constant subroutine %"SVf" redefined",
7806 SVfARG(cSVOPo->op_sv));
7808 SvREFCNT_inc_simple_void_NN(PL_compcv);
7809 CopLINE_set(PL_curcop, oldline);
7810 SvREFCNT_dec(SvRV(gv));
7815 const bool exists = CvROOT(cv) || CvXSUB(cv);
7817 /* if the subroutine doesn't exist and wasn't pre-declared
7818 * with a prototype, assume it will be AUTOLOADed,
7819 * skipping the prototype check
7821 if (exists || SvPOK(cv))
7822 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7823 /* already defined (or promised)? */
7824 if (exists || (isGV(gv) && GvASSUMECV(gv))) {
7825 if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7828 if (attrs) goto attrs;
7829 /* just a "sub foo;" when &foo is already defined */
7830 SAVEFREESV(PL_compcv);
7836 SvREFCNT_inc_simple_void_NN(const_sv);
7837 SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7839 assert(!CvROOT(cv) && !CvCONST(cv));
7841 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7842 CvXSUBANY(cv).any_ptr = const_sv;
7843 CvXSUB(cv) = const_sv_xsub;
7849 if (name) GvCV_set(gv, NULL);
7850 cv = newCONSTSUB_flags(
7851 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7857 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
7858 prepare_SV_for_RV((SV *)gv);
7862 SvRV_set(gv, const_sv);
7866 SvREFCNT_dec(PL_compcv);
7870 if (cv) { /* must reuse cv if autoloaded */
7871 /* transfer PL_compcv to cv */
7874 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7875 PADLIST *const temp_av = CvPADLIST(cv);
7876 CV *const temp_cv = CvOUTSIDE(cv);
7877 const cv_flags_t other_flags =
7878 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7879 OP * const cvstart = CvSTART(cv);
7883 assert(!CvCVGV_RC(cv));
7884 assert(CvGV(cv) == gv);
7889 PERL_HASH(hash, name, namlen);
7899 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
7901 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7902 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7903 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7904 CvOUTSIDE(PL_compcv) = temp_cv;
7905 CvPADLIST(PL_compcv) = temp_av;
7906 CvSTART(cv) = CvSTART(PL_compcv);
7907 CvSTART(PL_compcv) = cvstart;
7908 CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7909 CvFLAGS(PL_compcv) |= other_flags;
7911 if (CvFILE(cv) && CvDYNFILE(cv)) {
7912 Safefree(CvFILE(cv));
7914 CvFILE_set_from_cop(cv, PL_curcop);
7915 CvSTASH_set(cv, PL_curstash);
7917 /* inner references to PL_compcv must be fixed up ... */
7918 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7919 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7920 ++PL_sub_generation;
7923 /* Might have had built-in attributes applied -- propagate them. */
7924 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7926 /* ... before we throw it away */
7927 SvREFCNT_dec(PL_compcv);
7932 if (name && isGV(gv)) {
7935 if (HvENAME_HEK(GvSTASH(gv)))
7936 /* sub Foo::bar { (shift)+1 } */
7937 gv_method_changed(gv);
7941 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
7942 prepare_SV_for_RV((SV *)gv);
7946 SvRV_set(gv, (SV *)cv);
7950 if (isGV(gv)) CvGV_set(cv, gv);
7954 PERL_HASH(hash, name, namlen);
7955 CvNAME_HEK_set(cv, share_hek(name,
7961 CvFILE_set_from_cop(cv, PL_curcop);
7962 CvSTASH_set(cv, PL_curstash);
7966 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7967 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7973 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7974 the debugger could be able to set a breakpoint in, so signal to
7975 pp_entereval that it should not throw away any saved lines at scope
7978 PL_breakable_sub_gen++;
7979 /* This makes sub {}; work as expected. */
7980 if (block->op_type == OP_STUB) {
7981 OP* const newblock = newSTATEOP(0, NULL, 0);
7985 CvROOT(cv) = CvLVALUE(cv)
7986 ? newUNOP(OP_LEAVESUBLV, 0,
7987 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7988 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7989 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7990 OpREFCNT_set(CvROOT(cv), 1);
7991 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7992 itself has a refcount. */
7994 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7995 #ifdef PERL_DEBUG_READONLY_OPS
7996 slab = (OPSLAB *)CvSTART(cv);
7998 CvSTART(cv) = LINKLIST(CvROOT(cv));
7999 CvROOT(cv)->op_next = 0;
8000 CALL_PEEP(CvSTART(cv));
8001 finalize_optree(CvROOT(cv));
8002 S_prune_chain_head(&CvSTART(cv));
8004 /* now that optimizer has done its work, adjust pad values */
8006 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8009 assert(!CvCONST(cv));
8010 if (ps && !*ps && op_const_sv(block, cv))
8016 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8017 HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
8020 if (!name) SAVEFREESV(cv);
8021 apply_attrs(stash, MUTABLE_SV(cv), attrs);
8022 if (!name) SvREFCNT_inc_simple_void_NN(cv);
8025 if (block && has_name) {
8026 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8027 SV * const tmpstr = cv_name(cv,NULL);
8028 GV * const db_postponed = gv_fetchpvs("DB::postponed",
8029 GV_ADDMULTI, SVt_PVHV);
8031 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8034 (long)CopLINE(PL_curcop));
8035 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8036 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8037 hv = GvHVn(db_postponed);
8038 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8039 CV * const pcv = GvCV(db_postponed);
8045 call_sv(MUTABLE_SV(pcv), G_DISCARD);
8051 if (PL_parser && PL_parser->error_count)
8052 clear_special_blocks(name, gv, cv);
8054 #ifdef PERL_DEBUG_READONLY_OPS
8057 process_special_blocks(floor, name, gv, cv);
8063 PL_parser->copline = NOLINE;
8065 #ifdef PERL_DEBUG_READONLY_OPS
8066 /* Watch out for BEGIN blocks */
8067 if (!special) Slab_to_ro(slab);
8073 S_clear_special_blocks(pTHX_ const char *const fullname,
8074 GV *const gv, CV *const cv) {
8078 PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
8080 colon = strrchr(fullname,':');
8081 name = colon ? colon + 1 : fullname;
8083 if ((*name == 'B' && strEQ(name, "BEGIN"))
8084 || (*name == 'E' && strEQ(name, "END"))
8085 || (*name == 'U' && strEQ(name, "UNITCHECK"))
8086 || (*name == 'C' && strEQ(name, "CHECK"))
8087 || (*name == 'I' && strEQ(name, "INIT"))) {
8093 SvREFCNT_dec_NN(MUTABLE_SV(cv));
8098 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8102 const char *const colon = strrchr(fullname,':');
8103 const char *const name = colon ? colon + 1 : fullname;
8105 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8108 if (strEQ(name, "BEGIN")) {
8109 const I32 oldscope = PL_scopestack_ix;
8112 if (floor) LEAVE_SCOPE(floor);
8114 PUSHSTACKi(PERLSI_REQUIRE);
8115 SAVECOPFILE(&PL_compiling);
8116 SAVECOPLINE(&PL_compiling);
8117 SAVEVPTR(PL_curcop);
8119 DEBUG_x( dump_sub(gv) );
8120 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8121 GvCV_set(gv,0); /* cv has been hijacked */
8122 call_list(oldscope, PL_beginav);
8132 if strEQ(name, "END") {
8133 DEBUG_x( dump_sub(gv) );
8134 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8137 } else if (*name == 'U') {
8138 if (strEQ(name, "UNITCHECK")) {
8139 /* It's never too late to run a unitcheck block */
8140 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8144 } else if (*name == 'C') {
8145 if (strEQ(name, "CHECK")) {
8147 /* diag_listed_as: Too late to run %s block */
8148 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8149 "Too late to run CHECK block");
8150 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8154 } else if (*name == 'I') {
8155 if (strEQ(name, "INIT")) {
8157 /* diag_listed_as: Too late to run %s block */
8158 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8159 "Too late to run INIT block");
8160 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8166 DEBUG_x( dump_sub(gv) );
8168 GvCV_set(gv,0); /* cv has been hijacked */
8174 =for apidoc newCONSTSUB
8176 See L</newCONSTSUB_flags>.
8182 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8184 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8188 =for apidoc newCONSTSUB_flags
8190 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8191 eligible for inlining at compile-time.
8193 Currently, the only useful value for C<flags> is SVf_UTF8.
8195 The newly created subroutine takes ownership of a reference to the passed in
8198 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8199 which won't be called if used as a destructor, but will suppress the overhead
8200 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
8207 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8211 const char *const file = CopFILE(PL_curcop);
8215 if (IN_PERL_RUNTIME) {
8216 /* at runtime, it's not safe to manipulate PL_curcop: it may be
8217 * an op shared between threads. Use a non-shared COP for our
8219 SAVEVPTR(PL_curcop);
8220 SAVECOMPILEWARNINGS();
8221 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8222 PL_curcop = &PL_compiling;
8224 SAVECOPLINE(PL_curcop);
8225 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8228 PL_hints &= ~HINT_BLOCK_SCOPE;
8231 SAVEGENERICSV(PL_curstash);
8232 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8235 /* Protect sv against leakage caused by fatal warnings. */
8236 if (sv) SAVEFREESV(sv);
8238 /* file becomes the CvFILE. For an XS, it's usually static storage,
8239 and so doesn't get free()d. (It's expected to be from the C pre-
8240 processor __FILE__ directive). But we need a dynamically allocated one,
8241 and we need it to get freed. */
8242 cv = newXS_len_flags(name, len,
8243 sv && SvTYPE(sv) == SVt_PVAV
8246 file ? file : "", "",
8247 &sv, XS_DYNAMIC_FILENAME | flags);
8248 CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8257 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8258 const char *const filename, const char *const proto,
8261 PERL_ARGS_ASSERT_NEWXS_FLAGS;
8262 return newXS_len_flags(
8263 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8268 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8269 XSUBADDR_t subaddr, const char *const filename,
8270 const char *const proto, SV **const_svp,
8274 bool interleave = FALSE;
8276 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8279 GV * const gv = gv_fetchpvn(
8280 name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8281 name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8282 sizeof("__ANON__::__ANON__") - 1,
8283 GV_ADDMULTI | flags, SVt_PVCV);
8286 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8288 if ((cv = (name ? GvCV(gv) : NULL))) {
8290 /* just a cached method */
8294 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8295 /* already defined (or promised) */
8296 /* Redundant check that allows us to avoid creating an SV
8297 most of the time: */
8298 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8299 report_redefined_cv(newSVpvn_flags(
8300 name,len,(flags&SVf_UTF8)|SVs_TEMP
8311 if (cv) /* must reuse cv if autoloaded */
8314 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8318 if (HvENAME_HEK(GvSTASH(gv)))
8319 gv_method_changed(gv); /* newXS */
8325 (void)gv_fetchfile(filename);
8326 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8327 an external constant string */
8328 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8330 CvXSUB(cv) = subaddr;
8333 process_special_blocks(0, name, gv, cv);
8336 if (flags & XS_DYNAMIC_FILENAME) {
8337 CvFILE(cv) = savepv(filename);
8340 sv_setpv(MUTABLE_SV(cv), proto);
8341 if (interleave) LEAVE;
8346 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8348 CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8350 PERL_ARGS_ASSERT_NEWSTUB;
8354 if (!fake && HvENAME_HEK(GvSTASH(gv)))
8355 gv_method_changed(gv);
8357 cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8362 CvFILE_set_from_cop(cv, PL_curcop);
8363 CvSTASH_set(cv, PL_curstash);
8369 =for apidoc U||newXS
8371 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
8372 static storage, as it is used directly as CvFILE(), without a copy being made.
8378 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8380 PERL_ARGS_ASSERT_NEWXS;
8381 return newXS_len_flags(
8382 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8387 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8393 if (PL_parser && PL_parser->error_count) {
8399 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8400 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8403 if ((cv = GvFORM(gv))) {
8404 if (ckWARN(WARN_REDEFINE)) {
8405 const line_t oldline = CopLINE(PL_curcop);
8406 if (PL_parser && PL_parser->copline != NOLINE)
8407 CopLINE_set(PL_curcop, PL_parser->copline);
8409 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8410 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8412 /* diag_listed_as: Format %s redefined */
8413 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8414 "Format STDOUT redefined");
8416 CopLINE_set(PL_curcop, oldline);
8421 GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8423 CvFILE_set_from_cop(cv, PL_curcop);
8426 pad_tidy(padtidy_FORMAT);
8427 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8428 CvROOT(cv)->op_private |= OPpREFCOUNTED;
8429 OpREFCNT_set(CvROOT(cv), 1);
8430 CvSTART(cv) = LINKLIST(CvROOT(cv));
8431 CvROOT(cv)->op_next = 0;
8432 CALL_PEEP(CvSTART(cv));
8433 finalize_optree(CvROOT(cv));
8434 S_prune_chain_head(&CvSTART(cv));
8440 PL_parser->copline = NOLINE;
8445 Perl_newANONLIST(pTHX_ OP *o)
8447 return convert(OP_ANONLIST, OPf_SPECIAL, o);
8451 Perl_newANONHASH(pTHX_ OP *o)
8453 return convert(OP_ANONHASH, OPf_SPECIAL, o);
8457 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8459 return newANONATTRSUB(floor, proto, NULL, block);
8463 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8465 return newUNOP(OP_REFGEN, 0,
8466 newSVOP(OP_ANONCODE, 0,
8467 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8471 Perl_oopsAV(pTHX_ OP *o)
8475 PERL_ARGS_ASSERT_OOPSAV;
8477 switch (o->op_type) {
8480 o->op_type = OP_PADAV;
8481 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8482 return ref(o, OP_RV2AV);
8486 o->op_type = OP_RV2AV;
8487 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8492 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8499 Perl_oopsHV(pTHX_ OP *o)
8503 PERL_ARGS_ASSERT_OOPSHV;
8505 switch (o->op_type) {
8508 o->op_type = OP_PADHV;
8509 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8510 return ref(o, OP_RV2HV);
8514 o->op_type = OP_RV2HV;
8515 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8520 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8527 Perl_newAVREF(pTHX_ OP *o)
8531 PERL_ARGS_ASSERT_NEWAVREF;
8533 if (o->op_type == OP_PADANY) {
8534 o->op_type = OP_PADAV;
8535 o->op_ppaddr = PL_ppaddr[OP_PADAV];
8538 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8539 Perl_croak(aTHX_ "Can't use an array as a reference");
8541 return newUNOP(OP_RV2AV, 0, scalar(o));
8545 Perl_newGVREF(pTHX_ I32 type, OP *o)
8547 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8548 return newUNOP(OP_NULL, 0, o);
8549 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8553 Perl_newHVREF(pTHX_ OP *o)
8557 PERL_ARGS_ASSERT_NEWHVREF;
8559 if (o->op_type == OP_PADANY) {
8560 o->op_type = OP_PADHV;
8561 o->op_ppaddr = PL_ppaddr[OP_PADHV];
8564 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8565 Perl_croak(aTHX_ "Can't use a hash as a reference");
8567 return newUNOP(OP_RV2HV, 0, scalar(o));
8571 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8573 if (o->op_type == OP_PADANY) {
8575 o->op_type = OP_PADCV;
8576 o->op_ppaddr = PL_ppaddr[OP_PADCV];
8578 return newUNOP(OP_RV2CV, flags, scalar(o));
8582 Perl_newSVREF(pTHX_ OP *o)
8586 PERL_ARGS_ASSERT_NEWSVREF;
8588 if (o->op_type == OP_PADANY) {
8589 o->op_type = OP_PADSV;
8590 o->op_ppaddr = PL_ppaddr[OP_PADSV];
8593 return newUNOP(OP_RV2SV, 0, scalar(o));
8596 /* Check routines. See the comments at the top of this file for details
8597 * on when these are called */
8600 Perl_ck_anoncode(pTHX_ OP *o)
8602 PERL_ARGS_ASSERT_CK_ANONCODE;
8604 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8605 cSVOPo->op_sv = NULL;
8610 S_io_hints(pTHX_ OP *o)
8612 #if O_BINARY != 0 || O_TEXT != 0
8614 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8616 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8619 const char *d = SvPV_const(*svp, len);
8620 const I32 mode = mode_from_discipline(d, len);
8621 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8623 if (mode & O_BINARY)
8624 o->op_private |= OPpOPEN_IN_RAW;
8628 o->op_private |= OPpOPEN_IN_CRLF;
8632 svp = hv_fetchs(table, "open_OUT", FALSE);
8635 const char *d = SvPV_const(*svp, len);
8636 const I32 mode = mode_from_discipline(d, len);
8637 /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
8639 if (mode & O_BINARY)
8640 o->op_private |= OPpOPEN_OUT_RAW;
8644 o->op_private |= OPpOPEN_OUT_CRLF;
8649 PERL_UNUSED_CONTEXT;
8655 Perl_ck_backtick(pTHX_ OP *o)
8660 PERL_ARGS_ASSERT_CK_BACKTICK;
8661 /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8662 if (o->op_flags & OPf_KIDS && (sibl = OP_SIBLING(cUNOPo->op_first))
8663 && (gv = gv_override("readpipe",8)))
8665 /* detach rest of siblings from o and its first child */
8666 op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
8667 newop = S_new_entersubop(aTHX_ gv, sibl);
8669 else if (!(o->op_flags & OPf_KIDS))
8670 newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8675 S_io_hints(aTHX_ o);
8680 Perl_ck_bitop(pTHX_ OP *o)
8682 PERL_ARGS_ASSERT_CK_BITOP;
8684 o->op_private = (U8)(PL_hints & HINT_INTEGER);
8685 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8686 && (o->op_type == OP_BIT_OR
8687 || o->op_type == OP_BIT_AND
8688 || o->op_type == OP_BIT_XOR))
8690 const OP * const left = cBINOPo->op_first;
8691 const OP * const right = OP_SIBLING(left);
8692 if ((OP_IS_NUMCOMPARE(left->op_type) &&
8693 (left->op_flags & OPf_PARENS) == 0) ||
8694 (OP_IS_NUMCOMPARE(right->op_type) &&
8695 (right->op_flags & OPf_PARENS) == 0))
8696 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8697 "Possible precedence problem on bitwise %c operator",
8698 o->op_type == OP_BIT_OR ? '|'
8699 : o->op_type == OP_BIT_AND ? '&' : '^'
8705 PERL_STATIC_INLINE bool
8706 is_dollar_bracket(pTHX_ const OP * const o)
8709 PERL_UNUSED_CONTEXT;
8710 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8711 && (kid = cUNOPx(o)->op_first)
8712 && kid->op_type == OP_GV
8713 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8717 Perl_ck_cmp(pTHX_ OP *o)
8719 PERL_ARGS_ASSERT_CK_CMP;
8720 if (ckWARN(WARN_SYNTAX)) {
8721 const OP *kid = cUNOPo->op_first;
8724 ( is_dollar_bracket(aTHX_ kid)
8725 && OP_SIBLING(kid) && OP_SIBLING(kid)->op_type == OP_CONST
8727 || ( kid->op_type == OP_CONST
8728 && (kid = OP_SIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
8732 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8733 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
8739 Perl_ck_concat(pTHX_ OP *o)
8741 const OP * const kid = cUNOPo->op_first;
8743 PERL_ARGS_ASSERT_CK_CONCAT;
8744 PERL_UNUSED_CONTEXT;
8746 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8747 !(kUNOP->op_first->op_flags & OPf_MOD))
8748 o->op_flags |= OPf_STACKED;
8753 Perl_ck_spair(pTHX_ OP *o)
8757 PERL_ARGS_ASSERT_CK_SPAIR;
8759 if (o->op_flags & OPf_KIDS) {
8763 const OPCODE type = o->op_type;
8764 o = modkids(ck_fun(o), type);
8765 kid = cUNOPo->op_first;
8766 kidkid = kUNOP->op_first;
8767 newop = OP_SIBLING(kidkid);
8769 const OPCODE type = newop->op_type;
8770 if (OP_HAS_SIBLING(newop) || !(PL_opargs[type] & OA_RETSCALAR) ||
8771 type == OP_PADAV || type == OP_PADHV ||
8772 type == OP_RV2AV || type == OP_RV2HV)
8775 /* excise first sibling */
8776 op_sibling_splice(kid, NULL, 1, NULL);
8779 /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8780 * and OP_CHOMP into OP_SCHOMP */
8781 o->op_ppaddr = PL_ppaddr[++o->op_type];
8786 Perl_ck_delete(pTHX_ OP *o)
8788 PERL_ARGS_ASSERT_CK_DELETE;
8792 if (o->op_flags & OPf_KIDS) {
8793 OP * const kid = cUNOPo->op_first;
8794 switch (kid->op_type) {
8796 o->op_flags |= OPf_SPECIAL;
8799 o->op_private |= OPpSLICE;
8802 o->op_flags |= OPf_SPECIAL;
8807 Perl_croak(aTHX_ "delete argument is index/value array slice,"
8808 " use array slice");
8810 Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8813 Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8814 "element or slice");
8816 if (kid->op_private & OPpLVAL_INTRO)
8817 o->op_private |= OPpLVAL_INTRO;
8824 Perl_ck_eof(pTHX_ OP *o)
8826 PERL_ARGS_ASSERT_CK_EOF;
8828 if (o->op_flags & OPf_KIDS) {
8830 if (cLISTOPo->op_first->op_type == OP_STUB) {
8832 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8837 kid = cLISTOPo->op_first;
8838 if (kid->op_type == OP_RV2GV)
8839 kid->op_private |= OPpALLOW_FAKE;
8845 Perl_ck_eval(pTHX_ OP *o)
8849 PERL_ARGS_ASSERT_CK_EVAL;
8851 PL_hints |= HINT_BLOCK_SCOPE;
8852 if (o->op_flags & OPf_KIDS) {
8853 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8856 if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
8859 /* cut whole sibling chain free from o */
8860 op_sibling_splice(o, NULL, -1, NULL);
8863 enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
8864 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8866 /* establish postfix order */
8867 enter->op_next = (OP*)enter;
8869 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8870 o->op_type = OP_LEAVETRY;
8871 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8872 enter->op_other = o;
8881 const U8 priv = o->op_private;
8883 /* the newUNOP will recursively call ck_eval(), which will handle
8884 * all the stuff at the end of this function, like adding
8887 return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8889 o->op_targ = (PADOFFSET)PL_hints;
8890 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8891 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8892 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8893 /* Store a copy of %^H that pp_entereval can pick up. */
8894 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8895 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8896 /* append hhop to only child */
8897 op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
8899 o->op_private |= OPpEVAL_HAS_HH;
8901 if (!(o->op_private & OPpEVAL_BYTES)
8902 && FEATURE_UNIEVAL_IS_ENABLED)
8903 o->op_private |= OPpEVAL_UNICODE;
8908 Perl_ck_exec(pTHX_ OP *o)
8910 PERL_ARGS_ASSERT_CK_EXEC;
8912 if (o->op_flags & OPf_STACKED) {
8915 kid = OP_SIBLING(cUNOPo->op_first);
8916 if (kid->op_type == OP_RV2GV)
8925 Perl_ck_exists(pTHX_ OP *o)
8927 PERL_ARGS_ASSERT_CK_EXISTS;
8930 if (o->op_flags & OPf_KIDS) {
8931 OP * const kid = cUNOPo->op_first;
8932 if (kid->op_type == OP_ENTERSUB) {
8933 (void) ref(kid, o->op_type);
8934 if (kid->op_type != OP_RV2CV
8935 && !(PL_parser && PL_parser->error_count))
8937 "exists argument is not a subroutine name");
8938 o->op_private |= OPpEXISTS_SUB;
8940 else if (kid->op_type == OP_AELEM)
8941 o->op_flags |= OPf_SPECIAL;
8942 else if (kid->op_type != OP_HELEM)
8943 Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8944 "element or a subroutine");
8951 Perl_ck_rvconst(pTHX_ OP *o)
8954 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8956 PERL_ARGS_ASSERT_CK_RVCONST;
8958 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8960 if (kid->op_type == OP_CONST) {
8963 SV * const kidsv = kid->op_sv;
8965 /* Is it a constant from cv_const_sv()? */
8966 if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
8969 if (SvTYPE(kidsv) == SVt_PVAV) return o;
8970 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8971 const char *badthing;
8972 switch (o->op_type) {
8974 badthing = "a SCALAR";
8977 badthing = "an ARRAY";
8980 badthing = "a HASH";
8988 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8989 SVfARG(kidsv), badthing);
8992 * This is a little tricky. We only want to add the symbol if we
8993 * didn't add it in the lexer. Otherwise we get duplicate strict
8994 * warnings. But if we didn't add it in the lexer, we must at
8995 * least pretend like we wanted to add it even if it existed before,
8996 * or we get possible typo warnings. OPpCONST_ENTERED says
8997 * whether the lexer already added THIS instance of this symbol.
8999 iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
9000 gv = gv_fetchsv(kidsv,
9001 o->op_type == OP_RV2CV
9002 && o->op_private & OPpMAY_RETURN_CONSTANT
9004 : iscv | !(kid->op_private & OPpCONST_ENTERED),
9007 : o->op_type == OP_RV2SV
9009 : o->op_type == OP_RV2AV
9011 : o->op_type == OP_RV2HV
9018 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
9019 && SvTYPE(SvRV(gv)) != SVt_PVCV)
9020 gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
9022 kid->op_type = OP_GV;
9023 SvREFCNT_dec(kid->op_sv);
9025 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9026 assert (sizeof(PADOP) <= sizeof(SVOP));
9027 kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
9028 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9029 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9031 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9033 kid->op_private = 0;
9034 kid->op_ppaddr = PL_ppaddr[OP_GV];
9035 /* FAKE globs in the symbol table cause weird bugs (#77810) */
9043 Perl_ck_ftst(pTHX_ OP *o)
9046 const I32 type = o->op_type;
9048 PERL_ARGS_ASSERT_CK_FTST;
9050 if (o->op_flags & OPf_REF) {
9053 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9054 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9055 const OPCODE kidtype = kid->op_type;
9057 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9058 && !kid->op_folded) {
9059 OP * const newop = newGVOP(type, OPf_REF,
9060 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9064 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9065 o->op_private |= OPpFT_ACCESS;
9066 if (PL_check[kidtype] == Perl_ck_ftst
9067 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9068 o->op_private |= OPpFT_STACKED;
9069 kid->op_private |= OPpFT_STACKING;
9070 if (kidtype == OP_FTTTY && (
9071 !(kid->op_private & OPpFT_STACKED)
9072 || kid->op_private & OPpFT_AFTER_t
9074 o->op_private |= OPpFT_AFTER_t;
9079 if (type == OP_FTTTY)
9080 o = newGVOP(type, OPf_REF, PL_stdingv);
9082 o = newUNOP(type, 0, newDEFSVOP());
9088 Perl_ck_fun(pTHX_ OP *o)
9090 const int type = o->op_type;
9091 I32 oa = PL_opargs[type] >> OASHIFT;
9093 PERL_ARGS_ASSERT_CK_FUN;
9095 if (o->op_flags & OPf_STACKED) {
9096 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9099 return no_fh_allowed(o);
9102 if (o->op_flags & OPf_KIDS) {
9103 OP *prev_kid = NULL;
9104 OP *kid = cLISTOPo->op_first;
9106 bool seen_optional = FALSE;
9108 if (kid->op_type == OP_PUSHMARK ||
9109 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9112 kid = OP_SIBLING(kid);
9114 if (kid && kid->op_type == OP_COREARGS) {
9115 bool optional = FALSE;
9118 if (oa & OA_OPTIONAL) optional = TRUE;
9121 if (optional) o->op_private |= numargs;
9126 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9127 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
9129 /* append kid to chain */
9130 op_sibling_splice(o, prev_kid, 0, kid);
9132 seen_optional = TRUE;
9139 /* list seen where single (scalar) arg expected? */
9140 if (numargs == 1 && !(oa >> 4)
9141 && kid->op_type == OP_LIST && type != OP_SCALAR)
9143 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9145 if (type != OP_DELETE) scalar(kid);
9156 if ((type == OP_PUSH || type == OP_UNSHIFT)
9157 && !OP_HAS_SIBLING(kid))
9158 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9159 "Useless use of %s with no values",
9162 if (kid->op_type == OP_CONST
9163 && ( !SvROK(cSVOPx_sv(kid))
9164 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
9166 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9167 /* Defer checks to run-time if we have a scalar arg */
9168 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9169 op_lvalue(kid, type);
9172 /* diag_listed_as: push on reference is experimental */
9173 Perl_ck_warner_d(aTHX_
9174 packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9175 "%s on reference is experimental",
9180 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9181 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9182 op_lvalue(kid, type);
9186 /* replace kid with newop in chain */
9188 S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
9189 newop->op_next = newop;
9194 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9195 if (kid->op_type == OP_CONST &&
9196 (kid->op_private & OPpCONST_BARE))
9198 OP * const newop = newGVOP(OP_GV, 0,
9199 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9200 /* replace kid with newop in chain */
9201 op_sibling_splice(o, prev_kid, 1, newop);
9205 else if (kid->op_type == OP_READLINE) {
9206 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
9207 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9210 I32 flags = OPf_SPECIAL;
9214 /* is this op a FH constructor? */
9215 if (is_handle_constructor(o,numargs)) {
9216 const char *name = NULL;
9219 bool want_dollar = TRUE;
9222 /* Set a flag to tell rv2gv to vivify
9223 * need to "prove" flag does not mean something
9224 * else already - NI-S 1999/05/07
9227 if (kid->op_type == OP_PADSV) {
9229 = PAD_COMPNAME_SV(kid->op_targ);
9230 name = SvPV_const(namesv, len);
9231 name_utf8 = SvUTF8(namesv);
9233 else if (kid->op_type == OP_RV2SV
9234 && kUNOP->op_first->op_type == OP_GV)
9236 GV * const gv = cGVOPx_gv(kUNOP->op_first);
9238 len = GvNAMELEN(gv);
9239 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9241 else if (kid->op_type == OP_AELEM
9242 || kid->op_type == OP_HELEM)
9245 OP *op = ((BINOP*)kid)->op_first;
9249 const char * const a =
9250 kid->op_type == OP_AELEM ?
9252 if (((op->op_type == OP_RV2AV) ||
9253 (op->op_type == OP_RV2HV)) &&
9254 (firstop = ((UNOP*)op)->op_first) &&
9255 (firstop->op_type == OP_GV)) {
9256 /* packagevar $a[] or $h{} */
9257 GV * const gv = cGVOPx_gv(firstop);
9265 else if (op->op_type == OP_PADAV
9266 || op->op_type == OP_PADHV) {
9267 /* lexicalvar $a[] or $h{} */
9268 const char * const padname =
9269 PAD_COMPNAME_PV(op->op_targ);
9278 name = SvPV_const(tmpstr, len);
9279 name_utf8 = SvUTF8(tmpstr);
9284 name = "__ANONIO__";
9286 want_dollar = FALSE;
9288 op_lvalue(kid, type);
9292 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9293 namesv = PAD_SVl(targ);
9294 if (want_dollar && *name != '$')
9295 sv_setpvs(namesv, "$");
9297 sv_setpvs(namesv, "");
9298 sv_catpvn(namesv, name, len);
9299 if ( name_utf8 ) SvUTF8_on(namesv);
9303 kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
9305 kid->op_targ = targ;
9306 kid->op_private |= priv;
9312 if ((type == OP_UNDEF || type == OP_POS)
9313 && numargs == 1 && !(oa >> 4)
9314 && kid->op_type == OP_LIST)
9315 return too_many_arguments_pv(o,PL_op_desc[type], 0);
9316 op_lvalue(scalar(kid), type);
9321 kid = OP_SIBLING(kid);
9323 /* FIXME - should the numargs or-ing move after the too many
9324 * arguments check? */
9325 o->op_private |= numargs;
9327 return too_many_arguments_pv(o,OP_DESC(o), 0);
9330 else if (PL_opargs[type] & OA_DEFGV) {
9331 /* Ordering of these two is important to keep f_map.t passing. */
9333 return newUNOP(type, 0, newDEFSVOP());
9337 while (oa & OA_OPTIONAL)
9339 if (oa && oa != OA_LIST)
9340 return too_few_arguments_pv(o,OP_DESC(o), 0);
9346 Perl_ck_glob(pTHX_ OP *o)
9350 PERL_ARGS_ASSERT_CK_GLOB;
9353 if ((o->op_flags & OPf_KIDS) && !OP_HAS_SIBLING(cLISTOPo->op_first))
9354 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9356 if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9360 * \ null - const(wildcard)
9365 * \ mark - glob - rv2cv
9366 * | \ gv(CORE::GLOBAL::glob)
9368 * \ null - const(wildcard)
9370 o->op_flags |= OPf_SPECIAL;
9371 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9372 o = S_new_entersubop(aTHX_ gv, o);
9373 o = newUNOP(OP_NULL, 0, o);
9374 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9377 else o->op_flags &= ~OPf_SPECIAL;
9378 #if !defined(PERL_EXTERNAL_GLOB)
9381 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9382 newSVpvs("File::Glob"), NULL, NULL, NULL);
9385 #endif /* !PERL_EXTERNAL_GLOB */
9386 gv = (GV *)newSV(0);
9387 gv_init(gv, 0, "", 0, 0);
9389 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9390 SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9396 Perl_ck_grep(pTHX_ OP *o)
9401 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9404 PERL_ARGS_ASSERT_CK_GREP;
9406 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9407 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9409 if (o->op_flags & OPf_STACKED) {
9410 kid = cUNOPx(OP_SIBLING(cLISTOPo->op_first))->op_first;
9411 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9412 return no_fh_allowed(o);
9413 o->op_flags &= ~OPf_STACKED;
9415 kid = OP_SIBLING(cLISTOPo->op_first);
9416 if (type == OP_MAPWHILE)
9421 if (PL_parser && PL_parser->error_count)
9423 kid = OP_SIBLING(cLISTOPo->op_first);
9424 if (kid->op_type != OP_NULL)
9425 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9426 kid = kUNOP->op_first;
9428 gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
9429 gwop->op_ppaddr = PL_ppaddr[type];
9430 kid->op_next = (OP*)gwop;
9431 offset = pad_findmy_pvs("$_", 0);
9432 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9433 o->op_private = gwop->op_private = 0;
9434 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9437 o->op_private = gwop->op_private = OPpGREP_LEX;
9438 gwop->op_targ = o->op_targ = offset;
9441 kid = OP_SIBLING(cLISTOPo->op_first);
9442 for (kid = OP_SIBLING(kid); kid; kid = OP_SIBLING(kid))
9443 op_lvalue(kid, OP_GREPSTART);
9449 Perl_ck_index(pTHX_ OP *o)
9451 PERL_ARGS_ASSERT_CK_INDEX;
9453 if (o->op_flags & OPf_KIDS) {
9454 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9456 kid = OP_SIBLING(kid); /* get past "big" */
9457 if (kid && kid->op_type == OP_CONST) {
9458 const bool save_taint = TAINT_get;
9459 SV *sv = kSVOP->op_sv;
9460 if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9462 sv_copypv(sv, kSVOP->op_sv);
9463 SvREFCNT_dec_NN(kSVOP->op_sv);
9466 if (SvOK(sv)) fbm_compile(sv, 0);
9467 TAINT_set(save_taint);
9468 #ifdef NO_TAINT_SUPPORT
9469 PERL_UNUSED_VAR(save_taint);
9477 Perl_ck_lfun(pTHX_ OP *o)
9479 const OPCODE type = o->op_type;
9481 PERL_ARGS_ASSERT_CK_LFUN;
9483 return modkids(ck_fun(o), type);
9487 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
9489 PERL_ARGS_ASSERT_CK_DEFINED;
9491 if ((o->op_flags & OPf_KIDS)) {
9492 switch (cUNOPo->op_first->op_type) {
9495 Perl_croak(aTHX_ "Can't use 'defined(@array)'"
9496 " (Maybe you should just omit the defined()?)");
9500 Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
9501 " (Maybe you should just omit the defined()?)");
9512 Perl_ck_readline(pTHX_ OP *o)
9514 PERL_ARGS_ASSERT_CK_READLINE;
9516 if (o->op_flags & OPf_KIDS) {
9517 OP *kid = cLISTOPo->op_first;
9518 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9522 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9530 Perl_ck_rfun(pTHX_ OP *o)
9532 const OPCODE type = o->op_type;
9534 PERL_ARGS_ASSERT_CK_RFUN;
9536 return refkids(ck_fun(o), type);
9540 Perl_ck_listiob(pTHX_ OP *o)
9544 PERL_ARGS_ASSERT_CK_LISTIOB;
9546 kid = cLISTOPo->op_first;
9548 o = force_list(o, 1);
9549 kid = cLISTOPo->op_first;
9551 if (kid->op_type == OP_PUSHMARK)
9552 kid = OP_SIBLING(kid);
9553 if (kid && o->op_flags & OPf_STACKED)
9554 kid = OP_SIBLING(kid);
9555 else if (kid && !OP_HAS_SIBLING(kid)) { /* print HANDLE; */
9556 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9557 && !kid->op_folded) {
9558 o->op_flags |= OPf_STACKED; /* make it a filehandle */
9560 /* replace old const op with new OP_RV2GV parent */
9561 kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
9563 kid = OP_SIBLING(kid);
9568 op_append_elem(o->op_type, o, newDEFSVOP());
9570 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9575 Perl_ck_smartmatch(pTHX_ OP *o)
9578 PERL_ARGS_ASSERT_CK_SMARTMATCH;
9579 if (0 == (o->op_flags & OPf_SPECIAL)) {
9580 OP *first = cBINOPo->op_first;
9581 OP *second = OP_SIBLING(first);
9583 /* Implicitly take a reference to an array or hash */
9585 /* remove the original two siblings, then add back the
9586 * (possibly different) first and second sibs.
9588 op_sibling_splice(o, NULL, 1, NULL);
9589 op_sibling_splice(o, NULL, 1, NULL);
9590 first = ref_array_or_hash(first);
9591 second = ref_array_or_hash(second);
9592 op_sibling_splice(o, NULL, 0, second);
9593 op_sibling_splice(o, NULL, 0, first);
9595 /* Implicitly take a reference to a regular expression */
9596 if (first->op_type == OP_MATCH) {
9597 first->op_type = OP_QR;
9598 first->op_ppaddr = PL_ppaddr[OP_QR];
9600 if (second->op_type == OP_MATCH) {
9601 second->op_type = OP_QR;
9602 second->op_ppaddr = PL_ppaddr[OP_QR];
9611 Perl_ck_sassign(pTHX_ OP *o)
9614 OP * const kid = cLISTOPo->op_first;
9616 PERL_ARGS_ASSERT_CK_SASSIGN;
9618 /* has a disposable target? */
9619 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9620 && !(kid->op_flags & OPf_STACKED)
9621 /* Cannot steal the second time! */
9622 && !(kid->op_private & OPpTARGET_MY)
9625 OP * const kkid = OP_SIBLING(kid);
9627 /* Can just relocate the target. */
9628 if (kkid && kkid->op_type == OP_PADSV
9629 && !(kkid->op_private & OPpLVAL_INTRO))
9631 kid->op_targ = kkid->op_targ;
9633 /* Now we do not need PADSV and SASSIGN.
9634 * first replace the PADSV with OP_SIBLING(o), then
9635 * detach kid and OP_SIBLING(o) from o */
9636 op_sibling_splice(o, kid, 1, OP_SIBLING(o));
9637 op_sibling_splice(o, NULL, -1, NULL);
9640 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
9644 if (OP_HAS_SIBLING(kid)) {
9645 OP *kkid = OP_SIBLING(kid);
9646 /* For state variable assignment, kkid is a list op whose op_last
9648 if ((kkid->op_type == OP_PADSV ||
9649 (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
9650 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9653 && (kkid->op_private & OPpLVAL_INTRO)
9654 && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
9655 const PADOFFSET target = kkid->op_targ;
9656 OP *const other = newOP(OP_PADSV,
9658 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9659 OP *const first = newOP(OP_NULL, 0);
9660 OP *const nullop = newCONDOP(0, first, o, other);
9661 OP *const condop = first->op_next;
9662 /* hijacking PADSTALE for uninitialized state variables */
9663 SvPADSTALE_on(PAD_SVl(target));
9665 condop->op_type = OP_ONCE;
9666 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9667 condop->op_targ = target;
9668 other->op_targ = target;
9670 /* Because we change the type of the op here, we will skip the
9671 assignment binop->op_last = OP_SIBLING(binop->op_first); at the
9672 end of Perl_newBINOP(). So need to do it here. */
9673 cBINOPo->op_last = OP_SIBLING(cBINOPo->op_first);
9674 cBINOPo->op_first->op_lastsib = 0;
9675 cBINOPo->op_last ->op_lastsib = 1;
9676 #ifdef PERL_OP_PARENT
9677 cBINOPo->op_last->op_sibling = o;
9686 Perl_ck_match(pTHX_ OP *o)
9688 PERL_ARGS_ASSERT_CK_MATCH;
9690 if (o->op_type != OP_QR && PL_compcv) {
9691 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9692 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9693 o->op_targ = offset;
9694 o->op_private |= OPpTARGET_MY;
9697 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9698 o->op_private |= OPpRUNTIME;
9703 Perl_ck_method(pTHX_ OP *o)
9705 OP * const kid = cUNOPo->op_first;
9707 PERL_ARGS_ASSERT_CK_METHOD;
9709 if (kid->op_type == OP_CONST) {
9710 SV* sv = kSVOP->op_sv;
9711 const char * const method = SvPVX_const(sv);
9712 if (!(strchr(method, ':') || strchr(method, '\''))) {
9714 if (!SvIsCOW_shared_hash(sv)) {
9715 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9718 kSVOP->op_sv = NULL;
9720 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9729 Perl_ck_null(pTHX_ OP *o)
9731 PERL_ARGS_ASSERT_CK_NULL;
9732 PERL_UNUSED_CONTEXT;
9737 Perl_ck_open(pTHX_ OP *o)
9739 PERL_ARGS_ASSERT_CK_OPEN;
9741 S_io_hints(aTHX_ o);
9743 /* In case of three-arg dup open remove strictness
9744 * from the last arg if it is a bareword. */
9745 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9746 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
9750 if ((last->op_type == OP_CONST) && /* The bareword. */
9751 (last->op_private & OPpCONST_BARE) &&
9752 (last->op_private & OPpCONST_STRICT) &&
9753 (oa = OP_SIBLING(first)) && /* The fh. */
9754 (oa = OP_SIBLING(oa)) && /* The mode. */
9755 (oa->op_type == OP_CONST) &&
9756 SvPOK(((SVOP*)oa)->op_sv) &&
9757 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9758 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9759 (last == OP_SIBLING(oa))) /* The bareword. */
9760 last->op_private &= ~OPpCONST_STRICT;
9766 Perl_ck_repeat(pTHX_ OP *o)
9768 PERL_ARGS_ASSERT_CK_REPEAT;
9770 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9772 o->op_private |= OPpREPEAT_DOLIST;
9773 kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
9774 kids = force_list(kids, 1); /* promote them to a list */
9775 op_sibling_splice(o, NULL, 0, kids); /* and add back */
9783 Perl_ck_require(pTHX_ OP *o)
9787 PERL_ARGS_ASSERT_CK_REQUIRE;
9789 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9790 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9795 if (kid->op_type == OP_CONST) {
9796 SV * const sv = kid->op_sv;
9797 U32 const was_readonly = SvREADONLY(sv);
9798 if (kid->op_private & OPpCONST_BARE) {
9805 if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9810 for (; s < end; s++) {
9811 if (*s == ':' && s[1] == ':') {
9813 Move(s+2, s+1, end - s - 1, char);
9818 sv_catpvs(sv, ".pm");
9819 PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
9820 hek = share_hek(SvPVX(sv),
9821 (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
9825 SvFLAGS(sv) |= was_readonly;
9827 else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
9829 if (SvREFCNT(sv) > 1) {
9830 kid->op_sv = newSVpvn_share(
9831 s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
9832 SvREFCNT_dec_NN(sv);
9836 if (was_readonly) SvREADONLY_off(sv);
9837 PERL_HASH(hash, s, len);
9839 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
9843 SvFLAGS(sv) |= was_readonly;
9849 if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9850 /* handle override, if any */
9851 && (gv = gv_override("require", 7))) {
9853 if (o->op_flags & OPf_KIDS) {
9854 kid = cUNOPo->op_first;
9855 op_sibling_splice(o, NULL, -1, NULL);
9861 newop = S_new_entersubop(aTHX_ gv, kid);
9865 return scalar(ck_fun(o));
9869 Perl_ck_return(pTHX_ OP *o)
9873 PERL_ARGS_ASSERT_CK_RETURN;
9875 kid = OP_SIBLING(cLISTOPo->op_first);
9876 if (CvLVALUE(PL_compcv)) {
9877 for (; kid; kid = OP_SIBLING(kid))
9878 op_lvalue(kid, OP_LEAVESUBLV);
9885 Perl_ck_select(pTHX_ OP *o)
9890 PERL_ARGS_ASSERT_CK_SELECT;
9892 if (o->op_flags & OPf_KIDS) {
9893 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9894 if (kid && OP_HAS_SIBLING(kid)) {
9895 o->op_type = OP_SSELECT;
9896 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9898 return fold_constants(op_integerize(op_std_init(o)));
9902 kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9903 if (kid && kid->op_type == OP_RV2GV)
9904 kid->op_private &= ~HINT_STRICT_REFS;
9909 Perl_ck_shift(pTHX_ OP *o)
9911 const I32 type = o->op_type;
9913 PERL_ARGS_ASSERT_CK_SHIFT;
9915 if (!(o->op_flags & OPf_KIDS)) {
9918 if (!CvUNIQUE(PL_compcv)) {
9919 o->op_flags |= OPf_SPECIAL;
9923 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9925 return newUNOP(type, 0, scalar(argop));
9927 return scalar(ck_fun(o));
9931 Perl_ck_sort(pTHX_ OP *o)
9936 PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
9939 PERL_ARGS_ASSERT_CK_SORT;
9942 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9944 const I32 sorthints = (I32)SvIV(*svp);
9945 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9946 o->op_private |= OPpSORT_QSORT;
9947 if ((sorthints & HINT_SORT_STABLE) != 0)
9948 o->op_private |= OPpSORT_STABLE;
9952 if (o->op_flags & OPf_STACKED)
9954 firstkid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
9956 if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
9957 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9959 /* if the first arg is a code block, process it and mark sort as
9961 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9963 if (kid->op_type == OP_LEAVE)
9964 op_null(kid); /* wipe out leave */
9965 /* Prevent execution from escaping out of the sort block. */
9968 /* provide scalar context for comparison function/block */
9969 kid = scalar(firstkid);
9971 o->op_flags |= OPf_SPECIAL;
9973 else if (kid->op_type == OP_CONST
9974 && kid->op_private & OPpCONST_BARE) {
9978 const char * const name = SvPV(kSVOP_sv, len);
9981 Copy(name, tmpbuf+1, len, char);
9982 off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
9983 if (off != NOT_IN_PAD) {
9984 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
9986 newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
9987 sv_catpvs(fq, "::");
9988 sv_catsv(fq, kSVOP_sv);
9989 SvREFCNT_dec_NN(kSVOP_sv);
9993 OP * const padop = newOP(OP_PADCV, 0);
9994 padop->op_targ = off;
9995 cUNOPx(firstkid)->op_first = padop;
10001 firstkid = OP_SIBLING(firstkid);
10004 for (kid = firstkid; kid; kid = OP_SIBLING(kid)) {
10005 /* provide list context for arguments */
10008 op_lvalue(kid, OP_GREPSTART);
10014 /* for sort { X } ..., where X is one of
10015 * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10016 * elide the second child of the sort (the one containing X),
10017 * and set these flags as appropriate
10021 * Also, check and warn on lexical $a, $b.
10025 S_simplify_sort(pTHX_ OP *o)
10027 OP *kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
10031 const char *gvname;
10034 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10036 kid = kUNOP->op_first; /* get past null */
10037 if (!(have_scopeop = kid->op_type == OP_SCOPE)
10038 && kid->op_type != OP_LEAVE)
10040 kid = kLISTOP->op_last; /* get past scope */
10041 switch(kid->op_type) {
10045 if (!have_scopeop) goto padkids;
10050 k = kid; /* remember this node*/
10051 if (kBINOP->op_first->op_type != OP_RV2SV
10052 || kBINOP->op_last ->op_type != OP_RV2SV)
10055 Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10056 then used in a comparison. This catches most, but not
10057 all cases. For instance, it catches
10058 sort { my($a); $a <=> $b }
10060 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10061 (although why you'd do that is anyone's guess).
10065 if (!ckWARN(WARN_SYNTAX)) return;
10066 kid = kBINOP->op_first;
10068 if (kid->op_type == OP_PADSV) {
10069 SV * const name = PAD_COMPNAME_SV(kid->op_targ);
10070 if (SvCUR(name) == 2 && *SvPVX(name) == '$'
10071 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
10072 /* diag_listed_as: "my %s" used in sort comparison */
10073 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10074 "\"%s %s\" used in sort comparison",
10075 SvPAD_STATE(name) ? "state" : "my",
10078 } while ((kid = OP_SIBLING(kid)));
10081 kid = kBINOP->op_first; /* get past cmp */
10082 if (kUNOP->op_first->op_type != OP_GV)
10084 kid = kUNOP->op_first; /* get past rv2sv */
10086 if (GvSTASH(gv) != PL_curstash)
10088 gvname = GvNAME(gv);
10089 if (*gvname == 'a' && gvname[1] == '\0')
10091 else if (*gvname == 'b' && gvname[1] == '\0')
10096 kid = k; /* back to cmp */
10097 /* already checked above that it is rv2sv */
10098 kid = kBINOP->op_last; /* down to 2nd arg */
10099 if (kUNOP->op_first->op_type != OP_GV)
10101 kid = kUNOP->op_first; /* get past rv2sv */
10103 if (GvSTASH(gv) != PL_curstash)
10105 gvname = GvNAME(gv);
10107 ? !(*gvname == 'a' && gvname[1] == '\0')
10108 : !(*gvname == 'b' && gvname[1] == '\0'))
10110 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10112 o->op_private |= OPpSORT_DESCEND;
10113 if (k->op_type == OP_NCMP)
10114 o->op_private |= OPpSORT_NUMERIC;
10115 if (k->op_type == OP_I_NCMP)
10116 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10117 kid = OP_SIBLING(cLISTOPo->op_first);
10118 /* cut out and delete old block (second sibling) */
10119 op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
10124 Perl_ck_split(pTHX_ OP *o)
10129 PERL_ARGS_ASSERT_CK_SPLIT;
10131 if (o->op_flags & OPf_STACKED)
10132 return no_fh_allowed(o);
10134 kid = cLISTOPo->op_first;
10135 if (kid->op_type != OP_NULL)
10136 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10137 /* delete leading NULL node, then add a CONST if no other nodes */
10138 op_sibling_splice(o, NULL, 1,
10139 OP_HAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
10141 kid = cLISTOPo->op_first;
10143 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10144 /* remove kid, and replace with new optree */
10145 op_sibling_splice(o, NULL, 1, NULL);
10146 /* OPf_SPECIAL is used to trigger split " " behavior */
10147 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
10148 op_sibling_splice(o, NULL, 0, kid);
10151 kid->op_type = OP_PUSHRE;
10152 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
10154 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10155 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10156 "Use of /g modifier is meaningless in split");
10159 if (!OP_HAS_SIBLING(kid))
10160 op_append_elem(OP_SPLIT, o, newDEFSVOP());
10162 kid = OP_SIBLING(kid);
10166 if (!OP_HAS_SIBLING(kid))
10168 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10169 o->op_private |= OPpSPLIT_IMPLIM;
10171 assert(OP_HAS_SIBLING(kid));
10173 kid = OP_SIBLING(kid);
10176 if (OP_HAS_SIBLING(kid))
10177 return too_many_arguments_pv(o,OP_DESC(o), 0);
10183 Perl_ck_join(pTHX_ OP *o)
10185 const OP * const kid = OP_SIBLING(cLISTOPo->op_first);
10187 PERL_ARGS_ASSERT_CK_JOIN;
10189 if (kid && kid->op_type == OP_MATCH) {
10190 if (ckWARN(WARN_SYNTAX)) {
10191 const REGEXP *re = PM_GETRE(kPMOP);
10193 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10194 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10195 : newSVpvs_flags( "STRING", SVs_TEMP );
10196 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10197 "/%"SVf"/ should probably be written as \"%"SVf"\"",
10198 SVfARG(msg), SVfARG(msg));
10205 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10207 Examines an op, which is expected to identify a subroutine at runtime,
10208 and attempts to determine at compile time which subroutine it identifies.
10209 This is normally used during Perl compilation to determine whether
10210 a prototype can be applied to a function call. I<cvop> is the op
10211 being considered, normally an C<rv2cv> op. A pointer to the identified
10212 subroutine is returned, if it could be determined statically, and a null
10213 pointer is returned if it was not possible to determine statically.
10215 Currently, the subroutine can be identified statically if the RV that the
10216 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10217 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
10218 suitable if the constant value must be an RV pointing to a CV. Details of
10219 this process may change in future versions of Perl. If the C<rv2cv> op
10220 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10221 the subroutine statically: this flag is used to suppress compile-time
10222 magic on a subroutine call, forcing it to use default runtime behaviour.
10224 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10225 of a GV reference is modified. If a GV was examined and its CV slot was
10226 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10227 If the op is not optimised away, and the CV slot is later populated with
10228 a subroutine having a prototype, that flag eventually triggers the warning
10229 "called too early to check prototype".
10231 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10232 of returning a pointer to the subroutine it returns a pointer to the
10233 GV giving the most appropriate name for the subroutine in this context.
10234 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10235 (C<CvANON>) subroutine that is referenced through a GV it will be the
10236 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
10237 A null pointer is returned as usual if there is no statically-determinable
10243 /* shared by toke.c:yylex */
10245 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10247 PADNAME *name = PAD_COMPNAME(off);
10248 CV *compcv = PL_compcv;
10249 while (PadnameOUTER(name)) {
10250 assert(PARENT_PAD_INDEX(name));
10251 compcv = CvOUTSIDE(PL_compcv);
10252 name = PadlistNAMESARRAY(CvPADLIST(compcv))
10253 [off = PARENT_PAD_INDEX(name)];
10255 assert(!PadnameIsOUR(name));
10256 if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10257 MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10259 assert(mg->mg_obj);
10260 return (CV *)mg->mg_obj;
10262 return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10266 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10271 PERL_ARGS_ASSERT_RV2CV_OP_CV;
10272 if (flags & ~RV2CVOPCV_FLAG_MASK)
10273 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10274 if (cvop->op_type != OP_RV2CV)
10276 if (cvop->op_private & OPpENTERSUB_AMPER)
10278 if (!(cvop->op_flags & OPf_KIDS))
10280 rvop = cUNOPx(cvop)->op_first;
10281 switch (rvop->op_type) {
10283 gv = cGVOPx_gv(rvop);
10285 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
10286 cv = MUTABLE_CV(SvRV(gv));
10290 if (flags & RV2CVOPCV_RETURN_STUB)
10296 if (flags & RV2CVOPCV_MARK_EARLY)
10297 rvop->op_private |= OPpEARLY_CV;
10302 SV *rv = cSVOPx_sv(rvop);
10305 cv = (CV*)SvRV(rv);
10309 cv = find_lexical_cv(rvop->op_targ);
10314 } NOT_REACHED; /* NOTREACHED */
10316 if (SvTYPE((SV*)cv) != SVt_PVCV)
10318 if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) {
10319 if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)
10320 && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv)))
10329 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10331 Performs the default fixup of the arguments part of an C<entersub>
10332 op tree. This consists of applying list context to each of the
10333 argument ops. This is the standard treatment used on a call marked
10334 with C<&>, or a method call, or a call through a subroutine reference,
10335 or any other call where the callee can't be identified at compile time,
10336 or a call where the callee has no prototype.
10342 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10345 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10346 aop = cUNOPx(entersubop)->op_first;
10347 if (!OP_HAS_SIBLING(aop))
10348 aop = cUNOPx(aop)->op_first;
10349 for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
10351 op_lvalue(aop, OP_ENTERSUB);
10357 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10359 Performs the fixup of the arguments part of an C<entersub> op tree
10360 based on a subroutine prototype. This makes various modifications to
10361 the argument ops, from applying context up to inserting C<refgen> ops,
10362 and checking the number and syntactic types of arguments, as directed by
10363 the prototype. This is the standard treatment used on a subroutine call,
10364 not marked with C<&>, where the callee can be identified at compile time
10365 and has a prototype.
10367 I<protosv> supplies the subroutine prototype to be applied to the call.
10368 It may be a normal defined scalar, of which the string value will be used.
10369 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10370 that has been cast to C<SV*>) which has a prototype. The prototype
10371 supplied, in whichever form, does not need to match the actual callee
10372 referenced by the op tree.
10374 If the argument ops disagree with the prototype, for example by having
10375 an unacceptable number of arguments, a valid op tree is returned anyway.
10376 The error is reflected in the parser state, normally resulting in a single
10377 exception at the top level of parsing which covers all the compilation
10378 errors that occurred. In the error message, the callee is referred to
10379 by the name defined by the I<namegv> parameter.
10385 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10388 const char *proto, *proto_end;
10389 OP *aop, *prev, *cvop, *parent;
10392 I32 contextclass = 0;
10393 const char *e = NULL;
10394 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10395 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10396 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10397 "flags=%lx", (unsigned long) SvFLAGS(protosv));
10398 if (SvTYPE(protosv) == SVt_PVCV)
10399 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10400 else proto = SvPV(protosv, proto_len);
10401 proto = S_strip_spaces(aTHX_ proto, &proto_len);
10402 proto_end = proto + proto_len;
10403 parent = entersubop;
10404 aop = cUNOPx(entersubop)->op_first;
10405 if (!OP_HAS_SIBLING(aop)) {
10407 aop = cUNOPx(aop)->op_first;
10410 aop = OP_SIBLING(aop);
10411 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10412 while (aop != cvop) {
10415 if (proto >= proto_end)
10417 SV * const namesv = cv_name((CV *)namegv, NULL);
10418 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
10419 SVfARG(namesv)), SvUTF8(namesv));
10429 /* _ must be at the end */
10430 if (proto[1] && !strchr(";@%", proto[1]))
10446 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10448 arg == 1 ? "block or sub {}" : "sub {}",
10452 /* '*' allows any scalar type, including bareword */
10455 if (o3->op_type == OP_RV2GV)
10456 goto wrapref; /* autoconvert GLOB -> GLOBref */
10457 else if (o3->op_type == OP_CONST)
10458 o3->op_private &= ~OPpCONST_STRICT;
10464 if (o3->op_type == OP_RV2AV ||
10465 o3->op_type == OP_PADAV ||
10466 o3->op_type == OP_RV2HV ||
10467 o3->op_type == OP_PADHV
10473 case '[': case ']':
10480 switch (*proto++) {
10482 if (contextclass++ == 0) {
10483 e = strchr(proto, ']');
10484 if (!e || e == proto)
10492 if (contextclass) {
10493 const char *p = proto;
10494 const char *const end = proto;
10496 while (*--p != '[')
10497 /* \[$] accepts any scalar lvalue */
10499 && Perl_op_lvalue_flags(aTHX_
10501 OP_READ, /* not entersub */
10504 bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10505 (int)(end - p), p),
10511 if (o3->op_type == OP_RV2GV)
10514 bad_type_gv(arg, "symbol", namegv, 0, o3);
10517 if (o3->op_type == OP_ENTERSUB)
10520 bad_type_gv(arg, "subroutine entry", namegv, 0,
10524 if (o3->op_type == OP_RV2SV ||
10525 o3->op_type == OP_PADSV ||
10526 o3->op_type == OP_HELEM ||
10527 o3->op_type == OP_AELEM)
10529 if (!contextclass) {
10530 /* \$ accepts any scalar lvalue */
10531 if (Perl_op_lvalue_flags(aTHX_
10533 OP_READ, /* not entersub */
10536 bad_type_gv(arg, "scalar", namegv, 0, o3);
10540 if (o3->op_type == OP_RV2AV ||
10541 o3->op_type == OP_PADAV)
10544 bad_type_gv(arg, "array", namegv, 0, o3);
10547 if (o3->op_type == OP_RV2HV ||
10548 o3->op_type == OP_PADHV)
10551 bad_type_gv(arg, "hash", namegv, 0, o3);
10554 aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
10556 if (contextclass && e) {
10561 default: goto oops;
10571 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10572 SVfARG(cv_name((CV *)namegv, NULL)),
10577 op_lvalue(aop, OP_ENTERSUB);
10579 aop = OP_SIBLING(aop);
10581 if (aop == cvop && *proto == '_') {
10582 /* generate an access to $_ */
10583 op_sibling_splice(parent, prev, 0, newDEFSVOP());
10585 if (!optional && proto_end > proto &&
10586 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10588 SV * const namesv = cv_name((CV *)namegv, NULL);
10589 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
10590 SVfARG(namesv)), SvUTF8(namesv));
10596 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10598 Performs the fixup of the arguments part of an C<entersub> op tree either
10599 based on a subroutine prototype or using default list-context processing.
10600 This is the standard treatment used on a subroutine call, not marked
10601 with C<&>, where the callee can be identified at compile time.
10603 I<protosv> supplies the subroutine prototype to be applied to the call,
10604 or indicates that there is no prototype. It may be a normal scalar,
10605 in which case if it is defined then the string value will be used
10606 as a prototype, and if it is undefined then there is no prototype.
10607 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10608 that has been cast to C<SV*>), of which the prototype will be used if it
10609 has one. The prototype (or lack thereof) supplied, in whichever form,
10610 does not need to match the actual callee referenced by the op tree.
10612 If the argument ops disagree with the prototype, for example by having
10613 an unacceptable number of arguments, a valid op tree is returned anyway.
10614 The error is reflected in the parser state, normally resulting in a single
10615 exception at the top level of parsing which covers all the compilation
10616 errors that occurred. In the error message, the callee is referred to
10617 by the name defined by the I<namegv> parameter.
10623 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10624 GV *namegv, SV *protosv)
10626 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10627 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10628 return ck_entersub_args_proto(entersubop, namegv, protosv);
10630 return ck_entersub_args_list(entersubop);
10634 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10636 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10637 OP *aop = cUNOPx(entersubop)->op_first;
10639 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10643 if (!OP_HAS_SIBLING(aop))
10644 aop = cUNOPx(aop)->op_first;
10645 aop = OP_SIBLING(aop);
10646 for (cvop = aop; OP_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10648 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10650 op_free(entersubop);
10651 switch(GvNAME(namegv)[2]) {
10652 case 'F': return newSVOP(OP_CONST, 0,
10653 newSVpv(CopFILE(PL_curcop),0));
10654 case 'L': return newSVOP(
10656 Perl_newSVpvf(aTHX_
10657 "%"IVdf, (IV)CopLINE(PL_curcop)
10660 case 'P': return newSVOP(OP_CONST, 0,
10662 ? newSVhek(HvNAME_HEK(PL_curstash))
10670 OP *prev, *cvop, *first, *parent;
10673 parent = entersubop;
10674 if (!OP_HAS_SIBLING(aop)) {
10676 aop = cUNOPx(aop)->op_first;
10679 first = prev = aop;
10680 aop = OP_SIBLING(aop);
10681 /* find last sibling */
10683 OP_HAS_SIBLING(cvop);
10684 prev = cvop, cvop = OP_SIBLING(cvop))
10686 if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
10687 /* Usually, OPf_SPECIAL on a UNOP means that its arg had no
10688 * parens, but these have their own meaning for that flag: */
10689 && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
10690 && opnum != OP_DELETE && opnum != OP_EXISTS)
10691 flags |= OPf_SPECIAL;
10692 /* excise cvop from end of sibling chain */
10693 op_sibling_splice(parent, prev, 1, NULL);
10695 if (aop == cvop) aop = NULL;
10697 /* detach remaining siblings from the first sibling, then
10698 * dispose of original optree */
10701 op_sibling_splice(parent, first, -1, NULL);
10702 op_free(entersubop);
10704 if (opnum == OP_ENTEREVAL
10705 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10706 flags |= OPpEVAL_BYTES <<8;
10708 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10710 case OA_BASEOP_OR_UNOP:
10711 case OA_FILESTATOP:
10712 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10715 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10718 return opnum == OP_RUNCV
10719 ? newPVOP(OP_RUNCV,0,NULL)
10722 return convert(opnum,0,aop);
10730 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10732 Retrieves the function that will be used to fix up a call to I<cv>.
10733 Specifically, the function is applied to an C<entersub> op tree for a
10734 subroutine call, not marked with C<&>, where the callee can be identified
10735 at compile time as I<cv>.
10737 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10738 argument for it is returned in I<*ckobj_p>. The function is intended
10739 to be called in this manner:
10741 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10743 In this call, I<entersubop> is a pointer to the C<entersub> op,
10744 which may be replaced by the check function, and I<namegv> is a GV
10745 supplying the name that should be used by the check function to refer
10746 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10747 It is permitted to apply the check function in non-standard situations,
10748 such as to a call to a different subroutine or to a method call.
10750 By default, the function is
10751 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10752 and the SV parameter is I<cv> itself. This implements standard
10753 prototype processing. It can be changed, for a particular subroutine,
10754 by L</cv_set_call_checker>.
10760 S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
10764 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10766 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10767 *ckobj_p = callmg->mg_obj;
10768 if (flagsp) *flagsp = callmg->mg_flags;
10770 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10771 *ckobj_p = (SV*)cv;
10772 if (flagsp) *flagsp = 0;
10777 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10779 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10780 PERL_UNUSED_CONTEXT;
10781 S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
10785 =for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags
10787 Sets the function that will be used to fix up a call to I<cv>.
10788 Specifically, the function is applied to an C<entersub> op tree for a
10789 subroutine call, not marked with C<&>, where the callee can be identified
10790 at compile time as I<cv>.
10792 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10793 for it is supplied in I<ckobj>. The function should be defined like this:
10795 STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
10797 It is intended to be called in this manner:
10799 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10801 In this call, I<entersubop> is a pointer to the C<entersub> op,
10802 which may be replaced by the check function, and I<namegv> supplies
10803 the name that should be used by the check function to refer
10804 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10805 It is permitted to apply the check function in non-standard situations,
10806 such as to a call to a different subroutine or to a method call.
10808 I<namegv> may not actually be a GV. For efficiency, perl may pass a
10809 CV or other SV instead. Whatever is passed can be used as the first
10810 argument to L</cv_name>. You can force perl to pass a GV by including
10811 C<CALL_CHECKER_REQUIRE_GV> in the I<flags>.
10813 The current setting for a particular CV can be retrieved by
10814 L</cv_get_call_checker>.
10816 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10818 The original form of L</cv_set_call_checker_flags>, which passes it the
10819 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.
10825 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10827 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10828 cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
10832 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
10833 SV *ckobj, U32 flags)
10835 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
10836 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10837 if (SvMAGICAL((SV*)cv))
10838 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10841 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10842 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10844 if (callmg->mg_flags & MGf_REFCOUNTED) {
10845 SvREFCNT_dec(callmg->mg_obj);
10846 callmg->mg_flags &= ~MGf_REFCOUNTED;
10848 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10849 callmg->mg_obj = ckobj;
10850 if (ckobj != (SV*)cv) {
10851 SvREFCNT_inc_simple_void_NN(ckobj);
10852 callmg->mg_flags |= MGf_REFCOUNTED;
10854 callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
10855 | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
10860 Perl_ck_subr(pTHX_ OP *o)
10866 PERL_ARGS_ASSERT_CK_SUBR;
10868 aop = cUNOPx(o)->op_first;
10869 if (!OP_HAS_SIBLING(aop))
10870 aop = cUNOPx(aop)->op_first;
10871 aop = OP_SIBLING(aop);
10872 for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ;
10873 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10874 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
10876 o->op_private &= ~1;
10877 o->op_private |= OPpENTERSUB_HASTARG;
10878 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10879 if (PERLDB_SUB && PL_curstash != PL_debstash)
10880 o->op_private |= OPpENTERSUB_DB;
10881 if (cvop->op_type == OP_RV2CV) {
10882 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10884 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10885 if (aop->op_type == OP_CONST)
10886 aop->op_private &= ~OPpCONST_STRICT;
10887 else if (aop->op_type == OP_LIST) {
10888 OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
10889 if (sib && sib->op_type == OP_CONST)
10890 sib->op_private &= ~OPpCONST_STRICT;
10895 return ck_entersub_args_list(o);
10897 Perl_call_checker ckfun;
10900 S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags);
10902 /* The original call checker API guarantees that a GV will be
10903 be provided with the right name. So, if the old API was
10904 used (or the REQUIRE_GV flag was passed), we have to reify
10905 the CV’s GV, unless this is an anonymous sub. This is not
10906 ideal for lexical subs, as its stringification will include
10907 the package. But it is the best we can do. */
10908 if (flags & MGf_REQUIRE_GV) {
10909 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
10912 else namegv = MUTABLE_GV(cv);
10913 /* After a syntax error in a lexical sub, the cv that
10914 rv2cv_op_cv returns may be a nameless stub. */
10915 if (!namegv) return ck_entersub_args_list(o);
10918 return ckfun(aTHX_ o, namegv, ckobj);
10923 Perl_ck_svconst(pTHX_ OP *o)
10925 SV * const sv = cSVOPo->op_sv;
10926 PERL_ARGS_ASSERT_CK_SVCONST;
10927 PERL_UNUSED_CONTEXT;
10928 #ifdef PERL_OLD_COPY_ON_WRITE
10929 if (SvIsCOW(sv)) sv_force_normal(sv);
10930 #elif defined(PERL_NEW_COPY_ON_WRITE)
10931 /* Since the read-only flag may be used to protect a string buffer, we
10932 cannot do copy-on-write with existing read-only scalars that are not
10933 already copy-on-write scalars. To allow $_ = "hello" to do COW with
10934 that constant, mark the constant as COWable here, if it is not
10935 already read-only. */
10936 if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
10939 # ifdef PERL_DEBUG_READONLY_COW
10949 Perl_ck_trunc(pTHX_ OP *o)
10951 PERL_ARGS_ASSERT_CK_TRUNC;
10953 if (o->op_flags & OPf_KIDS) {
10954 SVOP *kid = (SVOP*)cUNOPo->op_first;
10956 if (kid->op_type == OP_NULL)
10957 kid = (SVOP*)OP_SIBLING(kid);
10958 if (kid && kid->op_type == OP_CONST &&
10959 (kid->op_private & OPpCONST_BARE) &&
10962 o->op_flags |= OPf_SPECIAL;
10963 kid->op_private &= ~OPpCONST_STRICT;
10970 Perl_ck_substr(pTHX_ OP *o)
10972 PERL_ARGS_ASSERT_CK_SUBSTR;
10975 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10976 OP *kid = cLISTOPo->op_first;
10978 if (kid->op_type == OP_NULL)
10979 kid = OP_SIBLING(kid);
10981 kid->op_flags |= OPf_MOD;
10988 Perl_ck_tell(pTHX_ OP *o)
10990 PERL_ARGS_ASSERT_CK_TELL;
10992 if (o->op_flags & OPf_KIDS) {
10993 OP *kid = cLISTOPo->op_first;
10994 if (kid->op_type == OP_NULL && OP_HAS_SIBLING(kid)) kid = OP_SIBLING(kid);
10995 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11001 Perl_ck_each(pTHX_ OP *o)
11004 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11005 const unsigned orig_type = o->op_type;
11006 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
11007 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
11008 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
11009 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
11011 PERL_ARGS_ASSERT_CK_EACH;
11014 switch (kid->op_type) {
11020 CHANGE_TYPE(o, array_type);
11023 if (kid->op_private == OPpCONST_BARE
11024 || !SvROK(cSVOPx_sv(kid))
11025 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11026 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
11028 /* we let ck_fun handle it */
11031 CHANGE_TYPE(o, ref_type);
11035 /* if treating as a reference, defer additional checks to runtime */
11036 if (o->op_type == ref_type) {
11037 /* diag_listed_as: keys on reference is experimental */
11038 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
11039 "%s is experimental", PL_op_desc[ref_type]);
11046 Perl_ck_length(pTHX_ OP *o)
11048 PERL_ARGS_ASSERT_CK_LENGTH;
11052 if (ckWARN(WARN_SYNTAX)) {
11053 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11057 const bool hash = kid->op_type == OP_PADHV
11058 || kid->op_type == OP_RV2HV;
11059 switch (kid->op_type) {
11064 name = S_op_varname(aTHX_ kid);
11070 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11071 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11073 SVfARG(name), hash ? "keys " : "", SVfARG(name)
11076 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11077 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11078 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11080 /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11081 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11082 "length() used on @array (did you mean \"scalar(@array)\"?)");
11089 /* Check for in place reverse and sort assignments like "@a = reverse @a"
11090 and modify the optree to make them work inplace */
11093 S_inplace_aassign(pTHX_ OP *o) {
11095 OP *modop, *modop_pushmark;
11097 OP *oleft, *oleft_pushmark;
11099 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
11101 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
11103 assert(cUNOPo->op_first->op_type == OP_NULL);
11104 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
11105 assert(modop_pushmark->op_type == OP_PUSHMARK);
11106 modop = OP_SIBLING(modop_pushmark);
11108 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
11111 /* no other operation except sort/reverse */
11112 if (OP_HAS_SIBLING(modop))
11115 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
11116 if (!(oright = OP_SIBLING(cUNOPx(modop)->op_first))) return;
11118 if (modop->op_flags & OPf_STACKED) {
11119 /* skip sort subroutine/block */
11120 assert(oright->op_type == OP_NULL);
11121 oright = OP_SIBLING(oright);
11124 assert(OP_SIBLING(cUNOPo->op_first)->op_type == OP_NULL);
11125 oleft_pushmark = cUNOPx(OP_SIBLING(cUNOPo->op_first))->op_first;
11126 assert(oleft_pushmark->op_type == OP_PUSHMARK);
11127 oleft = OP_SIBLING(oleft_pushmark);
11129 /* Check the lhs is an array */
11131 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
11132 || OP_HAS_SIBLING(oleft)
11133 || (oleft->op_private & OPpLVAL_INTRO)
11137 /* Only one thing on the rhs */
11138 if (OP_HAS_SIBLING(oright))
11141 /* check the array is the same on both sides */
11142 if (oleft->op_type == OP_RV2AV) {
11143 if (oright->op_type != OP_RV2AV
11144 || !cUNOPx(oright)->op_first
11145 || cUNOPx(oright)->op_first->op_type != OP_GV
11146 || cUNOPx(oleft )->op_first->op_type != OP_GV
11147 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11148 cGVOPx_gv(cUNOPx(oright)->op_first)
11152 else if (oright->op_type != OP_PADAV
11153 || oright->op_targ != oleft->op_targ
11157 /* This actually is an inplace assignment */
11159 modop->op_private |= OPpSORT_INPLACE;
11161 /* transfer MODishness etc from LHS arg to RHS arg */
11162 oright->op_flags = oleft->op_flags;
11164 /* remove the aassign op and the lhs */
11166 op_null(oleft_pushmark);
11167 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11168 op_null(cUNOPx(oleft)->op_first);
11174 /* mechanism for deferring recursion in rpeep() */
11176 #define MAX_DEFERRED 4
11180 if (defer_ix == (MAX_DEFERRED-1)) { \
11181 OP **defer = defer_queue[defer_base]; \
11182 CALL_RPEEP(*defer); \
11183 S_prune_chain_head(defer); \
11184 defer_base = (defer_base + 1) % MAX_DEFERRED; \
11187 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
11190 #define IS_AND_OP(o) (o->op_type == OP_AND)
11191 #define IS_OR_OP(o) (o->op_type == OP_OR)
11195 S_null_listop_in_list_context(pTHX_ OP *o)
11199 PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
11201 /* This is an OP_LIST in list context. That means we
11202 * can ditch the OP_LIST and the OP_PUSHMARK within. */
11204 kid = cLISTOPo->op_first;
11205 /* Find the end of the chain of OPs executed within the OP_LIST. */
11206 while (kid->op_next != o)
11207 kid = kid->op_next;
11209 kid->op_next = o->op_next; /* patch list out of exec chain */
11210 op_null(cUNOPo->op_first); /* NULL the pushmark */
11211 op_null(o); /* NULL the list */
11214 /* A peephole optimizer. We visit the ops in the order they're to execute.
11215 * See the comments at the top of this file for more details about when
11216 * peep() is called */
11219 Perl_rpeep(pTHX_ OP *o)
11223 OP* oldoldop = NULL;
11224 OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11225 int defer_base = 0;
11230 if (!o || o->op_opt)
11234 SAVEVPTR(PL_curcop);
11235 for (;; o = o->op_next) {
11236 if (o && o->op_opt)
11239 while (defer_ix >= 0) {
11241 defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
11242 CALL_RPEEP(*defer);
11243 S_prune_chain_head(defer);
11248 /* By default, this op has now been optimised. A couple of cases below
11249 clear this again. */
11254 /* The following will have the OP_LIST and OP_PUSHMARK
11255 * patched out later IF the OP_LIST is in list context.
11256 * So in that case, we can set the this OP's op_next
11257 * to skip to after the OP_PUSHMARK:
11263 * will eventually become:
11266 * - ex-pushmark -> -
11272 OP *other_pushmark;
11273 if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
11274 && (sibling = OP_SIBLING(o))
11275 && sibling->op_type == OP_LIST
11276 /* This KIDS check is likely superfluous since OP_LIST
11277 * would otherwise be an OP_STUB. */
11278 && sibling->op_flags & OPf_KIDS
11279 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
11280 && (other_pushmark = cLISTOPx(sibling)->op_first)
11281 /* Pointer equality also effectively checks that it's a
11283 && other_pushmark == o->op_next)
11285 o->op_next = other_pushmark->op_next;
11286 null_listop_in_list_context(sibling);
11290 switch (o->op_type) {
11292 PL_curcop = ((COP*)o); /* for warnings */
11295 PL_curcop = ((COP*)o); /* for warnings */
11297 /* Optimise a "return ..." at the end of a sub to just be "...".
11298 * This saves 2 ops. Before:
11299 * 1 <;> nextstate(main 1 -e:1) v ->2
11300 * 4 <@> return K ->5
11301 * 2 <0> pushmark s ->3
11302 * - <1> ex-rv2sv sK/1 ->4
11303 * 3 <#> gvsv[*cat] s ->4
11306 * - <@> return K ->-
11307 * - <0> pushmark s ->2
11308 * - <1> ex-rv2sv sK/1 ->-
11309 * 2 <$> gvsv(*cat) s ->3
11312 OP *next = o->op_next;
11313 OP *sibling = OP_SIBLING(o);
11314 if ( OP_TYPE_IS(next, OP_PUSHMARK)
11315 && OP_TYPE_IS(sibling, OP_RETURN)
11316 && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
11317 && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
11318 && cUNOPx(sibling)->op_first == next
11319 && OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
11322 /* Look through the PUSHMARK's siblings for one that
11323 * points to the RETURN */
11324 OP *top = OP_SIBLING(next);
11325 while (top && top->op_next) {
11326 if (top->op_next == sibling) {
11327 top->op_next = sibling->op_next;
11328 o->op_next = next->op_next;
11331 top = OP_SIBLING(top);
11336 /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
11338 * This latter form is then suitable for conversion into padrange
11339 * later on. Convert:
11341 * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
11345 * nextstate1 -> listop -> nextstate3
11347 * pushmark -> padop1 -> padop2
11349 if (o->op_next && (
11350 o->op_next->op_type == OP_PADSV
11351 || o->op_next->op_type == OP_PADAV
11352 || o->op_next->op_type == OP_PADHV
11354 && !(o->op_next->op_private & ~OPpLVAL_INTRO)
11355 && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
11356 && o->op_next->op_next->op_next && (
11357 o->op_next->op_next->op_next->op_type == OP_PADSV
11358 || o->op_next->op_next->op_next->op_type == OP_PADAV
11359 || o->op_next->op_next->op_next->op_type == OP_PADHV
11361 && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
11362 && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
11363 && (!CopLABEL((COP*)o)) /* Don't mess with labels */
11364 && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
11366 OP *pad1, *ns2, *pad2, *ns3, *newop, *newpm;
11369 ns2 = pad1->op_next;
11370 pad2 = ns2->op_next;
11371 ns3 = pad2->op_next;
11373 /* we assume here that the op_next chain is the same as
11374 * the op_sibling chain */
11375 assert(OP_SIBLING(o) == pad1);
11376 assert(OP_SIBLING(pad1) == ns2);
11377 assert(OP_SIBLING(ns2) == pad2);
11378 assert(OP_SIBLING(pad2) == ns3);
11380 /* create new listop, with children consisting of:
11381 * a new pushmark, pad1, pad2. */
11382 OP_SIBLING_set(pad2, NULL);
11383 newop = newLISTOP(OP_LIST, 0, pad1, pad2);
11384 newop->op_flags |= OPf_PARENS;
11385 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11386 newpm = cUNOPx(newop)->op_first; /* pushmark */
11388 /* Kill nextstate2 between padop1/padop2 */
11391 o ->op_next = newpm;
11392 newpm->op_next = pad1;
11393 pad1 ->op_next = pad2;
11394 pad2 ->op_next = newop; /* listop */
11395 newop->op_next = ns3;
11397 OP_SIBLING_set(o, newop);
11398 OP_SIBLING_set(newop, ns3);
11399 newop->op_lastsib = 0;
11401 newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11403 /* Ensure pushmark has this flag if padops do */
11404 if (pad1->op_flags & OPf_MOD && pad2->op_flags & OPf_MOD) {
11405 o->op_next->op_flags |= OPf_MOD;
11411 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11412 to carry two labels. For now, take the easier option, and skip
11413 this optimisation if the first NEXTSTATE has a label. */
11414 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
11415 OP *nextop = o->op_next;
11416 while (nextop && nextop->op_type == OP_NULL)
11417 nextop = nextop->op_next;
11419 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11420 COP *firstcop = (COP *)o;
11421 COP *secondcop = (COP *)nextop;
11422 /* We want the COP pointed to by o (and anything else) to
11423 become the next COP down the line. */
11424 cop_free(firstcop);
11426 firstcop->op_next = secondcop->op_next;
11428 /* Now steal all its pointers, and duplicate the other
11430 firstcop->cop_line = secondcop->cop_line;
11431 #ifdef USE_ITHREADS
11432 firstcop->cop_stashoff = secondcop->cop_stashoff;
11433 firstcop->cop_file = secondcop->cop_file;
11435 firstcop->cop_stash = secondcop->cop_stash;
11436 firstcop->cop_filegv = secondcop->cop_filegv;
11438 firstcop->cop_hints = secondcop->cop_hints;
11439 firstcop->cop_seq = secondcop->cop_seq;
11440 firstcop->cop_warnings = secondcop->cop_warnings;
11441 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11443 #ifdef USE_ITHREADS
11444 secondcop->cop_stashoff = 0;
11445 secondcop->cop_file = NULL;
11447 secondcop->cop_stash = NULL;
11448 secondcop->cop_filegv = NULL;
11450 secondcop->cop_warnings = NULL;
11451 secondcop->cop_hints_hash = NULL;
11453 /* If we use op_null(), and hence leave an ex-COP, some
11454 warnings are misreported. For example, the compile-time
11455 error in 'use strict; no strict refs;' */
11456 secondcop->op_type = OP_NULL;
11457 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11463 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11464 if (o->op_next->op_private & OPpTARGET_MY) {
11465 if (o->op_flags & OPf_STACKED) /* chained concats */
11466 break; /* ignore_optimization */
11468 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11469 o->op_targ = o->op_next->op_targ;
11470 o->op_next->op_targ = 0;
11471 o->op_private |= OPpTARGET_MY;
11474 op_null(o->op_next);
11478 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11479 break; /* Scalar stub must produce undef. List stub is noop */
11483 if (o->op_targ == OP_NEXTSTATE
11484 || o->op_targ == OP_DBSTATE)
11486 PL_curcop = ((COP*)o);
11488 /* XXX: We avoid setting op_seq here to prevent later calls
11489 to rpeep() from mistakenly concluding that optimisation
11490 has already occurred. This doesn't fix the real problem,
11491 though (See 20010220.007). AMS 20010719 */
11492 /* op_seq functionality is now replaced by op_opt */
11500 oldop->op_next = o->op_next;
11508 /* Convert a series of PAD ops for my vars plus support into a
11509 * single padrange op. Basically
11511 * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11513 * becomes, depending on circumstances, one of
11515 * padrange ----------------------------------> (list) -> rest
11516 * padrange --------------------------------------------> rest
11518 * where all the pad indexes are sequential and of the same type
11520 * We convert the pushmark into a padrange op, then skip
11521 * any other pad ops, and possibly some trailing ops.
11522 * Note that we don't null() the skipped ops, to make it
11523 * easier for Deparse to undo this optimisation (and none of
11524 * the skipped ops are holding any resourses). It also makes
11525 * it easier for find_uninit_var(), as it can just ignore
11526 * padrange, and examine the original pad ops.
11530 OP *followop = NULL; /* the op that will follow the padrange op */
11533 PADOFFSET base = 0; /* init only to stop compiler whining */
11534 U8 gimme = 0; /* init only to stop compiler whining */
11535 bool defav = 0; /* seen (...) = @_ */
11536 bool reuse = 0; /* reuse an existing padrange op */
11538 /* look for a pushmark -> gv[_] -> rv2av */
11544 if ( p->op_type == OP_GV
11545 && (gv = cGVOPx_gv(p)) && isGV(gv)
11546 && GvNAMELEN_get(gv) == 1
11547 && *GvNAME_get(gv) == '_'
11548 && GvSTASH(gv) == PL_defstash
11549 && (rv2av = p->op_next)
11550 && rv2av->op_type == OP_RV2AV
11551 && !(rv2av->op_flags & OPf_REF)
11552 && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11553 && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11554 && OP_SIBLING(o) == rv2av /* these two for Deparse */
11555 && cUNOPx(rv2av)->op_first == p
11557 q = rv2av->op_next;
11558 if (q->op_type == OP_NULL)
11560 if (q->op_type == OP_PUSHMARK) {
11567 /* To allow Deparse to pessimise this, it needs to be able
11568 * to restore the pushmark's original op_next, which it
11569 * will assume to be the same as OP_SIBLING. */
11570 if (o->op_next != OP_SIBLING(o))
11575 /* scan for PAD ops */
11577 for (p = p->op_next; p; p = p->op_next) {
11578 if (p->op_type == OP_NULL)
11581 if (( p->op_type != OP_PADSV
11582 && p->op_type != OP_PADAV
11583 && p->op_type != OP_PADHV
11585 /* any private flag other than INTRO? e.g. STATE */
11586 || (p->op_private & ~OPpLVAL_INTRO)
11590 /* let $a[N] potentially be optimised into AELEMFAST_LEX
11592 if ( p->op_type == OP_PADAV
11594 && p->op_next->op_type == OP_CONST
11595 && p->op_next->op_next
11596 && p->op_next->op_next->op_type == OP_AELEM
11600 /* for 1st padop, note what type it is and the range
11601 * start; for the others, check that it's the same type
11602 * and that the targs are contiguous */
11604 intro = (p->op_private & OPpLVAL_INTRO);
11606 gimme = (p->op_flags & OPf_WANT);
11609 if ((p->op_private & OPpLVAL_INTRO) != intro)
11611 /* Note that you'd normally expect targs to be
11612 * contiguous in my($a,$b,$c), but that's not the case
11613 * when external modules start doing things, e.g.
11614 i* Function::Parameters */
11615 if (p->op_targ != base + count)
11617 assert(p->op_targ == base + count);
11618 /* all the padops should be in the same context */
11619 if (gimme != (p->op_flags & OPf_WANT))
11623 /* for AV, HV, only when we're not flattening */
11624 if ( p->op_type != OP_PADSV
11625 && gimme != OPf_WANT_VOID
11626 && !(p->op_flags & OPf_REF)
11630 if (count >= OPpPADRANGE_COUNTMASK)
11633 /* there's a biggest base we can fit into a
11634 * SAVEt_CLEARPADRANGE in pp_padrange */
11635 if (intro && base >
11636 (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11639 /* Success! We've got another valid pad op to optimise away */
11641 followop = p->op_next;
11647 /* pp_padrange in specifically compile-time void context
11648 * skips pushing a mark and lexicals; in all other contexts
11649 * (including unknown till runtime) it pushes a mark and the
11650 * lexicals. We must be very careful then, that the ops we
11651 * optimise away would have exactly the same effect as the
11653 * In particular in void context, we can only optimise to
11654 * a padrange if see see the complete sequence
11655 * pushmark, pad*v, ...., list, nextstate
11656 * which has the net effect of of leaving the stack empty
11657 * (for now we leave the nextstate in the execution chain, for
11658 * its other side-effects).
11661 if (gimme == OPf_WANT_VOID) {
11662 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
11663 && gimme == (followop->op_flags & OPf_WANT)
11664 && ( followop->op_next->op_type == OP_NEXTSTATE
11665 || followop->op_next->op_type == OP_DBSTATE))
11667 followop = followop->op_next; /* skip OP_LIST */
11669 /* consolidate two successive my(...);'s */
11672 && oldoldop->op_type == OP_PADRANGE
11673 && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11674 && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11675 && !(oldoldop->op_flags & OPf_SPECIAL)
11678 assert(oldoldop->op_next == oldop);
11679 assert( oldop->op_type == OP_NEXTSTATE
11680 || oldop->op_type == OP_DBSTATE);
11681 assert(oldop->op_next == o);
11684 = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11686 /* Do not assume pad offsets for $c and $d are con-
11691 if ( oldoldop->op_targ + old_count == base
11692 && old_count < OPpPADRANGE_COUNTMASK - count) {
11693 base = oldoldop->op_targ;
11694 count += old_count;
11699 /* if there's any immediately following singleton
11700 * my var's; then swallow them and the associated
11702 * my ($a,$b); my $c; my $d;
11704 * my ($a,$b,$c,$d);
11707 while ( ((p = followop->op_next))
11708 && ( p->op_type == OP_PADSV
11709 || p->op_type == OP_PADAV
11710 || p->op_type == OP_PADHV)
11711 && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11712 && (p->op_private & OPpLVAL_INTRO) == intro
11713 && !(p->op_private & ~OPpLVAL_INTRO)
11715 && ( p->op_next->op_type == OP_NEXTSTATE
11716 || p->op_next->op_type == OP_DBSTATE)
11717 && count < OPpPADRANGE_COUNTMASK
11718 && base + count == p->op_targ
11721 followop = p->op_next;
11729 assert(oldoldop->op_type == OP_PADRANGE);
11730 oldoldop->op_next = followop;
11731 oldoldop->op_private = (intro | count);
11737 /* Convert the pushmark into a padrange.
11738 * To make Deparse easier, we guarantee that a padrange was
11739 * *always* formerly a pushmark */
11740 assert(o->op_type == OP_PUSHMARK);
11741 o->op_next = followop;
11742 o->op_type = OP_PADRANGE;
11743 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11745 /* bit 7: INTRO; bit 6..0: count */
11746 o->op_private = (intro | count);
11747 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11748 | gimme | (defav ? OPf_SPECIAL : 0));
11755 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11756 OP* const pop = (o->op_type == OP_PADAV) ?
11757 o->op_next : o->op_next->op_next;
11759 if (pop && pop->op_type == OP_CONST &&
11760 ((PL_op = pop->op_next)) &&
11761 pop->op_next->op_type == OP_AELEM &&
11762 !(pop->op_next->op_private &
11763 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11764 (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
11767 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11768 no_bareword_allowed(pop);
11769 if (o->op_type == OP_GV)
11770 op_null(o->op_next);
11771 op_null(pop->op_next);
11773 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11774 o->op_next = pop->op_next->op_next;
11775 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11776 o->op_private = (U8)i;
11777 if (o->op_type == OP_GV) {
11780 o->op_type = OP_AELEMFAST;
11783 o->op_type = OP_AELEMFAST_LEX;
11788 if (o->op_next->op_type == OP_RV2SV) {
11789 if (!(o->op_next->op_private & OPpDEREF)) {
11790 op_null(o->op_next);
11791 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11793 o->op_next = o->op_next->op_next;
11794 o->op_type = OP_GVSV;
11795 o->op_ppaddr = PL_ppaddr[OP_GVSV];
11798 else if (o->op_next->op_type == OP_READLINE
11799 && o->op_next->op_next->op_type == OP_CONCAT
11800 && (o->op_next->op_next->op_flags & OPf_STACKED))
11802 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11803 o->op_type = OP_RCATLINE;
11804 o->op_flags |= OPf_STACKED;
11805 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11806 op_null(o->op_next->op_next);
11807 op_null(o->op_next);
11812 #define HV_OR_SCALARHV(op) \
11813 ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11815 : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11816 && ( cUNOPx(op)->op_first->op_type == OP_PADHV \
11817 || cUNOPx(op)->op_first->op_type == OP_RV2HV) \
11818 ? cUNOPx(op)->op_first \
11822 if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11823 fop->op_private |= OPpTRUEBOOL;
11829 fop = cLOGOP->op_first;
11830 sop = OP_SIBLING(fop);
11831 while (cLOGOP->op_other->op_type == OP_NULL)
11832 cLOGOP->op_other = cLOGOP->op_other->op_next;
11833 while (o->op_next && ( o->op_type == o->op_next->op_type
11834 || o->op_next->op_type == OP_NULL))
11835 o->op_next = o->op_next->op_next;
11837 /* if we're an OR and our next is a AND in void context, we'll
11838 follow it's op_other on short circuit, same for reverse.
11839 We can't do this with OP_DOR since if it's true, its return
11840 value is the underlying value which must be evaluated
11844 (IS_AND_OP(o) && IS_OR_OP(o->op_next))
11845 || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
11847 && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
11849 o->op_next = ((LOGOP*)o->op_next)->op_other;
11851 DEFER(cLOGOP->op_other);
11854 fop = HV_OR_SCALARHV(fop);
11855 if (sop) sop = HV_OR_SCALARHV(sop);
11860 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11861 while (nop && nop->op_next) {
11862 switch (nop->op_next->op_type) {
11867 lop = nop = nop->op_next;
11870 nop = nop->op_next;
11879 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11880 || o->op_type == OP_AND )
11881 fop->op_private |= OPpTRUEBOOL;
11882 else if (!(lop->op_flags & OPf_WANT))
11883 fop->op_private |= OPpMAYBE_TRUEBOOL;
11885 if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11887 sop->op_private |= OPpTRUEBOOL;
11894 if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11895 fop->op_private |= OPpTRUEBOOL;
11896 #undef HV_OR_SCALARHV
11897 /* GERONIMO! */ /* FALLTHROUGH */
11906 while (cLOGOP->op_other->op_type == OP_NULL)
11907 cLOGOP->op_other = cLOGOP->op_other->op_next;
11908 DEFER(cLOGOP->op_other);
11913 while (cLOOP->op_redoop->op_type == OP_NULL)
11914 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11915 while (cLOOP->op_nextop->op_type == OP_NULL)
11916 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11917 while (cLOOP->op_lastop->op_type == OP_NULL)
11918 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11919 /* a while(1) loop doesn't have an op_next that escapes the
11920 * loop, so we have to explicitly follow the op_lastop to
11921 * process the rest of the code */
11922 DEFER(cLOOP->op_lastop);
11926 assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
11927 DEFER(cLOGOPo->op_other);
11931 assert(!(cPMOP->op_pmflags & PMf_ONCE));
11932 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11933 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11934 cPMOP->op_pmstashstartu.op_pmreplstart
11935 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11936 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11942 if (o->op_flags & OPf_SPECIAL) {
11943 /* first arg is a code block */
11944 OP * const nullop = OP_SIBLING(cLISTOP->op_first);
11945 OP * kid = cUNOPx(nullop)->op_first;
11947 assert(nullop->op_type == OP_NULL);
11948 assert(kid->op_type == OP_SCOPE
11949 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
11950 /* since OP_SORT doesn't have a handy op_other-style
11951 * field that can point directly to the start of the code
11952 * block, store it in the otherwise-unused op_next field
11953 * of the top-level OP_NULL. This will be quicker at
11954 * run-time, and it will also allow us to remove leading
11955 * OP_NULLs by just messing with op_nexts without
11956 * altering the basic op_first/op_sibling layout. */
11957 kid = kLISTOP->op_first;
11959 (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
11960 || kid->op_type == OP_STUB
11961 || kid->op_type == OP_ENTER);
11962 nullop->op_next = kLISTOP->op_next;
11963 DEFER(nullop->op_next);
11966 /* check that RHS of sort is a single plain array */
11967 oright = cUNOPo->op_first;
11968 if (!oright || oright->op_type != OP_PUSHMARK)
11971 if (o->op_private & OPpSORT_INPLACE)
11974 /* reverse sort ... can be optimised. */
11975 if (!OP_HAS_SIBLING(cUNOPo)) {
11976 /* Nothing follows us on the list. */
11977 OP * const reverse = o->op_next;
11979 if (reverse->op_type == OP_REVERSE &&
11980 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
11981 OP * const pushmark = cUNOPx(reverse)->op_first;
11982 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
11983 && (OP_SIBLING(cUNOPx(pushmark)) == o)) {
11984 /* reverse -> pushmark -> sort */
11985 o->op_private |= OPpSORT_REVERSE;
11987 pushmark->op_next = oright->op_next;
11997 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
11999 LISTOP *enter, *exlist;
12001 if (o->op_private & OPpSORT_INPLACE)
12004 enter = (LISTOP *) o->op_next;
12007 if (enter->op_type == OP_NULL) {
12008 enter = (LISTOP *) enter->op_next;
12012 /* for $a (...) will have OP_GV then OP_RV2GV here.
12013 for (...) just has an OP_GV. */
12014 if (enter->op_type == OP_GV) {
12015 gvop = (OP *) enter;
12016 enter = (LISTOP *) enter->op_next;
12019 if (enter->op_type == OP_RV2GV) {
12020 enter = (LISTOP *) enter->op_next;
12026 if (enter->op_type != OP_ENTERITER)
12029 iter = enter->op_next;
12030 if (!iter || iter->op_type != OP_ITER)
12033 expushmark = enter->op_first;
12034 if (!expushmark || expushmark->op_type != OP_NULL
12035 || expushmark->op_targ != OP_PUSHMARK)
12038 exlist = (LISTOP *) OP_SIBLING(expushmark);
12039 if (!exlist || exlist->op_type != OP_NULL
12040 || exlist->op_targ != OP_LIST)
12043 if (exlist->op_last != o) {
12044 /* Mmm. Was expecting to point back to this op. */
12047 theirmark = exlist->op_first;
12048 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
12051 if (OP_SIBLING(theirmark) != o) {
12052 /* There's something between the mark and the reverse, eg
12053 for (1, reverse (...))
12058 ourmark = ((LISTOP *)o)->op_first;
12059 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
12062 ourlast = ((LISTOP *)o)->op_last;
12063 if (!ourlast || ourlast->op_next != o)
12066 rv2av = OP_SIBLING(ourmark);
12067 if (rv2av && rv2av->op_type == OP_RV2AV && !OP_HAS_SIBLING(rv2av)
12068 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
12069 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
12070 /* We're just reversing a single array. */
12071 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
12072 enter->op_flags |= OPf_STACKED;
12075 /* We don't have control over who points to theirmark, so sacrifice
12077 theirmark->op_next = ourmark->op_next;
12078 theirmark->op_flags = ourmark->op_flags;
12079 ourlast->op_next = gvop ? gvop : (OP *) enter;
12082 enter->op_private |= OPpITER_REVERSED;
12083 iter->op_private |= OPpITER_REVERSED;
12090 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
12091 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
12096 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
12098 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
12100 sv = newRV((SV *)PL_compcv);
12104 o->op_type = OP_CONST;
12105 o->op_ppaddr = PL_ppaddr[OP_CONST];
12106 o->op_flags |= OPf_SPECIAL;
12107 cSVOPo->op_sv = sv;
12112 if (OP_GIMME(o,0) == G_VOID) {
12113 OP *right = cBINOP->op_first;
12132 OP *left = OP_SIBLING(right);
12133 if (left->op_type == OP_SUBSTR
12134 && (left->op_private & 7) < 4) {
12136 /* cut out right */
12137 op_sibling_splice(o, NULL, 1, NULL);
12138 /* and insert it as second child of OP_SUBSTR */
12139 op_sibling_splice(left, cBINOPx(left)->op_first, 0,
12141 left->op_private |= OPpSUBSTR_REPL_FIRST;
12143 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12150 Perl_cpeep_t cpeep =
12151 XopENTRYCUSTOM(o, xop_peep);
12153 cpeep(aTHX_ o, oldop);
12158 /* did we just null the current op? If so, re-process it to handle
12159 * eliding "empty" ops from the chain */
12160 if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
12173 Perl_peep(pTHX_ OP *o)
12179 =head1 Custom Operators
12181 =for apidoc Ao||custom_op_xop
12182 Return the XOP structure for a given custom op. This macro should be
12183 considered internal to OP_NAME and the other access macros: use them instead.
12184 This macro does call a function. Prior
12185 to 5.19.6, this was implemented as a
12192 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
12198 static const XOP xop_null = { 0, 0, 0, 0, 0 };
12200 PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
12201 assert(o->op_type == OP_CUSTOM);
12203 /* This is wrong. It assumes a function pointer can be cast to IV,
12204 * which isn't guaranteed, but this is what the old custom OP code
12205 * did. In principle it should be safer to Copy the bytes of the
12206 * pointer into a PV: since the new interface is hidden behind
12207 * functions, this can be changed later if necessary. */
12208 /* Change custom_op_xop if this ever happens */
12209 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
12212 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12214 /* assume noone will have just registered a desc */
12215 if (!he && PL_custom_op_names &&
12216 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
12221 /* XXX does all this need to be shared mem? */
12222 Newxz(xop, 1, XOP);
12223 pv = SvPV(HeVAL(he), l);
12224 XopENTRY_set(xop, xop_name, savepvn(pv, l));
12225 if (PL_custom_op_descs &&
12226 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
12228 pv = SvPV(HeVAL(he), l);
12229 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
12231 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
12235 xop = (XOP *)&xop_null;
12237 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
12241 if(field == XOPe_xop_ptr) {
12244 const U32 flags = XopFLAGS(xop);
12245 if(flags & field) {
12247 case XOPe_xop_name:
12248 any.xop_name = xop->xop_name;
12250 case XOPe_xop_desc:
12251 any.xop_desc = xop->xop_desc;
12253 case XOPe_xop_class:
12254 any.xop_class = xop->xop_class;
12256 case XOPe_xop_peep:
12257 any.xop_peep = xop->xop_peep;
12265 case XOPe_xop_name:
12266 any.xop_name = XOPd_xop_name;
12268 case XOPe_xop_desc:
12269 any.xop_desc = XOPd_xop_desc;
12271 case XOPe_xop_class:
12272 any.xop_class = XOPd_xop_class;
12274 case XOPe_xop_peep:
12275 any.xop_peep = XOPd_xop_peep;
12283 /* Some gcc releases emit a warning for this function:
12284 * op.c: In function 'Perl_custom_op_get_field':
12285 * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized]
12286 * Whether this is true, is currently unknown. */
12292 =for apidoc Ao||custom_op_register
12293 Register a custom op. See L<perlguts/"Custom Operators">.
12299 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
12303 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
12305 /* see the comment in custom_op_xop */
12306 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
12308 if (!PL_custom_ops)
12309 PL_custom_ops = newHV();
12311 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
12312 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
12317 =for apidoc core_prototype
12319 This function assigns the prototype of the named core function to C<sv>, or
12320 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
12321 NULL if the core function has no prototype. C<code> is a code as returned
12322 by C<keyword()>. It must not be equal to 0.
12328 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
12331 int i = 0, n = 0, seen_question = 0, defgv = 0;
12333 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
12334 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
12335 bool nullret = FALSE;
12337 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
12341 if (!sv) sv = sv_newmortal();
12343 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
12345 switch (code < 0 ? -code : code) {
12346 case KEY_and : case KEY_chop: case KEY_chomp:
12347 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
12348 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
12349 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
12350 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
12351 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
12352 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
12353 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
12354 case KEY_x : case KEY_xor :
12355 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
12356 case KEY_glob: retsetpvs("_;", OP_GLOB);
12357 case KEY_keys: retsetpvs("+", OP_KEYS);
12358 case KEY_values: retsetpvs("+", OP_VALUES);
12359 case KEY_each: retsetpvs("+", OP_EACH);
12360 case KEY_push: retsetpvs("+@", OP_PUSH);
12361 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
12362 case KEY_pop: retsetpvs(";+", OP_POP);
12363 case KEY_shift: retsetpvs(";+", OP_SHIFT);
12364 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
12366 retsetpvs("+;$$@", OP_SPLICE);
12367 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
12369 case KEY_evalbytes:
12370 name = "entereval"; break;
12378 while (i < MAXO) { /* The slow way. */
12379 if (strEQ(name, PL_op_name[i])
12380 || strEQ(name, PL_op_desc[i]))
12382 if (nullret) { assert(opnum); *opnum = i; return NULL; }
12389 defgv = PL_opargs[i] & OA_DEFGV;
12390 oa = PL_opargs[i] >> OASHIFT;
12392 if (oa & OA_OPTIONAL && !seen_question && (
12393 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
12398 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
12399 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
12400 /* But globs are already references (kinda) */
12401 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
12405 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
12406 && !scalar_mod_type(NULL, i)) {
12411 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
12415 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
12416 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
12417 str[n-1] = '_'; defgv = 0;
12421 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
12423 sv_setpvn(sv, str, n - 1);
12424 if (opnum) *opnum = i;
12429 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
12432 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
12435 PERL_ARGS_ASSERT_CORESUB_OP;
12439 return op_append_elem(OP_LINESEQ,
12442 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
12446 case OP_SELECT: /* which represents OP_SSELECT as well */
12451 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12452 newSVOP(OP_CONST, 0, newSVuv(1))
12454 coresub_op(newSVuv((UV)OP_SSELECT), 0,
12456 coresub_op(coreargssv, 0, OP_SELECT)
12460 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12462 return op_append_elem(
12465 opnum == OP_WANTARRAY || opnum == OP_RUNCV
12466 ? OPpOFFBYONE << 8 : 0)
12468 case OA_BASEOP_OR_UNOP:
12469 if (opnum == OP_ENTEREVAL) {
12470 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12471 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12473 else o = newUNOP(opnum,0,argop);
12474 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12477 if (is_handle_constructor(o, 1))
12478 argop->op_private |= OPpCOREARGS_DEREF1;
12479 if (scalar_mod_type(NULL, opnum))
12480 argop->op_private |= OPpCOREARGS_SCALARMOD;
12484 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
12485 if (is_handle_constructor(o, 2))
12486 argop->op_private |= OPpCOREARGS_DEREF2;
12487 if (opnum == OP_SUBSTR) {
12488 o->op_private |= OPpMAYBE_LVSUB;
12497 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12498 SV * const *new_const_svp)
12500 const char *hvname;
12501 bool is_const = !!CvCONST(old_cv);
12502 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12504 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12506 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12508 /* They are 2 constant subroutines generated from
12509 the same constant. This probably means that
12510 they are really the "same" proxy subroutine
12511 instantiated in 2 places. Most likely this is
12512 when a constant is exported twice. Don't warn.
12515 (ckWARN(WARN_REDEFINE)
12517 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12518 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12519 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12520 strEQ(hvname, "autouse"))
12524 && ckWARN_d(WARN_REDEFINE)
12525 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
12528 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12530 ? "Constant subroutine %"SVf" redefined"
12531 : "Subroutine %"SVf" redefined",
12536 =head1 Hook manipulation
12538 These functions provide convenient and thread-safe means of manipulating
12545 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12547 Puts a C function into the chain of check functions for a specified op
12548 type. This is the preferred way to manipulate the L</PL_check> array.
12549 I<opcode> specifies which type of op is to be affected. I<new_checker>
12550 is a pointer to the C function that is to be added to that opcode's
12551 check chain, and I<old_checker_p> points to the storage location where a
12552 pointer to the next function in the chain will be stored. The value of
12553 I<new_pointer> is written into the L</PL_check> array, while the value
12554 previously stored there is written to I<*old_checker_p>.
12556 The function should be defined like this:
12558 static OP *new_checker(pTHX_ OP *op) { ... }
12560 It is intended to be called in this manner:
12562 new_checker(aTHX_ op)
12564 I<old_checker_p> should be defined like this:
12566 static Perl_check_t old_checker_p;
12568 L</PL_check> is global to an entire process, and a module wishing to
12569 hook op checking may find itself invoked more than once per process,
12570 typically in different threads. To handle that situation, this function
12571 is idempotent. The location I<*old_checker_p> must initially (once
12572 per process) contain a null pointer. A C variable of static duration
12573 (declared at file scope, typically also marked C<static> to give
12574 it internal linkage) will be implicitly initialised appropriately,
12575 if it does not have an explicit initialiser. This function will only
12576 actually modify the check chain if it finds I<*old_checker_p> to be null.
12577 This function is also thread safe on the small scale. It uses appropriate
12578 locking to avoid race conditions in accessing L</PL_check>.
12580 When this function is called, the function referenced by I<new_checker>
12581 must be ready to be called, except for I<*old_checker_p> being unfilled.
12582 In a threading situation, I<new_checker> may be called immediately,
12583 even before this function has returned. I<*old_checker_p> will always
12584 be appropriately set before I<new_checker> is called. If I<new_checker>
12585 decides not to do anything special with an op that it is given (which
12586 is the usual case for most uses of op check hooking), it must chain the
12587 check function referenced by I<*old_checker_p>.
12589 If you want to influence compilation of calls to a specific subroutine,
12590 then use L</cv_set_call_checker> rather than hooking checking of all
12597 Perl_wrap_op_checker(pTHX_ Optype opcode,
12598 Perl_check_t new_checker, Perl_check_t *old_checker_p)
12602 PERL_UNUSED_CONTEXT;
12603 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12604 if (*old_checker_p) return;
12605 OP_CHECK_MUTEX_LOCK;
12606 if (!*old_checker_p) {
12607 *old_checker_p = PL_check[opcode];
12608 PL_check[opcode] = new_checker;
12610 OP_CHECK_MUTEX_UNLOCK;
12615 /* Efficient sub that returns a constant scalar value. */
12617 const_sv_xsub(pTHX_ CV* cv)
12620 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12621 PERL_UNUSED_ARG(items);
12631 const_av_xsub(pTHX_ CV* cv)
12634 AV * const av = MUTABLE_AV(XSANY.any_ptr);
12642 if (SvRMAGICAL(av))
12643 Perl_croak(aTHX_ "Magical list constants are not supported");
12644 if (GIMME_V != G_ARRAY) {
12646 ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
12649 EXTEND(SP, AvFILLp(av)+1);
12650 Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12651 XSRETURN(AvFILLp(av)+1);
12656 * c-indentation-style: bsd
12657 * c-basic-offset: 4
12658 * indent-tabs-mode: nil
12661 * ex: set ts=8 sts=4 sw=4 et: