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 #if defined(PL_OP_SLAB_ALLOC)
114 #ifdef PERL_DEBUG_READONLY_OPS
115 # define PERL_SLAB_SIZE 4096
116 # include <sys/mman.h>
119 #ifndef PERL_SLAB_SIZE
120 #define PERL_SLAB_SIZE 2048
124 Perl_Slab_Alloc(pTHX_ size_t sz)
128 * To make incrementing use count easy PL_OpSlab is an I32 *
129 * To make inserting the link to slab PL_OpPtr is I32 **
130 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
131 * Add an overhead for pointer to slab and round up as a number of pointers
133 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
134 if ((PL_OpSpace -= sz) < 0) {
135 #ifdef PERL_DEBUG_READONLY_OPS
136 /* We need to allocate chunk by chunk so that we can control the VM
138 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
139 MAP_ANON|MAP_PRIVATE, -1, 0);
141 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
142 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
144 if(PL_OpPtr == MAP_FAILED) {
145 perror("mmap failed");
150 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
155 /* We reserve the 0'th I32 sized chunk as a use count */
156 PL_OpSlab = (I32 *) PL_OpPtr;
157 /* Reduce size by the use count word, and by the size we need.
158 * Latter is to mimic the '-=' in the if() above
160 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
161 /* Allocation pointer starts at the top.
162 Theory: because we build leaves before trunk allocating at end
163 means that at run time access is cache friendly upward
165 PL_OpPtr += PERL_SLAB_SIZE;
167 #ifdef PERL_DEBUG_READONLY_OPS
168 /* We remember this slab. */
169 /* This implementation isn't efficient, but it is simple. */
170 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
171 PL_slabs[PL_slab_count++] = PL_OpSlab;
172 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
175 assert( PL_OpSpace >= 0 );
176 /* Move the allocation pointer down */
178 assert( PL_OpPtr > (I32 **) PL_OpSlab );
179 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
180 (*PL_OpSlab)++; /* Increment use count of slab */
181 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
182 assert( *PL_OpSlab > 0 );
183 return (void *)(PL_OpPtr + 1);
186 #ifdef PERL_DEBUG_READONLY_OPS
188 Perl_pending_Slabs_to_ro(pTHX) {
189 /* Turn all the allocated op slabs read only. */
190 U32 count = PL_slab_count;
191 I32 **const slabs = PL_slabs;
193 /* Reset the array of pending OP slabs, as we're about to turn this lot
194 read only. Also, do it ahead of the loop in case the warn triggers,
195 and a warn handler has an eval */
200 /* Force a new slab for any further allocation. */
204 void *const start = slabs[count];
205 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
206 if(mprotect(start, size, PROT_READ)) {
207 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
208 start, (unsigned long) size, errno);
216 S_Slab_to_rw(pTHX_ void *op)
218 I32 * const * const ptr = (I32 **) op;
219 I32 * const slab = ptr[-1];
221 PERL_ARGS_ASSERT_SLAB_TO_RW;
223 assert( ptr-1 > (I32 **) slab );
224 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
226 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
227 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
228 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
233 Perl_op_refcnt_inc(pTHX_ OP *o)
244 Perl_op_refcnt_dec(pTHX_ OP *o)
246 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
251 # define Slab_to_rw(op)
255 Perl_Slab_Free(pTHX_ void *op)
257 I32 * const * const ptr = (I32 **) op;
258 I32 * const slab = ptr[-1];
259 PERL_ARGS_ASSERT_SLAB_FREE;
260 assert( ptr-1 > (I32 **) slab );
261 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
264 if (--(*slab) == 0) {
266 # define PerlMemShared PerlMem
269 #ifdef PERL_DEBUG_READONLY_OPS
270 U32 count = PL_slab_count;
271 /* Need to remove this slab from our list of slabs */
274 if (PL_slabs[count] == slab) {
276 /* Found it. Move the entry at the end to overwrite it. */
277 DEBUG_m(PerlIO_printf(Perl_debug_log,
278 "Deallocate %p by moving %p from %lu to %lu\n",
280 PL_slabs[PL_slab_count - 1],
281 PL_slab_count, count));
282 PL_slabs[count] = PL_slabs[--PL_slab_count];
283 /* Could realloc smaller at this point, but probably not
285 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
286 perror("munmap failed");
294 PerlMemShared_free(slab);
296 if (slab == PL_OpSlab) {
301 #else /* !defined(PL_OP_SLAB_ALLOC) */
303 /* See the explanatory comments above struct opslab in op.h. */
305 # ifndef PERL_SLAB_SIZE
306 # define PERL_SLAB_SIZE 64
309 /* rounds up to nearest pointer */
310 # define SIZE_TO_PSIZE(x) (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
311 # define DIFF(o,p) ((size_t)((I32 **)(p) - (I32**)(o)))
314 S_new_slab(pTHX_ size_t sz)
316 OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
317 slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
321 /* requires double parens and aTHX_ */
322 #define DEBUG_S_warn(args) \
324 PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
328 Perl_Slab_Alloc(pTHX_ size_t sz)
337 if (!PL_compcv || CvROOT(PL_compcv)
338 || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
339 return PerlMemShared_calloc(1, sz);
341 if (!CvSTART(PL_compcv)) { /* sneak it in here */
343 (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
344 CvSLABBED_on(PL_compcv);
345 slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
347 else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
349 opsz = SIZE_TO_PSIZE(sz);
350 sz = opsz + OPSLOT_HEADER_P;
352 if (slab->opslab_freed) {
353 OP **too = &slab->opslab_freed;
355 DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
356 while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
357 DEBUG_S_warn((aTHX_ "Alas! too small"));
358 o = *(too = &o->op_next);
359 if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
363 Zero(o, opsz, I32 *);
369 # define INIT_OPSLOT \
370 slot->opslot_slab = slab; \
371 slot->opslot_next = slab2->opslab_first; \
372 slab2->opslab_first = slot; \
373 o = &slot->opslot_op; \
376 /* The partially-filled slab is next in the chain. */
377 slab2 = slab->opslab_next ? slab->opslab_next : slab;
378 if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
379 /* Remaining space is too small. */
381 /* If we can fit a BASEOP, add it to the free chain, so as not
383 if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
384 slot = &slab2->opslab_slots;
386 o->op_type = OP_FREED;
387 o->op_next = slab->opslab_freed;
388 slab->opslab_freed = o;
391 /* Create a new slab. Make this one twice as big. */
392 slot = slab2->opslab_first;
393 while (slot->opslot_next) slot = slot->opslot_next;
394 slab2 = S_new_slab(aTHX_ DIFF(slab2, slot)*2);
395 slab2->opslab_next = slab->opslab_next;
396 slab->opslab_next = slab2;
398 assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
400 /* Create a new op slot */
401 slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
402 assert(slot >= &slab2->opslab_slots);
403 if (DIFF(&slab2->opslab_slots, slot)
404 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
405 slot = &slab2->opslab_slots;
407 DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
413 /* This cannot possibly be right, but it was copied from the old slab
414 allocator, to which it was originally added, without explanation, in
417 # define PerlMemShared PerlMem
421 Perl_Slab_Free(pTHX_ void *op)
424 OP * const o = (OP *)op;
427 PERL_ARGS_ASSERT_SLAB_FREE;
429 if (!o->op_slabbed) {
430 PerlMemShared_free(op);
435 /* If this op is already freed, our refcount will get screwy. */
436 assert(o->op_type != OP_FREED);
437 o->op_type = OP_FREED;
438 o->op_next = slab->opslab_freed;
439 slab->opslab_freed = o;
440 DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
441 OpslabREFCNT_dec_padok(slab);
445 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
448 const bool havepad = !!PL_comppad;
449 PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
452 PAD_SAVE_SETNULLPAD();
459 Perl_opslab_free(pTHX_ OPSLAB *slab)
463 PERL_ARGS_ASSERT_OPSLAB_FREE;
464 DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
465 assert(slab->opslab_refcnt == 1);
466 for (; slab; slab = slab2) {
467 slab2 = slab->opslab_next;
469 slab->opslab_refcnt = ~(size_t)0;
471 PerlMemShared_free(slab);
476 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
481 size_t savestack_count = 0;
483 PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
486 for (slot = slab2->opslab_first;
488 slot = slot->opslot_next) {
489 if (slot->opslot_op.op_type != OP_FREED
490 && !(slot->opslot_op.op_savefree
496 assert(slot->opslot_op.op_slabbed);
497 slab->opslab_refcnt++; /* op_free may free slab */
498 op_free(&slot->opslot_op);
499 if (!--slab->opslab_refcnt) goto free;
502 } while ((slab2 = slab2->opslab_next));
503 /* > 1 because the CV still holds a reference count. */
504 if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
506 assert(savestack_count == slab->opslab_refcnt-1);
516 * In the following definition, the ", (OP*)0" is just to make the compiler
517 * think the expression is of the right type: croak actually does a Siglongjmp.
519 #define CHECKOP(type,o) \
520 ((PL_op_mask && PL_op_mask[type]) \
521 ? ( op_free((OP*)o), \
522 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
524 : PL_check[type](aTHX_ (OP*)o))
526 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
528 #define CHANGE_TYPE(o,type) \
530 o->op_type = (OPCODE)type; \
531 o->op_ppaddr = PL_ppaddr[type]; \
535 S_gv_ename(pTHX_ GV *gv)
537 SV* const tmpsv = sv_newmortal();
539 PERL_ARGS_ASSERT_GV_ENAME;
541 gv_efullname3(tmpsv, gv, NULL);
546 S_no_fh_allowed(pTHX_ OP *o)
548 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
550 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
556 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
558 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
559 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
560 SvUTF8(namesv) | flags);
565 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
567 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
568 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
573 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
575 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
577 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
582 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
584 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
586 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
587 SvUTF8(namesv) | flags);
592 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
594 PERL_ARGS_ASSERT_BAD_TYPE_PV;
596 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
597 (int)n, name, t, OP_DESC(kid)), flags);
601 S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
603 PERL_ARGS_ASSERT_BAD_TYPE_SV;
605 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
606 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
610 S_no_bareword_allowed(pTHX_ OP *o)
612 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
615 return; /* various ok barewords are hidden in extra OP_NULL */
616 qerror(Perl_mess(aTHX_
617 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
619 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
622 /* "register" allocation */
625 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
629 const bool is_our = (PL_parser->in_my == KEY_our);
631 PERL_ARGS_ASSERT_ALLOCMY;
633 if (flags & ~SVf_UTF8)
634 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
637 /* Until we're using the length for real, cross check that we're being
639 assert(strlen(name) == len);
641 /* complain about "my $<special_var>" etc etc */
645 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
646 (name[1] == '_' && (*name == '$' || len > 2))))
648 /* name[2] is true if strlen(name) > 2 */
649 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
650 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
651 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
652 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
653 PL_parser->in_my == KEY_state ? "state" : "my"));
655 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
656 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
660 /* allocate a spare slot and store the name in that slot */
662 off = pad_add_name_pvn(name, len,
663 (is_our ? padadd_OUR :
664 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
665 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
666 PL_parser->in_my_stash,
668 /* $_ is always in main::, even with our */
669 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
673 /* anon sub prototypes contains state vars should always be cloned,
674 * otherwise the state var would be shared between anon subs */
676 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
677 CvCLONE_on(PL_compcv);
683 =for apidoc alloccopstash
685 Available only under threaded builds, this function allocates an entry in
686 C<PL_stashpad> for the stash passed to it.
693 Perl_alloccopstash(pTHX_ HV *hv)
695 PADOFFSET off = 0, o = 1;
696 bool found_slot = FALSE;
698 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
700 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
702 for (; o < PL_stashpadmax; ++o) {
703 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
704 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
705 found_slot = TRUE, off = o;
708 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
709 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
710 off = PL_stashpadmax;
711 PL_stashpadmax += 10;
714 PL_stashpad[PL_stashpadix = off] = hv;
719 /* free the body of an op without examining its contents.
720 * Always use this rather than FreeOp directly */
723 S_op_destroy(pTHX_ OP *o)
725 if (o->op_latefree) {
733 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
735 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
741 Perl_op_free(pTHX_ OP *o)
746 #ifndef PL_OP_SLAB_ALLOC
747 /* Though ops may be freed twice, freeing the op after its slab is a
749 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
751 /* During the forced freeing of ops after compilation failure, kidops
752 may be freed before their parents. */
753 if (!o || o->op_type == OP_FREED)
755 if (o->op_latefreed) {
762 if (o->op_private & OPpREFCOUNTED) {
773 refcnt = OpREFCNT_dec(o);
776 /* Need to find and remove any pattern match ops from the list
777 we maintain for reset(). */
778 find_and_forget_pmops(o);
788 /* Call the op_free hook if it has been set. Do it now so that it's called
789 * at the right time for refcounted ops, but still before all of the kids
793 if (o->op_flags & OPf_KIDS) {
794 register OP *kid, *nextkid;
795 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
796 nextkid = kid->op_sibling; /* Get before next freeing kid */
801 #ifdef PERL_DEBUG_READONLY_OPS
805 /* COP* is not cleared by op_clear() so that we may track line
806 * numbers etc even after null() */
807 if (type == OP_NEXTSTATE || type == OP_DBSTATE
808 || (type == OP_NULL /* the COP might have been null'ed */
809 && ((OPCODE)o->op_targ == OP_NEXTSTATE
810 || (OPCODE)o->op_targ == OP_DBSTATE))) {
815 type = (OPCODE)o->op_targ;
818 if (o->op_latefree) {
824 #ifdef DEBUG_LEAKING_SCALARS
831 Perl_op_clear(pTHX_ OP *o)
836 PERL_ARGS_ASSERT_OP_CLEAR;
839 mad_free(o->op_madprop);
844 switch (o->op_type) {
845 case OP_NULL: /* Was holding old type, if any. */
846 if (PL_madskills && o->op_targ != OP_NULL) {
847 o->op_type = (Optype)o->op_targ;
852 case OP_ENTEREVAL: /* Was holding hints. */
856 if (!(o->op_flags & OPf_REF)
857 || (PL_check[o->op_type] != Perl_ck_ftst))
864 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
869 /* It's possible during global destruction that the GV is freed
870 before the optree. Whilst the SvREFCNT_inc is happy to bump from
871 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
872 will trigger an assertion failure, because the entry to sv_clear
873 checks that the scalar is not already freed. A check of for
874 !SvIS_FREED(gv) turns out to be invalid, because during global
875 destruction the reference count can be forced down to zero
876 (with SVf_BREAK set). In which case raising to 1 and then
877 dropping to 0 triggers cleanup before it should happen. I
878 *think* that this might actually be a general, systematic,
879 weakness of the whole idea of SVf_BREAK, in that code *is*
880 allowed to raise and lower references during global destruction,
881 so any *valid* code that happens to do this during global
882 destruction might well trigger premature cleanup. */
883 bool still_valid = gv && SvREFCNT(gv);
886 SvREFCNT_inc_simple_void(gv);
888 if (cPADOPo->op_padix > 0) {
889 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
890 * may still exist on the pad */
891 pad_swipe(cPADOPo->op_padix, TRUE);
892 cPADOPo->op_padix = 0;
895 SvREFCNT_dec(cSVOPo->op_sv);
896 cSVOPo->op_sv = NULL;
899 int try_downgrade = SvREFCNT(gv) == 2;
902 gv_try_downgrade(gv);
906 case OP_METHOD_NAMED:
909 SvREFCNT_dec(cSVOPo->op_sv);
910 cSVOPo->op_sv = NULL;
913 Even if op_clear does a pad_free for the target of the op,
914 pad_free doesn't actually remove the sv that exists in the pad;
915 instead it lives on. This results in that it could be reused as
916 a target later on when the pad was reallocated.
919 pad_swipe(o->op_targ,1);
928 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
933 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
935 if (cPADOPo->op_padix > 0) {
936 pad_swipe(cPADOPo->op_padix, TRUE);
937 cPADOPo->op_padix = 0;
940 SvREFCNT_dec(cSVOPo->op_sv);
941 cSVOPo->op_sv = NULL;
945 PerlMemShared_free(cPVOPo->op_pv);
946 cPVOPo->op_pv = NULL;
950 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
954 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
955 /* No GvIN_PAD_off here, because other references may still
956 * exist on the pad */
957 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
960 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
966 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
967 op_free(cPMOPo->op_code_list);
968 cPMOPo->op_code_list = NULL;
969 forget_pmop(cPMOPo, 1);
970 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
971 /* we use the same protection as the "SAFE" version of the PM_ macros
972 * here since sv_clean_all might release some PMOPs
973 * after PL_regex_padav has been cleared
974 * and the clearing of PL_regex_padav needs to
975 * happen before sv_clean_all
978 if(PL_regex_pad) { /* We could be in destruction */
979 const IV offset = (cPMOPo)->op_pmoffset;
980 ReREFCNT_dec(PM_GETRE(cPMOPo));
981 PL_regex_pad[offset] = &PL_sv_undef;
982 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
986 ReREFCNT_dec(PM_GETRE(cPMOPo));
987 PM_SETRE(cPMOPo, NULL);
993 if (o->op_targ > 0) {
994 pad_free(o->op_targ);
1000 S_cop_free(pTHX_ COP* cop)
1002 PERL_ARGS_ASSERT_COP_FREE;
1005 if (! specialWARN(cop->cop_warnings))
1006 PerlMemShared_free(cop->cop_warnings);
1007 cophh_free(CopHINTHASH_get(cop));
1011 S_forget_pmop(pTHX_ PMOP *const o
1017 HV * const pmstash = PmopSTASH(o);
1019 PERL_ARGS_ASSERT_FORGET_PMOP;
1021 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1022 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1024 PMOP **const array = (PMOP**) mg->mg_ptr;
1025 U32 count = mg->mg_len / sizeof(PMOP**);
1029 if (array[i] == o) {
1030 /* Found it. Move the entry at the end to overwrite it. */
1031 array[i] = array[--count];
1032 mg->mg_len = count * sizeof(PMOP**);
1033 /* Could realloc smaller at this point always, but probably
1034 not worth it. Probably worth free()ing if we're the
1037 Safefree(mg->mg_ptr);
1054 S_find_and_forget_pmops(pTHX_ OP *o)
1056 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1058 if (o->op_flags & OPf_KIDS) {
1059 OP *kid = cUNOPo->op_first;
1061 switch (kid->op_type) {
1066 forget_pmop((PMOP*)kid, 0);
1068 find_and_forget_pmops(kid);
1069 kid = kid->op_sibling;
1075 Perl_op_null(pTHX_ OP *o)
1079 PERL_ARGS_ASSERT_OP_NULL;
1081 if (o->op_type == OP_NULL)
1085 o->op_targ = o->op_type;
1086 o->op_type = OP_NULL;
1087 o->op_ppaddr = PL_ppaddr[OP_NULL];
1091 Perl_op_refcnt_lock(pTHX)
1094 PERL_UNUSED_CONTEXT;
1099 Perl_op_refcnt_unlock(pTHX)
1102 PERL_UNUSED_CONTEXT;
1106 /* Contextualizers */
1109 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1111 Applies a syntactic context to an op tree representing an expression.
1112 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1113 or C<G_VOID> to specify the context to apply. The modified op tree
1120 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1122 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1124 case G_SCALAR: return scalar(o);
1125 case G_ARRAY: return list(o);
1126 case G_VOID: return scalarvoid(o);
1128 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1135 =head1 Optree Manipulation Functions
1137 =for apidoc Am|OP*|op_linklist|OP *o
1138 This function is the implementation of the L</LINKLIST> macro. It should
1139 not be called directly.
1145 Perl_op_linklist(pTHX_ OP *o)
1149 PERL_ARGS_ASSERT_OP_LINKLIST;
1154 /* establish postfix order */
1155 first = cUNOPo->op_first;
1158 o->op_next = LINKLIST(first);
1161 if (kid->op_sibling) {
1162 kid->op_next = LINKLIST(kid->op_sibling);
1163 kid = kid->op_sibling;
1177 S_scalarkids(pTHX_ OP *o)
1179 if (o && o->op_flags & OPf_KIDS) {
1181 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1188 S_scalarboolean(pTHX_ OP *o)
1192 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1194 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1195 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1196 if (ckWARN(WARN_SYNTAX)) {
1197 const line_t oldline = CopLINE(PL_curcop);
1199 if (PL_parser && PL_parser->copline != NOLINE)
1200 CopLINE_set(PL_curcop, PL_parser->copline);
1201 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1202 CopLINE_set(PL_curcop, oldline);
1209 Perl_scalar(pTHX_ OP *o)
1214 /* assumes no premature commitment */
1215 if (!o || (PL_parser && PL_parser->error_count)
1216 || (o->op_flags & OPf_WANT)
1217 || o->op_type == OP_RETURN)
1222 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1224 switch (o->op_type) {
1226 scalar(cBINOPo->op_first);
1231 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1241 if (o->op_flags & OPf_KIDS) {
1242 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1248 kid = cLISTOPo->op_first;
1250 kid = kid->op_sibling;
1253 OP *sib = kid->op_sibling;
1254 if (sib && kid->op_type != OP_LEAVEWHEN)
1260 PL_curcop = &PL_compiling;
1265 kid = cLISTOPo->op_first;
1268 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1275 Perl_scalarvoid(pTHX_ OP *o)
1279 const char* useless = NULL;
1280 U32 useless_is_utf8 = 0;
1284 PERL_ARGS_ASSERT_SCALARVOID;
1286 /* trailing mad null ops don't count as "there" for void processing */
1288 o->op_type != OP_NULL &&
1290 o->op_sibling->op_type == OP_NULL)
1293 for (sib = o->op_sibling;
1294 sib && sib->op_type == OP_NULL;
1295 sib = sib->op_sibling) ;
1301 if (o->op_type == OP_NEXTSTATE
1302 || o->op_type == OP_DBSTATE
1303 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1304 || o->op_targ == OP_DBSTATE)))
1305 PL_curcop = (COP*)o; /* for warning below */
1307 /* assumes no premature commitment */
1308 want = o->op_flags & OPf_WANT;
1309 if ((want && want != OPf_WANT_SCALAR)
1310 || (PL_parser && PL_parser->error_count)
1311 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1316 if ((o->op_private & OPpTARGET_MY)
1317 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1319 return scalar(o); /* As if inside SASSIGN */
1322 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1324 switch (o->op_type) {
1326 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1330 if (o->op_flags & OPf_STACKED)
1334 if (o->op_private == 4)
1359 case OP_AELEMFAST_LEX:
1378 case OP_GETSOCKNAME:
1379 case OP_GETPEERNAME:
1384 case OP_GETPRIORITY:
1409 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1410 /* Otherwise it's "Useless use of grep iterator" */
1411 useless = OP_DESC(o);
1415 kid = cLISTOPo->op_first;
1416 if (kid && kid->op_type == OP_PUSHRE
1418 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1420 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1422 useless = OP_DESC(o);
1426 kid = cUNOPo->op_first;
1427 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1428 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1431 useless = "negative pattern binding (!~)";
1435 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1436 useless = "non-destructive substitution (s///r)";
1440 useless = "non-destructive transliteration (tr///r)";
1447 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1448 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1449 useless = "a variable";
1454 if (cSVOPo->op_private & OPpCONST_STRICT)
1455 no_bareword_allowed(o);
1457 if (ckWARN(WARN_VOID)) {
1458 /* don't warn on optimised away booleans, eg
1459 * use constant Foo, 5; Foo || print; */
1460 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1462 /* the constants 0 and 1 are permitted as they are
1463 conventionally used as dummies in constructs like
1464 1 while some_condition_with_side_effects; */
1465 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1467 else if (SvPOK(sv)) {
1468 /* perl4's way of mixing documentation and code
1469 (before the invention of POD) was based on a
1470 trick to mix nroff and perl code. The trick was
1471 built upon these three nroff macros being used in
1472 void context. The pink camel has the details in
1473 the script wrapman near page 319. */
1474 const char * const maybe_macro = SvPVX_const(sv);
1475 if (strnEQ(maybe_macro, "di", 2) ||
1476 strnEQ(maybe_macro, "ds", 2) ||
1477 strnEQ(maybe_macro, "ig", 2))
1480 SV * const dsv = newSVpvs("");
1481 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1483 pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1484 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1486 useless = SvPV_nolen(msv);
1487 useless_is_utf8 = SvUTF8(msv);
1490 else if (SvOK(sv)) {
1491 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1492 "a constant (%"SVf")", sv));
1493 useless = SvPV_nolen(msv);
1496 useless = "a constant (undef)";
1499 op_null(o); /* don't execute or even remember it */
1503 o->op_type = OP_PREINC; /* pre-increment is faster */
1504 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1508 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1509 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1513 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1514 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1518 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1519 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1524 UNOP *refgen, *rv2cv;
1527 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1530 rv2gv = ((BINOP *)o)->op_last;
1531 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1534 refgen = (UNOP *)((BINOP *)o)->op_first;
1536 if (!refgen || refgen->op_type != OP_REFGEN)
1539 exlist = (LISTOP *)refgen->op_first;
1540 if (!exlist || exlist->op_type != OP_NULL
1541 || exlist->op_targ != OP_LIST)
1544 if (exlist->op_first->op_type != OP_PUSHMARK)
1547 rv2cv = (UNOP*)exlist->op_last;
1549 if (rv2cv->op_type != OP_RV2CV)
1552 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1553 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1554 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1556 o->op_private |= OPpASSIGN_CV_TO_GV;
1557 rv2gv->op_private |= OPpDONT_INIT_GV;
1558 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1570 kid = cLOGOPo->op_first;
1571 if (kid->op_type == OP_NOT
1572 && (kid->op_flags & OPf_KIDS)
1574 if (o->op_type == OP_AND) {
1576 o->op_ppaddr = PL_ppaddr[OP_OR];
1578 o->op_type = OP_AND;
1579 o->op_ppaddr = PL_ppaddr[OP_AND];
1588 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1593 if (o->op_flags & OPf_STACKED)
1600 if (!(o->op_flags & OPf_KIDS))
1611 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1621 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1622 newSVpvn_flags(useless, strlen(useless),
1623 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1628 S_listkids(pTHX_ OP *o)
1630 if (o && o->op_flags & OPf_KIDS) {
1632 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1639 Perl_list(pTHX_ OP *o)
1644 /* assumes no premature commitment */
1645 if (!o || (o->op_flags & OPf_WANT)
1646 || (PL_parser && PL_parser->error_count)
1647 || o->op_type == OP_RETURN)
1652 if ((o->op_private & OPpTARGET_MY)
1653 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1655 return o; /* As if inside SASSIGN */
1658 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1660 switch (o->op_type) {
1663 list(cBINOPo->op_first);
1668 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1676 if (!(o->op_flags & OPf_KIDS))
1678 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1679 list(cBINOPo->op_first);
1680 return gen_constant_list(o);
1687 kid = cLISTOPo->op_first;
1689 kid = kid->op_sibling;
1692 OP *sib = kid->op_sibling;
1693 if (sib && kid->op_type != OP_LEAVEWHEN)
1699 PL_curcop = &PL_compiling;
1703 kid = cLISTOPo->op_first;
1710 S_scalarseq(pTHX_ OP *o)
1714 const OPCODE type = o->op_type;
1716 if (type == OP_LINESEQ || type == OP_SCOPE ||
1717 type == OP_LEAVE || type == OP_LEAVETRY)
1720 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1721 if (kid->op_sibling) {
1725 PL_curcop = &PL_compiling;
1727 o->op_flags &= ~OPf_PARENS;
1728 if (PL_hints & HINT_BLOCK_SCOPE)
1729 o->op_flags |= OPf_PARENS;
1732 o = newOP(OP_STUB, 0);
1737 S_modkids(pTHX_ OP *o, I32 type)
1739 if (o && o->op_flags & OPf_KIDS) {
1741 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1742 op_lvalue(kid, type);
1748 =for apidoc finalize_optree
1750 This function finalizes the optree. Should be called directly after
1751 the complete optree is built. It does some additional
1752 checking which can't be done in the normal ck_xxx functions and makes
1753 the tree thread-safe.
1758 Perl_finalize_optree(pTHX_ OP* o)
1760 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1763 SAVEVPTR(PL_curcop);
1771 S_finalize_op(pTHX_ OP* o)
1773 PERL_ARGS_ASSERT_FINALIZE_OP;
1775 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1777 /* Make sure mad ops are also thread-safe */
1778 MADPROP *mp = o->op_madprop;
1780 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1781 OP *prop_op = (OP *) mp->mad_val;
1782 /* We only need "Relocate sv to the pad for thread safety.", but this
1783 easiest way to make sure it traverses everything */
1784 if (prop_op->op_type == OP_CONST)
1785 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1786 finalize_op(prop_op);
1793 switch (o->op_type) {
1796 PL_curcop = ((COP*)o); /* for warnings */
1800 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1801 && ckWARN(WARN_SYNTAX))
1803 if (o->op_sibling->op_sibling) {
1804 const OPCODE type = o->op_sibling->op_sibling->op_type;
1805 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1806 const line_t oldline = CopLINE(PL_curcop);
1807 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1808 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1809 "Statement unlikely to be reached");
1810 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1811 "\t(Maybe you meant system() when you said exec()?)\n");
1812 CopLINE_set(PL_curcop, oldline);
1819 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1820 GV * const gv = cGVOPo_gv;
1821 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1822 /* XXX could check prototype here instead of just carping */
1823 SV * const sv = sv_newmortal();
1824 gv_efullname3(sv, gv, NULL);
1825 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1826 "%"SVf"() called too early to check prototype",
1833 if (cSVOPo->op_private & OPpCONST_STRICT)
1834 no_bareword_allowed(o);
1838 case OP_METHOD_NAMED:
1839 /* Relocate sv to the pad for thread safety.
1840 * Despite being a "constant", the SV is written to,
1841 * for reference counts, sv_upgrade() etc. */
1842 if (cSVOPo->op_sv) {
1843 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1844 if (o->op_type != OP_METHOD_NAMED &&
1845 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1847 /* If op_sv is already a PADTMP/MY then it is being used by
1848 * some pad, so make a copy. */
1849 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1850 SvREADONLY_on(PAD_SVl(ix));
1851 SvREFCNT_dec(cSVOPo->op_sv);
1853 else if (o->op_type != OP_METHOD_NAMED
1854 && cSVOPo->op_sv == &PL_sv_undef) {
1855 /* PL_sv_undef is hack - it's unsafe to store it in the
1856 AV that is the pad, because av_fetch treats values of
1857 PL_sv_undef as a "free" AV entry and will merrily
1858 replace them with a new SV, causing pad_alloc to think
1859 that this pad slot is free. (When, clearly, it is not)
1861 SvOK_off(PAD_SVl(ix));
1862 SvPADTMP_on(PAD_SVl(ix));
1863 SvREADONLY_on(PAD_SVl(ix));
1866 SvREFCNT_dec(PAD_SVl(ix));
1867 SvPADTMP_on(cSVOPo->op_sv);
1868 PAD_SETSV(ix, cSVOPo->op_sv);
1869 /* XXX I don't know how this isn't readonly already. */
1870 SvREADONLY_on(PAD_SVl(ix));
1872 cSVOPo->op_sv = NULL;
1883 const char *key = NULL;
1886 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1889 /* Make the CONST have a shared SV */
1890 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1891 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1892 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1893 key = SvPV_const(sv, keylen);
1894 lexname = newSVpvn_share(key,
1895 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1901 if ((o->op_private & (OPpLVAL_INTRO)))
1904 rop = (UNOP*)((BINOP*)o)->op_first;
1905 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1907 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1908 if (!SvPAD_TYPED(lexname))
1910 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1911 if (!fields || !GvHV(*fields))
1913 key = SvPV_const(*svp, keylen);
1914 if (!hv_fetch(GvHV(*fields), key,
1915 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1916 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1917 "in variable %"SVf" of type %"HEKf,
1918 SVfARG(*svp), SVfARG(lexname),
1919 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1931 SVOP *first_key_op, *key_op;
1933 if ((o->op_private & (OPpLVAL_INTRO))
1934 /* I bet there's always a pushmark... */
1935 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1936 /* hmmm, no optimization if list contains only one key. */
1938 rop = (UNOP*)((LISTOP*)o)->op_last;
1939 if (rop->op_type != OP_RV2HV)
1941 if (rop->op_first->op_type == OP_PADSV)
1942 /* @$hash{qw(keys here)} */
1943 rop = (UNOP*)rop->op_first;
1945 /* @{$hash}{qw(keys here)} */
1946 if (rop->op_first->op_type == OP_SCOPE
1947 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1949 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1955 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1956 if (!SvPAD_TYPED(lexname))
1958 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1959 if (!fields || !GvHV(*fields))
1961 /* Again guessing that the pushmark can be jumped over.... */
1962 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1963 ->op_first->op_sibling;
1964 for (key_op = first_key_op; key_op;
1965 key_op = (SVOP*)key_op->op_sibling) {
1966 if (key_op->op_type != OP_CONST)
1968 svp = cSVOPx_svp(key_op);
1969 key = SvPV_const(*svp, keylen);
1970 if (!hv_fetch(GvHV(*fields), key,
1971 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1972 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1973 "in variable %"SVf" of type %"HEKf,
1974 SVfARG(*svp), SVfARG(lexname),
1975 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1981 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1982 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1989 if (o->op_flags & OPf_KIDS) {
1991 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1997 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1999 Propagate lvalue ("modifiable") context to an op and its children.
2000 I<type> represents the context type, roughly based on the type of op that
2001 would do the modifying, although C<local()> is represented by OP_NULL,
2002 because it has no op type of its own (it is signalled by a flag on
2005 This function detects things that can't be modified, such as C<$x+1>, and
2006 generates errors for them. For example, C<$x+1 = 2> would cause it to be
2007 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2009 It also flags things that need to behave specially in an lvalue context,
2010 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2016 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2020 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2023 if (!o || (PL_parser && PL_parser->error_count))
2026 if ((o->op_private & OPpTARGET_MY)
2027 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2032 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2034 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2036 switch (o->op_type) {
2041 if ((o->op_flags & OPf_PARENS) || PL_madskills)
2045 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2046 !(o->op_flags & OPf_STACKED)) {
2047 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2048 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2049 poses, so we need it clear. */
2050 o->op_private &= ~1;
2051 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2052 assert(cUNOPo->op_first->op_type == OP_NULL);
2053 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2056 else { /* lvalue subroutine call */
2057 o->op_private |= OPpLVAL_INTRO
2058 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2059 PL_modcount = RETURN_UNLIMITED_NUMBER;
2060 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2061 /* Potential lvalue context: */
2062 o->op_private |= OPpENTERSUB_INARGS;
2065 else { /* Compile-time error message: */
2066 OP *kid = cUNOPo->op_first;
2069 if (kid->op_type != OP_PUSHMARK) {
2070 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2072 "panic: unexpected lvalue entersub "
2073 "args: type/targ %ld:%"UVuf,
2074 (long)kid->op_type, (UV)kid->op_targ);
2075 kid = kLISTOP->op_first;
2077 while (kid->op_sibling)
2078 kid = kid->op_sibling;
2079 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2080 break; /* Postpone until runtime */
2083 kid = kUNOP->op_first;
2084 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2085 kid = kUNOP->op_first;
2086 if (kid->op_type == OP_NULL)
2088 "Unexpected constant lvalue entersub "
2089 "entry via type/targ %ld:%"UVuf,
2090 (long)kid->op_type, (UV)kid->op_targ);
2091 if (kid->op_type != OP_GV) {
2095 cv = GvCV(kGVOP_gv);
2105 if (flags & OP_LVALUE_NO_CROAK) return NULL;
2106 /* grep, foreach, subcalls, refgen */
2107 if (type == OP_GREPSTART || type == OP_ENTERSUB
2108 || type == OP_REFGEN || type == OP_LEAVESUBLV)
2110 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2111 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2113 : (o->op_type == OP_ENTERSUB
2114 ? "non-lvalue subroutine call"
2116 type ? PL_op_desc[type] : "local"));
2130 case OP_RIGHT_SHIFT:
2139 if (!(o->op_flags & OPf_STACKED))
2146 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2147 op_lvalue(kid, type);
2152 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2153 PL_modcount = RETURN_UNLIMITED_NUMBER;
2154 return o; /* Treat \(@foo) like ordinary list. */
2158 if (scalar_mod_type(o, type))
2160 ref(cUNOPo->op_first, o->op_type);
2164 if (type == OP_LEAVESUBLV)
2165 o->op_private |= OPpMAYBE_LVSUB;
2171 PL_modcount = RETURN_UNLIMITED_NUMBER;
2174 PL_hints |= HINT_BLOCK_SCOPE;
2175 if (type == OP_LEAVESUBLV)
2176 o->op_private |= OPpMAYBE_LVSUB;
2180 ref(cUNOPo->op_first, o->op_type);
2184 PL_hints |= HINT_BLOCK_SCOPE;
2193 case OP_AELEMFAST_LEX:
2200 PL_modcount = RETURN_UNLIMITED_NUMBER;
2201 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2202 return o; /* Treat \(@foo) like ordinary list. */
2203 if (scalar_mod_type(o, type))
2205 if (type == OP_LEAVESUBLV)
2206 o->op_private |= OPpMAYBE_LVSUB;
2210 if (!type) /* local() */
2211 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2212 PAD_COMPNAME_SV(o->op_targ));
2221 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2225 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2231 if (type == OP_LEAVESUBLV)
2232 o->op_private |= OPpMAYBE_LVSUB;
2233 pad_free(o->op_targ);
2234 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
2235 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
2236 if (o->op_flags & OPf_KIDS)
2237 op_lvalue(cBINOPo->op_first->op_sibling, type);
2242 ref(cBINOPo->op_first, o->op_type);
2243 if (type == OP_ENTERSUB &&
2244 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2245 o->op_private |= OPpLVAL_DEFER;
2246 if (type == OP_LEAVESUBLV)
2247 o->op_private |= OPpMAYBE_LVSUB;
2257 if (o->op_flags & OPf_KIDS)
2258 op_lvalue(cLISTOPo->op_last, type);
2263 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2265 else if (!(o->op_flags & OPf_KIDS))
2267 if (o->op_targ != OP_LIST) {
2268 op_lvalue(cBINOPo->op_first, type);
2274 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2275 /* elements might be in void context because the list is
2276 in scalar context or because they are attribute sub calls */
2277 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2278 op_lvalue(kid, type);
2282 if (type != OP_LEAVESUBLV)
2284 break; /* op_lvalue()ing was handled by ck_return() */
2290 /* [20011101.069] File test operators interpret OPf_REF to mean that
2291 their argument is a filehandle; thus \stat(".") should not set
2293 if (type == OP_REFGEN &&
2294 PL_check[o->op_type] == Perl_ck_ftst)
2297 if (type != OP_LEAVESUBLV)
2298 o->op_flags |= OPf_MOD;
2300 if (type == OP_AASSIGN || type == OP_SASSIGN)
2301 o->op_flags |= OPf_SPECIAL|OPf_REF;
2302 else if (!type) { /* local() */
2305 o->op_private |= OPpLVAL_INTRO;
2306 o->op_flags &= ~OPf_SPECIAL;
2307 PL_hints |= HINT_BLOCK_SCOPE;
2312 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2313 "Useless localization of %s", OP_DESC(o));
2316 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2317 && type != OP_LEAVESUBLV)
2318 o->op_flags |= OPf_REF;
2323 S_scalar_mod_type(const OP *o, I32 type)
2328 if (o && o->op_type == OP_RV2GV)
2352 case OP_RIGHT_SHIFT:
2373 S_is_handle_constructor(const OP *o, I32 numargs)
2375 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2377 switch (o->op_type) {
2385 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2398 S_refkids(pTHX_ OP *o, I32 type)
2400 if (o && o->op_flags & OPf_KIDS) {
2402 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2409 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2414 PERL_ARGS_ASSERT_DOREF;
2416 if (!o || (PL_parser && PL_parser->error_count))
2419 switch (o->op_type) {
2421 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2422 !(o->op_flags & OPf_STACKED)) {
2423 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2424 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2425 assert(cUNOPo->op_first->op_type == OP_NULL);
2426 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2427 o->op_flags |= OPf_SPECIAL;
2428 o->op_private &= ~1;
2430 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2431 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2432 : type == OP_RV2HV ? OPpDEREF_HV
2434 o->op_flags |= OPf_MOD;
2440 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2441 doref(kid, type, set_op_ref);
2444 if (type == OP_DEFINED)
2445 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2446 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2449 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2450 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2451 : type == OP_RV2HV ? OPpDEREF_HV
2453 o->op_flags |= OPf_MOD;
2460 o->op_flags |= OPf_REF;
2463 if (type == OP_DEFINED)
2464 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2465 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2471 o->op_flags |= OPf_REF;
2476 if (!(o->op_flags & OPf_KIDS))
2478 doref(cBINOPo->op_first, type, set_op_ref);
2482 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2483 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2484 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2485 : type == OP_RV2HV ? OPpDEREF_HV
2487 o->op_flags |= OPf_MOD;
2497 if (!(o->op_flags & OPf_KIDS))
2499 doref(cLISTOPo->op_last, type, set_op_ref);
2509 S_dup_attrlist(pTHX_ OP *o)
2514 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2516 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2517 * where the first kid is OP_PUSHMARK and the remaining ones
2518 * are OP_CONST. We need to push the OP_CONST values.
2520 if (o->op_type == OP_CONST)
2521 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2523 else if (o->op_type == OP_NULL)
2527 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2529 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2530 if (o->op_type == OP_CONST)
2531 rop = op_append_elem(OP_LIST, rop,
2532 newSVOP(OP_CONST, o->op_flags,
2533 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2540 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2545 PERL_ARGS_ASSERT_APPLY_ATTRS;
2547 /* fake up C<use attributes $pkg,$rv,@attrs> */
2548 ENTER; /* need to protect against side-effects of 'use' */
2549 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2551 #define ATTRSMODULE "attributes"
2552 #define ATTRSMODULE_PM "attributes.pm"
2555 /* Don't force the C<use> if we don't need it. */
2556 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2557 if (svp && *svp != &PL_sv_undef)
2558 NOOP; /* already in %INC */
2560 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2561 newSVpvs(ATTRSMODULE), NULL);
2564 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2565 newSVpvs(ATTRSMODULE),
2567 op_prepend_elem(OP_LIST,
2568 newSVOP(OP_CONST, 0, stashsv),
2569 op_prepend_elem(OP_LIST,
2570 newSVOP(OP_CONST, 0,
2572 dup_attrlist(attrs))));
2578 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2581 OP *pack, *imop, *arg;
2584 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2589 assert(target->op_type == OP_PADSV ||
2590 target->op_type == OP_PADHV ||
2591 target->op_type == OP_PADAV);
2593 /* Ensure that attributes.pm is loaded. */
2594 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2596 /* Need package name for method call. */
2597 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2599 /* Build up the real arg-list. */
2600 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2602 arg = newOP(OP_PADSV, 0);
2603 arg->op_targ = target->op_targ;
2604 arg = op_prepend_elem(OP_LIST,
2605 newSVOP(OP_CONST, 0, stashsv),
2606 op_prepend_elem(OP_LIST,
2607 newUNOP(OP_REFGEN, 0,
2608 op_lvalue(arg, OP_REFGEN)),
2609 dup_attrlist(attrs)));
2611 /* Fake up a method call to import */
2612 meth = newSVpvs_share("import");
2613 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2614 op_append_elem(OP_LIST,
2615 op_prepend_elem(OP_LIST, pack, list(arg)),
2616 newSVOP(OP_METHOD_NAMED, 0, meth)));
2618 /* Combine the ops. */
2619 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2623 =notfor apidoc apply_attrs_string
2625 Attempts to apply a list of attributes specified by the C<attrstr> and
2626 C<len> arguments to the subroutine identified by the C<cv> argument which
2627 is expected to be associated with the package identified by the C<stashpv>
2628 argument (see L<attributes>). It gets this wrong, though, in that it
2629 does not correctly identify the boundaries of the individual attribute
2630 specifications within C<attrstr>. This is not really intended for the
2631 public API, but has to be listed here for systems such as AIX which
2632 need an explicit export list for symbols. (It's called from XS code
2633 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2634 to respect attribute syntax properly would be welcome.
2640 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2641 const char *attrstr, STRLEN len)
2645 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2648 len = strlen(attrstr);
2652 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2654 const char * const sstr = attrstr;
2655 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2656 attrs = op_append_elem(OP_LIST, attrs,
2657 newSVOP(OP_CONST, 0,
2658 newSVpvn(sstr, attrstr-sstr)));
2662 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2663 newSVpvs(ATTRSMODULE),
2664 NULL, op_prepend_elem(OP_LIST,
2665 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2666 op_prepend_elem(OP_LIST,
2667 newSVOP(OP_CONST, 0,
2668 newRV(MUTABLE_SV(cv))),
2673 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2677 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2679 PERL_ARGS_ASSERT_MY_KID;
2681 if (!o || (PL_parser && PL_parser->error_count))
2685 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2686 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2690 if (type == OP_LIST) {
2692 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2693 my_kid(kid, attrs, imopsp);
2695 } else if (type == OP_UNDEF || type == OP_STUB) {
2697 } else if (type == OP_RV2SV || /* "our" declaration */
2699 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2700 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2701 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2703 PL_parser->in_my == KEY_our
2705 : PL_parser->in_my == KEY_state ? "state" : "my"));
2707 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2708 PL_parser->in_my = FALSE;
2709 PL_parser->in_my_stash = NULL;
2710 apply_attrs(GvSTASH(gv),
2711 (type == OP_RV2SV ? GvSV(gv) :
2712 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2713 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2716 o->op_private |= OPpOUR_INTRO;
2719 else if (type != OP_PADSV &&
2722 type != OP_PUSHMARK)
2724 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2726 PL_parser->in_my == KEY_our
2728 : PL_parser->in_my == KEY_state ? "state" : "my"));
2731 else if (attrs && type != OP_PUSHMARK) {
2734 PL_parser->in_my = FALSE;
2735 PL_parser->in_my_stash = NULL;
2737 /* check for C<my Dog $spot> when deciding package */
2738 stash = PAD_COMPNAME_TYPE(o->op_targ);
2740 stash = PL_curstash;
2741 apply_attrs_my(stash, o, attrs, imopsp);
2743 o->op_flags |= OPf_MOD;
2744 o->op_private |= OPpLVAL_INTRO;
2746 o->op_private |= OPpPAD_STATE;
2751 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2755 int maybe_scalar = 0;
2757 PERL_ARGS_ASSERT_MY_ATTRS;
2759 /* [perl #17376]: this appears to be premature, and results in code such as
2760 C< our(%x); > executing in list mode rather than void mode */
2762 if (o->op_flags & OPf_PARENS)
2772 o = my_kid(o, attrs, &rops);
2774 if (maybe_scalar && o->op_type == OP_PADSV) {
2775 o = scalar(op_append_list(OP_LIST, rops, o));
2776 o->op_private |= OPpLVAL_INTRO;
2779 /* The listop in rops might have a pushmark at the beginning,
2780 which will mess up list assignment. */
2781 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2782 if (rops->op_type == OP_LIST &&
2783 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2785 OP * const pushmark = lrops->op_first;
2786 lrops->op_first = pushmark->op_sibling;
2789 o = op_append_list(OP_LIST, o, rops);
2792 PL_parser->in_my = FALSE;
2793 PL_parser->in_my_stash = NULL;
2798 Perl_sawparens(pTHX_ OP *o)
2800 PERL_UNUSED_CONTEXT;
2802 o->op_flags |= OPf_PARENS;
2807 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2811 const OPCODE ltype = left->op_type;
2812 const OPCODE rtype = right->op_type;
2814 PERL_ARGS_ASSERT_BIND_MATCH;
2816 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2817 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2819 const char * const desc
2821 rtype == OP_SUBST || rtype == OP_TRANS
2822 || rtype == OP_TRANSR
2824 ? (int)rtype : OP_MATCH];
2825 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2828 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2829 ? cUNOPx(left)->op_first->op_type == OP_GV
2830 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2831 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2834 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2837 Perl_warner(aTHX_ packWARN(WARN_MISC),
2838 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2841 const char * const sample = (isary
2842 ? "@array" : "%hash");
2843 Perl_warner(aTHX_ packWARN(WARN_MISC),
2844 "Applying %s to %s will act on scalar(%s)",
2845 desc, sample, sample);
2849 if (rtype == OP_CONST &&
2850 cSVOPx(right)->op_private & OPpCONST_BARE &&
2851 cSVOPx(right)->op_private & OPpCONST_STRICT)
2853 no_bareword_allowed(right);
2856 /* !~ doesn't make sense with /r, so error on it for now */
2857 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2859 yyerror("Using !~ with s///r doesn't make sense");
2860 if (rtype == OP_TRANSR && type == OP_NOT)
2861 yyerror("Using !~ with tr///r doesn't make sense");
2863 ismatchop = (rtype == OP_MATCH ||
2864 rtype == OP_SUBST ||
2865 rtype == OP_TRANS || rtype == OP_TRANSR)
2866 && !(right->op_flags & OPf_SPECIAL);
2867 if (ismatchop && right->op_private & OPpTARGET_MY) {
2869 right->op_private &= ~OPpTARGET_MY;
2871 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2874 right->op_flags |= OPf_STACKED;
2875 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2876 ! (rtype == OP_TRANS &&
2877 right->op_private & OPpTRANS_IDENTICAL) &&
2878 ! (rtype == OP_SUBST &&
2879 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2880 newleft = op_lvalue(left, rtype);
2883 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2884 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2886 o = op_prepend_elem(rtype, scalar(newleft), right);
2888 return newUNOP(OP_NOT, 0, scalar(o));
2892 return bind_match(type, left,
2893 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2897 Perl_invert(pTHX_ OP *o)
2901 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2905 =for apidoc Amx|OP *|op_scope|OP *o
2907 Wraps up an op tree with some additional ops so that at runtime a dynamic
2908 scope will be created. The original ops run in the new dynamic scope,
2909 and then, provided that they exit normally, the scope will be unwound.
2910 The additional ops used to create and unwind the dynamic scope will
2911 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2912 instead if the ops are simple enough to not need the full dynamic scope
2919 Perl_op_scope(pTHX_ OP *o)
2923 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2924 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2925 o->op_type = OP_LEAVE;
2926 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2928 else if (o->op_type == OP_LINESEQ) {
2930 o->op_type = OP_SCOPE;
2931 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2932 kid = ((LISTOP*)o)->op_first;
2933 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2936 /* The following deals with things like 'do {1 for 1}' */
2937 kid = kid->op_sibling;
2939 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2944 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2950 Perl_block_start(pTHX_ int full)
2953 const int retval = PL_savestack_ix;
2955 pad_block_start(full);
2957 PL_hints &= ~HINT_BLOCK_SCOPE;
2958 SAVECOMPILEWARNINGS();
2959 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2961 CALL_BLOCK_HOOKS(bhk_start, full);
2967 Perl_block_end(pTHX_ I32 floor, OP *seq)
2970 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2971 OP* retval = scalarseq(seq);
2973 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2976 CopHINTS_set(&PL_compiling, PL_hints);
2978 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2981 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2987 =head1 Compile-time scope hooks
2989 =for apidoc Aox||blockhook_register
2991 Register a set of hooks to be called when the Perl lexical scope changes
2992 at compile time. See L<perlguts/"Compile-time scope hooks">.
2998 Perl_blockhook_register(pTHX_ BHK *hk)
3000 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3002 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3009 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3010 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3011 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3014 OP * const o = newOP(OP_PADSV, 0);
3015 o->op_targ = offset;
3021 Perl_newPROG(pTHX_ OP *o)
3025 PERL_ARGS_ASSERT_NEWPROG;
3032 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3033 ((PL_in_eval & EVAL_KEEPERR)
3034 ? OPf_SPECIAL : 0), o);
3036 cx = &cxstack[cxstack_ix];
3037 assert(CxTYPE(cx) == CXt_EVAL);
3039 if ((cx->blk_gimme & G_WANT) == G_VOID)
3040 scalarvoid(PL_eval_root);
3041 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3044 scalar(PL_eval_root);
3046 PL_eval_start = op_linklist(PL_eval_root);
3047 PL_eval_root->op_private |= OPpREFCOUNTED;
3048 OpREFCNT_set(PL_eval_root, 1);
3049 PL_eval_root->op_next = 0;
3050 i = PL_savestack_ix;
3053 CALL_PEEP(PL_eval_start);
3054 finalize_optree(PL_eval_root);
3056 PL_savestack_ix = i;
3059 if (o->op_type == OP_STUB) {
3060 PL_comppad_name = 0;
3062 S_op_destroy(aTHX_ o);
3065 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3066 PL_curcop = &PL_compiling;
3067 PL_main_start = LINKLIST(PL_main_root);
3068 PL_main_root->op_private |= OPpREFCOUNTED;
3069 OpREFCNT_set(PL_main_root, 1);
3070 PL_main_root->op_next = 0;
3071 CALL_PEEP(PL_main_start);
3072 finalize_optree(PL_main_root);
3073 cv_forget_slab(PL_compcv);
3076 /* Register with debugger */
3078 CV * const cv = get_cvs("DB::postponed", 0);
3082 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3084 call_sv(MUTABLE_SV(cv), G_DISCARD);
3091 Perl_localize(pTHX_ OP *o, I32 lex)
3095 PERL_ARGS_ASSERT_LOCALIZE;
3097 if (o->op_flags & OPf_PARENS)
3098 /* [perl #17376]: this appears to be premature, and results in code such as
3099 C< our(%x); > executing in list mode rather than void mode */
3106 if ( PL_parser->bufptr > PL_parser->oldbufptr
3107 && PL_parser->bufptr[-1] == ','
3108 && ckWARN(WARN_PARENTHESIS))
3110 char *s = PL_parser->bufptr;
3113 /* some heuristics to detect a potential error */
3114 while (*s && (strchr(", \t\n", *s)))
3118 if (*s && strchr("@$%*", *s) && *++s
3119 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
3122 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
3124 while (*s && (strchr(", \t\n", *s)))
3130 if (sigil && (*s == ';' || *s == '=')) {
3131 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3132 "Parentheses missing around \"%s\" list",
3134 ? (PL_parser->in_my == KEY_our
3136 : PL_parser->in_my == KEY_state
3146 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
3147 PL_parser->in_my = FALSE;
3148 PL_parser->in_my_stash = NULL;
3153 Perl_jmaybe(pTHX_ OP *o)
3155 PERL_ARGS_ASSERT_JMAYBE;
3157 if (o->op_type == OP_LIST) {
3159 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3160 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3165 PERL_STATIC_INLINE OP *
3166 S_op_std_init(pTHX_ OP *o)
3168 I32 type = o->op_type;
3170 PERL_ARGS_ASSERT_OP_STD_INIT;
3172 if (PL_opargs[type] & OA_RETSCALAR)
3174 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3175 o->op_targ = pad_alloc(type, SVs_PADTMP);
3180 PERL_STATIC_INLINE OP *
3181 S_op_integerize(pTHX_ OP *o)
3183 I32 type = o->op_type;
3185 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3187 /* integerize op. */
3188 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3191 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3194 if (type == OP_NEGATE)
3195 /* XXX might want a ck_negate() for this */
3196 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3202 S_fold_constants(pTHX_ register OP *o)
3205 register OP * VOL curop;
3207 VOL I32 type = o->op_type;
3212 SV * const oldwarnhook = PL_warnhook;
3213 SV * const olddiehook = PL_diehook;
3217 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3219 if (!(PL_opargs[type] & OA_FOLDCONST))
3233 /* XXX what about the numeric ops? */
3234 if (IN_LOCALE_COMPILETIME)
3238 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3241 if (PL_parser && PL_parser->error_count)
3242 goto nope; /* Don't try to run w/ errors */
3244 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3245 const OPCODE type = curop->op_type;
3246 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3248 type != OP_SCALAR &&
3250 type != OP_PUSHMARK)
3256 curop = LINKLIST(o);
3257 old_next = o->op_next;
3261 oldscope = PL_scopestack_ix;
3262 create_eval_scope(G_FAKINGEVAL);
3264 /* Verify that we don't need to save it: */
3265 assert(PL_curcop == &PL_compiling);
3266 StructCopy(&PL_compiling, ¬_compiling, COP);
3267 PL_curcop = ¬_compiling;
3268 /* The above ensures that we run with all the correct hints of the
3269 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3270 assert(IN_PERL_RUNTIME);
3271 PL_warnhook = PERL_WARNHOOK_FATAL;
3278 sv = *(PL_stack_sp--);
3279 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3281 /* Can't simply swipe the SV from the pad, because that relies on
3282 the op being freed "real soon now". Under MAD, this doesn't
3283 happen (see the #ifdef below). */
3286 pad_swipe(o->op_targ, FALSE);
3289 else if (SvTEMP(sv)) { /* grab mortal temp? */
3290 SvREFCNT_inc_simple_void(sv);
3295 /* Something tried to die. Abandon constant folding. */
3296 /* Pretend the error never happened. */
3298 o->op_next = old_next;
3302 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3303 PL_warnhook = oldwarnhook;
3304 PL_diehook = olddiehook;
3305 /* XXX note that this croak may fail as we've already blown away
3306 * the stack - eg any nested evals */
3307 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3310 PL_warnhook = oldwarnhook;
3311 PL_diehook = olddiehook;
3312 PL_curcop = &PL_compiling;
3314 if (PL_scopestack_ix > oldscope)
3315 delete_eval_scope();
3324 if (type == OP_RV2GV)
3325 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3327 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3328 op_getmad(o,newop,'f');
3336 S_gen_constant_list(pTHX_ register OP *o)
3340 const I32 oldtmps_floor = PL_tmps_floor;
3343 if (PL_parser && PL_parser->error_count)
3344 return o; /* Don't attempt to run with errors */
3346 PL_op = curop = LINKLIST(o);
3349 Perl_pp_pushmark(aTHX);
3352 assert (!(curop->op_flags & OPf_SPECIAL));
3353 assert(curop->op_type == OP_RANGE);
3354 Perl_pp_anonlist(aTHX);
3355 PL_tmps_floor = oldtmps_floor;
3357 o->op_type = OP_RV2AV;
3358 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3359 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3360 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3361 o->op_opt = 0; /* needs to be revisited in rpeep() */
3362 curop = ((UNOP*)o)->op_first;
3363 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3365 op_getmad(curop,o,'O');
3374 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3377 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3378 if (!o || o->op_type != OP_LIST)
3379 o = newLISTOP(OP_LIST, 0, o, NULL);
3381 o->op_flags &= ~OPf_WANT;
3383 if (!(PL_opargs[type] & OA_MARK))
3384 op_null(cLISTOPo->op_first);
3386 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3387 if (kid2 && kid2->op_type == OP_COREARGS) {
3388 op_null(cLISTOPo->op_first);
3389 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3393 o->op_type = (OPCODE)type;
3394 o->op_ppaddr = PL_ppaddr[type];
3395 o->op_flags |= flags;
3397 o = CHECKOP(type, o);
3398 if (o->op_type != (unsigned)type)
3401 return fold_constants(op_integerize(op_std_init(o)));
3405 =head1 Optree Manipulation Functions
3408 /* List constructors */
3411 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3413 Append an item to the list of ops contained directly within a list-type
3414 op, returning the lengthened list. I<first> is the list-type op,
3415 and I<last> is the op to append to the list. I<optype> specifies the
3416 intended opcode for the list. If I<first> is not already a list of the
3417 right type, it will be upgraded into one. If either I<first> or I<last>
3418 is null, the other is returned unchanged.
3424 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3432 if (first->op_type != (unsigned)type
3433 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3435 return newLISTOP(type, 0, first, last);
3438 if (first->op_flags & OPf_KIDS)
3439 ((LISTOP*)first)->op_last->op_sibling = last;
3441 first->op_flags |= OPf_KIDS;
3442 ((LISTOP*)first)->op_first = last;
3444 ((LISTOP*)first)->op_last = last;
3449 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3451 Concatenate the lists of ops contained directly within two list-type ops,
3452 returning the combined list. I<first> and I<last> are the list-type ops
3453 to concatenate. I<optype> specifies the intended opcode for the list.
3454 If either I<first> or I<last> is not already a list of the right type,
3455 it will be upgraded into one. If either I<first> or I<last> is null,
3456 the other is returned unchanged.
3462 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3470 if (first->op_type != (unsigned)type)
3471 return op_prepend_elem(type, first, last);
3473 if (last->op_type != (unsigned)type)
3474 return op_append_elem(type, first, last);
3476 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3477 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3478 first->op_flags |= (last->op_flags & OPf_KIDS);
3481 if (((LISTOP*)last)->op_first && first->op_madprop) {
3482 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3484 while (mp->mad_next)
3486 mp->mad_next = first->op_madprop;
3489 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3492 first->op_madprop = last->op_madprop;
3493 last->op_madprop = 0;
3496 S_op_destroy(aTHX_ last);
3502 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3504 Prepend an item to the list of ops contained directly within a list-type
3505 op, returning the lengthened list. I<first> is the op to prepend to the
3506 list, and I<last> is the list-type op. I<optype> specifies the intended
3507 opcode for the list. If I<last> is not already a list of the right type,
3508 it will be upgraded into one. If either I<first> or I<last> is null,
3509 the other is returned unchanged.
3515 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3523 if (last->op_type == (unsigned)type) {
3524 if (type == OP_LIST) { /* already a PUSHMARK there */
3525 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3526 ((LISTOP*)last)->op_first->op_sibling = first;
3527 if (!(first->op_flags & OPf_PARENS))
3528 last->op_flags &= ~OPf_PARENS;
3531 if (!(last->op_flags & OPf_KIDS)) {
3532 ((LISTOP*)last)->op_last = first;
3533 last->op_flags |= OPf_KIDS;
3535 first->op_sibling = ((LISTOP*)last)->op_first;
3536 ((LISTOP*)last)->op_first = first;
3538 last->op_flags |= OPf_KIDS;
3542 return newLISTOP(type, 0, first, last);
3550 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3553 Newxz(tk, 1, TOKEN);
3554 tk->tk_type = (OPCODE)optype;
3555 tk->tk_type = 12345;
3557 tk->tk_mad = madprop;
3562 Perl_token_free(pTHX_ TOKEN* tk)
3564 PERL_ARGS_ASSERT_TOKEN_FREE;
3566 if (tk->tk_type != 12345)
3568 mad_free(tk->tk_mad);
3573 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3578 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3580 if (tk->tk_type != 12345) {
3581 Perl_warner(aTHX_ packWARN(WARN_MISC),
3582 "Invalid TOKEN object ignored");
3589 /* faked up qw list? */
3591 tm->mad_type == MAD_SV &&
3592 SvPVX((SV *)tm->mad_val)[0] == 'q')
3599 /* pretend constant fold didn't happen? */
3600 if (mp->mad_key == 'f' &&
3601 (o->op_type == OP_CONST ||
3602 o->op_type == OP_GV) )
3604 token_getmad(tk,(OP*)mp->mad_val,slot);
3618 if (mp->mad_key == 'X')
3619 mp->mad_key = slot; /* just change the first one */
3629 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3638 /* pretend constant fold didn't happen? */
3639 if (mp->mad_key == 'f' &&
3640 (o->op_type == OP_CONST ||
3641 o->op_type == OP_GV) )
3643 op_getmad(from,(OP*)mp->mad_val,slot);
3650 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3653 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3659 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3668 /* pretend constant fold didn't happen? */
3669 if (mp->mad_key == 'f' &&
3670 (o->op_type == OP_CONST ||
3671 o->op_type == OP_GV) )
3673 op_getmad(from,(OP*)mp->mad_val,slot);
3680 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3683 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3687 PerlIO_printf(PerlIO_stderr(),
3688 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3694 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3712 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3716 addmad(tm, &(o->op_madprop), slot);
3720 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3741 Perl_newMADsv(pTHX_ char key, SV* sv)
3743 PERL_ARGS_ASSERT_NEWMADSV;
3745 return newMADPROP(key, MAD_SV, sv, 0);
3749 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3751 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3754 mp->mad_vlen = vlen;
3755 mp->mad_type = type;
3757 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3762 Perl_mad_free(pTHX_ MADPROP* mp)
3764 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3768 mad_free(mp->mad_next);
3769 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3770 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3771 switch (mp->mad_type) {
3775 Safefree((char*)mp->mad_val);
3778 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3779 op_free((OP*)mp->mad_val);
3782 sv_free(MUTABLE_SV(mp->mad_val));
3785 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3788 PerlMemShared_free(mp);
3794 =head1 Optree construction
3796 =for apidoc Am|OP *|newNULLLIST
3798 Constructs, checks, and returns a new C<stub> op, which represents an
3799 empty list expression.
3805 Perl_newNULLLIST(pTHX)
3807 return newOP(OP_STUB, 0);
3811 S_force_list(pTHX_ OP *o)
3813 if (!o || o->op_type != OP_LIST)
3814 o = newLISTOP(OP_LIST, 0, o, NULL);
3820 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3822 Constructs, checks, and returns an op of any list type. I<type> is
3823 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3824 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3825 supply up to two ops to be direct children of the list op; they are
3826 consumed by this function and become part of the constructed op tree.
3832 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3837 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3839 NewOp(1101, listop, 1, LISTOP);
3841 listop->op_type = (OPCODE)type;
3842 listop->op_ppaddr = PL_ppaddr[type];
3845 listop->op_flags = (U8)flags;
3849 else if (!first && last)
3852 first->op_sibling = last;
3853 listop->op_first = first;
3854 listop->op_last = last;
3855 if (type == OP_LIST) {
3856 OP* const pushop = newOP(OP_PUSHMARK, 0);
3857 pushop->op_sibling = first;
3858 listop->op_first = pushop;
3859 listop->op_flags |= OPf_KIDS;
3861 listop->op_last = pushop;
3864 return CHECKOP(type, listop);
3868 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3870 Constructs, checks, and returns an op of any base type (any type that
3871 has no extra fields). I<type> is the opcode. I<flags> gives the
3872 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3879 Perl_newOP(pTHX_ I32 type, I32 flags)
3884 if (type == -OP_ENTEREVAL) {
3885 type = OP_ENTEREVAL;
3886 flags |= OPpEVAL_BYTES<<8;
3889 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3890 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3891 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3892 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3894 NewOp(1101, o, 1, OP);
3895 o->op_type = (OPCODE)type;
3896 o->op_ppaddr = PL_ppaddr[type];
3897 o->op_flags = (U8)flags;
3899 o->op_latefreed = 0;
3903 o->op_private = (U8)(0 | (flags >> 8));
3904 if (PL_opargs[type] & OA_RETSCALAR)
3906 if (PL_opargs[type] & OA_TARGET)
3907 o->op_targ = pad_alloc(type, SVs_PADTMP);
3908 return CHECKOP(type, o);
3912 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3914 Constructs, checks, and returns an op of any unary type. I<type> is
3915 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3916 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3917 bits, the eight bits of C<op_private>, except that the bit with value 1
3918 is automatically set. I<first> supplies an optional op to be the direct
3919 child of the unary op; it is consumed by this function and become part
3920 of the constructed op tree.
3926 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3931 if (type == -OP_ENTEREVAL) {
3932 type = OP_ENTEREVAL;
3933 flags |= OPpEVAL_BYTES<<8;
3936 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3937 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3938 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3939 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3940 || type == OP_SASSIGN
3941 || type == OP_ENTERTRY
3942 || type == OP_NULL );
3945 first = newOP(OP_STUB, 0);
3946 if (PL_opargs[type] & OA_MARK)
3947 first = force_list(first);
3949 NewOp(1101, unop, 1, UNOP);
3950 unop->op_type = (OPCODE)type;
3951 unop->op_ppaddr = PL_ppaddr[type];
3952 unop->op_first = first;
3953 unop->op_flags = (U8)(flags | OPf_KIDS);
3954 unop->op_private = (U8)(1 | (flags >> 8));
3955 unop = (UNOP*) CHECKOP(type, unop);
3959 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3963 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3965 Constructs, checks, and returns an op of any binary type. I<type>
3966 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3967 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3968 the eight bits of C<op_private>, except that the bit with value 1 or
3969 2 is automatically set as required. I<first> and I<last> supply up to
3970 two ops to be the direct children of the binary op; they are consumed
3971 by this function and become part of the constructed op tree.
3977 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3982 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3983 || type == OP_SASSIGN || type == OP_NULL );
3985 NewOp(1101, binop, 1, BINOP);
3988 first = newOP(OP_NULL, 0);
3990 binop->op_type = (OPCODE)type;
3991 binop->op_ppaddr = PL_ppaddr[type];
3992 binop->op_first = first;
3993 binop->op_flags = (U8)(flags | OPf_KIDS);
3996 binop->op_private = (U8)(1 | (flags >> 8));
3999 binop->op_private = (U8)(2 | (flags >> 8));
4000 first->op_sibling = last;
4003 binop = (BINOP*)CHECKOP(type, binop);
4004 if (binop->op_next || binop->op_type != (OPCODE)type)
4007 binop->op_last = binop->op_first->op_sibling;
4009 return fold_constants(op_integerize(op_std_init((OP *)binop)));
4012 static int uvcompare(const void *a, const void *b)
4013 __attribute__nonnull__(1)
4014 __attribute__nonnull__(2)
4015 __attribute__pure__;
4016 static int uvcompare(const void *a, const void *b)
4018 if (*((const UV *)a) < (*(const UV *)b))
4020 if (*((const UV *)a) > (*(const UV *)b))
4022 if (*((const UV *)a+1) < (*(const UV *)b+1))
4024 if (*((const UV *)a+1) > (*(const UV *)b+1))
4030 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4033 SV * const tstr = ((SVOP*)expr)->op_sv;
4036 (repl->op_type == OP_NULL)
4037 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4039 ((SVOP*)repl)->op_sv;
4042 const U8 *t = (U8*)SvPV_const(tstr, tlen);
4043 const U8 *r = (U8*)SvPV_const(rstr, rlen);
4047 register short *tbl;
4049 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4050 const I32 squash = o->op_private & OPpTRANS_SQUASH;
4051 I32 del = o->op_private & OPpTRANS_DELETE;
4054 PERL_ARGS_ASSERT_PMTRANS;
4056 PL_hints |= HINT_BLOCK_SCOPE;
4059 o->op_private |= OPpTRANS_FROM_UTF;
4062 o->op_private |= OPpTRANS_TO_UTF;
4064 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4065 SV* const listsv = newSVpvs("# comment\n");
4067 const U8* tend = t + tlen;
4068 const U8* rend = r + rlen;
4082 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
4083 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
4086 const U32 flags = UTF8_ALLOW_DEFAULT;
4090 t = tsave = bytes_to_utf8(t, &len);
4093 if (!to_utf && rlen) {
4095 r = rsave = bytes_to_utf8(r, &len);
4099 /* There are several snags with this code on EBCDIC:
4100 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
4101 2. scan_const() in toke.c has encoded chars in native encoding which makes
4102 ranges at least in EBCDIC 0..255 range the bottom odd.
4106 U8 tmpbuf[UTF8_MAXBYTES+1];
4109 Newx(cp, 2*tlen, UV);
4111 transv = newSVpvs("");
4113 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4115 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
4117 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
4121 cp[2*i+1] = cp[2*i];
4125 qsort(cp, i, 2*sizeof(UV), uvcompare);
4126 for (j = 0; j < i; j++) {
4128 diff = val - nextmin;
4130 t = uvuni_to_utf8(tmpbuf,nextmin);
4131 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4133 U8 range_mark = UTF_TO_NATIVE(0xff);
4134 t = uvuni_to_utf8(tmpbuf, val - 1);
4135 sv_catpvn(transv, (char *)&range_mark, 1);
4136 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4143 t = uvuni_to_utf8(tmpbuf,nextmin);
4144 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4146 U8 range_mark = UTF_TO_NATIVE(0xff);
4147 sv_catpvn(transv, (char *)&range_mark, 1);
4149 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
4150 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4151 t = (const U8*)SvPVX_const(transv);
4152 tlen = SvCUR(transv);
4156 else if (!rlen && !del) {
4157 r = t; rlen = tlen; rend = tend;
4160 if ((!rlen && !del) || t == r ||
4161 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4163 o->op_private |= OPpTRANS_IDENTICAL;
4167 while (t < tend || tfirst <= tlast) {
4168 /* see if we need more "t" chars */
4169 if (tfirst > tlast) {
4170 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4172 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
4174 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
4181 /* now see if we need more "r" chars */
4182 if (rfirst > rlast) {
4184 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4186 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
4188 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
4197 rfirst = rlast = 0xffffffff;
4201 /* now see which range will peter our first, if either. */
4202 tdiff = tlast - tfirst;
4203 rdiff = rlast - rfirst;
4210 if (rfirst == 0xffffffff) {
4211 diff = tdiff; /* oops, pretend rdiff is infinite */
4213 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4214 (long)tfirst, (long)tlast);
4216 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4220 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4221 (long)tfirst, (long)(tfirst + diff),
4224 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4225 (long)tfirst, (long)rfirst);
4227 if (rfirst + diff > max)
4228 max = rfirst + diff;
4230 grows = (tfirst < rfirst &&
4231 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4243 else if (max > 0xff)
4248 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4250 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4251 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4252 PAD_SETSV(cPADOPo->op_padix, swash);
4254 SvREADONLY_on(swash);
4256 cSVOPo->op_sv = swash;
4258 SvREFCNT_dec(listsv);
4259 SvREFCNT_dec(transv);
4261 if (!del && havefinal && rlen)
4262 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4263 newSVuv((UV)final), 0);
4266 o->op_private |= OPpTRANS_GROWS;
4272 op_getmad(expr,o,'e');
4273 op_getmad(repl,o,'r');
4281 tbl = (short*)PerlMemShared_calloc(
4282 (o->op_private & OPpTRANS_COMPLEMENT) &&
4283 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4285 cPVOPo->op_pv = (char*)tbl;
4287 for (i = 0; i < (I32)tlen; i++)
4289 for (i = 0, j = 0; i < 256; i++) {
4291 if (j >= (I32)rlen) {
4300 if (i < 128 && r[j] >= 128)
4310 o->op_private |= OPpTRANS_IDENTICAL;
4312 else if (j >= (I32)rlen)
4317 PerlMemShared_realloc(tbl,
4318 (0x101+rlen-j) * sizeof(short));
4319 cPVOPo->op_pv = (char*)tbl;
4321 tbl[0x100] = (short)(rlen - j);
4322 for (i=0; i < (I32)rlen - j; i++)
4323 tbl[0x101+i] = r[j+i];
4327 if (!rlen && !del) {
4330 o->op_private |= OPpTRANS_IDENTICAL;
4332 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4333 o->op_private |= OPpTRANS_IDENTICAL;
4335 for (i = 0; i < 256; i++)
4337 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4338 if (j >= (I32)rlen) {
4340 if (tbl[t[i]] == -1)
4346 if (tbl[t[i]] == -1) {
4347 if (t[i] < 128 && r[j] >= 128)
4354 if(del && rlen == tlen) {
4355 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4356 } else if(rlen > tlen) {
4357 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4361 o->op_private |= OPpTRANS_GROWS;
4363 op_getmad(expr,o,'e');
4364 op_getmad(repl,o,'r');
4374 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4376 Constructs, checks, and returns an op of any pattern matching type.
4377 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4378 and, shifted up eight bits, the eight bits of C<op_private>.
4384 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4389 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4391 NewOp(1101, pmop, 1, PMOP);
4392 pmop->op_type = (OPCODE)type;
4393 pmop->op_ppaddr = PL_ppaddr[type];
4394 pmop->op_flags = (U8)flags;
4395 pmop->op_private = (U8)(0 | (flags >> 8));
4397 if (PL_hints & HINT_RE_TAINT)
4398 pmop->op_pmflags |= PMf_RETAINT;
4399 if (IN_LOCALE_COMPILETIME) {
4400 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4402 else if ((! (PL_hints & HINT_BYTES))
4403 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4404 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4406 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4408 if (PL_hints & HINT_RE_FLAGS) {
4409 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4410 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4412 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4413 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4414 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4416 if (reflags && SvOK(reflags)) {
4417 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4423 assert(SvPOK(PL_regex_pad[0]));
4424 if (SvCUR(PL_regex_pad[0])) {
4425 /* Pop off the "packed" IV from the end. */
4426 SV *const repointer_list = PL_regex_pad[0];
4427 const char *p = SvEND(repointer_list) - sizeof(IV);
4428 const IV offset = *((IV*)p);
4430 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4432 SvEND_set(repointer_list, p);
4434 pmop->op_pmoffset = offset;
4435 /* This slot should be free, so assert this: */
4436 assert(PL_regex_pad[offset] == &PL_sv_undef);
4438 SV * const repointer = &PL_sv_undef;
4439 av_push(PL_regex_padav, repointer);
4440 pmop->op_pmoffset = av_len(PL_regex_padav);
4441 PL_regex_pad = AvARRAY(PL_regex_padav);
4445 return CHECKOP(type, pmop);
4448 /* Given some sort of match op o, and an expression expr containing a
4449 * pattern, either compile expr into a regex and attach it to o (if it's
4450 * constant), or convert expr into a runtime regcomp op sequence (if it's
4453 * isreg indicates that the pattern is part of a regex construct, eg
4454 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4455 * split "pattern", which aren't. In the former case, expr will be a list
4456 * if the pattern contains more than one term (eg /a$b/) or if it contains
4457 * a replacement, ie s/// or tr///.
4459 * When the pattern has been compiled within a new anon CV (for
4460 * qr/(?{...})/ ), then floor indicates the savestack level just before
4461 * the new sub was created
4465 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4470 I32 repl_has_vars = 0;
4472 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4473 bool is_compiletime;
4476 PERL_ARGS_ASSERT_PMRUNTIME;
4478 /* for s/// and tr///, last element in list is the replacement; pop it */
4480 if (is_trans || o->op_type == OP_SUBST) {
4482 repl = cLISTOPx(expr)->op_last;
4483 kid = cLISTOPx(expr)->op_first;
4484 while (kid->op_sibling != repl)
4485 kid = kid->op_sibling;
4486 kid->op_sibling = NULL;
4487 cLISTOPx(expr)->op_last = kid;
4490 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4493 OP* const oe = expr;
4494 assert(expr->op_type == OP_LIST);
4495 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4496 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4497 expr = cLISTOPx(oe)->op_last;
4498 cLISTOPx(oe)->op_first->op_sibling = NULL;
4499 cLISTOPx(oe)->op_last = NULL;
4502 return pmtrans(o, expr, repl);
4505 /* find whether we have any runtime or code elements;
4506 * at the same time, temporarily set the op_next of each DO block;
4507 * then when we LINKLIST, this will cause the DO blocks to be excluded
4508 * from the op_next chain (and from having LINKLIST recursively
4509 * applied to them). We fix up the DOs specially later */
4513 if (expr->op_type == OP_LIST) {
4515 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4516 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4518 assert(!o->op_next && o->op_sibling);
4519 o->op_next = o->op_sibling;
4521 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4525 else if (expr->op_type != OP_CONST)
4530 /* fix up DO blocks; treat each one as a separate little sub */
4532 if (expr->op_type == OP_LIST) {
4534 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4535 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4537 o->op_next = NULL; /* undo temporary hack from above */
4540 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4541 LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
4543 assert(leave->op_first->op_type == OP_ENTER);
4544 assert(leave->op_first->op_sibling);
4545 o->op_next = leave->op_first->op_sibling;
4547 assert(leave->op_flags & OPf_KIDS);
4548 assert(leave->op_last->op_next = (OP*)leave);
4549 leave->op_next = NULL; /* stop on last op */
4550 op_null((OP*)leave);
4554 OP *scope = cLISTOPo->op_first;
4555 assert(scope->op_type == OP_SCOPE);
4556 assert(scope->op_flags & OPf_KIDS);
4557 scope->op_next = NULL; /* stop on last op */
4560 /* have to peep the DOs individually as we've removed it from
4561 * the op_next chain */
4564 /* runtime finalizes as part of finalizing whole tree */
4569 PL_hints |= HINT_BLOCK_SCOPE;
4571 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4573 if (is_compiletime) {
4574 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4575 regexp_engine const *eng = current_re_engine();
4577 if (o->op_flags & OPf_SPECIAL)
4578 rx_flags |= RXf_SPLIT;
4580 if (!has_code || !eng->op_comp) {
4581 /* compile-time simple constant pattern */
4583 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4584 /* whoops! we guessed that a qr// had a code block, but we
4585 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4586 * that isn't required now. Note that we have to be pretty
4587 * confident that nothing used that CV's pad while the
4588 * regex was parsed */
4589 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4590 /* But we know that one op is using this CV's slab. */
4591 cv_forget_slab(PL_compcv);
4593 pm->op_pmflags &= ~PMf_HAS_CV;
4598 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4599 rx_flags, pm->op_pmflags)
4600 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4601 rx_flags, pm->op_pmflags)
4604 op_getmad(expr,(OP*)pm,'e');
4610 /* compile-time pattern that includes literal code blocks */
4611 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4614 ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4617 if (pm->op_pmflags & PMf_HAS_CV) {
4619 /* this QR op (and the anon sub we embed it in) is never
4620 * actually executed. It's just a placeholder where we can
4621 * squirrel away expr in op_code_list without the peephole
4622 * optimiser etc processing it for a second time */
4623 OP *qr = newPMOP(OP_QR, 0);
4624 ((PMOP*)qr)->op_code_list = expr;
4626 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4627 SvREFCNT_inc_simple_void(PL_compcv);
4628 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4629 ((struct regexp *)SvANY(re))->qr_anoncv = cv;
4631 /* attach the anon CV to the pad so that
4632 * pad_fixup_inner_anons() can find it */
4633 (void)pad_add_anon(cv, o->op_type);
4634 SvREFCNT_inc_simple_void(cv);
4639 pm->op_code_list = expr;
4644 /* runtime pattern: build chain of regcomp etc ops */
4646 PADOFFSET cv_targ = 0;
4648 reglist = isreg && expr->op_type == OP_LIST;
4653 pm->op_code_list = expr;
4654 /* don't free op_code_list; its ops are embedded elsewhere too */
4655 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4658 /* the OP_REGCMAYBE is a placeholder in the non-threaded case
4659 * to allow its op_next to be pointed past the regcomp and
4660 * preceding stacking ops;
4661 * OP_REGCRESET is there to reset taint before executing the
4663 if (pm->op_pmflags & PMf_KEEP || PL_tainting)
4664 expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
4666 if (pm->op_pmflags & PMf_HAS_CV) {
4667 /* we have a runtime qr with literal code. This means
4668 * that the qr// has been wrapped in a new CV, which
4669 * means that runtime consts, vars etc will have been compiled
4670 * against a new pad. So... we need to execute those ops
4671 * within the environment of the new CV. So wrap them in a call
4672 * to a new anon sub. i.e. for
4676 * we build an anon sub that looks like
4678 * sub { "a", $b, '(?{...})' }
4680 * and call it, passing the returned list to regcomp.
4681 * Or to put it another way, the list of ops that get executed
4685 * ------ -------------------
4686 * pushmark (for regcomp)
4687 * pushmark (for entersub)
4688 * pushmark (for refgen)
4692 * regcreset regcreset
4694 * const("a") const("a")
4696 * const("(?{...})") const("(?{...})")
4701 SvREFCNT_inc_simple_void(PL_compcv);
4702 /* these lines are just an unrolled newANONATTRSUB */
4703 expr = newSVOP(OP_ANONCODE, 0,
4704 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4705 cv_targ = expr->op_targ;
4706 expr = newUNOP(OP_REFGEN, 0, expr);
4708 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4711 NewOp(1101, rcop, 1, LOGOP);
4712 rcop->op_type = OP_REGCOMP;
4713 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4714 rcop->op_first = scalar(expr);
4715 rcop->op_flags |= OPf_KIDS
4716 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4717 | (reglist ? OPf_STACKED : 0);
4718 rcop->op_private = 0;
4720 rcop->op_targ = cv_targ;
4722 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4723 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4725 /* establish postfix order */
4726 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4728 rcop->op_next = expr;
4729 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4732 rcop->op_next = LINKLIST(expr);
4733 expr->op_next = (OP*)rcop;
4736 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4741 if (pm->op_pmflags & PMf_EVAL) {
4743 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4744 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4746 else if (repl->op_type == OP_CONST)
4750 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4751 if (curop->op_type == OP_SCOPE
4752 || curop->op_type == OP_LEAVE
4753 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4754 if (curop->op_type == OP_GV) {
4755 GV * const gv = cGVOPx_gv(curop);
4757 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4760 else if (curop->op_type == OP_RV2CV)
4762 else if (curop->op_type == OP_RV2SV ||
4763 curop->op_type == OP_RV2AV ||
4764 curop->op_type == OP_RV2HV ||
4765 curop->op_type == OP_RV2GV) {
4766 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4769 else if (curop->op_type == OP_PADSV ||
4770 curop->op_type == OP_PADAV ||
4771 curop->op_type == OP_PADHV ||
4772 curop->op_type == OP_PADANY)
4776 else if (curop->op_type == OP_PUSHRE)
4777 NOOP; /* Okay here, dangerous in newASSIGNOP */
4787 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4789 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4790 op_prepend_elem(o->op_type, scalar(repl), o);
4793 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4794 pm->op_pmflags |= PMf_MAYBE_CONST;
4796 NewOp(1101, rcop, 1, LOGOP);
4797 rcop->op_type = OP_SUBSTCONT;
4798 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4799 rcop->op_first = scalar(repl);
4800 rcop->op_flags |= OPf_KIDS;
4801 rcop->op_private = 1;
4804 /* establish postfix order */
4805 rcop->op_next = LINKLIST(repl);
4806 repl->op_next = (OP*)rcop;
4808 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4809 assert(!(pm->op_pmflags & PMf_ONCE));
4810 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4819 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4821 Constructs, checks, and returns an op of any type that involves an
4822 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4823 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4824 takes ownership of one reference to it.
4830 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4835 PERL_ARGS_ASSERT_NEWSVOP;
4837 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4838 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4839 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4841 NewOp(1101, svop, 1, SVOP);
4842 svop->op_type = (OPCODE)type;
4843 svop->op_ppaddr = PL_ppaddr[type];
4845 svop->op_next = (OP*)svop;
4846 svop->op_flags = (U8)flags;
4847 if (PL_opargs[type] & OA_RETSCA