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, 0);
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 /* complain about "my $<special_var>" etc etc */
574 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
575 (name[1] == '_' && (*name == '$' || len > 2))))
577 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
578 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
579 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
580 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
581 PL_parser->in_my == KEY_state ? "state" : "my"));
583 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
584 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
587 else if (len == 2 && name[1] == '_' && !is_our)
588 /* diag_listed_as: Use of my $_ is experimental */
589 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
590 "Use of %s $_ is experimental",
591 PL_parser->in_my == KEY_state
595 /* allocate a spare slot and store the name in that slot */
597 off = pad_add_name_pvn(name, len,
598 (is_our ? padadd_OUR :
599 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
600 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
601 PL_parser->in_my_stash,
603 /* $_ is always in main::, even with our */
604 ? (PL_curstash && !memEQs(name,len,"$_")
610 /* anon sub prototypes contains state vars should always be cloned,
611 * otherwise the state var would be shared between anon subs */
613 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
614 CvCLONE_on(PL_compcv);
620 =head1 Optree Manipulation Functions
622 =for apidoc alloccopstash
624 Available only under threaded builds, this function allocates an entry in
625 C<PL_stashpad> for the stash passed to it.
632 Perl_alloccopstash(pTHX_ HV *hv)
634 PADOFFSET off = 0, o = 1;
635 bool found_slot = FALSE;
637 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
639 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
641 for (; o < PL_stashpadmax; ++o) {
642 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
643 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
644 found_slot = TRUE, off = o;
647 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
648 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
649 off = PL_stashpadmax;
650 PL_stashpadmax += 10;
653 PL_stashpad[PL_stashpadix = off] = hv;
658 /* free the body of an op without examining its contents.
659 * Always use this rather than FreeOp directly */
662 S_op_destroy(pTHX_ OP *o)
670 =for apidoc Am|void|op_free|OP *o
672 Free an op. Only use this when an op is no longer linked to from any
679 Perl_op_free(pTHX_ OP *o)
686 /* Though ops may be freed twice, freeing the op after its slab is a
688 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
689 /* During the forced freeing of ops after compilation failure, kidops
690 may be freed before their parents. */
691 if (!o || o->op_type == OP_FREED)
696 /* an op should only ever acquire op_private flags that we know about.
697 * If this fails, you may need to fix something in regen/op_private */
698 assert(!(o->op_private & ~PL_op_private_valid[type]));
700 if (o->op_private & OPpREFCOUNTED) {
711 refcnt = OpREFCNT_dec(o);
714 /* Need to find and remove any pattern match ops from the list
715 we maintain for reset(). */
716 find_and_forget_pmops(o);
726 /* Call the op_free hook if it has been set. Do it now so that it's called
727 * at the right time for refcounted ops, but still before all of the kids
731 if (o->op_flags & OPf_KIDS) {
733 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
734 nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
739 type = (OPCODE)o->op_targ;
742 Slab_to_rw(OpSLAB(o));
744 /* COP* is not cleared by op_clear() so that we may track line
745 * numbers etc even after null() */
746 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
752 #ifdef DEBUG_LEAKING_SCALARS
759 Perl_op_clear(pTHX_ OP *o)
764 PERL_ARGS_ASSERT_OP_CLEAR;
766 switch (o->op_type) {
767 case OP_NULL: /* Was holding old type, if any. */
770 case OP_ENTEREVAL: /* Was holding hints. */
774 if (!(o->op_flags & OPf_REF)
775 || (PL_check[o->op_type] != Perl_ck_ftst))
782 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
787 /* It's possible during global destruction that the GV is freed
788 before the optree. Whilst the SvREFCNT_inc is happy to bump from
789 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
790 will trigger an assertion failure, because the entry to sv_clear
791 checks that the scalar is not already freed. A check of for
792 !SvIS_FREED(gv) turns out to be invalid, because during global
793 destruction the reference count can be forced down to zero
794 (with SVf_BREAK set). In which case raising to 1 and then
795 dropping to 0 triggers cleanup before it should happen. I
796 *think* that this might actually be a general, systematic,
797 weakness of the whole idea of SVf_BREAK, in that code *is*
798 allowed to raise and lower references during global destruction,
799 so any *valid* code that happens to do this during global
800 destruction might well trigger premature cleanup. */
801 bool still_valid = gv && SvREFCNT(gv);
804 SvREFCNT_inc_simple_void(gv);
806 if (cPADOPo->op_padix > 0) {
807 pad_swipe(cPADOPo->op_padix, TRUE);
808 cPADOPo->op_padix = 0;
811 SvREFCNT_dec(cSVOPo->op_sv);
812 cSVOPo->op_sv = NULL;
815 int try_downgrade = SvREFCNT(gv) == 2;
818 gv_try_downgrade(gv);
822 case OP_METHOD_NAMED:
823 SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
824 cMETHOPx(o)->op_u.op_meth_sv = NULL;
827 pad_swipe(o->op_targ, 1);
834 SvREFCNT_dec(cSVOPo->op_sv);
835 cSVOPo->op_sv = NULL;
838 Even if op_clear does a pad_free for the target of the op,
839 pad_free doesn't actually remove the sv that exists in the pad;
840 instead it lives on. This results in that it could be reused as
841 a target later on when the pad was reallocated.
844 pad_swipe(o->op_targ,1);
854 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
859 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
860 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
862 if (cPADOPo->op_padix > 0) {
863 pad_swipe(cPADOPo->op_padix, TRUE);
864 cPADOPo->op_padix = 0;
867 SvREFCNT_dec(cSVOPo->op_sv);
868 cSVOPo->op_sv = NULL;
872 PerlMemShared_free(cPVOPo->op_pv);
873 cPVOPo->op_pv = NULL;
877 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
881 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
882 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
885 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
891 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
892 op_free(cPMOPo->op_code_list);
893 cPMOPo->op_code_list = NULL;
895 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
896 /* we use the same protection as the "SAFE" version of the PM_ macros
897 * here since sv_clean_all might release some PMOPs
898 * after PL_regex_padav has been cleared
899 * and the clearing of PL_regex_padav needs to
900 * happen before sv_clean_all
903 if(PL_regex_pad) { /* We could be in destruction */
904 const IV offset = (cPMOPo)->op_pmoffset;
905 ReREFCNT_dec(PM_GETRE(cPMOPo));
906 PL_regex_pad[offset] = &PL_sv_undef;
907 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
911 ReREFCNT_dec(PM_GETRE(cPMOPo));
912 PM_SETRE(cPMOPo, NULL);
918 if (o->op_targ > 0) {
919 pad_free(o->op_targ);
925 S_cop_free(pTHX_ COP* cop)
927 PERL_ARGS_ASSERT_COP_FREE;
930 if (! specialWARN(cop->cop_warnings))
931 PerlMemShared_free(cop->cop_warnings);
932 cophh_free(CopHINTHASH_get(cop));
933 if (PL_curcop == cop)
938 S_forget_pmop(pTHX_ PMOP *const o
941 HV * const pmstash = PmopSTASH(o);
943 PERL_ARGS_ASSERT_FORGET_PMOP;
945 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
946 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
948 PMOP **const array = (PMOP**) mg->mg_ptr;
949 U32 count = mg->mg_len / sizeof(PMOP**);
954 /* Found it. Move the entry at the end to overwrite it. */
955 array[i] = array[--count];
956 mg->mg_len = count * sizeof(PMOP**);
957 /* Could realloc smaller at this point always, but probably
958 not worth it. Probably worth free()ing if we're the
961 Safefree(mg->mg_ptr);
974 S_find_and_forget_pmops(pTHX_ OP *o)
976 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
978 if (o->op_flags & OPf_KIDS) {
979 OP *kid = cUNOPo->op_first;
981 switch (kid->op_type) {
986 forget_pmop((PMOP*)kid);
988 find_and_forget_pmops(kid);
989 kid = OP_SIBLING(kid);
995 =for apidoc Am|void|op_null|OP *o
997 Neutralizes an op when it is no longer needed, but is still linked to from
1004 Perl_op_null(pTHX_ OP *o)
1008 PERL_ARGS_ASSERT_OP_NULL;
1010 if (o->op_type == OP_NULL)
1013 o->op_targ = o->op_type;
1014 o->op_type = OP_NULL;
1015 o->op_ppaddr = PL_ppaddr[OP_NULL];
1019 Perl_op_refcnt_lock(pTHX)
1024 PERL_UNUSED_CONTEXT;
1029 Perl_op_refcnt_unlock(pTHX)
1034 PERL_UNUSED_CONTEXT;
1040 =for apidoc op_sibling_splice
1042 A general function for editing the structure of an existing chain of
1043 op_sibling nodes. By analogy with the perl-level splice() function, allows
1044 you to delete zero or more sequential nodes, replacing them with zero or
1045 more different nodes. Performs the necessary op_first/op_last
1046 housekeeping on the parent node and op_sibling manipulation on the
1047 children. The last deleted node will be marked as as the last node by
1048 updating the op_sibling or op_lastsib field as appropriate.
1050 Note that op_next is not manipulated, and nodes are not freed; that is the
1051 responsibility of the caller. It also won't create a new list op for an
1052 empty list etc; use higher-level functions like op_append_elem() for that.
1054 parent is the parent node of the sibling chain.
1056 start is the node preceding the first node to be spliced. Node(s)
1057 following it will be deleted, and ops will be inserted after it. If it is
1058 NULL, the first node onwards is deleted, and nodes are inserted at the
1061 del_count is the number of nodes to delete. If zero, no nodes are deleted.
1062 If -1 or greater than or equal to the number of remaining kids, all
1063 remaining kids are deleted.
1065 insert is the first of a chain of nodes to be inserted in place of the nodes.
1066 If NULL, no nodes are inserted.
1068 The head of the chain of deleted ops is returned, or NULL if no ops were
1073 action before after returns
1074 ------ ----- ----- -------
1077 splice(P, A, 2, X-Y-Z) | | B-C
1081 splice(P, NULL, 1, X-Y) | | A
1085 splice(P, NULL, 3, NULL) | | A-B-C
1089 splice(P, B, 0, X-Y) | | NULL
1096 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1098 OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1100 OP *last_del = NULL;
1101 OP *last_ins = NULL;
1103 PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1105 assert(del_count >= -1);
1107 if (del_count && first) {
1109 while (--del_count && OP_HAS_SIBLING(last_del))
1110 last_del = OP_SIBLING(last_del);
1111 rest = OP_SIBLING(last_del);
1112 OP_SIBLING_set(last_del, NULL);
1113 last_del->op_lastsib = 1;
1120 while (OP_HAS_SIBLING(last_ins))
1121 last_ins = OP_SIBLING(last_ins);
1122 OP_SIBLING_set(last_ins, rest);
1123 last_ins->op_lastsib = rest ? 0 : 1;
1129 OP_SIBLING_set(start, insert);
1130 start->op_lastsib = insert ? 0 : 1;
1133 cLISTOPx(parent)->op_first = insert;
1136 /* update op_last etc */
1137 U32 type = parent->op_type;
1140 if (type == OP_NULL)
1141 type = parent->op_targ;
1142 type = PL_opargs[type] & OA_CLASS_MASK;
1144 lastop = last_ins ? last_ins : start ? start : NULL;
1145 if ( type == OA_BINOP
1146 || type == OA_LISTOP
1150 cLISTOPx(parent)->op_last = lastop;
1153 lastop->op_lastsib = 1;
1154 #ifdef PERL_OP_PARENT
1155 lastop->op_sibling = parent;
1159 return last_del ? first : NULL;
1163 =for apidoc op_parent
1165 returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1166 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1173 Perl_op_parent(OP *o)
1175 PERL_ARGS_ASSERT_OP_PARENT;
1176 #ifdef PERL_OP_PARENT
1177 while (OP_HAS_SIBLING(o))
1179 return o->op_sibling;
1187 /* replace the sibling following start with a new UNOP, which becomes
1188 * the parent of the original sibling; e.g.
1190 * op_sibling_newUNOP(P, A, unop-args...)
1198 * where U is the new UNOP.
1200 * parent and start args are the same as for op_sibling_splice();
1201 * type and flags args are as newUNOP().
1203 * Returns the new UNOP.
1207 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1211 kid = op_sibling_splice(parent, start, 1, NULL);
1212 newop = newUNOP(type, flags, kid);
1213 op_sibling_splice(parent, start, 0, newop);
1218 /* lowest-level newLOGOP-style function - just allocates and populates
1219 * the struct. Higher-level stuff should be done by S_new_logop() /
1220 * newLOGOP(). This function exists mainly to avoid op_first assignment
1221 * being spread throughout this file.
1225 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1229 NewOp(1101, logop, 1, LOGOP);
1230 logop->op_type = (OPCODE)type;
1231 logop->op_first = first;
1232 logop->op_other = other;
1233 logop->op_flags = OPf_KIDS;
1234 while (kid && OP_HAS_SIBLING(kid))
1235 kid = OP_SIBLING(kid);
1237 kid->op_lastsib = 1;
1238 #ifdef PERL_OP_PARENT
1239 kid->op_sibling = (OP*)logop;
1246 /* Contextualizers */
1249 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1251 Applies a syntactic context to an op tree representing an expression.
1252 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1253 or C<G_VOID> to specify the context to apply. The modified op tree
1260 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1262 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1264 case G_SCALAR: return scalar(o);
1265 case G_ARRAY: return list(o);
1266 case G_VOID: return scalarvoid(o);
1268 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1275 =for apidoc Am|OP*|op_linklist|OP *o
1276 This function is the implementation of the L</LINKLIST> macro. It should
1277 not be called directly.
1283 Perl_op_linklist(pTHX_ OP *o)
1287 PERL_ARGS_ASSERT_OP_LINKLIST;
1292 /* establish postfix order */
1293 first = cUNOPo->op_first;
1296 o->op_next = LINKLIST(first);
1299 OP *sibl = OP_SIBLING(kid);
1301 kid->op_next = LINKLIST(sibl);
1316 S_scalarkids(pTHX_ OP *o)
1318 if (o && o->op_flags & OPf_KIDS) {
1320 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1327 S_scalarboolean(pTHX_ OP *o)
1329 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1331 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1332 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1333 if (ckWARN(WARN_SYNTAX)) {
1334 const line_t oldline = CopLINE(PL_curcop);
1336 if (PL_parser && PL_parser->copline != NOLINE) {
1337 /* This ensures that warnings are reported at the first line
1338 of the conditional, not the last. */
1339 CopLINE_set(PL_curcop, PL_parser->copline);
1341 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1342 CopLINE_set(PL_curcop, oldline);
1349 S_op_varname(pTHX_ const OP *o)
1352 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1353 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1355 const char funny = o->op_type == OP_PADAV
1356 || o->op_type == OP_RV2AV ? '@' : '%';
1357 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1359 if (cUNOPo->op_first->op_type != OP_GV
1360 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1362 return varname(gv, funny, 0, NULL, 0, 1);
1365 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1370 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1371 { /* or not so pretty :-) */
1372 if (o->op_type == OP_CONST) {
1374 if (SvPOK(*retsv)) {
1376 *retsv = sv_newmortal();
1377 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1378 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1380 else if (!SvOK(*retsv))
1383 else *retpv = "...";
1387 S_scalar_slice_warning(pTHX_ const OP *o)
1391 o->op_type == OP_HSLICE ? '{' : '[';
1393 o->op_type == OP_HSLICE ? '}' : ']';
1395 SV *keysv = NULL; /* just to silence compiler warnings */
1396 const char *key = NULL;
1398 if (!(o->op_private & OPpSLICEWARNING))
1400 if (PL_parser && PL_parser->error_count)
1401 /* This warning can be nonsensical when there is a syntax error. */
1404 kid = cLISTOPo->op_first;
1405 kid = OP_SIBLING(kid); /* get past pushmark */
1406 /* weed out false positives: any ops that can return lists */
1407 switch (kid->op_type) {
1436 /* Don't warn if we have a nulled list either. */
1437 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1440 assert(OP_SIBLING(kid));
1441 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1442 if (!name) /* XS module fiddling with the op tree */
1444 S_op_pretty(aTHX_ kid, &keysv, &key);
1445 assert(SvPOK(name));
1446 sv_chop(name,SvPVX(name)+1);
1448 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1449 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1450 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1452 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1453 lbrack, key, rbrack);
1455 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1456 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1457 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1459 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1460 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1464 Perl_scalar(pTHX_ OP *o)
1468 /* assumes no premature commitment */
1469 if (!o || (PL_parser && PL_parser->error_count)
1470 || (o->op_flags & OPf_WANT)
1471 || o->op_type == OP_RETURN)
1476 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1478 switch (o->op_type) {
1480 scalar(cBINOPo->op_first);
1485 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1495 if (o->op_flags & OPf_KIDS) {
1496 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1502 kid = cLISTOPo->op_first;
1504 kid = OP_SIBLING(kid);
1507 OP *sib = OP_SIBLING(kid);
1508 if (sib && kid->op_type != OP_LEAVEWHEN)
1514 PL_curcop = &PL_compiling;
1519 kid = cLISTOPo->op_first;
1522 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1527 /* Warn about scalar context */
1528 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1529 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1532 const char *key = NULL;
1534 /* This warning can be nonsensical when there is a syntax error. */
1535 if (PL_parser && PL_parser->error_count)
1538 if (!ckWARN(WARN_SYNTAX)) break;
1540 kid = cLISTOPo->op_first;
1541 kid = OP_SIBLING(kid); /* get past pushmark */
1542 assert(OP_SIBLING(kid));
1543 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1544 if (!name) /* XS module fiddling with the op tree */
1546 S_op_pretty(aTHX_ kid, &keysv, &key);
1547 assert(SvPOK(name));
1548 sv_chop(name,SvPVX(name)+1);
1550 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1551 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1552 "%%%"SVf"%c%s%c in scalar context better written "
1554 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1555 lbrack, key, rbrack);
1557 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1558 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1559 "%%%"SVf"%c%"SVf"%c in scalar context better "
1560 "written as $%"SVf"%c%"SVf"%c",
1561 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1562 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1569 Perl_scalarvoid(pTHX_ OP *o)
1573 SV *useless_sv = NULL;
1574 const char* useless = NULL;
1578 PERL_ARGS_ASSERT_SCALARVOID;
1580 if (o->op_type == OP_NEXTSTATE
1581 || o->op_type == OP_DBSTATE
1582 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1583 || o->op_targ == OP_DBSTATE)))
1584 PL_curcop = (COP*)o; /* for warning below */
1586 /* assumes no premature commitment */
1587 want = o->op_flags & OPf_WANT;
1588 if ((want && want != OPf_WANT_SCALAR)
1589 || (PL_parser && PL_parser->error_count)
1590 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1595 if ((o->op_private & OPpTARGET_MY)
1596 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1598 return scalar(o); /* As if inside SASSIGN */
1601 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1603 switch (o->op_type) {
1605 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1609 if (o->op_flags & OPf_STACKED)
1613 if (o->op_private == 4)
1638 case OP_AELEMFAST_LEX:
1659 case OP_GETSOCKNAME:
1660 case OP_GETPEERNAME:
1665 case OP_GETPRIORITY:
1690 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1691 /* Otherwise it's "Useless use of grep iterator" */
1692 useless = OP_DESC(o);
1696 kid = cLISTOPo->op_first;
1697 if (kid && kid->op_type == OP_PUSHRE
1699 && !(o->op_flags & OPf_STACKED)
1701 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1703 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1705 useless = OP_DESC(o);
1709 kid = cUNOPo->op_first;
1710 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1711 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1714 useless = "negative pattern binding (!~)";
1718 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1719 useless = "non-destructive substitution (s///r)";
1723 useless = "non-destructive transliteration (tr///r)";
1730 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1731 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1732 useless = "a variable";
1737 if (cSVOPo->op_private & OPpCONST_STRICT)
1738 no_bareword_allowed(o);
1740 if (ckWARN(WARN_VOID)) {
1742 /* don't warn on optimised away booleans, eg
1743 * use constant Foo, 5; Foo || print; */
1744 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1746 /* the constants 0 and 1 are permitted as they are
1747 conventionally used as dummies in constructs like
1748 1 while some_condition_with_side_effects; */
1749 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1751 else if (SvPOK(sv)) {
1752 SV * const dsv = newSVpvs("");
1754 = Perl_newSVpvf(aTHX_
1756 pv_pretty(dsv, SvPVX_const(sv),
1757 SvCUR(sv), 32, NULL, NULL,
1759 | PERL_PV_ESCAPE_NOCLEAR
1760 | PERL_PV_ESCAPE_UNI_DETECT));
1761 SvREFCNT_dec_NN(dsv);
1763 else if (SvOK(sv)) {
1764 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1767 useless = "a constant (undef)";
1770 op_null(o); /* don't execute or even remember it */
1774 o->op_type = OP_PREINC; /* pre-increment is faster */
1775 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1779 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1780 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1784 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1785 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1789 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1790 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1795 UNOP *refgen, *rv2cv;
1798 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1801 rv2gv = ((BINOP *)o)->op_last;
1802 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1805 refgen = (UNOP *)((BINOP *)o)->op_first;
1807 if (!refgen || (refgen->op_type != OP_REFGEN
1808 && refgen->op_type != OP_SREFGEN))
1811 exlist = (LISTOP *)refgen->op_first;
1812 if (!exlist || exlist->op_type != OP_NULL
1813 || exlist->op_targ != OP_LIST)
1816 if (exlist->op_first->op_type != OP_PUSHMARK
1817 && exlist->op_first != exlist->op_last)
1820 rv2cv = (UNOP*)exlist->op_last;
1822 if (rv2cv->op_type != OP_RV2CV)
1825 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1826 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1827 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1829 o->op_private |= OPpASSIGN_CV_TO_GV;
1830 rv2gv->op_private |= OPpDONT_INIT_GV;
1831 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1843 kid = cLOGOPo->op_first;
1844 if (kid->op_type == OP_NOT
1845 && (kid->op_flags & OPf_KIDS)) {
1846 if (o->op_type == OP_AND) {
1848 o->op_ppaddr = PL_ppaddr[OP_OR];
1850 o->op_type = OP_AND;
1851 o->op_ppaddr = PL_ppaddr[OP_AND];
1861 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1866 if (o->op_flags & OPf_STACKED)
1873 if (!(o->op_flags & OPf_KIDS))
1884 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1895 /* mortalise it, in case warnings are fatal. */
1896 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1897 "Useless use of %"SVf" in void context",
1898 SVfARG(sv_2mortal(useless_sv)));
1901 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1902 "Useless use of %s in void context",
1909 S_listkids(pTHX_ OP *o)
1911 if (o && o->op_flags & OPf_KIDS) {
1913 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1920 Perl_list(pTHX_ OP *o)
1924 /* assumes no premature commitment */
1925 if (!o || (o->op_flags & OPf_WANT)
1926 || (PL_parser && PL_parser->error_count)
1927 || o->op_type == OP_RETURN)
1932 if ((o->op_private & OPpTARGET_MY)
1933 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1935 return o; /* As if inside SASSIGN */
1938 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1940 switch (o->op_type) {
1943 list(cBINOPo->op_first);
1948 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1956 if (!(o->op_flags & OPf_KIDS))
1958 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1959 list(cBINOPo->op_first);
1960 return gen_constant_list(o);
1967 kid = cLISTOPo->op_first;
1969 kid = OP_SIBLING(kid);
1972 OP *sib = OP_SIBLING(kid);
1973 if (sib && kid->op_type != OP_LEAVEWHEN)
1979 PL_curcop = &PL_compiling;
1983 kid = cLISTOPo->op_first;
1990 S_scalarseq(pTHX_ OP *o)
1993 const OPCODE type = o->op_type;
1995 if (type == OP_LINESEQ || type == OP_SCOPE ||
1996 type == OP_LEAVE || type == OP_LEAVETRY)
1999 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2000 if (OP_HAS_SIBLING(kid)) {
2004 PL_curcop = &PL_compiling;
2006 o->op_flags &= ~OPf_PARENS;
2007 if (PL_hints & HINT_BLOCK_SCOPE)
2008 o->op_flags |= OPf_PARENS;
2011 o = newOP(OP_STUB, 0);
2016 S_modkids(pTHX_ OP *o, I32 type)
2018 if (o && o->op_flags & OPf_KIDS) {
2020 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2021 op_lvalue(kid, type);
2027 =for apidoc finalize_optree
2029 This function finalizes the optree. Should be called directly after
2030 the complete optree is built. It does some additional
2031 checking which can't be done in the normal ck_xxx functions and makes
2032 the tree thread-safe.
2037 Perl_finalize_optree(pTHX_ OP* o)
2039 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2042 SAVEVPTR(PL_curcop);
2050 /* Relocate sv to the pad for thread safety.
2051 * Despite being a "constant", the SV is written to,
2052 * for reference counts, sv_upgrade() etc. */
2053 PERL_STATIC_INLINE void
2054 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2057 PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2059 ix = pad_alloc(OP_CONST, SVf_READONLY);
2060 SvREFCNT_dec(PAD_SVl(ix));
2061 PAD_SETSV(ix, *svp);
2062 /* XXX I don't know how this isn't readonly already. */
2063 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2071 S_finalize_op(pTHX_ OP* o)
2073 PERL_ARGS_ASSERT_FINALIZE_OP;
2076 switch (o->op_type) {
2079 PL_curcop = ((COP*)o); /* for warnings */
2082 if (OP_HAS_SIBLING(o)) {
2083 OP *sib = OP_SIBLING(o);
2084 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2085 && ckWARN(WARN_EXEC)
2086 && OP_HAS_SIBLING(sib))
2088 const OPCODE type = OP_SIBLING(sib)->op_type;
2089 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2090 const line_t oldline = CopLINE(PL_curcop);
2091 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2092 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2093 "Statement unlikely to be reached");
2094 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2095 "\t(Maybe you meant system() when you said exec()?)\n");
2096 CopLINE_set(PL_curcop, oldline);
2103 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2104 GV * const gv = cGVOPo_gv;
2105 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2106 /* XXX could check prototype here instead of just carping */
2107 SV * const sv = sv_newmortal();
2108 gv_efullname3(sv, gv, NULL);
2109 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2110 "%"SVf"() called too early to check prototype",
2117 if (cSVOPo->op_private & OPpCONST_STRICT)
2118 no_bareword_allowed(o);
2122 op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2127 /* Relocate all the METHOP's SVs to the pad for thread safety. */
2128 case OP_METHOD_NAMED:
2129 op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2141 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2144 rop = (UNOP*)((BINOP*)o)->op_first;
2149 S_scalar_slice_warning(aTHX_ o);
2153 kid = OP_SIBLING(cLISTOPo->op_first);
2154 if (/* I bet there's always a pushmark... */
2155 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2156 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2161 key_op = (SVOP*)(kid->op_type == OP_CONST
2163 : OP_SIBLING(kLISTOP->op_first));
2165 rop = (UNOP*)((LISTOP*)o)->op_last;
2168 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2170 else if (rop->op_first->op_type == OP_PADSV)
2171 /* @$hash{qw(keys here)} */
2172 rop = (UNOP*)rop->op_first;
2174 /* @{$hash}{qw(keys here)} */
2175 if (rop->op_first->op_type == OP_SCOPE
2176 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2178 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2184 lexname = NULL; /* just to silence compiler warnings */
2185 fields = NULL; /* just to silence compiler warnings */
2189 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2190 SvPAD_TYPED(lexname))
2191 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2192 && isGV(*fields) && GvHV(*fields);
2194 key_op = (SVOP*)OP_SIBLING(key_op)) {
2196 if (key_op->op_type != OP_CONST)
2198 svp = cSVOPx_svp(key_op);
2200 /* Make the CONST have a shared SV */
2201 if ((!SvIsCOW_shared_hash(sv = *svp))
2202 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2204 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2205 SV *nsv = newSVpvn_share(key,
2206 SvUTF8(sv) ? -keylen : keylen, 0);
2207 SvREFCNT_dec_NN(sv);
2212 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2213 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2214 "in variable %"SVf" of type %"HEKf,
2215 SVfARG(*svp), SVfARG(lexname),
2216 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2222 S_scalar_slice_warning(aTHX_ o);
2226 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2227 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2234 if (o->op_flags & OPf_KIDS) {
2238 /* check that op_last points to the last sibling, and that
2239 * the last op_sibling field points back to the parent, and
2240 * that the only ops with KIDS are those which are entitled to
2242 U32 type = o->op_type;
2246 if (type == OP_NULL) {
2248 /* ck_glob creates a null UNOP with ex-type GLOB
2249 * (which is a list op. So pretend it wasn't a listop */
2250 if (type == OP_GLOB)
2253 family = PL_opargs[type] & OA_CLASS_MASK;
2255 has_last = ( family == OA_BINOP
2256 || family == OA_LISTOP
2257 || family == OA_PMOP
2258 || family == OA_LOOP
2260 assert( has_last /* has op_first and op_last, or ...
2261 ... has (or may have) op_first: */
2262 || family == OA_UNOP
2263 || family == OA_LOGOP
2264 || family == OA_BASEOP_OR_UNOP
2265 || family == OA_FILESTATOP
2266 || family == OA_LOOPEXOP
2267 || family == OA_METHOP
2268 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2269 || type == OP_SASSIGN
2270 || type == OP_CUSTOM
2271 || type == OP_NULL /* new_logop does this */
2273 /* XXX list form of 'x' is has a null op_last. This is wrong,
2274 * but requires too much hacking (e.g. in Deparse) to fix for
2276 if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2281 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2282 # ifdef PERL_OP_PARENT
2283 if (!OP_HAS_SIBLING(kid)) {
2285 assert(kid == cLISTOPo->op_last);
2286 assert(kid->op_sibling == o);
2289 if (OP_HAS_SIBLING(kid)) {
2290 assert(!kid->op_lastsib);
2293 assert(kid->op_lastsib);
2295 assert(kid == cLISTOPo->op_last);
2301 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2307 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2309 Propagate lvalue ("modifiable") context to an op and its children.
2310 I<type> represents the context type, roughly based on the type of op that
2311 would do the modifying, although C<local()> is represented by OP_NULL,
2312 because it has no op type of its own (it is signalled by a flag on
2315 This function detects things that can't be modified, such as C<$x+1>, and
2316 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2317 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2319 It also flags things that need to behave specially in an lvalue context,
2320 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2326 S_vivifies(const OPCODE type)
2329 case OP_RV2AV: case OP_ASLICE:
2330 case OP_RV2HV: case OP_KVASLICE:
2331 case OP_RV2SV: case OP_HSLICE:
2332 case OP_AELEMFAST: case OP_KVHSLICE:
2341 S_lvref(pTHX_ OP *o, I32 type)
2344 switch (o->op_type) {
2346 for (kid = OP_SIBLING(cUNOPo->op_first); kid;
2347 kid = OP_SIBLING(kid))
2348 S_lvref(aTHX_ kid, type);
2353 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2354 o->op_flags |= OPf_STACKED;
2355 if (o->op_flags & OPf_PARENS) {
2356 if (o->op_private & OPpLVAL_INTRO) {
2357 /* diag_listed_as: Can't modify %s in %s */
2358 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2359 "localized parenthesized array in list assignment"));
2363 o->op_type = OP_LVAVREF;
2364 o->op_ppaddr = PL_ppaddr[OP_LVAVREF];
2365 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2366 o->op_flags |= OPf_MOD|OPf_REF;
2369 o->op_private |= OPpLVREF_AV;
2372 kid = cUNOPo->op_first;
2373 if (kid->op_type == OP_NULL)
2374 kid = cUNOPx(kUNOP->op_first->op_sibling)
2376 o->op_private = OPpLVREF_CV;
2377 if (kid->op_type == OP_GV)
2378 o->op_flags |= OPf_STACKED;
2379 else if (kid->op_type == OP_PADCV) {
2380 o->op_targ = kid->op_targ;
2382 op_free(cUNOPo->op_first);
2383 cUNOPo->op_first = NULL;
2384 o->op_flags &=~ OPf_KIDS;
2389 if (o->op_flags & OPf_PARENS) {
2391 /* diag_listed_as: Can't modify %s in %s */
2392 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2393 "parenthesized hash in list assignment"));
2396 o->op_private |= OPpLVREF_HV;
2400 if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2401 o->op_flags |= OPf_STACKED;
2404 if (o->op_flags & OPf_PARENS) goto parenhash;
2405 o->op_private |= OPpLVREF_HV;
2408 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2411 PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2412 if (o->op_flags & OPf_PARENS) goto slurpy;
2413 o->op_private |= OPpLVREF_AV;
2417 o->op_private |= OPpLVREF_ELEM;
2418 o->op_flags |= OPf_STACKED;
2422 o->op_type = OP_LVREFSLICE;
2423 o->op_ppaddr = PL_ppaddr[OP_LVREFSLICE];
2424 o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2427 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2429 else if (!(o->op_flags & OPf_KIDS))
2431 if (o->op_targ != OP_LIST) {
2432 S_lvref(aTHX_ cBINOPo->op_first, type);
2437 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2438 assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2439 S_lvref(aTHX_ kid, type);
2443 if (o->op_flags & OPf_PARENS)
2448 /* diag_listed_as: Can't modify %s in %s */
2449 yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2450 o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2456 o->op_type = OP_LVREF;
2457 o->op_ppaddr = PL_ppaddr[OP_LVREF];
2459 OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2460 if (type == OP_ENTERLOOP)
2461 o->op_private |= OPpLVREF_ITER;
2465 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2469 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2472 if (!o || (PL_parser && PL_parser->error_count))
2475 if ((o->op_private & OPpTARGET_MY)
2476 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2481 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2483 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2485 switch (o->op_type) {
2490 if ((o->op_flags & OPf_PARENS))
2494 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2495 !(o->op_flags & OPf_STACKED)) {
2496 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2497 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2498 assert(cUNOPo->op_first->op_type == OP_NULL);
2499 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2502 else { /* lvalue subroutine call */
2503 o->op_private |= OPpLVAL_INTRO;
2504 PL_modcount = RETURN_UNLIMITED_NUMBER;
2505 if (type == OP_GREPSTART || type == OP_ENTERSUB
2506 || type == OP_REFGEN || type == OP_LEAVESUBLV) {
2507 /* Potential lvalue context: */
2508 o->op_private |= OPpENTERSUB_INARGS;
2511 else { /* Compile-time error message: */
2512 OP *kid = cUNOPo->op_first;
2516 if (kid->op_type != OP_PUSHMARK) {
2517 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2519 "panic: unexpected lvalue entersub "
2520 "args: type/targ %ld:%"UVuf,
2521 (long)kid->op_type, (UV)kid->op_targ);
2522 kid = kLISTOP->op_first;
2524 while (OP_HAS_SIBLING(kid))
2525 kid = OP_SIBLING(kid);
2526 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2527 break; /* Postpone until runtime */
2530 kid = kUNOP->op_first;
2531 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2532 kid = kUNOP->op_first;
2533 if (kid->op_type == OP_NULL)
2535 "Unexpected constant lvalue entersub "
2536 "entry via type/targ %ld:%"UVuf,
2537 (long)kid->op_type, (UV)kid->op_targ);
2538 if (kid->op_type != OP_GV) {
2545 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2546 ? MUTABLE_CV(SvRV(gv))
2557 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2558 /* grep, foreach, subcalls, refgen */
2559 if (type == OP_GREPSTART || type == OP_ENTERSUB
2560 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2562 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2563 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2565 : (o->op_type == OP_ENTERSUB
2566 ? "non-lvalue subroutine call"
2568 type ? PL_op_desc[type] : "local"));
2582 case OP_RIGHT_SHIFT:
2591 if (!(o->op_flags & OPf_STACKED))
2598 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2599 op_lvalue(kid, type);
2604 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2605 PL_modcount = RETURN_UNLIMITED_NUMBER;
2606 return o; /* Treat \(@foo) like ordinary list. */
2610 if (scalar_mod_type(o, type))
2612 ref(cUNOPo->op_first, o->op_type);
2619 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2620 if (type == OP_LEAVESUBLV && (
2621 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2622 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2624 o->op_private |= OPpMAYBE_LVSUB;
2628 PL_modcount = RETURN_UNLIMITED_NUMBER;
2632 if (type == OP_LEAVESUBLV)
2633 o->op_private |= OPpMAYBE_LVSUB;
2636 PL_hints |= HINT_BLOCK_SCOPE;
2637 if (type == OP_LEAVESUBLV)
2638 o->op_private |= OPpMAYBE_LVSUB;
2642 ref(cUNOPo->op_first, o->op_type);
2646 PL_hints |= HINT_BLOCK_SCOPE;
2656 case OP_AELEMFAST_LEX:
2663 PL_modcount = RETURN_UNLIMITED_NUMBER;
2664 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2665 return o; /* Treat \(@foo) like ordinary list. */
2666 if (scalar_mod_type(o, type))
2668 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2669 && type == OP_LEAVESUBLV)
2670 o->op_private |= OPpMAYBE_LVSUB;
2674 if (!type) /* local() */
2675 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2676 PAD_COMPNAME_SV(o->op_targ));
2685 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2689 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2695 if (type == OP_LEAVESUBLV)
2696 o->op_private |= OPpMAYBE_LVSUB;
2697 if (o->op_flags & OPf_KIDS)
2698 op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2703 ref(cBINOPo->op_first, o->op_type);
2704 if (type == OP_ENTERSUB &&
2705 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2706 o->op_private |= OPpLVAL_DEFER;
2707 if (type == OP_LEAVESUBLV)
2708 o->op_private |= OPpMAYBE_LVSUB;
2715 o->op_private |= OPpLVALUE;
2721 if (o->op_flags & OPf_KIDS)
2722 op_lvalue(cLISTOPo->op_last, type);
2727 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2729 else if (!(o->op_flags & OPf_KIDS))
2731 if (o->op_targ != OP_LIST) {
2732 op_lvalue(cBINOPo->op_first, type);
2738 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2739 /* elements might be in void context because the list is
2740 in scalar context or because they are attribute sub calls */
2741 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2742 op_lvalue(kid, type);
2750 if (type == OP_LEAVESUBLV
2751 || !S_vivifies(cLOGOPo->op_first->op_type))
2752 op_lvalue(cLOGOPo->op_first, type);
2753 if (type == OP_LEAVESUBLV
2754 || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2755 op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2759 if (type != OP_AASSIGN && type != OP_SASSIGN
2760 && type != OP_ENTERLOOP)
2762 /* Don’t bother applying lvalue context to the ex-list. */
2763 kid = cUNOPx(cUNOPo->op_first)->op_first;
2764 assert (!OP_HAS_SIBLING(kid));
2767 if (type != OP_AASSIGN) goto nomod;
2768 kid = cUNOPo->op_first;
2771 const U8 ec = PL_parser ? PL_parser->error_count : 0;
2772 S_lvref(aTHX_ kid, type);
2773 if (!PL_parser || PL_parser->error_count == ec) {
2774 if (!FEATURE_LVREF_IS_ENABLED)
2776 "Experimental lvalue references not enabled");
2777 Perl_ck_warner_d(aTHX_
2778 packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
2779 "Lvalue references are experimental");
2782 if (o->op_type == OP_REFGEN)
2783 op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
2788 /* [20011101.069] File test operators interpret OPf_REF to mean that
2789 their argument is a filehandle; thus \stat(".") should not set
2791 if (type == OP_REFGEN &&
2792 PL_check[o->op_type] == Perl_ck_ftst)
2795 if (type != OP_LEAVESUBLV)
2796 o->op_flags |= OPf_MOD;
2798 if (type == OP_AASSIGN || type == OP_SASSIGN)
2799 o->op_flags |= OPf_SPECIAL|OPf_REF;
2800 else if (!type) { /* local() */
2803 o->op_private |= OPpLVAL_INTRO;
2804 o->op_flags &= ~OPf_SPECIAL;
2805 PL_hints |= HINT_BLOCK_SCOPE;
2810 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2811 "Useless localization of %s", OP_DESC(o));
2814 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2815 && type != OP_LEAVESUBLV)
2816 o->op_flags |= OPf_REF;
2821 S_scalar_mod_type(const OP *o, I32 type)
2826 if (o && o->op_type == OP_RV2GV)
2850 case OP_RIGHT_SHIFT:
2871 S_is_handle_constructor(const OP *o, I32 numargs)
2873 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2875 switch (o->op_type) {
2883 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2896 S_refkids(pTHX_ OP *o, I32 type)
2898 if (o && o->op_flags & OPf_KIDS) {
2900 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2907 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2912 PERL_ARGS_ASSERT_DOREF;
2914 if (!o || (PL_parser && PL_parser->error_count))
2917 switch (o->op_type) {
2919 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2920 !(o->op_flags & OPf_STACKED)) {
2921 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2922 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2923 assert(cUNOPo->op_first->op_type == OP_NULL);
2924 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2925 o->op_flags |= OPf_SPECIAL;
2927 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2928 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2929 : type == OP_RV2HV ? OPpDEREF_HV
2931 o->op_flags |= OPf_MOD;
2937 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2938 doref(kid, type, set_op_ref);
2941 if (type == OP_DEFINED)
2942 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2943 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2946 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2947 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2948 : type == OP_RV2HV ? OPpDEREF_HV
2950 o->op_flags |= OPf_MOD;
2957 o->op_flags |= OPf_REF;
2960 if (type == OP_DEFINED)
2961 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2962 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2968 o->op_flags |= OPf_REF;
2973 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2975 doref(cBINOPo->op_first, type, set_op_ref);
2979 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2980 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2981 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2982 : type == OP_RV2HV ? OPpDEREF_HV
2984 o->op_flags |= OPf_MOD;
2994 if (!(o->op_flags & OPf_KIDS))
2996 doref(cLISTOPo->op_last, type, set_op_ref);
3006 S_dup_attrlist(pTHX_ OP *o)
3010 PERL_ARGS_ASSERT_DUP_ATTRLIST;
3012 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3013 * where the first kid is OP_PUSHMARK and the remaining ones
3014 * are OP_CONST. We need to push the OP_CONST values.
3016 if (o->op_type == OP_CONST)
3017 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3019 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3021 for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
3022 if (o->op_type == OP_CONST)
3023 rop = op_append_elem(OP_LIST, rop,
3024 newSVOP(OP_CONST, o->op_flags,
3025 SvREFCNT_inc_NN(cSVOPo->op_sv)));
3032 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3034 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3036 PERL_ARGS_ASSERT_APPLY_ATTRS;
3038 /* fake up C<use attributes $pkg,$rv,@attrs> */
3040 #define ATTRSMODULE "attributes"
3041 #define ATTRSMODULE_PM "attributes.pm"
3043 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3044 newSVpvs(ATTRSMODULE),
3046 op_prepend_elem(OP_LIST,
3047 newSVOP(OP_CONST, 0, stashsv),
3048 op_prepend_elem(OP_LIST,
3049 newSVOP(OP_CONST, 0,
3051 dup_attrlist(attrs))));
3055 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3057 OP *pack, *imop, *arg;
3058 SV *meth, *stashsv, **svp;
3060 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3065 assert(target->op_type == OP_PADSV ||
3066 target->op_type == OP_PADHV ||
3067 target->op_type == OP_PADAV);
3069 /* Ensure that attributes.pm is loaded. */
3070 /* Don't force the C<use> if we don't need it. */
3071 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3072 if (svp && *svp != &PL_sv_undef)
3073 NOOP; /* already in %INC */
3075 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3076 newSVpvs(ATTRSMODULE), NULL);
3078 /* Need package name for method call. */
3079 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3081 /* Build up the real arg-list. */
3082 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3084 arg = newOP(OP_PADSV, 0);
3085 arg->op_targ = target->op_targ;
3086 arg = op_prepend_elem(OP_LIST,
3087 newSVOP(OP_CONST, 0, stashsv),
3088 op_prepend_elem(OP_LIST,
3089 newUNOP(OP_REFGEN, 0,
3090 op_lvalue(arg, OP_REFGEN)),
3091 dup_attrlist(attrs)));
3093 /* Fake up a method call to import */
3094 meth = newSVpvs_share("import");
3095 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3096 op_append_elem(OP_LIST,
3097 op_prepend_elem(OP_LIST, pack, list(arg)),
3098 newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3100 /* Combine the ops. */
3101 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3105 =notfor apidoc apply_attrs_string
3107 Attempts to apply a list of attributes specified by the C<attrstr> and
3108 C<len> arguments to the subroutine identified by the C<cv> argument which
3109 is expected to be associated with the package identified by the C<stashpv>
3110 argument (see L<attributes>). It gets this wrong, though, in that it
3111 does not correctly identify the boundaries of the individual attribute
3112 specifications within C<attrstr>. This is not really intended for the
3113 public API, but has to be listed here for systems such as AIX which
3114 need an explicit export list for symbols. (It's called from XS code
3115 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
3116 to respect attribute syntax properly would be welcome.
3122 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3123 const char *attrstr, STRLEN len)
3127 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3130 len = strlen(attrstr);
3134 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3136 const char * const sstr = attrstr;
3137 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3138 attrs = op_append_elem(OP_LIST, attrs,
3139 newSVOP(OP_CONST, 0,
3140 newSVpvn(sstr, attrstr-sstr)));
3144 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3145 newSVpvs(ATTRSMODULE),
3146 NULL, op_prepend_elem(OP_LIST,
3147 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3148 op_prepend_elem(OP_LIST,
3149 newSVOP(OP_CONST, 0,
3150 newRV(MUTABLE_SV(cv))),
3155 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3157 OP *new_proto = NULL;
3162 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3168 if (o->op_type == OP_CONST) {
3169 pv = SvPV(cSVOPo_sv, pvlen);
3170 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3171 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3172 SV ** const tmpo = cSVOPx_svp(o);
3173 SvREFCNT_dec(cSVOPo_sv);
3178 } else if (o->op_type == OP_LIST) {
3180 assert(o->op_flags & OPf_KIDS);
3181 lasto = cLISTOPo->op_first;
3182 assert(lasto->op_type == OP_PUSHMARK);
3183 for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3184 if (o->op_type == OP_CONST) {
3185 pv = SvPV(cSVOPo_sv, pvlen);
3186 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3187 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3188 SV ** const tmpo = cSVOPx_svp(o);
3189 SvREFCNT_dec(cSVOPo_sv);
3191 if (new_proto && ckWARN(WARN_MISC)) {
3193 const char * newp = SvPV(cSVOPo_sv, new_len);
3194 Perl_warner(aTHX_ packWARN(WARN_MISC),
3195 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3196 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3202 /* excise new_proto from the list */
3203 op_sibling_splice(*attrs, lasto, 1, NULL);
3210 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3211 would get pulled in with no real need */
3212 if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3221 svname = sv_newmortal();
3222 gv_efullname3(svname, name, NULL);
3224 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3225 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3227 svname = (SV *)name;
3228 if (ckWARN(WARN_ILLEGALPROTO))
3229 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3230 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3231 STRLEN old_len, new_len;
3232 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3233 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3235 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3236 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3238 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3239 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3249 S_cant_declare(pTHX_ OP *o)
3251 if (o->op_type == OP_NULL
3252 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3253 o = cUNOPo->op_first;
3254 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3255 o->op_type == OP_NULL
3256 && o->op_flags & OPf_SPECIAL
3259 PL_parser->in_my == KEY_our ? "our" :
3260 PL_parser->in_my == KEY_state ? "state" :
3265 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3268 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3270 PERL_ARGS_ASSERT_MY_KID;
3272 if (!o || (PL_parser && PL_parser->error_count))
3277 if (type == OP_LIST) {
3279 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3280 my_kid(kid, attrs, imopsp);
3282 } else if (type == OP_UNDEF || type == OP_STUB) {
3284 } else if (type == OP_RV2SV || /* "our" declaration */
3286 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3287 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3288 S_cant_declare(aTHX_ o);
3290 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3292 PL_parser->in_my = FALSE;
3293 PL_parser->in_my_stash = NULL;
3294 apply_attrs(GvSTASH(gv),
3295 (type == OP_RV2SV ? GvSV(gv) :
3296 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3297 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3300 o->op_private |= OPpOUR_INTRO;
3303 else if (type != OP_PADSV &&
3306 type != OP_PUSHMARK)
3308 S_cant_declare(aTHX_ o);
3311 else if (attrs && type != OP_PUSHMARK) {
3315 PL_parser->in_my = FALSE;
3316 PL_parser->in_my_stash = NULL;
3318 /* check for C<my Dog $spot> when deciding package */
3319 stash = PAD_COMPNAME_TYPE(o->op_targ);
3321 stash = PL_curstash;
3322 apply_attrs_my(stash, o, attrs, imopsp);
3324 o->op_flags |= OPf_MOD;
3325 o->op_private |= OPpLVAL_INTRO;
3327 o->op_private |= OPpPAD_STATE;
3332 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3335 int maybe_scalar = 0;
3337 PERL_ARGS_ASSERT_MY_ATTRS;
3339 /* [perl #17376]: this appears to be premature, and results in code such as
3340 C< our(%x); > executing in list mode rather than void mode */
3342 if (o->op_flags & OPf_PARENS)
3352 o = my_kid(o, attrs, &rops);
3354 if (maybe_scalar && o->op_type == OP_PADSV) {
3355 o = scalar(op_append_list(OP_LIST, rops, o));
3356 o->op_private |= OPpLVAL_INTRO;
3359 /* The listop in rops might have a pushmark at the beginning,
3360 which will mess up list assignment. */
3361 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3362 if (rops->op_type == OP_LIST &&
3363 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3365 OP * const pushmark = lrops->op_first;
3366 /* excise pushmark */
3367 op_sibling_splice(rops, NULL, 1, NULL);
3370 o = op_append_list(OP_LIST, o, rops);
3373 PL_parser->in_my = FALSE;
3374 PL_parser->in_my_stash = NULL;
3379 Perl_sawparens(pTHX_ OP *o)
3381 PERL_UNUSED_CONTEXT;
3383 o->op_flags |= OPf_PARENS;
3388 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3392 const OPCODE ltype = left->op_type;
3393 const OPCODE rtype = right->op_type;
3395 PERL_ARGS_ASSERT_BIND_MATCH;
3397 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3398 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3400 const char * const desc
3402 rtype == OP_SUBST || rtype == OP_TRANS
3403 || rtype == OP_TRANSR
3405 ? (int)rtype : OP_MATCH];
3406 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3408 S_op_varname(aTHX_ left);
3410 Perl_warner(aTHX_ packWARN(WARN_MISC),
3411 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3412 desc, SVfARG(name), SVfARG(name));
3414 const char * const sample = (isary
3415 ? "@array" : "%hash");
3416 Perl_warner(aTHX_ packWARN(WARN_MISC),
3417 "Applying %s to %s will act on scalar(%s)",
3418 desc, sample, sample);
3422 if (rtype == OP_CONST &&
3423 cSVOPx(right)->op_private & OPpCONST_BARE &&
3424 cSVOPx(right)->op_private & OPpCONST_STRICT)
3426 no_bareword_allowed(right);
3429 /* !~ doesn't make sense with /r, so error on it for now */
3430 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3432 /* diag_listed_as: Using !~ with %s doesn't make sense */
3433 yyerror("Using !~ with s///r doesn't make sense");
3434 if (rtype == OP_TRANSR && type == OP_NOT)
3435 /* diag_listed_as: Using !~ with %s doesn't make sense */
3436 yyerror("Using !~ with tr///r doesn't make sense");
3438 ismatchop = (rtype == OP_MATCH ||
3439 rtype == OP_SUBST ||
3440 rtype == OP_TRANS || rtype == OP_TRANSR)
3441 && !(right->op_flags & OPf_SPECIAL);
3442 if (ismatchop && right->op_private & OPpTARGET_MY) {
3444 right->op_private &= ~OPpTARGET_MY;
3446 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3449 right->op_flags |= OPf_STACKED;
3450 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3451 ! (rtype == OP_TRANS &&
3452 right->op_private & OPpTRANS_IDENTICAL) &&
3453 ! (rtype == OP_SUBST &&
3454 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3455 newleft = op_lvalue(left, rtype);
3458 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3459 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3461 o = op_prepend_elem(rtype, scalar(newleft), right);
3463 return newUNOP(OP_NOT, 0, scalar(o));
3467 return bind_match(type, left,
3468 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3472 Perl_invert(pTHX_ OP *o)
3476 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3480 =for apidoc Amx|OP *|op_scope|OP *o
3482 Wraps up an op tree with some additional ops so that at runtime a dynamic
3483 scope will be created. The original ops run in the new dynamic scope,
3484 and then, provided that they exit normally, the scope will be unwound.
3485 The additional ops used to create and unwind the dynamic scope will
3486 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3487 instead if the ops are simple enough to not need the full dynamic scope
3494 Perl_op_scope(pTHX_ OP *o)
3498 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3499 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3500 o->op_type = OP_LEAVE;
3501 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3503 else if (o->op_type == OP_LINESEQ) {
3505 o->op_type = OP_SCOPE;
3506 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3507 kid = ((LISTOP*)o)->op_first;
3508 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3511 /* The following deals with things like 'do {1 for 1}' */
3512 kid = OP_SIBLING(kid);
3514 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3519 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3525 Perl_op_unscope(pTHX_ OP *o)
3527 if (o && o->op_type == OP_LINESEQ) {
3528 OP *kid = cLISTOPo->op_first;
3529 for(; kid; kid = OP_SIBLING(kid))
3530 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3537 Perl_block_start(pTHX_ int full)
3539 const int retval = PL_savestack_ix;
3541 pad_block_start(full);
3543 PL_hints &= ~HINT_BLOCK_SCOPE;
3544 SAVECOMPILEWARNINGS();
3545 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3547 CALL_BLOCK_HOOKS(bhk_start, full);
3553 Perl_block_end(pTHX_ I32 floor, OP *seq)
3555 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3556 OP* retval = scalarseq(seq);
3559 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3563 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3567 /* pad_leavemy has created a sequence of introcv ops for all my
3568 subs declared in the block. We have to replicate that list with
3569 clonecv ops, to deal with this situation:
3574 sub s1 { state sub foo { \&s2 } }
3577 Originally, I was going to have introcv clone the CV and turn
3578 off the stale flag. Since &s1 is declared before &s2, the
3579 introcv op for &s1 is executed (on sub entry) before the one for
3580 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3581 cloned, since it is a state sub) closes over &s2 and expects
3582 to see it in its outer CV’s pad. If the introcv op clones &s1,
3583 then &s2 is still marked stale. Since &s1 is not active, and
3584 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3585 ble will not stay shared’ warning. Because it is the same stub
3586 that will be used when the introcv op for &s2 is executed, clos-
3587 ing over it is safe. Hence, we have to turn off the stale flag
3588 on all lexical subs in the block before we clone any of them.
3589 Hence, having introcv clone the sub cannot work. So we create a
3590 list of ops like this:
3614 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3615 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3616 for (;; kid = OP_SIBLING(kid)) {
3617 OP *newkid = newOP(OP_CLONECV, 0);
3618 newkid->op_targ = kid->op_targ;
3619 o = op_append_elem(OP_LINESEQ, o, newkid);
3620 if (kid == last) break;
3622 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3625 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3631 =head1 Compile-time scope hooks
3633 =for apidoc Aox||blockhook_register
3635 Register a set of hooks to be called when the Perl lexical scope changes
3636 at compile time. See L<perlguts/"Compile-time scope hooks">.
3642 Perl_blockhook_register(pTHX_ BHK *hk)
3644 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3646 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3652 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3653 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3654 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3657 OP * const o = newOP(OP_PADSV, 0);
3658 o->op_targ = offset;
3664 Perl_newPROG(pTHX_ OP *o)
3666 PERL_ARGS_ASSERT_NEWPROG;
3673 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3674 ((PL_in_eval & EVAL_KEEPERR)
3675 ? OPf_SPECIAL : 0), o);
3677 cx = &cxstack[cxstack_ix];
3678 assert(CxTYPE(cx) == CXt_EVAL);
3680 if ((cx->blk_gimme & G_WANT) == G_VOID)
3681 scalarvoid(PL_eval_root);
3682 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3685 scalar(PL_eval_root);
3687 PL_eval_start = op_linklist(PL_eval_root);
3688 PL_eval_root->op_private |= OPpREFCOUNTED;
3689 OpREFCNT_set(PL_eval_root, 1);
3690 PL_eval_root->op_next = 0;
3691 i = PL_savestack_ix;
3694 CALL_PEEP(PL_eval_start);
3695 finalize_optree(PL_eval_root);
3696 S_prune_chain_head(&PL_eval_start);
3698 PL_savestack_ix = i;
3701 if (o->op_type == OP_STUB) {
3702 /* This block is entered if nothing is compiled for the main
3703 program. This will be the case for an genuinely empty main
3704 program, or one which only has BEGIN blocks etc, so already
3707 Historically (5.000) the guard above was !o. However, commit
3708 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3709 c71fccf11fde0068, changed perly.y so that newPROG() is now
3710 called with the output of block_end(), which returns a new
3711 OP_STUB for the case of an empty optree. ByteLoader (and
3712 maybe other things) also take this path, because they set up
3713 PL_main_start and PL_main_root directly, without generating an
3716 If the parsing the main program aborts (due to parse errors,
3717 or due to BEGIN or similar calling exit), then newPROG()
3718 isn't even called, and hence this code path and its cleanups
3719 are skipped. This shouldn't make a make a difference:
3720 * a non-zero return from perl_parse is a failure, and
3721 perl_destruct() should be called immediately.
3722 * however, if exit(0) is called during the parse, then
3723 perl_parse() returns 0, and perl_run() is called. As
3724 PL_main_start will be NULL, perl_run() will return
3725 promptly, and the exit code will remain 0.
3728 PL_comppad_name = 0;
3730 S_op_destroy(aTHX_ o);
3733 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3734 PL_curcop = &PL_compiling;
3735 PL_main_start = LINKLIST(PL_main_root);
3736 PL_main_root->op_private |= OPpREFCOUNTED;
3737 OpREFCNT_set(PL_main_root, 1);
3738 PL_main_root->op_next = 0;
3739 CALL_PEEP(PL_main_start);
3740 finalize_optree(PL_main_root);
3741 S_prune_chain_head(&PL_main_start);
3742 cv_forget_slab(PL_compcv);
3745 /* Register with debugger */
3747 CV * const cv = get_cvs("DB::postponed", 0);
3751 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3753 call_sv(MUTABLE_SV(cv), G_DISCARD);
3760 Perl_localize(pTHX_ OP *o, I32 lex)
3762 PERL_ARGS_ASSERT_LOCALIZE;
3764 if (o->op_flags & OPf_PARENS)
3765 /* [perl #17376]: this appears to be premature, and results in code such as
3766 C< our(%x); > executing in list mode rather than void mode */
3773 if ( PL_parser->bufptr > PL_parser->oldbufptr
3774 && PL_parser->bufptr[-1] == ','
3775 && ckWARN(WARN_PARENTHESIS))
3777 char *s = PL_parser->bufptr;
3780 /* some heuristics to detect a potential error */
3781 while (*s && (strchr(", \t\n", *s)))
3785 if (*s && strchr("@$%*", *s) && *++s
3786 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3789 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3791 while (*s && (strchr(", \t\n", *s)))
3797 if (sigil && (*s == ';' || *s == '=')) {
3798 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3799 "Parentheses missing around \"%s\" list",
3801 ? (PL_parser->in_my == KEY_our
3803 : PL_parser->in_my == KEY_state
3813 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3814 PL_parser->in_my = FALSE;
3815 PL_parser->in_my_stash = NULL;
3820 Perl_jmaybe(pTHX_ OP *o)
3822 PERL_ARGS_ASSERT_JMAYBE;
3824 if (o->op_type == OP_LIST) {
3826 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3827 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3832 PERL_STATIC_INLINE OP *
3833 S_op_std_init(pTHX_ OP *o)
3835 I32 type = o->op_type;
3837 PERL_ARGS_ASSERT_OP_STD_INIT;
3839 if (PL_opargs[type] & OA_RETSCALAR)
3841 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3842 o->op_targ = pad_alloc(type, SVs_PADTMP);
3847 PERL_STATIC_INLINE OP *
3848 S_op_integerize(pTHX_ OP *o)
3850 I32 type = o->op_type;
3852 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3854 /* integerize op. */
3855 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3858 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3861 if (type == OP_NEGATE)
3862 /* XXX might want a ck_negate() for this */
3863 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3869 S_fold_constants(pTHX_ OP *o)
3874 VOL I32 type = o->op_type;
3880 SV * const oldwarnhook = PL_warnhook;
3881 SV * const olddiehook = PL_diehook;
3883 U8 oldwarn = PL_dowarn;
3886 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3888 if (!(PL_opargs[type] & OA_FOLDCONST))
3897 #ifdef USE_LOCALE_CTYPE
3898 if (IN_LC_COMPILETIME(LC_CTYPE))
3907 #ifdef USE_LOCALE_COLLATE
3908 if (IN_LC_COMPILETIME(LC_COLLATE))
3913 /* XXX what about the numeric ops? */
3914 #ifdef USE_LOCALE_NUMERIC
3915 if (IN_LC_COMPILETIME(LC_NUMERIC))
3920 if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3921 || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3924 SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3925 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3927 const char *s = SvPVX_const(sv);
3928 while (s < SvEND(sv)) {
3929 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
3936 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3939 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3940 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3944 if (PL_parser && PL_parser->error_count)
3945 goto nope; /* Don't try to run w/ errors */
3947 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3948 const OPCODE type = curop->op_type;
3949 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3951 type != OP_SCALAR &&
3953 type != OP_PUSHMARK)
3959 curop = LINKLIST(o);
3960 old_next = o->op_next;
3964 oldscope = PL_scopestack_ix;
3965 create_eval_scope(G_FAKINGEVAL);
3967 /* Verify that we don't need to save it: */
3968 assert(PL_curcop == &PL_compiling);
3969 StructCopy(&PL_compiling, ¬_compiling, COP);
3970 PL_curcop = ¬_compiling;
3971 /* The above ensures that we run with all the correct hints of the
3972 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3973 assert(IN_PERL_RUNTIME);
3974 PL_warnhook = PERL_WARNHOOK_FATAL;
3978 /* Effective $^W=1. */
3979 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
3980 PL_dowarn |= G_WARN_ON;
3985 sv = *(PL_stack_sp--);
3986 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3987 pad_swipe(o->op_targ, FALSE);
3989 else if (SvTEMP(sv)) { /* grab mortal temp? */
3990 SvREFCNT_inc_simple_void(sv);
3993 else { assert(SvIMMORTAL(sv)); }
3996 /* Something tried to die. Abandon constant folding. */
3997 /* Pretend the error never happened. */
3999 o->op_next = old_next;
4003 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
4004 PL_warnhook = oldwarnhook;
4005 PL_diehook = olddiehook;
4006 /* XXX note that this croak may fail as we've already blown away
4007 * the stack - eg any nested evals */
4008 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4011 PL_dowarn = oldwarn;
4012 PL_warnhook = oldwarnhook;
4013 PL_diehook = olddiehook;
4014 PL_curcop = &PL_compiling;
4016 if (PL_scopestack_ix > oldscope)
4017 delete_eval_scope();
4022 folded = o->op_folded;
4025 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
4026 else if (!SvIMMORTAL(sv)) {
4030 if (type == OP_RV2GV)
4031 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
4034 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4035 /* OP_STRINGIFY and constant folding are used to implement qq.
4036 Here the constant folding is an implementation detail that we
4037 want to hide. If the stringify op is itself already marked
4038 folded, however, then it is actually a folded join. */
4039 if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
4048 S_gen_constant_list(pTHX_ OP *o)
4052 const SSize_t oldtmps_floor = PL_tmps_floor;
4057 if (PL_parser && PL_parser->error_count)
4058 return o; /* Don't attempt to run with errors */
4060 curop = LINKLIST(o);
4063 S_prune_chain_head(&curop);
4065 Perl_pp_pushmark(aTHX);
4068 assert (!(curop->op_flags & OPf_SPECIAL));
4069 assert(curop->op_type == OP_RANGE);
4070 Perl_pp_anonlist(aTHX);
4071 PL_tmps_floor = oldtmps_floor;
4073 o->op_type = OP_RV2AV;
4074 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4075 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
4076 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
4077 o->op_opt = 0; /* needs to be revisited in rpeep() */
4078 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4080 /* replace subtree with an OP_CONST */
4081 curop = ((UNOP*)o)->op_first;
4082 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4085 if (AvFILLp(av) != -1)
4086 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4089 SvREADONLY_on(*svp);
4095 /* convert o (and any siblings) into a list if not already, then
4096 * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
4100 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
4103 if (type < 0) type = -type, flags |= OPf_SPECIAL;
4104 if (!o || o->op_type != OP_LIST)
4105 o = force_list(o, 0);
4107 o->op_flags &= ~OPf_WANT;
4109 if (!(PL_opargs[type] & OA_MARK))
4110 op_null(cLISTOPo->op_first);
4112 OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
4113 if (kid2 && kid2->op_type == OP_COREARGS) {
4114 op_null(cLISTOPo->op_first);
4115 kid2->op_private |= OPpCOREARGS_PUSHMARK;
4119 o->op_type = (OPCODE)type;
4120 o->op_ppaddr = PL_ppaddr[type];
4121 o->op_flags |= flags;
4123 o = CHECKOP(type, o);
4124 if (o->op_type != (unsigned)type)
4127 return fold_constants(op_integerize(op_std_init(o)));
4131 =head1 Optree Manipulation Functions
4134 /* List constructors */
4137 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4139 Append an item to the list of ops contained directly within a list-type
4140 op, returning the lengthened list. I<first> is the list-type op,
4141 and I<last> is the op to append to the list. I<optype> specifies the
4142 intended opcode for the list. If I<first> is not already a list of the
4143 right type, it will be upgraded into one. If either I<first> or I<last>
4144 is null, the other is returned unchanged.
4150 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4158 if (first->op_type != (unsigned)type
4159 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4161 return newLISTOP(type, 0, first, last);
4164 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4165 first->op_flags |= OPf_KIDS;
4170 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4172 Concatenate the lists of ops contained directly within two list-type ops,
4173 returning the combined list. I<first> and I<last> are the list-type ops
4174 to concatenate. I<optype> specifies the intended opcode for the list.
4175 If either I<first> or I<last> is not already a list of the right type,
4176 it will be upgraded into one. If either I<first> or I<last> is null,
4177 the other is returned unchanged.
4183 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4191 if (first->op_type != (unsigned)type)
4192 return op_prepend_elem(type, first, last);
4194 if (last->op_type != (unsigned)type)
4195 return op_append_elem(type, first, last);
4197 ((LISTOP*)first)->op_last->op_lastsib = 0;
4198 OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4199 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4200 ((LISTOP*)first)->op_last->op_lastsib = 1;
4201 #ifdef PERL_OP_PARENT
4202 ((LISTOP*)first)->op_last->op_sibling = first;
4204 first->op_flags |= (last->op_flags & OPf_KIDS);
4207 S_op_destroy(aTHX_ last);
4213 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4215 Prepend an item to the list of ops contained directly within a list-type
4216 op, returning the lengthened list. I<first> is the op to prepend to the
4217 list, and I<last> is the list-type op. I<optype> specifies the intended
4218 opcode for the list. If I<last> is not already a list of the right type,
4219 it will be upgraded into one. If either I<first> or I<last> is null,
4220 the other is returned unchanged.
4226 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4234 if (last->op_type == (unsigned)type) {
4235 if (type == OP_LIST) { /* already a PUSHMARK there */
4236 /* insert 'first' after pushmark */
4237 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4238 if (!(first->op_flags & OPf_PARENS))
4239 last->op_flags &= ~OPf_PARENS;
4242 op_sibling_splice(last, NULL, 0, first);
4243 last->op_flags |= OPf_KIDS;
4247 return newLISTOP(type, 0, first, last);
4254 =head1 Optree construction
4256 =for apidoc Am|OP *|newNULLLIST
4258 Constructs, checks, and returns a new C<stub> op, which represents an
4259 empty list expression.
4265 Perl_newNULLLIST(pTHX)
4267 return newOP(OP_STUB, 0);
4270 /* promote o and any siblings to be a list if its not already; i.e.
4278 * pushmark - o - A - B
4280 * If nullit it true, the list op is nulled.
4284 S_force_list(pTHX_ OP *o, bool nullit)
4286 if (!o || o->op_type != OP_LIST) {
4289 /* manually detach any siblings then add them back later */
4290 rest = OP_SIBLING(o);
4291 OP_SIBLING_set(o, NULL);
4294 o = newLISTOP(OP_LIST, 0, o, NULL);
4296 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4304 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4306 Constructs, checks, and returns an op of any list type. I<type> is
4307 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4308 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4309 supply up to two ops to be direct children of the list op; they are
4310 consumed by this function and become part of the constructed op tree.
4316 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4321 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4323 NewOp(1101, listop, 1, LISTOP);
4325 listop->op_type = (OPCODE)type;
4326 listop->op_ppaddr = PL_ppaddr[type];
4329 listop->op_flags = (U8)flags;
4333 else if (!first && last)
4336 OP_SIBLING_set(first, last);
4337 listop->op_first = first;
4338 listop->op_last = last;
4339 if (type == OP_LIST) {
4340 OP* const pushop = newOP(OP_PUSHMARK, 0);
4341 pushop->op_lastsib = 0;
4342 OP_SIBLING_set(pushop, first);
4343 listop->op_first = pushop;
4344 listop->op_flags |= OPf_KIDS;
4346 listop->op_last = pushop;
4349 first->op_lastsib = 0;
4350 if (listop->op_last) {
4351 listop->op_last->op_lastsib = 1;
4352 #ifdef PERL_OP_PARENT
4353 listop->op_last->op_sibling = (OP*)listop;
4357 return CHECKOP(type, listop);
4361 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4363 Constructs, checks, and returns an op of any base type (any type that
4364 has no extra fields). I<type> is the opcode. I<flags> gives the
4365 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4372 Perl_newOP(pTHX_ I32 type, I32 flags)
4377 if (type == -OP_ENTEREVAL) {
4378 type = OP_ENTEREVAL;
4379 flags |= OPpEVAL_BYTES<<8;
4382 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4383 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4384 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4385 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4387 NewOp(1101, o, 1, OP);
4388 o->op_type = (OPCODE)type;
4389 o->op_ppaddr = PL_ppaddr[type];
4390 o->op_flags = (U8)flags;
4393 o->op_private = (U8)(0 | (flags >> 8));
4394 if (PL_opargs[type] & OA_RETSCALAR)
4396 if (PL_opargs[type] & OA_TARGET)
4397 o->op_targ = pad_alloc(type, SVs_PADTMP);
4398 return CHECKOP(type, o);
4402 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4404 Constructs, checks, and returns an op of any unary type. I<type> is
4405 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4406 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4407 bits, the eight bits of C<op_private>, except that the bit with value 1
4408 is automatically set. I<first> supplies an optional op to be the direct
4409 child of the unary op; it is consumed by this function and become part
4410 of the constructed op tree.
4416 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4421 if (type == -OP_ENTEREVAL) {
4422 type = OP_ENTEREVAL;
4423 flags |= OPpEVAL_BYTES<<8;
4426 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4427 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4428 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4429 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4430 || type == OP_SASSIGN
4431 || type == OP_ENTERTRY
4432 || type == OP_NULL );
4435 first = newOP(OP_STUB, 0);
4436 if (PL_opargs[type] & OA_MARK)
4437 first = force_list(first, 1);
4439 NewOp(1101, unop, 1, UNOP);
4440 unop->op_type = (OPCODE)type;
4441 unop->op_ppaddr = PL_ppaddr[type];
4442 unop->op_first = first;
4443 unop->op_flags = (U8)(flags | OPf_KIDS);
4444 unop->op_private = (U8)(1 | (flags >> 8));
4446 #ifdef PERL_OP_PARENT
4447 if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4448 first->op_sibling = (OP*)unop;
4451 unop = (UNOP*) CHECKOP(type, unop);
4455 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4459 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4461 Constructs, checks, and returns an op of method type with a method name
4462 evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
4463 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4464 and, shifted up eight bits, the eight bits of C<op_private>, except that
4465 the bit with value 1 is automatically set. I<dynamic_meth> supplies an
4466 op which evaluates method name; it is consumed by this function and
4467 become part of the constructed op tree.
4468 Supported optypes: OP_METHOD.
4474 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4478 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP);
4480 NewOp(1101, methop, 1, METHOP);
4482 if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4483 methop->op_flags = (U8)(flags | OPf_KIDS);
4484 methop->op_u.op_first = dynamic_meth;
4485 methop->op_private = (U8)(1 | (flags >> 8));
4489 methop->op_flags = (U8)(flags & ~OPf_KIDS);
4490 methop->op_u.op_meth_sv = const_meth;
4491 methop->op_private = (U8)(0 | (flags >> 8));
4492 methop->op_next = (OP*)methop;
4495 methop->op_type = (OPCODE)type;
4496 methop->op_ppaddr = PL_ppaddr[type];
4497 methop = (METHOP*) CHECKOP(type, methop);
4499 if (methop->op_next) return (OP*)methop;
4501 return fold_constants(op_integerize(op_std_init((OP *) methop)));
4505 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4506 PERL_ARGS_ASSERT_NEWMETHOP;
4507 return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4511 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4513 Constructs, checks, and returns an op of method type with a constant
4514 method name. I<type> is the opcode. I<flags> gives the eight bits of
4515 C<op_flags>, and, shifted up eight bits, the eight bits of
4516 C<op_private>. I<const_meth> supplies a constant method name;
4517 it must be a shared COW string.
4518 Supported optypes: OP_METHOD_NAMED.
4524 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4525 PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4526 return newMETHOP_internal(type, flags, NULL, const_meth);
4530 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4532 Constructs, checks, and returns an op of any binary type. I<type>
4533 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4534 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4535 the eight bits of C<op_private>, except that the bit with value 1 or
4536 2 is automatically set as required. I<first> and I<last> supply up to
4537 two ops to be the direct children of the binary op; they are consumed
4538 by this function and become part of the constructed op tree.
4544 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4549 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4550 || type == OP_SASSIGN || type == OP_NULL );
4552 NewOp(1101, binop, 1, BINOP);
4555 first = newOP(OP_NULL, 0);
4557 binop->op_type = (OPCODE)type;
4558 binop->op_ppaddr = PL_ppaddr[type];
4559 binop->op_first = first;
4560 binop->op_flags = (U8)(flags | OPf_KIDS);
4563 binop->op_private = (U8)(1 | (flags >> 8));
4566 binop->op_private = (U8)(2 | (flags >> 8));
4567 OP_SIBLING_set(first, last);
4568 first->op_lastsib = 0;
4571 #ifdef PERL_OP_PARENT
4572 if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4573 last->op_sibling = (OP*)binop;
4576 binop->op_last = OP_SIBLING(binop->op_first);
4577 #ifdef PERL_OP_PARENT
4579 binop->op_last->op_sibling = (OP*)binop;
4582 binop = (BINOP*)CHECKOP(type, binop);
4583 if (binop->op_next || binop->op_type != (OPCODE)type)
4586 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4589 static int uvcompare(const void *a, const void *b)
4590 __attribute__nonnull__(1)
4591 __attribute__nonnull__(2)
4592 __attribute__pure__;
4593 static int uvcompare(const void *a, const void *b)
4595 if (*((const UV *)a) < (*(const UV *)b))
4597 if (*((const UV *)a) > (*(const UV *)b))
4599 if (*((const UV *)a+1) < (*(const UV *)b+1))
4601 if (*((const UV *)a+1) > (*(const UV *)b+1))
4607 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4609 SV * const tstr = ((SVOP*)expr)->op_sv;
4611 ((SVOP*)repl)->op_sv;
4614 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4615 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4621 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4622 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4623 I32 del = o->op_private & OPpTRANS_DELETE;
4626 PERL_ARGS_ASSERT_PMTRANS;
4628 PL_hints |= HINT_BLOCK_SCOPE;
4631 o->op_private |= OPpTRANS_FROM_UTF;
4634 o->op_private |= OPpTRANS_TO_UTF;
4636 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4637 SV* const listsv = newSVpvs("# comment\n");
4639 const U8* tend = t + tlen;
4640 const U8* rend = r + rlen;
4654 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4655 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4658 const U32 flags = UTF8_ALLOW_DEFAULT;
4662 t = tsave = bytes_to_utf8(t, &len);
4665 if (!to_utf && rlen) {
4667 r = rsave = bytes_to_utf8(r, &len);
4671 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4672 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4676 U8 tmpbuf[UTF8_MAXBYTES+1];
4679 Newx(cp, 2*tlen, UV);
4681 transv = newSVpvs("");
4683 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4685 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4687 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4691 cp[2*i+1] = cp[2*i];
4695 qsort(cp, i, 2*sizeof(UV), uvcompare);
4696 for (j = 0; j < i; j++) {
4698 diff = val - nextmin;
4700 t = uvchr_to_utf8(tmpbuf,nextmin);
4701 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4703 U8 range_mark = ILLEGAL_UTF8_BYTE;
4704 t = uvchr_to_utf8(tmpbuf, val - 1);
4705 sv_catpvn(transv, (char *)&range_mark, 1);
4706 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4713 t = uvchr_to_utf8(tmpbuf,nextmin);
4714 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4716 U8 range_mark = ILLEGAL_UTF8_BYTE;
4717 sv_catpvn(transv, (char *)&range_mark, 1);
4719 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4720 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4721 t = (const U8*)SvPVX_const(transv);
4722 tlen = SvCUR(transv);
4726 else if (!rlen && !del) {
4727 r = t; rlen = tlen; rend = tend;
4730 if ((!rlen && !del) || t == r ||
4731 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4733 o->op_private |= OPpTRANS_IDENTICAL;
4737 while (t < tend || tfirst <= tlast) {
4738 /* see if we need more "t" chars */
4739 if (tfirst > tlast) {
4740 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4742 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4744 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4751 /* now see if we need more "r" chars */
4752 if (rfirst > rlast) {
4754 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4756 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4758 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4767 rfirst = rlast = 0xffffffff;
4771 /* now see which range will peter our first, if either. */
4772 tdiff = tlast - tfirst;
4773 rdiff = rlast - rfirst;
4780 if (rfirst == 0xffffffff) {
4781 diff = tdiff; /* oops, pretend rdiff is infinite */
4783 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4784 (long)tfirst, (long)tlast);
4786 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4790 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4791 (long)tfirst, (long)(tfirst + diff),
4794 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4795 (long)tfirst, (long)rfirst);
4797 if (rfirst + diff > max)
4798 max = rfirst + diff;
4800 grows = (tfirst < rfirst &&
4801 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4813 else if (max > 0xff)
4818 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4820 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4821 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4822 PAD_SETSV(cPADOPo->op_padix, swash);
4824 SvREADONLY_on(swash);
4826 cSVOPo->op_sv = swash;
4828 SvREFCNT_dec(listsv);
4829 SvREFCNT_dec(transv);
4831 if (!del && havefinal && rlen)
4832 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4833 newSVuv((UV)final), 0);
4836 o->op_private |= OPpTRANS_GROWS;
4846 tbl = (short*)PerlMemShared_calloc(
4847 (o->op_private & OPpTRANS_COMPLEMENT) &&
4848 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4850 cPVOPo->op_pv = (char*)tbl;
4852 for (i = 0; i < (I32)tlen; i++)
4854 for (i = 0, j = 0; i < 256; i++) {
4856 if (j >= (I32)rlen) {
4865 if (i < 128 && r[j] >= 128)