4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
112 /* remove any leading "empty" ops from the op_next chain whose first
113 * node's address is stored in op_p. Store the updated address of the
114 * first node in op_p.
118 S_prune_chain_head(OP** op_p)
121 && ( (*op_p)->op_type == OP_NULL
122 || (*op_p)->op_type == OP_SCOPE
123 || (*op_p)->op_type == OP_SCALAR
124 || (*op_p)->op_type == OP_LINESEQ)
126 *op_p = (*op_p)->op_next;
130 /* See the explanatory comments above struct opslab in op.h. */
132 #ifdef PERL_DEBUG_READONLY_OPS
133 # define PERL_SLAB_SIZE 128
134 # define PERL_MAX_SLAB_SIZE 4096
135 # include <sys/mman.h>
138 #ifndef PERL_SLAB_SIZE
139 # define PERL_SLAB_SIZE 64
141 #ifndef PERL_MAX_SLAB_SIZE
142 # define PERL_MAX_SLAB_SIZE 2048
145 /* rounds up to nearest pointer */
146 #define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
147 #define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
150 S_new_slab(pTHX_ size_t sz)
152 #ifdef PERL_DEBUG_READONLY_OPS
153 OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
154 PROT_READ|PROT_WRITE,
155 MAP_ANON|MAP_PRIVATE, -1, 0);
156 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
157 (unsigned long) sz, slab));
158 if (slab == MAP_FAILED) {
159 perror("mmap failed");
162 slab->opslab_size = (U16)sz;
164 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
167 /* The context is unused in non-Windows */
170 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
174 /* requires double parens and aTHX_ */
175 #define DEBUG_S_warn(args) \
177 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
181 Perl_Slab_Alloc(pTHX_ size_t sz)
189 /* We only allocate ops from the slab during subroutine compilation.
190 We find the slab via PL_compcv, hence that must be non-NULL. It could
191 also be pointing to a subroutine which is now fully set up (CvROOT()
192 pointing to the top of the optree for that sub), or a subroutine
193 which isn't using the slab allocator. If our sanity checks aren't met,
194 don't use a slab, but allocate the OP directly from the heap. */
195 if (!PL_compcv || CvROOT(PL_compcv)
196 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
198 o = (OP*)PerlMemShared_calloc(1, sz);
202 /* While the subroutine is under construction, the slabs are accessed via
203 CvSTART(), to avoid needing to expand PVCV by one pointer for something
204 unneeded at runtime. Once a subroutine is constructed, the slabs are
205 accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
206 allocated yet. See the commit message for 8be227ab5eaa23f2 for more
208 if (!CvSTART(PL_compcv)) {
210 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
211 CvSLABBED_on(PL_compcv);
212 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
214 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
216 opsz = SIZE_TO_PSIZE(sz);
217 sz = opsz + OPSLOT_HEADER_P;
219 /* The slabs maintain a free list of OPs. In particular, constant folding
220 will free up OPs, so it makes sense to re-use them where possible. A
221 freed up slot is used in preference to a new allocation. */
222 if (slab->opslab_freed) {
223 OP **too = &slab->opslab_freed;
225 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
226 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
227 DEBUG_S_warn((aTHX_ "Alas! too small"));
228 o = *(too = &o->op_next);
229 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
233 Zero(o, opsz, I32 *);
239 #define INIT_OPSLOT \
240 slot->opslot_slab = slab; \
241 slot->opslot_next = slab2->opslab_first; \
242 slab2->opslab_first = slot; \
243 o = &slot->opslot_op; \
246 /* The partially-filled slab is next in the chain. */
247 slab2 = slab->opslab_next ? slab->opslab_next : slab;
248 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
249 /* Remaining space is too small. */
251 /* If we can fit a BASEOP, add it to the free chain, so as not
253 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
254 slot = &slab2->opslab_slots;
256 o->op_type = OP_FREED;
257 o->op_next = slab->opslab_freed;
258 slab->opslab_freed = o;
261 /* Create a new slab. Make this one twice as big. */
262 slot = slab2->opslab_first;
263 while (slot->opslot_next) slot = slot->opslot_next;
264 slab2 = S_new_slab(aTHX_
265 (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
267 : (DIFF(slab2, slot)+1)*2);
268 slab2->opslab_next = slab->opslab_next;
269 slab->opslab_next = slab2;
271 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
273 /* Create a new op slot */
274 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
275 assert(slot >= &slab2->opslab_slots);
276 if (DIFF(&slab2->opslab_slots, slot)
277 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
278 slot = &slab2->opslab_slots;
280 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
283 /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
285 assert(!o->op_sibling);
292 #ifdef PERL_DEBUG_READONLY_OPS
294 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
296 PERL_ARGS_ASSERT_SLAB_TO_RO;
298 if (slab->opslab_readonly) return;
299 slab->opslab_readonly = 1;
300 for (; slab; slab = slab->opslab_next) {
301 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
302 (unsigned long) slab->opslab_size, slab));*/
303 if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
304 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
305 (unsigned long)slab->opslab_size, errno);
310 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
314 PERL_ARGS_ASSERT_SLAB_TO_RW;
316 if (!slab->opslab_readonly) return;
318 for (; slab2; slab2 = slab2->opslab_next) {
319 /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
320 (unsigned long) size, slab2));*/
321 if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
322 PROT_READ|PROT_WRITE)) {
323 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
324 (unsigned long)slab2->opslab_size, errno);
327 slab->opslab_readonly = 0;
331 # define Slab_to_rw(op) NOOP
334 /* This cannot possibly be right, but it was copied from the old slab
335 allocator, to which it was originally added, without explanation, in
338 # define PerlMemShared PerlMem
342 Perl_Slab_Free(pTHX_ void *op)
344 OP * const o = (OP *)op;
347 PERL_ARGS_ASSERT_SLAB_FREE;
349 if (!o->op_slabbed) {
351 PerlMemShared_free(op);
356 /* If this op is already freed, our refcount will get screwy. */
357 assert(o->op_type != OP_FREED);
358 o->op_type = OP_FREED;
359 o->op_next = slab->opslab_freed;
360 slab->opslab_freed = o;
361 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
362 OpslabREFCNT_dec_padok(slab);
366 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
368 const bool havepad = !!PL_comppad;
369 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
372 PAD_SAVE_SETNULLPAD();
379 Perl_opslab_free(pTHX_ OPSLAB *slab)
382 PERL_ARGS_ASSERT_OPSLAB_FREE;
384 DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
385 assert(slab->opslab_refcnt == 1);
386 for (; slab; slab = slab2) {
387 slab2 = slab->opslab_next;
389 slab->opslab_refcnt = ~(size_t)0;
391 #ifdef PERL_DEBUG_READONLY_OPS
392 DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
394 if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
395 perror("munmap failed");
399 PerlMemShared_free(slab);
405 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
410 size_t savestack_count = 0;
412 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
415 for (slot = slab2->opslab_first;
417 slot = slot->opslot_next) {
418 if (slot->opslot_op.op_type != OP_FREED
419 && !(slot->opslot_op.op_savefree
425 assert(slot->opslot_op.op_slabbed);
426 op_free(&slot->opslot_op);
427 if (slab->opslab_refcnt == 1) goto free;
430 } while ((slab2 = slab2->opslab_next));
431 /* > 1 because the CV still holds a reference count. */
432 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
434 assert(savestack_count == slab->opslab_refcnt-1);
436 /* Remove the CV’s reference count. */
437 slab->opslab_refcnt--;
444 #ifdef PERL_DEBUG_READONLY_OPS
446 Perl_op_refcnt_inc(pTHX_ OP *o)
449 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
450 if (slab && slab->opslab_readonly) {
463 Perl_op_refcnt_dec(pTHX_ OP *o)
466 OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
468 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
470 if (slab && slab->opslab_readonly) {
472 result = --o->op_targ;
475 result = --o->op_targ;
481 * In the following definition, the ", (OP*)0" is just to make the compiler
482 * think the expression is of the right type: croak actually does a Siglongjmp.
484 #define CHECKOP(type,o) \
485 ((PL_op_mask && PL_op_mask[type]) \
486 ? ( op_free((OP*)o), \
487 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
489 : PL_check[type](aTHX_ (OP*)o))
491 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
493 #define CHANGE_TYPE(o,type) \
495 o->op_type = (OPCODE)type; \
496 o->op_ppaddr = PL_ppaddr[type]; \
500 S_no_fh_allowed(pTHX_ OP *o)
502 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
504 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
510 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
512 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
513 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
518 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
520 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
522 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
527 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
529 PERL_ARGS_ASSERT_BAD_TYPE_PV;
531 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
532 (int)n, name, t, OP_DESC(kid)), flags);
536 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
538 SV * const namesv = cv_name((CV *)gv, NULL);
539 PERL_ARGS_ASSERT_BAD_TYPE_GV;
541 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
542 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
546 S_no_bareword_allowed(pTHX_ OP *o)
548 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
550 qerror(Perl_mess(aTHX_
551 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
553 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
556 /* "register" allocation */
559 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
562 const bool is_our = (PL_parser->in_my == KEY_our);
564 PERL_ARGS_ASSERT_ALLOCMY;
566 if (flags & ~SVf_UTF8)
567 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
570 /* Until we're using the length for real, cross check that we're being
572 assert(strlen(name) == len);
574 /* complain about "my $<special_var>" etc etc */
578 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
579 (name[1] == '_' && (*name == '$' || len > 2))))
581 /* name[2] is true if strlen(name) > 2 */
582 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
583 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
584 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
585 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
586 PL_parser->in_my == KEY_state ? "state" : "my"));
588 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
589 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
592 else if (len == 2 && name[1] == '_' && !is_our)
593 /* diag_listed_as: Use of my $_ is experimental */
594 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
595 "Use of %s $_ is experimental",
596 PL_parser->in_my == KEY_state
600 /* allocate a spare slot and store the name in that slot */
602 off = pad_add_name_pvn(name, len,
603 (is_our ? padadd_OUR :
604 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
605 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
606 PL_parser->in_my_stash,
608 /* $_ is always in main::, even with our */
609 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
613 /* anon sub prototypes contains state vars should always be cloned,
614 * otherwise the state var would be shared between anon subs */
616 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
617 CvCLONE_on(PL_compcv);
623 =head1 Optree Manipulation Functions
625 =for apidoc alloccopstash
627 Available only under threaded builds, this function allocates an entry in
628 C<PL_stashpad> for the stash passed to it.
635 Perl_alloccopstash(pTHX_ HV *hv)
637 PADOFFSET off = 0, o = 1;
638 bool found_slot = FALSE;
640 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
642 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
644 for (; o < PL_stashpadmax; ++o) {
645 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
646 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
647 found_slot = TRUE, off = o;
650 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
651 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
652 off = PL_stashpadmax;
653 PL_stashpadmax += 10;
656 PL_stashpad[PL_stashpadix = off] = hv;
661 /* free the body of an op without examining its contents.
662 * Always use this rather than FreeOp directly */
665 S_op_destroy(pTHX_ OP *o)
673 =for apidoc Am|void|op_free|OP *o
675 Free an op. Only use this when an op is no longer linked to from any
682 Perl_op_free(pTHX_ OP *o)
689 /* Though ops may be freed twice, freeing the op after its slab is a
691 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
692 /* During the forced freeing of ops after compilation failure, kidops
693 may be freed before their parents. */
694 if (!o || o->op_type == OP_FREED)
699 /* an op should only ever acquire op_private flags that we know about.
700 * If this fails, you may need to fix something in regen/op_private */
701 assert(!(o->op_private & ~PL_op_private_valid[type]));
703 if (o->op_private & OPpREFCOUNTED) {
714 refcnt = OpREFCNT_dec(o);
717 /* Need to find and remove any pattern match ops from the list
718 we maintain for reset(). */
719 find_and_forget_pmops(o);
729 /* Call the op_free hook if it has been set. Do it now so that it's called
730 * at the right time for refcounted ops, but still before all of the kids
734 if (o->op_flags & OPf_KIDS) {
736 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
737 nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
742 type = (OPCODE)o->op_targ;
745 Slab_to_rw(OpSLAB(o));
747 /* COP* is not cleared by op_clear() so that we may track line
748 * numbers etc even after null() */
749 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
755 #ifdef DEBUG_LEAKING_SCALARS
762 Perl_op_clear(pTHX_ OP *o)
767 PERL_ARGS_ASSERT_OP_CLEAR;
769 switch (o->op_type) {
770 case OP_NULL: /* Was holding old type, if any. */
773 case OP_ENTEREVAL: /* Was holding hints. */
777 if (!(o->op_flags & OPf_REF)
778 || (PL_check[o->op_type] != Perl_ck_ftst))
785 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
790 /* It's possible during global destruction that the GV is freed
791 before the optree. Whilst the SvREFCNT_inc is happy to bump from
792 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
793 will trigger an assertion failure, because the entry to sv_clear
794 checks that the scalar is not already freed. A check of for
795 !SvIS_FREED(gv) turns out to be invalid, because during global
796 destruction the reference count can be forced down to zero
797 (with SVf_BREAK set). In which case raising to 1 and then
798 dropping to 0 triggers cleanup before it should happen. I
799 *think* that this might actually be a general, systematic,
800 weakness of the whole idea of SVf_BREAK, in that code *is*
801 allowed to raise and lower references during global destruction,
802 so any *valid* code that happens to do this during global
803 destruction might well trigger premature cleanup. */
804 bool still_valid = gv && SvREFCNT(gv);
807 SvREFCNT_inc_simple_void(gv);
809 if (cPADOPo->op_padix > 0) {
810 pad_swipe(cPADOPo->op_padix, TRUE);
811 cPADOPo->op_padix = 0;
814 SvREFCNT_dec(cSVOPo->op_sv);
815 cSVOPo->op_sv = NULL;
818 int try_downgrade = SvREFCNT(gv) == 2;
821 gv_try_downgrade(gv);
825 case OP_METHOD_NAMED:
828 SvREFCNT_dec(cSVOPo->op_sv);
829 cSVOPo->op_sv = NULL;
832 Even if op_clear does a pad_free for the target of the op,
833 pad_free doesn't actually remove the sv that exists in the pad;
834 instead it lives on. This results in that it could be reused as
835 a target later on when the pad was reallocated.
838 pad_swipe(o->op_targ,1);
848 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
853 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
854 assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
856 if (cPADOPo->op_padix > 0) {
857 pad_swipe(cPADOPo->op_padix, TRUE);
858 cPADOPo->op_padix = 0;
861 SvREFCNT_dec(cSVOPo->op_sv);
862 cSVOPo->op_sv = NULL;
866 PerlMemShared_free(cPVOPo->op_pv);
867 cPVOPo->op_pv = NULL;
871 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
875 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
876 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
879 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
885 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
886 op_free(cPMOPo->op_code_list);
887 cPMOPo->op_code_list = NULL;
889 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
890 /* we use the same protection as the "SAFE" version of the PM_ macros
891 * here since sv_clean_all might release some PMOPs
892 * after PL_regex_padav has been cleared
893 * and the clearing of PL_regex_padav needs to
894 * happen before sv_clean_all
897 if(PL_regex_pad) { /* We could be in destruction */
898 const IV offset = (cPMOPo)->op_pmoffset;
899 ReREFCNT_dec(PM_GETRE(cPMOPo));
900 PL_regex_pad[offset] = &PL_sv_undef;
901 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
905 ReREFCNT_dec(PM_GETRE(cPMOPo));
906 PM_SETRE(cPMOPo, NULL);
912 if (o->op_targ > 0) {
913 pad_free(o->op_targ);
919 S_cop_free(pTHX_ COP* cop)
921 PERL_ARGS_ASSERT_COP_FREE;
924 if (! specialWARN(cop->cop_warnings))
925 PerlMemShared_free(cop->cop_warnings);
926 cophh_free(CopHINTHASH_get(cop));
927 if (PL_curcop == cop)
932 S_forget_pmop(pTHX_ PMOP *const o
935 HV * const pmstash = PmopSTASH(o);
937 PERL_ARGS_ASSERT_FORGET_PMOP;
939 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
940 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
942 PMOP **const array = (PMOP**) mg->mg_ptr;
943 U32 count = mg->mg_len / sizeof(PMOP**);
948 /* Found it. Move the entry at the end to overwrite it. */
949 array[i] = array[--count];
950 mg->mg_len = count * sizeof(PMOP**);
951 /* Could realloc smaller at this point always, but probably
952 not worth it. Probably worth free()ing if we're the
955 Safefree(mg->mg_ptr);
968 S_find_and_forget_pmops(pTHX_ OP *o)
970 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
972 if (o->op_flags & OPf_KIDS) {
973 OP *kid = cUNOPo->op_first;
975 switch (kid->op_type) {
980 forget_pmop((PMOP*)kid);
982 find_and_forget_pmops(kid);
983 kid = OP_SIBLING(kid);
989 =for apidoc Am|void|op_null|OP *o
991 Neutralizes an op when it is no longer needed, but is still linked to from
998 Perl_op_null(pTHX_ OP *o)
1002 PERL_ARGS_ASSERT_OP_NULL;
1004 if (o->op_type == OP_NULL)
1007 o->op_targ = o->op_type;
1008 o->op_type = OP_NULL;
1009 o->op_ppaddr = PL_ppaddr[OP_NULL];
1013 Perl_op_refcnt_lock(pTHX)
1018 PERL_UNUSED_CONTEXT;
1023 Perl_op_refcnt_unlock(pTHX)
1028 PERL_UNUSED_CONTEXT;
1034 =for apidoc op_sibling_splice
1036 A general function for editing the structure of an existing chain of
1037 op_sibling nodes. By analogy with the perl-level splice() function, allows
1038 you to delete zero or more sequential nodes, replacing them with zero or
1039 more different nodes. Performs the necessary op_first/op_last
1040 housekeeping on the parent node and op_sibling manipulation on the
1041 children. The last deleted node will be marked as as the last node by
1042 updating the op_sibling or op_lastsib field as appropriate.
1044 Note that op_next is not manipulated, and nodes are not freed; that is the
1045 responsibility of the caller. It also won't create a new list op for an
1046 empty list etc; use higher-level functions like op_append_elem() for that.
1048 parent is the parent node of the sibling chain.
1050 start is the node preceding the first node to be spliced. Node(s)
1051 following it will be deleted, and ops will be inserted after it. If it is
1052 NULL, the first node onwards is deleted, and nodes are inserted at the
1055 del_count is the number of nodes to delete. If zero, no nodes are deleted.
1056 If -1 or greater than or equal to the number of remaining kids, all
1057 remaining kids are deleted.
1059 insert is the first of a chain of nodes to be inserted in place of the nodes.
1060 If NULL, no nodes are inserted.
1062 The head of the chain of deleted ops is returned, or NULL if no ops were
1067 action before after returns
1068 ------ ----- ----- -------
1071 splice(P, A, 2, X-Y-Z) | | B-C
1075 splice(P, NULL, 1, X-Y) | | A
1079 splice(P, NULL, 3, NULL) | | A-B-C
1083 splice(P, B, 0, X-Y) | | NULL
1090 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1092 OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1094 OP *last_del = NULL;
1095 OP *last_ins = NULL;
1097 PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1099 assert(del_count >= -1);
1101 if (del_count && first) {
1103 while (--del_count && OP_HAS_SIBLING(last_del))
1104 last_del = OP_SIBLING(last_del);
1105 rest = OP_SIBLING(last_del);
1106 OP_SIBLING_set(last_del, NULL);
1107 last_del->op_lastsib = 1;
1114 while (OP_HAS_SIBLING(last_ins))
1115 last_ins = OP_SIBLING(last_ins);
1116 OP_SIBLING_set(last_ins, rest);
1117 last_ins->op_lastsib = rest ? 0 : 1;
1123 OP_SIBLING_set(start, insert);
1124 start->op_lastsib = insert ? 0 : 1;
1127 cLISTOPx(parent)->op_first = insert;
1130 /* update op_last etc */
1131 U32 type = parent->op_type;
1134 if (type == OP_NULL)
1135 type = parent->op_targ;
1136 type = PL_opargs[type] & OA_CLASS_MASK;
1138 lastop = last_ins ? last_ins : start ? start : NULL;
1139 if ( type == OA_BINOP
1140 || type == OA_LISTOP
1144 cLISTOPx(parent)->op_last = lastop;
1147 lastop->op_lastsib = 1;
1148 #ifdef PERL_OP_PARENT
1149 lastop->op_sibling = parent;
1153 return last_del ? first : NULL;
1157 =for apidoc op_parent
1159 returns the parent OP of o, if it has a parent. Returns NULL otherwise.
1160 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1167 Perl_op_parent(OP *o)
1169 PERL_ARGS_ASSERT_OP_PARENT;
1170 #ifdef PERL_OP_PARENT
1171 while (OP_HAS_SIBLING(o))
1173 return o->op_sibling;
1181 /* replace the sibling following start with a new UNOP, which becomes
1182 * the parent of the original sibling; e.g.
1184 * op_sibling_newUNOP(P, A, unop-args...)
1192 * where U is the new UNOP.
1194 * parent and start args are the same as for op_sibling_splice();
1195 * type and flags args are as newUNOP().
1197 * Returns the new UNOP.
1201 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1205 kid = op_sibling_splice(parent, start, 1, NULL);
1206 newop = newUNOP(type, flags, kid);
1207 op_sibling_splice(parent, start, 0, newop);
1212 /* lowest-level newLOGOP-style function - just allocates and populates
1213 * the struct. Higher-level stuff should be done by S_new_logop() /
1214 * newLOGOP(). This function exists mainly to avoid op_first assignment
1215 * being spread throughout this file.
1219 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1223 NewOp(1101, logop, 1, LOGOP);
1224 logop->op_type = (OPCODE)type;
1225 logop->op_first = first;
1226 logop->op_other = other;
1227 logop->op_flags = OPf_KIDS;
1228 while (kid && OP_HAS_SIBLING(kid))
1229 kid = OP_SIBLING(kid);
1231 kid->op_lastsib = 1;
1232 #ifdef PERL_OP_PARENT
1233 kid->op_sibling = (OP*)logop;
1240 /* Contextualizers */
1243 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1245 Applies a syntactic context to an op tree representing an expression.
1246 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1247 or C<G_VOID> to specify the context to apply. The modified op tree
1254 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1256 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1258 case G_SCALAR: return scalar(o);
1259 case G_ARRAY: return list(o);
1260 case G_VOID: return scalarvoid(o);
1262 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1269 =for apidoc Am|OP*|op_linklist|OP *o
1270 This function is the implementation of the L</LINKLIST> macro. It should
1271 not be called directly.
1277 Perl_op_linklist(pTHX_ OP *o)
1281 PERL_ARGS_ASSERT_OP_LINKLIST;
1286 /* establish postfix order */
1287 first = cUNOPo->op_first;
1290 o->op_next = LINKLIST(first);
1293 OP *sibl = OP_SIBLING(kid);
1295 kid->op_next = LINKLIST(sibl);
1310 S_scalarkids(pTHX_ OP *o)
1312 if (o && o->op_flags & OPf_KIDS) {
1314 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1321 S_scalarboolean(pTHX_ OP *o)
1323 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1325 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1326 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1327 if (ckWARN(WARN_SYNTAX)) {
1328 const line_t oldline = CopLINE(PL_curcop);
1330 if (PL_parser && PL_parser->copline != NOLINE) {
1331 /* This ensures that warnings are reported at the first line
1332 of the conditional, not the last. */
1333 CopLINE_set(PL_curcop, PL_parser->copline);
1335 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1336 CopLINE_set(PL_curcop, oldline);
1343 S_op_varname(pTHX_ const OP *o)
1346 assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1347 o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1349 const char funny = o->op_type == OP_PADAV
1350 || o->op_type == OP_RV2AV ? '@' : '%';
1351 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1353 if (cUNOPo->op_first->op_type != OP_GV
1354 || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1356 return varname(gv, funny, 0, NULL, 0, 1);
1359 varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1364 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1365 { /* or not so pretty :-) */
1366 if (o->op_type == OP_CONST) {
1368 if (SvPOK(*retsv)) {
1370 *retsv = sv_newmortal();
1371 pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1372 PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1374 else if (!SvOK(*retsv))
1377 else *retpv = "...";
1381 S_scalar_slice_warning(pTHX_ const OP *o)
1385 o->op_type == OP_HSLICE ? '{' : '[';
1387 o->op_type == OP_HSLICE ? '}' : ']';
1389 SV *keysv = NULL; /* just to silence compiler warnings */
1390 const char *key = NULL;
1392 if (!(o->op_private & OPpSLICEWARNING))
1394 if (PL_parser && PL_parser->error_count)
1395 /* This warning can be nonsensical when there is a syntax error. */
1398 kid = cLISTOPo->op_first;
1399 kid = OP_SIBLING(kid); /* get past pushmark */
1400 /* weed out false positives: any ops that can return lists */
1401 switch (kid->op_type) {
1430 /* Don't warn if we have a nulled list either. */
1431 if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1434 assert(OP_SIBLING(kid));
1435 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1436 if (!name) /* XS module fiddling with the op tree */
1438 S_op_pretty(aTHX_ kid, &keysv, &key);
1439 assert(SvPOK(name));
1440 sv_chop(name,SvPVX(name)+1);
1442 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1443 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1444 "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1446 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1447 lbrack, key, rbrack);
1449 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1450 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1451 "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1453 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1454 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1458 Perl_scalar(pTHX_ OP *o)
1462 /* assumes no premature commitment */
1463 if (!o || (PL_parser && PL_parser->error_count)
1464 || (o->op_flags & OPf_WANT)
1465 || o->op_type == OP_RETURN)
1470 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1472 switch (o->op_type) {
1474 scalar(cBINOPo->op_first);
1479 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1489 if (o->op_flags & OPf_KIDS) {
1490 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1496 kid = cLISTOPo->op_first;
1498 kid = OP_SIBLING(kid);
1501 OP *sib = OP_SIBLING(kid);
1502 if (sib && kid->op_type != OP_LEAVEWHEN)
1508 PL_curcop = &PL_compiling;
1513 kid = cLISTOPo->op_first;
1516 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1521 /* Warn about scalar context */
1522 const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1523 const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1526 const char *key = NULL;
1528 /* This warning can be nonsensical when there is a syntax error. */
1529 if (PL_parser && PL_parser->error_count)
1532 if (!ckWARN(WARN_SYNTAX)) break;
1534 kid = cLISTOPo->op_first;
1535 kid = OP_SIBLING(kid); /* get past pushmark */
1536 assert(OP_SIBLING(kid));
1537 name = S_op_varname(aTHX_ OP_SIBLING(kid));
1538 if (!name) /* XS module fiddling with the op tree */
1540 S_op_pretty(aTHX_ kid, &keysv, &key);
1541 assert(SvPOK(name));
1542 sv_chop(name,SvPVX(name)+1);
1544 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1545 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1546 "%%%"SVf"%c%s%c in scalar context better written "
1548 SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1549 lbrack, key, rbrack);
1551 /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1552 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1553 "%%%"SVf"%c%"SVf"%c in scalar context better "
1554 "written as $%"SVf"%c%"SVf"%c",
1555 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1556 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1563 Perl_scalarvoid(pTHX_ OP *o)
1567 SV *useless_sv = NULL;
1568 const char* useless = NULL;
1572 PERL_ARGS_ASSERT_SCALARVOID;
1574 if (o->op_type == OP_NEXTSTATE
1575 || o->op_type == OP_DBSTATE
1576 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1577 || o->op_targ == OP_DBSTATE)))
1578 PL_curcop = (COP*)o; /* for warning below */
1580 /* assumes no premature commitment */
1581 want = o->op_flags & OPf_WANT;
1582 if ((want && want != OPf_WANT_SCALAR)
1583 || (PL_parser && PL_parser->error_count)
1584 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1589 if ((o->op_private & OPpTARGET_MY)
1590 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1592 return scalar(o); /* As if inside SASSIGN */
1595 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1597 switch (o->op_type) {
1599 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1603 if (o->op_flags & OPf_STACKED)
1607 if (o->op_private == 4)
1632 case OP_AELEMFAST_LEX:
1653 case OP_GETSOCKNAME:
1654 case OP_GETPEERNAME:
1659 case OP_GETPRIORITY:
1684 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1685 /* Otherwise it's "Useless use of grep iterator" */
1686 useless = OP_DESC(o);
1690 kid = cLISTOPo->op_first;
1691 if (kid && kid->op_type == OP_PUSHRE
1693 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1695 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1697 useless = OP_DESC(o);
1701 kid = cUNOPo->op_first;
1702 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1703 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1706 useless = "negative pattern binding (!~)";
1710 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1711 useless = "non-destructive substitution (s///r)";
1715 useless = "non-destructive transliteration (tr///r)";
1722 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1723 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1724 useless = "a variable";
1729 if (cSVOPo->op_private & OPpCONST_STRICT)
1730 no_bareword_allowed(o);
1732 if (ckWARN(WARN_VOID)) {
1734 /* don't warn on optimised away booleans, eg
1735 * use constant Foo, 5; Foo || print; */
1736 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1738 /* the constants 0 and 1 are permitted as they are
1739 conventionally used as dummies in constructs like
1740 1 while some_condition_with_side_effects; */
1741 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1743 else if (SvPOK(sv)) {
1744 SV * const dsv = newSVpvs("");
1746 = Perl_newSVpvf(aTHX_
1748 pv_pretty(dsv, SvPVX_const(sv),
1749 SvCUR(sv), 32, NULL, NULL,
1751 | PERL_PV_ESCAPE_NOCLEAR
1752 | PERL_PV_ESCAPE_UNI_DETECT));
1753 SvREFCNT_dec_NN(dsv);
1755 else if (SvOK(sv)) {
1756 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1759 useless = "a constant (undef)";
1762 op_null(o); /* don't execute or even remember it */
1766 o->op_type = OP_PREINC; /* pre-increment is faster */
1767 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1771 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1772 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1776 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1777 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1781 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1782 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1787 UNOP *refgen, *rv2cv;
1790 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1793 rv2gv = ((BINOP *)o)->op_last;
1794 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1797 refgen = (UNOP *)((BINOP *)o)->op_first;
1799 if (!refgen || refgen->op_type != OP_REFGEN)
1802 exlist = (LISTOP *)refgen->op_first;
1803 if (!exlist || exlist->op_type != OP_NULL
1804 || exlist->op_targ != OP_LIST)
1807 if (exlist->op_first->op_type != OP_PUSHMARK)
1810 rv2cv = (UNOP*)exlist->op_last;
1812 if (rv2cv->op_type != OP_RV2CV)
1815 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1816 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1817 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1819 o->op_private |= OPpASSIGN_CV_TO_GV;
1820 rv2gv->op_private |= OPpDONT_INIT_GV;
1821 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1833 kid = cLOGOPo->op_first;
1834 if (kid->op_type == OP_NOT
1835 && (kid->op_flags & OPf_KIDS)) {
1836 if (o->op_type == OP_AND) {
1838 o->op_ppaddr = PL_ppaddr[OP_OR];
1840 o->op_type = OP_AND;
1841 o->op_ppaddr = PL_ppaddr[OP_AND];
1851 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1856 if (o->op_flags & OPf_STACKED)
1863 if (!(o->op_flags & OPf_KIDS))
1874 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1885 /* mortalise it, in case warnings are fatal. */
1886 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1887 "Useless use of %"SVf" in void context",
1888 SVfARG(sv_2mortal(useless_sv)));
1891 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1892 "Useless use of %s in void context",
1899 S_listkids(pTHX_ OP *o)
1901 if (o && o->op_flags & OPf_KIDS) {
1903 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1910 Perl_list(pTHX_ OP *o)
1914 /* assumes no premature commitment */
1915 if (!o || (o->op_flags & OPf_WANT)
1916 || (PL_parser && PL_parser->error_count)
1917 || o->op_type == OP_RETURN)
1922 if ((o->op_private & OPpTARGET_MY)
1923 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1925 return o; /* As if inside SASSIGN */
1928 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1930 switch (o->op_type) {
1933 list(cBINOPo->op_first);
1938 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1946 if (!(o->op_flags & OPf_KIDS))
1948 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1949 list(cBINOPo->op_first);
1950 return gen_constant_list(o);
1957 kid = cLISTOPo->op_first;
1959 kid = OP_SIBLING(kid);
1962 OP *sib = OP_SIBLING(kid);
1963 if (sib && kid->op_type != OP_LEAVEWHEN)
1969 PL_curcop = &PL_compiling;
1973 kid = cLISTOPo->op_first;
1980 S_scalarseq(pTHX_ OP *o)
1983 const OPCODE type = o->op_type;
1985 if (type == OP_LINESEQ || type == OP_SCOPE ||
1986 type == OP_LEAVE || type == OP_LEAVETRY)
1989 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
1990 if (OP_HAS_SIBLING(kid)) {
1994 PL_curcop = &PL_compiling;
1996 o->op_flags &= ~OPf_PARENS;
1997 if (PL_hints & HINT_BLOCK_SCOPE)
1998 o->op_flags |= OPf_PARENS;
2001 o = newOP(OP_STUB, 0);
2006 S_modkids(pTHX_ OP *o, I32 type)
2008 if (o && o->op_flags & OPf_KIDS) {
2010 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2011 op_lvalue(kid, type);
2017 =for apidoc finalize_optree
2019 This function finalizes the optree. Should be called directly after
2020 the complete optree is built. It does some additional
2021 checking which can't be done in the normal ck_xxx functions and makes
2022 the tree thread-safe.
2027 Perl_finalize_optree(pTHX_ OP* o)
2029 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2032 SAVEVPTR(PL_curcop);
2040 S_finalize_op(pTHX_ OP* o)
2042 PERL_ARGS_ASSERT_FINALIZE_OP;
2045 switch (o->op_type) {
2048 PL_curcop = ((COP*)o); /* for warnings */
2051 if (OP_HAS_SIBLING(o)) {
2052 OP *sib = OP_SIBLING(o);
2053 if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2054 && ckWARN(WARN_EXEC)
2055 && OP_HAS_SIBLING(sib))
2057 const OPCODE type = OP_SIBLING(sib)->op_type;
2058 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2059 const line_t oldline = CopLINE(PL_curcop);
2060 CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2061 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2062 "Statement unlikely to be reached");
2063 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2064 "\t(Maybe you meant system() when you said exec()?)\n");
2065 CopLINE_set(PL_curcop, oldline);
2072 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2073 GV * const gv = cGVOPo_gv;
2074 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2075 /* XXX could check prototype here instead of just carping */
2076 SV * const sv = sv_newmortal();
2077 gv_efullname3(sv, gv, NULL);
2078 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2079 "%"SVf"() called too early to check prototype",
2086 if (cSVOPo->op_private & OPpCONST_STRICT)
2087 no_bareword_allowed(o);
2091 case OP_METHOD_NAMED:
2092 /* Relocate sv to the pad for thread safety.
2093 * Despite being a "constant", the SV is written to,
2094 * for reference counts, sv_upgrade() etc. */
2095 if (cSVOPo->op_sv) {
2096 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
2097 SvREFCNT_dec(PAD_SVl(ix));
2098 PAD_SETSV(ix, cSVOPo->op_sv);
2099 /* XXX I don't know how this isn't readonly already. */
2100 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2101 cSVOPo->op_sv = NULL;
2115 if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2118 rop = (UNOP*)((BINOP*)o)->op_first;
2123 S_scalar_slice_warning(aTHX_ o);
2127 kid = OP_SIBLING(cLISTOPo->op_first);
2128 if (/* I bet there's always a pushmark... */
2129 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2130 && OP_TYPE_ISNT_NN(kid, OP_CONST))
2135 key_op = (SVOP*)(kid->op_type == OP_CONST
2137 : OP_SIBLING(kLISTOP->op_first));
2139 rop = (UNOP*)((LISTOP*)o)->op_last;
2142 if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2144 else if (rop->op_first->op_type == OP_PADSV)
2145 /* @$hash{qw(keys here)} */
2146 rop = (UNOP*)rop->op_first;
2148 /* @{$hash}{qw(keys here)} */
2149 if (rop->op_first->op_type == OP_SCOPE
2150 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2152 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2158 lexname = NULL; /* just to silence compiler warnings */
2159 fields = NULL; /* just to silence compiler warnings */
2163 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2164 SvPAD_TYPED(lexname))
2165 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2166 && isGV(*fields) && GvHV(*fields);
2168 key_op = (SVOP*)OP_SIBLING(key_op)) {
2170 if (key_op->op_type != OP_CONST)
2172 svp = cSVOPx_svp(key_op);
2174 /* Make the CONST have a shared SV */
2175 if ((!SvIsCOW_shared_hash(sv = *svp))
2176 && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2178 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2179 SV *nsv = newSVpvn_share(key,
2180 SvUTF8(sv) ? -keylen : keylen, 0);
2181 SvREFCNT_dec_NN(sv);
2186 && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2187 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2188 "in variable %"SVf" of type %"HEKf,
2189 SVfARG(*svp), SVfARG(lexname),
2190 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2196 S_scalar_slice_warning(aTHX_ o);
2200 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2201 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2208 if (o->op_flags & OPf_KIDS) {
2212 /* check that op_last points to the last sibling, and that
2213 * the last op_sibling field points back to the parent, and
2214 * that the only ops with KIDS are those which are entitled to
2216 U32 type = o->op_type;
2220 if (type == OP_NULL) {
2222 /* ck_glob creates a null UNOP with ex-type GLOB
2223 * (which is a list op. So pretend it wasn't a listop */
2224 if (type == OP_GLOB)
2227 family = PL_opargs[type] & OA_CLASS_MASK;
2229 has_last = ( family == OA_BINOP
2230 || family == OA_LISTOP
2231 || family == OA_PMOP
2232 || family == OA_LOOP
2234 assert( has_last /* has op_first and op_last, or ...
2235 ... has (or may have) op_first: */
2236 || family == OA_UNOP
2237 || family == OA_LOGOP
2238 || family == OA_BASEOP_OR_UNOP
2239 || family == OA_FILESTATOP
2240 || family == OA_LOOPEXOP
2241 /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2242 || type == OP_SASSIGN
2243 || type == OP_CUSTOM
2244 || type == OP_NULL /* new_logop does this */
2246 /* XXX list form of 'x' is has a null op_last. This is wrong,
2247 * but requires too much hacking (e.g. in Deparse) to fix for
2249 if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2254 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2255 # ifdef PERL_OP_PARENT
2256 if (!OP_HAS_SIBLING(kid)) {
2258 assert(kid == cLISTOPo->op_last);
2259 assert(kid->op_sibling == o);
2262 if (OP_HAS_SIBLING(kid)) {
2263 assert(!kid->op_lastsib);
2266 assert(kid->op_lastsib);
2268 assert(kid == cLISTOPo->op_last);
2274 for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2280 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2282 Propagate lvalue ("modifiable") context to an op and its children.
2283 I<type> represents the context type, roughly based on the type of op that
2284 would do the modifying, although C<local()> is represented by OP_NULL,
2285 because it has no op type of its own (it is signalled by a flag on
2288 This function detects things that can't be modified, such as C<$x+1>, and
2289 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2290 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2292 It also flags things that need to behave specially in an lvalue context,
2293 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2299 S_vivifies(const OPCODE type)
2302 case OP_RV2AV: case OP_ASLICE:
2303 case OP_RV2HV: case OP_KVASLICE:
2304 case OP_RV2SV: case OP_HSLICE:
2305 case OP_AELEMFAST: case OP_KVHSLICE:
2314 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2318 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2321 if (!o || (PL_parser && PL_parser->error_count))
2324 if ((o->op_private & OPpTARGET_MY)
2325 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2330 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2332 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2334 switch (o->op_type) {
2339 if ((o->op_flags & OPf_PARENS))
2343 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2344 !(o->op_flags & OPf_STACKED)) {
2345 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2346 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2347 assert(cUNOPo->op_first->op_type == OP_NULL);
2348 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2351 else { /* lvalue subroutine call */
2352 o->op_private |= OPpLVAL_INTRO
2353 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2354 PL_modcount = RETURN_UNLIMITED_NUMBER;
2355 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2356 /* Potential lvalue context: */
2357 o->op_private |= OPpENTERSUB_INARGS;
2360 else { /* Compile-time error message: */
2361 OP *kid = cUNOPo->op_first;
2365 if (kid->op_type != OP_PUSHMARK) {
2366 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2368 "panic: unexpected lvalue entersub "
2369 "args: type/targ %ld:%"UVuf,
2370 (long)kid->op_type, (UV)kid->op_targ);
2371 kid = kLISTOP->op_first;
2373 while (OP_HAS_SIBLING(kid))
2374 kid = OP_SIBLING(kid);
2375 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2376 break; /* Postpone until runtime */
2379 kid = kUNOP->op_first;
2380 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2381 kid = kUNOP->op_first;
2382 if (kid->op_type == OP_NULL)
2384 "Unexpected constant lvalue entersub "
2385 "entry via type/targ %ld:%"UVuf,
2386 (long)kid->op_type, (UV)kid->op_targ);
2387 if (kid->op_type != OP_GV) {
2394 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2395 ? MUTABLE_CV(SvRV(gv))
2406 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2407 /* grep, foreach, subcalls, refgen */
2408 if (type == OP_GREPSTART || type == OP_ENTERSUB
2409 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2411 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2412 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2414 : (o->op_type == OP_ENTERSUB
2415 ? "non-lvalue subroutine call"
2417 type ? PL_op_desc[type] : "local"));
2431 case OP_RIGHT_SHIFT:
2440 if (!(o->op_flags & OPf_STACKED))
2447 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2448 op_lvalue(kid, type);
2453 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2454 PL_modcount = RETURN_UNLIMITED_NUMBER;
2455 return o; /* Treat \(@foo) like ordinary list. */
2459 if (scalar_mod_type(o, type))
2461 ref(cUNOPo->op_first, o->op_type);
2468 /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
2469 if (type == OP_LEAVESUBLV && (
2470 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2471 || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2473 o->op_private |= OPpMAYBE_LVSUB;
2477 PL_modcount = RETURN_UNLIMITED_NUMBER;
2481 if (type == OP_LEAVESUBLV)
2482 o->op_private |= OPpMAYBE_LVSUB;
2485 PL_hints |= HINT_BLOCK_SCOPE;
2486 if (type == OP_LEAVESUBLV)
2487 o->op_private |= OPpMAYBE_LVSUB;
2491 ref(cUNOPo->op_first, o->op_type);
2495 PL_hints |= HINT_BLOCK_SCOPE;
2505 case OP_AELEMFAST_LEX:
2512 PL_modcount = RETURN_UNLIMITED_NUMBER;
2513 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2514 return o; /* Treat \(@foo) like ordinary list. */
2515 if (scalar_mod_type(o, type))
2517 if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2518 && type == OP_LEAVESUBLV)
2519 o->op_private |= OPpMAYBE_LVSUB;
2523 if (!type) /* local() */
2524 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2525 PAD_COMPNAME_SV(o->op_targ));
2534 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2538 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2544 if (type == OP_LEAVESUBLV)
2545 o->op_private |= OPpMAYBE_LVSUB;
2546 if (o->op_flags & OPf_KIDS)
2547 op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2552 ref(cBINOPo->op_first, o->op_type);
2553 if (type == OP_ENTERSUB &&
2554 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2555 o->op_private |= OPpLVAL_DEFER;
2556 if (type == OP_LEAVESUBLV)
2557 o->op_private |= OPpMAYBE_LVSUB;
2564 o->op_private |= OPpLVALUE;
2570 if (o->op_flags & OPf_KIDS)
2571 op_lvalue(cLISTOPo->op_last, type);
2576 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2578 else if (!(o->op_flags & OPf_KIDS))
2580 if (o->op_targ != OP_LIST) {
2581 op_lvalue(cBINOPo->op_first, type);
2587 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2588 /* elements might be in void context because the list is
2589 in scalar context or because they are attribute sub calls */
2590 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2591 op_lvalue(kid, type);
2595 if (type != OP_LEAVESUBLV)
2597 break; /* op_lvalue()ing was handled by ck_return() */
2604 if (type == OP_LEAVESUBLV
2605 || !S_vivifies(cLOGOPo->op_first->op_type))
2606 op_lvalue(cLOGOPo->op_first, type);
2607 if (type == OP_LEAVESUBLV
2608 || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2609 op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2613 /* [20011101.069] File test operators interpret OPf_REF to mean that
2614 their argument is a filehandle; thus \stat(".") should not set
2616 if (type == OP_REFGEN &&
2617 PL_check[o->op_type] == Perl_ck_ftst)
2620 if (type != OP_LEAVESUBLV)
2621 o->op_flags |= OPf_MOD;
2623 if (type == OP_AASSIGN || type == OP_SASSIGN)
2624 o->op_flags |= OPf_SPECIAL|OPf_REF;
2625 else if (!type) { /* local() */
2628 o->op_private |= OPpLVAL_INTRO;
2629 o->op_flags &= ~OPf_SPECIAL;
2630 PL_hints |= HINT_BLOCK_SCOPE;
2635 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2636 "Useless localization of %s", OP_DESC(o));
2639 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2640 && type != OP_LEAVESUBLV)
2641 o->op_flags |= OPf_REF;
2646 S_scalar_mod_type(const OP *o, I32 type)
2651 if (o && o->op_type == OP_RV2GV)
2675 case OP_RIGHT_SHIFT:
2696 S_is_handle_constructor(const OP *o, I32 numargs)
2698 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2700 switch (o->op_type) {
2708 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2721 S_refkids(pTHX_ OP *o, I32 type)
2723 if (o && o->op_flags & OPf_KIDS) {
2725 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2732 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2737 PERL_ARGS_ASSERT_DOREF;
2739 if (!o || (PL_parser && PL_parser->error_count))
2742 switch (o->op_type) {
2744 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2745 !(o->op_flags & OPf_STACKED)) {
2746 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2747 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2748 assert(cUNOPo->op_first->op_type == OP_NULL);
2749 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2750 o->op_flags |= OPf_SPECIAL;
2752 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2753 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2754 : type == OP_RV2HV ? OPpDEREF_HV
2756 o->op_flags |= OPf_MOD;
2762 for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2763 doref(kid, type, set_op_ref);
2766 if (type == OP_DEFINED)
2767 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2768 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2771 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2772 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2773 : type == OP_RV2HV ? OPpDEREF_HV
2775 o->op_flags |= OPf_MOD;
2782 o->op_flags |= OPf_REF;
2785 if (type == OP_DEFINED)
2786 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2787 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2793 o->op_flags |= OPf_REF;
2798 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2800 doref(cBINOPo->op_first, type, set_op_ref);
2804 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2805 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2806 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2807 : type == OP_RV2HV ? OPpDEREF_HV
2809 o->op_flags |= OPf_MOD;
2819 if (!(o->op_flags & OPf_KIDS))
2821 doref(cLISTOPo->op_last, type, set_op_ref);
2831 S_dup_attrlist(pTHX_ OP *o)
2835 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2837 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2838 * where the first kid is OP_PUSHMARK and the remaining ones
2839 * are OP_CONST. We need to push the OP_CONST values.
2841 if (o->op_type == OP_CONST)
2842 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2844 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2846 for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
2847 if (o->op_type == OP_CONST)
2848 rop = op_append_elem(OP_LIST, rop,
2849 newSVOP(OP_CONST, o->op_flags,
2850 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2857 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2859 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2861 PERL_ARGS_ASSERT_APPLY_ATTRS;
2863 /* fake up C<use attributes $pkg,$rv,@attrs> */
2865 #define ATTRSMODULE "attributes"
2866 #define ATTRSMODULE_PM "attributes.pm"
2868 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2869 newSVpvs(ATTRSMODULE),
2871 op_prepend_elem(OP_LIST,
2872 newSVOP(OP_CONST, 0, stashsv),
2873 op_prepend_elem(OP_LIST,
2874 newSVOP(OP_CONST, 0,
2876 dup_attrlist(attrs))));
2880 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2882 OP *pack, *imop, *arg;
2883 SV *meth, *stashsv, **svp;
2885 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2890 assert(target->op_type == OP_PADSV ||
2891 target->op_type == OP_PADHV ||
2892 target->op_type == OP_PADAV);
2894 /* Ensure that attributes.pm is loaded. */
2895 /* Don't force the C<use> if we don't need it. */
2896 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2897 if (svp && *svp != &PL_sv_undef)
2898 NOOP; /* already in %INC */
2900 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2901 newSVpvs(ATTRSMODULE), NULL);
2903 /* Need package name for method call. */
2904 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2906 /* Build up the real arg-list. */
2907 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2909 arg = newOP(OP_PADSV, 0);
2910 arg->op_targ = target->op_targ;
2911 arg = op_prepend_elem(OP_LIST,
2912 newSVOP(OP_CONST, 0, stashsv),
2913 op_prepend_elem(OP_LIST,
2914 newUNOP(OP_REFGEN, 0,
2915 op_lvalue(arg, OP_REFGEN)),
2916 dup_attrlist(attrs)));
2918 /* Fake up a method call to import */
2919 meth = newSVpvs_share("import");
2920 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2921 op_append_elem(OP_LIST,
2922 op_prepend_elem(OP_LIST, pack, list(arg)),
2923 newSVOP(OP_METHOD_NAMED, 0, meth)));
2925 /* Combine the ops. */
2926 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2930 =notfor apidoc apply_attrs_string
2932 Attempts to apply a list of attributes specified by the C<attrstr> and
2933 C<len> arguments to the subroutine identified by the C<cv> argument which
2934 is expected to be associated with the package identified by the C<stashpv>
2935 argument (see L<attributes>). It gets this wrong, though, in that it
2936 does not correctly identify the boundaries of the individual attribute
2937 specifications within C<attrstr>. This is not really intended for the
2938 public API, but has to be listed here for systems such as AIX which
2939 need an explicit export list for symbols. (It's called from XS code
2940 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2941 to respect attribute syntax properly would be welcome.
2947 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2948 const char *attrstr, STRLEN len)
2952 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2955 len = strlen(attrstr);
2959 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2961 const char * const sstr = attrstr;
2962 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2963 attrs = op_append_elem(OP_LIST, attrs,
2964 newSVOP(OP_CONST, 0,
2965 newSVpvn(sstr, attrstr-sstr)));
2969 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2970 newSVpvs(ATTRSMODULE),
2971 NULL, op_prepend_elem(OP_LIST,
2972 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2973 op_prepend_elem(OP_LIST,
2974 newSVOP(OP_CONST, 0,
2975 newRV(MUTABLE_SV(cv))),
2980 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2982 OP *new_proto = NULL;
2987 PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2993 if (o->op_type == OP_CONST) {
2994 pv = SvPV(cSVOPo_sv, pvlen);
2995 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2996 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2997 SV ** const tmpo = cSVOPx_svp(o);
2998 SvREFCNT_dec(cSVOPo_sv);
3003 } else if (o->op_type == OP_LIST) {
3005 assert(o->op_flags & OPf_KIDS);
3006 lasto = cLISTOPo->op_first;
3007 assert(lasto->op_type == OP_PUSHMARK);
3008 for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3009 if (o->op_type == OP_CONST) {
3010 pv = SvPV(cSVOPo_sv, pvlen);
3011 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3012 SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3013 SV ** const tmpo = cSVOPx_svp(o);
3014 SvREFCNT_dec(cSVOPo_sv);
3016 if (new_proto && ckWARN(WARN_MISC)) {
3018 const char * newp = SvPV(cSVOPo_sv, new_len);
3019 Perl_warner(aTHX_ packWARN(WARN_MISC),
3020 "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3021 UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3027 /* excise new_proto from the list */
3028 op_sibling_splice(*attrs, lasto, 1, NULL);
3035 /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3036 would get pulled in with no real need */
3037 if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3046 svname = sv_newmortal();
3047 gv_efullname3(svname, name, NULL);
3049 else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3050 svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3052 svname = (SV *)name;
3053 if (ckWARN(WARN_ILLEGALPROTO))
3054 (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3055 if (*proto && ckWARN(WARN_PROTOTYPE)) {
3056 STRLEN old_len, new_len;
3057 const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3058 const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3060 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3061 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3063 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3064 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3074 S_cant_declare(pTHX_ OP *o)
3076 if (o->op_type == OP_NULL
3077 && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3078 o = cUNOPo->op_first;
3079 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3080 o->op_type == OP_NULL
3081 && o->op_flags & OPf_SPECIAL
3084 PL_parser->in_my == KEY_our ? "our" :
3085 PL_parser->in_my == KEY_state ? "state" :
3090 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3093 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3095 PERL_ARGS_ASSERT_MY_KID;
3097 if (!o || (PL_parser && PL_parser->error_count))
3102 if (type == OP_LIST) {
3104 for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3105 my_kid(kid, attrs, imopsp);
3107 } else if (type == OP_UNDEF || type == OP_STUB) {
3109 } else if (type == OP_RV2SV || /* "our" declaration */
3111 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3112 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3113 S_cant_declare(aTHX_ o);
3115 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3117 PL_parser->in_my = FALSE;
3118 PL_parser->in_my_stash = NULL;
3119 apply_attrs(GvSTASH(gv),
3120 (type == OP_RV2SV ? GvSV(gv) :
3121 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3122 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3125 o->op_private |= OPpOUR_INTRO;
3128 else if (type != OP_PADSV &&
3131 type != OP_PUSHMARK)
3133 S_cant_declare(aTHX_ o);
3136 else if (attrs && type != OP_PUSHMARK) {
3140 PL_parser->in_my = FALSE;
3141 PL_parser->in_my_stash = NULL;
3143 /* check for C<my Dog $spot> when deciding package */
3144 stash = PAD_COMPNAME_TYPE(o->op_targ);
3146 stash = PL_curstash;
3147 apply_attrs_my(stash, o, attrs, imopsp);
3149 o->op_flags |= OPf_MOD;
3150 o->op_private |= OPpLVAL_INTRO;
3152 o->op_private |= OPpPAD_STATE;
3157 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3160 int maybe_scalar = 0;
3162 PERL_ARGS_ASSERT_MY_ATTRS;
3164 /* [perl #17376]: this appears to be premature, and results in code such as
3165 C< our(%x); > executing in list mode rather than void mode */
3167 if (o->op_flags & OPf_PARENS)
3177 o = my_kid(o, attrs, &rops);
3179 if (maybe_scalar && o->op_type == OP_PADSV) {
3180 o = scalar(op_append_list(OP_LIST, rops, o));
3181 o->op_private |= OPpLVAL_INTRO;
3184 /* The listop in rops might have a pushmark at the beginning,
3185 which will mess up list assignment. */
3186 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3187 if (rops->op_type == OP_LIST &&
3188 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3190 OP * const pushmark = lrops->op_first;
3191 /* excise pushmark */
3192 op_sibling_splice(rops, NULL, 1, NULL);
3195 o = op_append_list(OP_LIST, o, rops);
3198 PL_parser->in_my = FALSE;
3199 PL_parser->in_my_stash = NULL;
3204 Perl_sawparens(pTHX_ OP *o)
3206 PERL_UNUSED_CONTEXT;
3208 o->op_flags |= OPf_PARENS;
3213 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3217 const OPCODE ltype = left->op_type;
3218 const OPCODE rtype = right->op_type;
3220 PERL_ARGS_ASSERT_BIND_MATCH;
3222 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3223 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3225 const char * const desc
3227 rtype == OP_SUBST || rtype == OP_TRANS
3228 || rtype == OP_TRANSR
3230 ? (int)rtype : OP_MATCH];
3231 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3233 S_op_varname(aTHX_ left);
3235 Perl_warner(aTHX_ packWARN(WARN_MISC),
3236 "Applying %s to %"SVf" will act on scalar(%"SVf")",
3237 desc, SVfARG(name), SVfARG(name));
3239 const char * const sample = (isary
3240 ? "@array" : "%hash");
3241 Perl_warner(aTHX_ packWARN(WARN_MISC),
3242 "Applying %s to %s will act on scalar(%s)",
3243 desc, sample, sample);
3247 if (rtype == OP_CONST &&
3248 cSVOPx(right)->op_private & OPpCONST_BARE &&
3249 cSVOPx(right)->op_private & OPpCONST_STRICT)
3251 no_bareword_allowed(right);
3254 /* !~ doesn't make sense with /r, so error on it for now */
3255 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3257 /* diag_listed_as: Using !~ with %s doesn't make sense */
3258 yyerror("Using !~ with s///r doesn't make sense");
3259 if (rtype == OP_TRANSR && type == OP_NOT)
3260 /* diag_listed_as: Using !~ with %s doesn't make sense */
3261 yyerror("Using !~ with tr///r doesn't make sense");
3263 ismatchop = (rtype == OP_MATCH ||
3264 rtype == OP_SUBST ||
3265 rtype == OP_TRANS || rtype == OP_TRANSR)
3266 && !(right->op_flags & OPf_SPECIAL);
3267 if (ismatchop && right->op_private & OPpTARGET_MY) {
3269 right->op_private &= ~OPpTARGET_MY;
3271 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3274 right->op_flags |= OPf_STACKED;
3275 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3276 ! (rtype == OP_TRANS &&
3277 right->op_private & OPpTRANS_IDENTICAL) &&
3278 ! (rtype == OP_SUBST &&
3279 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3280 newleft = op_lvalue(left, rtype);
3283 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3284 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3286 o = op_prepend_elem(rtype, scalar(newleft), right);
3288 return newUNOP(OP_NOT, 0, scalar(o));
3292 return bind_match(type, left,
3293 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3297 Perl_invert(pTHX_ OP *o)
3301 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3305 =for apidoc Amx|OP *|op_scope|OP *o
3307 Wraps up an op tree with some additional ops so that at runtime a dynamic
3308 scope will be created. The original ops run in the new dynamic scope,
3309 and then, provided that they exit normally, the scope will be unwound.
3310 The additional ops used to create and unwind the dynamic scope will
3311 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3312 instead if the ops are simple enough to not need the full dynamic scope
3319 Perl_op_scope(pTHX_ OP *o)
3323 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3324 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3325 o->op_type = OP_LEAVE;
3326 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3328 else if (o->op_type == OP_LINESEQ) {
3330 o->op_type = OP_SCOPE;
3331 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3332 kid = ((LISTOP*)o)->op_first;
3333 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3336 /* The following deals with things like 'do {1 for 1}' */
3337 kid = OP_SIBLING(kid);
3339 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3344 o = newLISTOP(OP_SCOPE, 0, o, NULL);
3350 Perl_op_unscope(pTHX_ OP *o)
3352 if (o && o->op_type == OP_LINESEQ) {
3353 OP *kid = cLISTOPo->op_first;
3354 for(; kid; kid = OP_SIBLING(kid))
3355 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3362 Perl_block_start(pTHX_ int full)
3364 const int retval = PL_savestack_ix;
3366 pad_block_start(full);
3368 PL_hints &= ~HINT_BLOCK_SCOPE;
3369 SAVECOMPILEWARNINGS();
3370 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3372 CALL_BLOCK_HOOKS(bhk_start, full);
3378 Perl_block_end(pTHX_ I32 floor, OP *seq)
3380 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3381 OP* retval = scalarseq(seq);
3384 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3388 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3392 /* pad_leavemy has created a sequence of introcv ops for all my
3393 subs declared in the block. We have to replicate that list with
3394 clonecv ops, to deal with this situation:
3399 sub s1 { state sub foo { \&s2 } }
3402 Originally, I was going to have introcv clone the CV and turn
3403 off the stale flag. Since &s1 is declared before &s2, the
3404 introcv op for &s1 is executed (on sub entry) before the one for
3405 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
3406 cloned, since it is a state sub) closes over &s2 and expects
3407 to see it in its outer CV’s pad. If the introcv op clones &s1,
3408 then &s2 is still marked stale. Since &s1 is not active, and
3409 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3410 ble will not stay shared’ warning. Because it is the same stub
3411 that will be used when the introcv op for &s2 is executed, clos-
3412 ing over it is safe. Hence, we have to turn off the stale flag
3413 on all lexical subs in the block before we clone any of them.
3414 Hence, having introcv clone the sub cannot work. So we create a
3415 list of ops like this:
3439 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3440 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3441 for (;; kid = OP_SIBLING(kid)) {
3442 OP *newkid = newOP(OP_CLONECV, 0);
3443 newkid->op_targ = kid->op_targ;
3444 o = op_append_elem(OP_LINESEQ, o, newkid);
3445 if (kid == last) break;
3447 retval = op_prepend_elem(OP_LINESEQ, o, retval);
3450 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3456 =head1 Compile-time scope hooks
3458 =for apidoc Aox||blockhook_register
3460 Register a set of hooks to be called when the Perl lexical scope changes
3461 at compile time. See L<perlguts/"Compile-time scope hooks">.
3467 Perl_blockhook_register(pTHX_ BHK *hk)
3469 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3471 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3477 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3478 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3479 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3482 OP * const o = newOP(OP_PADSV, 0);
3483 o->op_targ = offset;
3489 Perl_newPROG(pTHX_ OP *o)
3491 PERL_ARGS_ASSERT_NEWPROG;
3498 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3499 ((PL_in_eval & EVAL_KEEPERR)
3500 ? OPf_SPECIAL : 0), o);
3502 cx = &cxstack[cxstack_ix];
3503 assert(CxTYPE(cx) == CXt_EVAL);
3505 if ((cx->blk_gimme & G_WANT) == G_VOID)
3506 scalarvoid(PL_eval_root);
3507 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3510 scalar(PL_eval_root);
3512 PL_eval_start = op_linklist(PL_eval_root);
3513 PL_eval_root->op_private |= OPpREFCOUNTED;
3514 OpREFCNT_set(PL_eval_root, 1);
3515 PL_eval_root->op_next = 0;
3516 i = PL_savestack_ix;
3519 CALL_PEEP(PL_eval_start);
3520 finalize_optree(PL_eval_root);
3521 S_prune_chain_head(&PL_eval_start);
3523 PL_savestack_ix = i;
3526 if (o->op_type == OP_STUB) {
3527 /* This block is entered if nothing is compiled for the main
3528 program. This will be the case for an genuinely empty main
3529 program, or one which only has BEGIN blocks etc, so already
3532 Historically (5.000) the guard above was !o. However, commit
3533 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3534 c71fccf11fde0068, changed perly.y so that newPROG() is now
3535 called with the output of block_end(), which returns a new
3536 OP_STUB for the case of an empty optree. ByteLoader (and
3537 maybe other things) also take this path, because they set up
3538 PL_main_start and PL_main_root directly, without generating an
3541 If the parsing the main program aborts (due to parse errors,
3542 or due to BEGIN or similar calling exit), then newPROG()
3543 isn't even called, and hence this code path and its cleanups
3544 are skipped. This shouldn't make a make a difference:
3545 * a non-zero return from perl_parse is a failure, and
3546 perl_destruct() should be called immediately.
3547 * however, if exit(0) is called during the parse, then
3548 perl_parse() returns 0, and perl_run() is called. As
3549 PL_main_start will be NULL, perl_run() will return
3550 promptly, and the exit code will remain 0.
3553 PL_comppad_name = 0;
3555 S_op_destroy(aTHX_ o);
3558 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3559 PL_curcop = &PL_compiling;
3560 PL_main_start = LINKLIST(PL_main_root);
3561 PL_main_root->op_private |= OPpREFCOUNTED;
3562 OpREFCNT_set(PL_main_root, 1);
3563 PL_main_root->op_next = 0;
3564 CALL_PEEP(PL_main_start);
3565 finalize_optree(PL_main_root);
3566 S_prune_chain_head(&PL_main_start);
3567 cv_forget_slab(PL_compcv);
3570 /* Register with debugger */
3572 CV * const cv = get_cvs("DB::postponed", 0);
3576 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3578 call_sv(MUTABLE_SV(cv), G_DISCARD);
3585 Perl_localize(pTHX_ OP *o, I32 lex)
3587 PERL_ARGS_ASSERT_LOCALIZE;
3589 if (o->op_flags & OPf_PARENS)
3590 /* [perl #17376]: this appears to be premature, and results in code such as
3591 C< our(%x); > executing in list mode rather than void mode */
3598 if ( PL_parser->bufptr > PL_parser->oldbufptr
3599 && PL_parser->bufptr[-1] == ','
3600 && ckWARN(WARN_PARENTHESIS))
3602 char *s = PL_parser->bufptr;
3605 /* some heuristics to detect a potential error */
3606 while (*s && (strchr(", \t\n", *s)))
3610 if (*s && strchr("@$%*", *s) && *++s
3611 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3614 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3616 while (*s && (strchr(", \t\n", *s)))
3622 if (sigil && (*s == ';' || *s == '=')) {
3623 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3624 "Parentheses missing around \"%s\" list",
3626 ? (PL_parser->in_my == KEY_our
3628 : PL_parser->in_my == KEY_state
3638 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3639 PL_parser->in_my = FALSE;
3640 PL_parser->in_my_stash = NULL;
3645 Perl_jmaybe(pTHX_ OP *o)
3647 PERL_ARGS_ASSERT_JMAYBE;
3649 if (o->op_type == OP_LIST) {
3651 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3652 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3657 PERL_STATIC_INLINE OP *
3658 S_op_std_init(pTHX_ OP *o)
3660 I32 type = o->op_type;
3662 PERL_ARGS_ASSERT_OP_STD_INIT;
3664 if (PL_opargs[type] & OA_RETSCALAR)
3666 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3667 o->op_targ = pad_alloc(type, SVs_PADTMP);
3672 PERL_STATIC_INLINE OP *
3673 S_op_integerize(pTHX_ OP *o)
3675 I32 type = o->op_type;
3677 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3679 /* integerize op. */
3680 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3683 o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3686 if (type == OP_NEGATE)
3687 /* XXX might want a ck_negate() for this */
3688 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3694 S_fold_constants(pTHX_ OP *o)
3699 VOL I32 type = o->op_type;
3704 SV * const oldwarnhook = PL_warnhook;
3705 SV * const olddiehook = PL_diehook;
3707 U8 oldwarn = PL_dowarn;
3710 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3712 if (!(PL_opargs[type] & OA_FOLDCONST))
3721 #ifdef USE_LOCALE_CTYPE
3722 if (IN_LC_COMPILETIME(LC_CTYPE))
3731 #ifdef USE_LOCALE_COLLATE
3732 if (IN_LC_COMPILETIME(LC_COLLATE))
3737 /* XXX what about the numeric ops? */
3738 #ifdef USE_LOCALE_NUMERIC
3739 if (IN_LC_COMPILETIME(LC_NUMERIC))
3744 if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3745 || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3748 SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3749 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3751 const char *s = SvPVX_const(sv);
3752 while (s < SvEND(sv)) {
3753 if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
3760 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3763 if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3764 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3768 if (PL_parser && PL_parser->error_count)
3769 goto nope; /* Don't try to run w/ errors */
3771 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3772 const OPCODE type = curop->op_type;
3773 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3775 type != OP_SCALAR &&
3777 type != OP_PUSHMARK)
3783 curop = LINKLIST(o);
3784 old_next = o->op_next;
3788 oldscope = PL_scopestack_ix;
3789 create_eval_scope(G_FAKINGEVAL);
3791 /* Verify that we don't need to save it: */
3792 assert(PL_curcop == &PL_compiling);
3793 StructCopy(&PL_compiling, ¬_compiling, COP);
3794 PL_curcop = ¬_compiling;
3795 /* The above ensures that we run with all the correct hints of the
3796 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3797 assert(IN_PERL_RUNTIME);
3798 PL_warnhook = PERL_WARNHOOK_FATAL;
3802 /* Effective $^W=1. */
3803 if ( ! (PL_dowarn & G_WARN_ALL_MASK))
3804 PL_dowarn |= G_WARN_ON;
3809 sv = *(PL_stack_sp--);
3810 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3811 pad_swipe(o->op_targ, FALSE);
3813 else if (SvTEMP(sv)) { /* grab mortal temp? */
3814 SvREFCNT_inc_simple_void(sv);
3817 else { assert(SvIMMORTAL(sv)); }
3820 /* Something tried to die. Abandon constant folding. */
3821 /* Pretend the error never happened. */
3823 o->op_next = old_next;
3827 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3828 PL_warnhook = oldwarnhook;
3829 PL_diehook = olddiehook;
3830 /* XXX note that this croak may fail as we've already blown away
3831 * the stack - eg any nested evals */
3832 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3835 PL_dowarn = oldwarn;
3836 PL_warnhook = oldwarnhook;
3837 PL_diehook = olddiehook;
3838 PL_curcop = &PL_compiling;
3840 if (PL_scopestack_ix > oldscope)
3841 delete_eval_scope();
3848 if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3849 else if (!SvIMMORTAL(sv)) {
3853 if (type == OP_RV2GV)
3854 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3857 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3858 if (type != OP_STRINGIFY) newop->op_folded = 1;
3867 S_gen_constant_list(pTHX_ OP *o)
3871 const SSize_t oldtmps_floor = PL_tmps_floor;
3876 if (PL_parser && PL_parser->error_count)
3877 return o; /* Don't attempt to run with errors */
3879 curop = LINKLIST(o);
3882 S_prune_chain_head(&curop);
3884 Perl_pp_pushmark(aTHX);
3887 assert (!(curop->op_flags & OPf_SPECIAL));
3888 assert(curop->op_type == OP_RANGE);
3889 Perl_pp_anonlist(aTHX);
3890 PL_tmps_floor = oldtmps_floor;
3892 o->op_type = OP_RV2AV;
3893 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3894 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3895 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3896 o->op_opt = 0; /* needs to be revisited in rpeep() */
3897 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3899 /* replace subtree with an OP_CONST */
3900 curop = ((UNOP*)o)->op_first;
3901 op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
3904 if (AvFILLp(av) != -1)
3905 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3908 SvREADONLY_on(*svp);
3914 /* convert o (and any siblings) into a list if not already, then
3915 * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
3919 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3922 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3923 if (!o || o->op_type != OP_LIST)
3924 o = force_list(o, 0);
3926 o->op_flags &= ~OPf_WANT;
3928 if (!(PL_opargs[type] & OA_MARK))
3929 op_null(cLISTOPo->op_first);
3931 OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
3932 if (kid2 && kid2->op_type == OP_COREARGS) {
3933 op_null(cLISTOPo->op_first);
3934 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3938 o->op_type = (OPCODE)type;
3939 o->op_ppaddr = PL_ppaddr[type];
3940 o->op_flags |= flags;
3942 o = CHECKOP(type, o);
3943 if (o->op_type != (unsigned)type)
3946 return fold_constants(op_integerize(op_std_init(o)));
3950 =head1 Optree Manipulation Functions
3953 /* List constructors */
3956 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3958 Append an item to the list of ops contained directly within a list-type
3959 op, returning the lengthened list. I<first> is the list-type op,
3960 and I<last> is the op to append to the list. I<optype> specifies the
3961 intended opcode for the list. If I<first> is not already a list of the
3962 right type, it will be upgraded into one. If either I<first> or I<last>
3963 is null, the other is returned unchanged.
3969 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3977 if (first->op_type != (unsigned)type
3978 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3980 return newLISTOP(type, 0, first, last);
3983 op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
3984 first->op_flags |= OPf_KIDS;
3989 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3991 Concatenate the lists of ops contained directly within two list-type ops,
3992 returning the combined list. I<first> and I<last> are the list-type ops
3993 to concatenate. I<optype> specifies the intended opcode for the list.
3994 If either I<first> or I<last> is not already a list of the right type,
3995 it will be upgraded into one. If either I<first> or I<last> is null,
3996 the other is returned unchanged.
4002 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4010 if (first->op_type != (unsigned)type)
4011 return op_prepend_elem(type, first, last);
4013 if (last->op_type != (unsigned)type)
4014 return op_append_elem(type, first, last);
4016 ((LISTOP*)first)->op_last->op_lastsib = 0;
4017 OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4018 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4019 ((LISTOP*)first)->op_last->op_lastsib = 1;
4020 #ifdef PERL_OP_PARENT
4021 ((LISTOP*)first)->op_last->op_sibling = first;
4023 first->op_flags |= (last->op_flags & OPf_KIDS);
4026 S_op_destroy(aTHX_ last);
4032 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4034 Prepend an item to the list of ops contained directly within a list-type
4035 op, returning the lengthened list. I<first> is the op to prepend to the
4036 list, and I<last> is the list-type op. I<optype> specifies the intended
4037 opcode for the list. If I<last> is not already a list of the right type,
4038 it will be upgraded into one. If either I<first> or I<last> is null,
4039 the other is returned unchanged.
4045 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4053 if (last->op_type == (unsigned)type) {
4054 if (type == OP_LIST) { /* already a PUSHMARK there */
4055 /* insert 'first' after pushmark */
4056 op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4057 if (!(first->op_flags & OPf_PARENS))
4058 last->op_flags &= ~OPf_PARENS;
4061 op_sibling_splice(last, NULL, 0, first);
4062 last->op_flags |= OPf_KIDS;
4066 return newLISTOP(type, 0, first, last);
4073 =head1 Optree construction
4075 =for apidoc Am|OP *|newNULLLIST
4077 Constructs, checks, and returns a new C<stub> op, which represents an
4078 empty list expression.
4084 Perl_newNULLLIST(pTHX)
4086 return newOP(OP_STUB, 0);
4089 /* promote o and any siblings to be a list if its not already; i.e.
4097 * pushmark - o - A - B
4099 * If nullit it true, the list op is nulled.
4103 S_force_list(pTHX_ OP *o, bool nullit)
4105 if (!o || o->op_type != OP_LIST) {
4108 /* manually detach any siblings then add them back later */
4109 rest = OP_SIBLING(o);
4110 OP_SIBLING_set(o, NULL);
4113 o = newLISTOP(OP_LIST, 0, o, NULL);
4115 op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4123 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4125 Constructs, checks, and returns an op of any list type. I<type> is
4126 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4127 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
4128 supply up to two ops to be direct children of the list op; they are
4129 consumed by this function and become part of the constructed op tree.
4135 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4140 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4142 NewOp(1101, listop, 1, LISTOP);
4144 listop->op_type = (OPCODE)type;
4145 listop->op_ppaddr = PL_ppaddr[type];
4148 listop->op_flags = (U8)flags;
4152 else if (!first && last)
4155 OP_SIBLING_set(first, last);
4156 listop->op_first = first;
4157 listop->op_last = last;
4158 if (type == OP_LIST) {
4159 OP* const pushop = newOP(OP_PUSHMARK, 0);
4160 pushop->op_lastsib = 0;
4161 OP_SIBLING_set(pushop, first);
4162 listop->op_first = pushop;
4163 listop->op_flags |= OPf_KIDS;
4165 listop->op_last = pushop;
4168 first->op_lastsib = 0;
4169 if (listop->op_last) {
4170 listop->op_last->op_lastsib = 1;
4171 #ifdef PERL_OP_PARENT
4172 listop->op_last->op_sibling = (OP*)listop;
4176 return CHECKOP(type, listop);
4180 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4182 Constructs, checks, and returns an op of any base type (any type that
4183 has no extra fields). I<type> is the opcode. I<flags> gives the
4184 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4191 Perl_newOP(pTHX_ I32 type, I32 flags)
4196 if (type == -OP_ENTEREVAL) {
4197 type = OP_ENTEREVAL;
4198 flags |= OPpEVAL_BYTES<<8;
4201 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4202 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4203 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4204 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4206 NewOp(1101, o, 1, OP);
4207 o->op_type = (OPCODE)type;
4208 o->op_ppaddr = PL_ppaddr[type];
4209 o->op_flags = (U8)flags;
4212 o->op_private = (U8)(0 | (flags >> 8));
4213 if (PL_opargs[type] & OA_RETSCALAR)
4215 if (PL_opargs[type] & OA_TARGET)
4216 o->op_targ = pad_alloc(type, SVs_PADTMP);
4217 return CHECKOP(type, o);
4221 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4223 Constructs, checks, and returns an op of any unary type. I<type> is
4224 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
4225 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4226 bits, the eight bits of C<op_private>, except that the bit with value 1
4227 is automatically set. I<first> supplies an optional op to be the direct
4228 child of the unary op; it is consumed by this function and become part
4229 of the constructed op tree.
4235 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4240 if (type == -OP_ENTEREVAL) {
4241 type = OP_ENTEREVAL;
4242 flags |= OPpEVAL_BYTES<<8;
4245 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4246 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4247 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4248 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4249 || type == OP_SASSIGN
4250 || type == OP_ENTERTRY
4251 || type == OP_NULL );
4254 first = newOP(OP_STUB, 0);
4255 if (PL_opargs[type] & OA_MARK)
4256 first = force_list(first, 1);
4258 NewOp(1101, unop, 1, UNOP);
4259 unop->op_type = (OPCODE)type;
4260 unop->op_ppaddr = PL_ppaddr[type];
4261 unop->op_first = first;
4262 unop->op_flags = (U8)(flags | OPf_KIDS);
4263 unop->op_private = (U8)(1 | (flags >> 8));
4265 #ifdef PERL_OP_PARENT
4266 if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4267 first->op_sibling = (OP*)unop;
4270 unop = (UNOP*) CHECKOP(type, unop);
4274 return fold_constants(op_integerize(op_std_init((OP *) unop)));
4278 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4280 Constructs, checks, and returns an op of any binary type. I<type>
4281 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
4282 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4283 the eight bits of C<op_private>, except that the bit with value 1 or
4284 2 is automatically set as required. I<first> and I<last> supply up to
4285 two ops to be the direct children of the binary op; they are consumed
4286 by this function and become part of the constructed op tree.
4292 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4297 ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4298 || type == OP_SASSIGN || type == OP_NULL );
4300 NewOp(1101, binop, 1, BINOP);
4303 first = newOP(OP_NULL, 0);
4305 binop->op_type = (OPCODE)type;
4306 binop->op_ppaddr = PL_ppaddr[type];
4307 binop->op_first = first;
4308 binop->op_flags = (U8)(flags | OPf_KIDS);
4311 binop->op_private = (U8)(1 | (flags >> 8));
4314 binop->op_private = (U8)(2 | (flags >> 8));
4315 OP_SIBLING_set(first, last);
4316 first->op_lastsib = 0;
4319 #ifdef PERL_OP_PARENT
4320 if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4321 last->op_sibling = (OP*)binop;
4324 binop = (BINOP*)CHECKOP(type, binop);
4325 if (binop->op_next || binop->op_type != (OPCODE)type)
4328 binop->op_last = OP_SIBLING(binop->op_first);
4329 #ifdef PERL_OP_PARENT
4331 binop->op_last->op_sibling = (OP*)binop;
4334 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4337 static int uvcompare(const void *a, const void *b)
4338 __attribute__nonnull__(1)
4339 __attribute__nonnull__(2)
4340 __attribute__pure__;
4341 static int uvcompare(const void *a, const void *b)
4343 if (*((const UV *)a) < (*(const UV *)b))
4345 if (*((const UV *)a) > (*(const UV *)b))
4347 if (*((const UV *)a+1) < (*(const UV *)b+1))
4349 if (*((const UV *)a+1) > (*(const UV *)b+1))
4355 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4357 SV * const tstr = ((SVOP*)expr)->op_sv;
4359 ((SVOP*)repl)->op_sv;
4362 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4363 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4369 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4370 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4371 I32 del = o->op_private & OPpTRANS_DELETE;
4374 PERL_ARGS_ASSERT_PMTRANS;
4376 PL_hints |= HINT_BLOCK_SCOPE;
4379 o->op_private |= OPpTRANS_FROM_UTF;
4382 o->op_private |= OPpTRANS_TO_UTF;
4384 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4385 SV* const listsv = newSVpvs("# comment\n");
4387 const U8* tend = t + tlen;
4388 const U8* rend = r + rlen;
4402 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4403 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4406 const U32 flags = UTF8_ALLOW_DEFAULT;
4410 t = tsave = bytes_to_utf8(t, &len);
4413 if (!to_utf && rlen) {
4415 r = rsave = bytes_to_utf8(r, &len);
4419 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4420 * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4424 U8 tmpbuf[UTF8_MAXBYTES+1];
4427 Newx(cp, 2*tlen, UV);
4429 transv = newSVpvs("");
4431 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4433 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4435 cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4439 cp[2*i+1] = cp[2*i];
4443 qsort(cp, i, 2*sizeof(UV), uvcompare);
4444 for (j = 0; j < i; j++) {
4446 diff = val - nextmin;
4448 t = uvchr_to_utf8(tmpbuf,nextmin);
4449 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4451 U8 range_mark = ILLEGAL_UTF8_BYTE;
4452 t = uvchr_to_utf8(tmpbuf, val - 1);
4453 sv_catpvn(transv, (char *)&range_mark, 1);
4454 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4461 t = uvchr_to_utf8(tmpbuf,nextmin);
4462 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4464 U8 range_mark = ILLEGAL_UTF8_BYTE;
4465 sv_catpvn(transv, (char *)&range_mark, 1);
4467 t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4468 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4469 t = (const U8*)SvPVX_const(transv);
4470 tlen = SvCUR(transv);
4474 else if (!rlen && !del) {
4475 r = t; rlen = tlen; rend = tend;
4478 if ((!rlen && !del) || t == r ||
4479 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4481 o->op_private |= OPpTRANS_IDENTICAL;
4485 while (t < tend || tfirst <= tlast) {
4486 /* see if we need more "t" chars */
4487 if (tfirst > tlast) {
4488 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4490 if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4492 tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4499 /* now see if we need more "r" chars */
4500 if (rfirst > rlast) {
4502 rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4504 if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
4506 rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4515 rfirst = rlast = 0xffffffff;
4519 /* now see which range will peter our first, if either. */
4520 tdiff = tlast - tfirst;
4521 rdiff = rlast - rfirst;
4528 if (rfirst == 0xffffffff) {
4529 diff = tdiff; /* oops, pretend rdiff is infinite */
4531 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4532 (long)tfirst, (long)tlast);
4534 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4538 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4539 (long)tfirst, (long)(tfirst + diff),
4542 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4543 (long)tfirst, (long)rfirst);
4545 if (rfirst + diff > max)
4546 max = rfirst + diff;
4548 grows = (tfirst < rfirst &&
4549 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4561 else if (max > 0xff)
4566 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4568 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4569 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4570 PAD_SETSV(cPADOPo->op_padix, swash);
4572 SvREADONLY_on(swash);
4574 cSVOPo->op_sv = swash;
4576 SvREFCNT_dec(listsv);
4577 SvREFCNT_dec(transv);
4579 if (!del && havefinal && rlen)
4580 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4581 newSVuv((UV)final), 0);
4584 o->op_private |= OPpTRANS_GROWS;
4594 tbl = (short*)PerlMemShared_calloc(
4595 (o->op_private & OPpTRANS_COMPLEMENT) &&
4596 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4598 cPVOPo->op_pv = (char*)tbl;
4600 for (i = 0; i < (I32)tlen; i++)
4602 for (i = 0, j = 0; i < 256; i++) {
4604 if (j >= (I32)rlen) {
4613 if (i < 128 && r[j] >= 128)
4623 o->op_private |= OPpTRANS_IDENTICAL;
4625 else if (j >= (I32)rlen)
4630 PerlMemShared_realloc(tbl,
4631 (0x101+rlen-j) * sizeof(short));
4632 cPVOPo->op_pv = (char*)tbl;
4634 tbl[0x100] = (short)(rlen - j);
4635 for (i=0; i < (I32)rlen - j; i++)
4636 tbl[0x101+i] = r[j+i];
4640 if (!rlen && !del) {
4643 o->op_private |= OPpTRANS_IDENTICAL;
4645 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4646 o->op_private |= OPpTRANS_IDENTICAL;
4648 for (i = 0; i < 256; i++)
4650 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4651 if (j >= (I32)rlen) {
4653 if (tbl[t[i]] == -1)
4659 if (tbl[t[i]] == -1) {
4660 if (t[i] < 128 && r[j] >= 128)
4667 if(del && rlen == tlen) {
4668 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4669 } else if(rlen > tlen && !complement) {
4670 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4674 o->op_private |= OPpTRANS_GROWS;
4682 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4684 Constructs, checks, and returns an op of any pattern matching type.
4685 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4686 and, shifted up eight bits, the eight bits of C<op_private>.
4692 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4697 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4699 NewOp(1101, pmop, 1, PMOP);
4700 pmop->op_type = (OPCODE)type;
4701 pmop->op_ppaddr = PL_ppaddr[type];
4702 pmop->op_flags = (U8)flags;
4703 pmop->op_private = (U8)(0 | (flags >> 8));
4705 if (PL_hints & HINT_RE_TAINT)
4706 pmop->op_pmflags |= PMf_RETAINT;
4707 #ifdef USE_LOCALE_CTYPE
4708 if (IN_LC_COMPILETIME(LC_CTYPE)) {
4709 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4714 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4716 if (PL_hints & HINT_RE_FLAGS) {
4717 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4718 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4720 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4721 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4722 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4724 if (reflags && SvOK(reflags)) {
4725 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4731 assert(SvPOK(PL_regex_pad[0]));
4732 if (SvCUR(PL_regex_pad[0])) {
4733 /* Pop off the "packed" IV from the end. */
4734 SV *const repointer_list = PL_regex_pad[0];
4735 const char *p = SvEND(repointer_list) - sizeof(IV);
4736 const IV offset = *((IV*)p);
4738 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4740 SvEND_set(repointer_list, p);
4742 pmop->op_pmoffset = offset;
4743 /* This slot should be free, so assert this: */
4744 assert(PL_regex_pad[offset] == &PL_sv_undef);
4746 SV * const repointer = &PL_sv_undef;
4747 av_push(PL_regex_padav, repointer);
4748 pmop->op_pmoffset = av_tindex(PL_regex_padav);
4749 PL_regex_pad = AvARRAY(PL_regex_padav);
4753 return CHECKOP(type, pmop);
4756 /* Given some sort of match op o, and an expression expr containing a
4757 * pattern, either compile expr into a regex and attach it to o (if it's
4758 * constant), or convert expr into a runtime regcomp op sequence (if it's
4761 * isreg indicates that the pattern is part of a regex construct, eg
4762 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4763 * split "pattern", which aren't. In the former case, expr will be a list
4764 * if the pattern contains more than one term (eg /a$b/) or if it contains
4765 * a replacement, ie s/// or tr///.
4767 * When the pattern has been compiled within a new anon CV (for
4768 * qr/(?{...})/ ), then floor indicates the savestack level just before
4769 * the new sub was created
4773 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4778 I32 repl_has_vars = 0;
4780 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4781 bool is_compiletime;
4784 PERL_ARGS_ASSERT_PMRUNTIME;
4786 /* for s/// and tr///, last element in list is the replacement; pop it */
4788 if (is_trans || o->op_type == OP_SUBST) {
4790 repl = cLISTOPx(expr)->op_last;
4791 kid = cLISTOPx(expr)->op_first;
4792 while (OP_SIBLING(kid) != repl)
4793 kid = OP_SIBLING(kid);
4794 op_sibling_splice(expr, kid, 1, NULL);
4797 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4802 assert(expr->op_type == OP_LIST);
4803 first = cLISTOPx(expr)->op_first;
4804 last = cLISTOPx(expr)->op_last;
4805 assert(first->op_type == OP_PUSHMARK);
4806 assert(OP_SIBLING(first) == last);
4808 /* cut 'last' from sibling chain, then free everything else */
4809 op_sibling_splice(expr, first, 1, NULL);
4812 return pmtrans(o, last, repl);
4815 /* find whether we have any runtime or code elements;
4816 * at the same time, temporarily set the op_next of each DO block;
4817 * then when we LINKLIST, this will cause the DO blocks to be excluded
4818 * from the op_next chain (and from having LINKLIST recursively
4819 * applied to them). We fix up the DOs specially later */
4823 if (expr->op_type == OP_LIST) {
4825 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4826 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4828 assert(!o->op_next && OP_HAS_SIBLING(o));
4829 o->op_next = OP_SIBLING(o);
4831 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4835 else if (expr->op_type != OP_CONST)
4840 /* fix up DO blocks; treat each one as a separate little sub;
4841 * also, mark any arrays as LIST/REF */
4843 if (expr->op_type == OP_LIST) {
4845 for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
4847 if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4848 assert( !(o->op_flags & OPf_WANT));
4849 /* push the array rather than its contents. The regex
4850 * engine will retrieve and join the elements later */
4851 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4855 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4857 o->op_next = NULL; /* undo temporary hack from above */
4860 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4861 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4863 assert(leaveop->op_first->op_type == OP_ENTER);
4864 assert(OP_HAS_SIBLING(leaveop->op_first));
4865 o->op_next = OP_SIBLING(leaveop->op_first);
4867 assert(leaveop->op_flags & OPf_KIDS);