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_RETSCALAR)
4849 if (PL_opargs[type] & OA_TARGET)
4850 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4851 return CHECKOP(type, svop);
4857 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4859 Constructs, checks, and returns an op of any type that involves a
4860 reference to a pad element. I<type> is the opcode. I<flags> gives the
4861 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4862 is populated with I<sv>; this function takes ownership of one reference
4865 This function only exists if Perl has been compiled to use ithreads.
4871 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4876 PERL_ARGS_ASSERT_NEWPADOP;
4878 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4879 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4880 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4882 NewOp(1101, padop, 1, PADOP);
4883 padop->op_type = (OPCODE)type;
4884 padop->op_ppaddr = PL_ppaddr[type];
4885 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4886 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4887 PAD_SETSV(padop->op_padix, sv);
4890 padop->op_next = (OP*)padop;
4891 padop->op_flags = (U8)flags;
4892 if (PL_opargs[type] & OA_RETSCALAR)
4894 if (PL_opargs[type] & OA_TARGET)
4895 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4896 return CHECKOP(type, padop);
4899 #endif /* !USE_ITHREADS */
4902 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4904 Constructs, checks, and returns an op of any type that involves an
4905 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4906 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4907 reference; calling this function does not transfer ownership of any
4914 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4918 PERL_ARGS_ASSERT_NEWGVOP;
4922 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4924 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4929 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4931 Constructs, checks, and returns an op of any type that involves an
4932 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4933 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4934 must have been allocated using L</PerlMemShared_malloc>; the memory will
4935 be freed when the op is destroyed.
4941 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4944 const bool utf8 = cBOOL(flags & SVf_UTF8);
4949 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4951 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4953 NewOp(1101, pvop, 1, PVOP);
4954 pvop->op_type = (OPCODE)type;
4955 pvop->op_ppaddr = PL_ppaddr[type];
4957 pvop->op_next = (OP*)pvop;
4958 pvop->op_flags = (U8)flags;
4959 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4960 if (PL_opargs[type] & OA_RETSCALAR)
4962 if (PL_opargs[type] & OA_TARGET)
4963 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4964 return CHECKOP(type, pvop);
4972 Perl_package(pTHX_ OP *o)
4975 SV *const sv = cSVOPo->op_sv;
4980 PERL_ARGS_ASSERT_PACKAGE;
4982 SAVEGENERICSV(PL_curstash);
4983 save_item(PL_curstname);
4985 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4987 sv_setsv(PL_curstname, sv);
4989 PL_hints |= HINT_BLOCK_SCOPE;
4990 PL_parser->copline = NOLINE;
4991 PL_parser->expect = XSTATE;
4996 if (!PL_madskills) {
5001 pegop = newOP(OP_NULL,0);
5002 op_getmad(o,pegop,'P');
5008 Perl_package_version( pTHX_ OP *v )
5011 U32 savehints = PL_hints;
5012 PERL_ARGS_ASSERT_PACKAGE_VERSION;
5013 PL_hints &= ~HINT_STRICT_VARS;
5014 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5015 PL_hints = savehints;
5024 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5031 OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
5033 SV *use_version = NULL;
5035 PERL_ARGS_ASSERT_UTILIZE;
5037 if (idop->op_type != OP_CONST)
5038 Perl_croak(aTHX_ "Module name must be constant");
5041 op_getmad(idop,pegop,'U');
5046 SV * const vesv = ((SVOP*)version)->op_sv;
5049 op_getmad(version,pegop,'V');
5050 if (!arg && !SvNIOKp(vesv)) {
5057 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5058 Perl_croak(aTHX_ "Version number must be a constant number");
5060 /* Make copy of idop so we don't free it twice */
5061 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5063 /* Fake up a method call to VERSION */
5064 meth = newSVpvs_share("VERSION");
5065 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5066 op_append_elem(OP_LIST,
5067 op_prepend_elem(OP_LIST, pack, list(version)),
5068 newSVOP(OP_METHOD_NAMED, 0, meth)));
5072 /* Fake up an import/unimport */
5073 if (arg && arg->op_type == OP_STUB) {
5075 op_getmad(arg,pegop,'S');
5076 imop = arg; /* no import on explicit () */
5078 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5079 imop = NULL; /* use 5.0; */
5081 use_version = ((SVOP*)idop)->op_sv;
5083 idop->op_private |= OPpCONST_NOVER;
5089 op_getmad(arg,pegop,'A');
5091 /* Make copy of idop so we don't free it twice */
5092 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5094 /* Fake up a method call to import/unimport */
5096 ? newSVpvs_share("import") : newSVpvs_share("unimport");
5097 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5098 op_append_elem(OP_LIST,
5099 op_prepend_elem(OP_LIST, pack, list(arg)),
5100 newSVOP(OP_METHOD_NAMED, 0, meth)));
5103 /* Fake up the BEGIN {}, which does its thing immediately. */
5105 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5108 op_append_elem(OP_LINESEQ,
5109 op_append_elem(OP_LINESEQ,
5110 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5111 newSTATEOP(0, NULL, veop)),
5112 newSTATEOP(0, NULL, imop) ));
5116 * feature bundle that corresponds to the required version. */
5117 use_version = sv_2mortal(new_version(use_version));
5118 S_enable_feature_bundle(aTHX_ use_version);
5120 /* If a version >= 5.11.0 is requested, strictures are on by default! */
5121 if (vcmp(use_version,
5122 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5123 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5124 PL_hints |= HINT_STRICT_REFS;
5125 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5126 PL_hints |= HINT_STRICT_SUBS;
5127 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5128 PL_hints |= HINT_STRICT_VARS;
5130 /* otherwise they are off */
5132 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5133 PL_hints &= ~HINT_STRICT_REFS;
5134 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5135 PL_hints &= ~HINT_STRICT_SUBS;
5136 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5137 PL_hints &= ~HINT_STRICT_VARS;
5141 /* The "did you use incorrect case?" warning used to be here.
5142 * The problem is that on case-insensitive filesystems one
5143 * might get false positives for "use" (and "require"):
5144 * "use Strict" or "require CARP" will work. This causes
5145 * portability problems for the script: in case-strict
5146 * filesystems the script will stop working.
5148 * The "incorrect case" warning checked whether "use Foo"
5149 * imported "Foo" to your namespace, but that is wrong, too:
5150 * there is no requirement nor promise in the language that
5151 * a Foo.pm should or would contain anything in package "Foo".
5153 * There is very little Configure-wise that can be done, either:
5154 * the case-sensitivity of the build filesystem of Perl does not
5155 * help in guessing the case-sensitivity of the runtime environment.
5158 PL_hints |= HINT_BLOCK_SCOPE;
5159 PL_parser->copline = NOLINE;
5160 PL_parser->expect = XSTATE;
5161 PL_cop_seqmax++; /* Purely for B::*'s benefit */
5162 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5171 =head1 Embedding Functions
5173 =for apidoc load_module
5175 Loads the module whose name is pointed to by the string part of name.
5176 Note that the actual module name, not its filename, should be given.
5177 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
5178 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5179 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
5180 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
5181 arguments can be used to specify arguments to the module's import()
5182 method, similar to C<use Foo::Bar VERSION LIST>. They must be
5183 terminated with a final NULL pointer. Note that this list can only
5184 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5185 Otherwise at least a single NULL pointer to designate the default
5186 import list is required.
5188 The reference count for each specified C<SV*> parameter is decremented.
5193 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5197 PERL_ARGS_ASSERT_LOAD_MODULE;
5199 va_start(args, ver);
5200 vload_module(flags, name, ver, &args);
5204 #ifdef PERL_IMPLICIT_CONTEXT
5206 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5210 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5211 va_start(args, ver);
5212 vload_module(flags, name, ver, &args);
5218 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5222 OP * const modname = newSVOP(OP_CONST, 0, name);
5224 PERL_ARGS_ASSERT_VLOAD_MODULE;
5226 modname->op_private |= OPpCONST_BARE;
5228 veop = newSVOP(OP_CONST, 0, ver);
5232 if (flags & PERL_LOADMOD_NOIMPORT) {
5233 imop = sawparens(newNULLLIST());
5235 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5236 imop = va_arg(*args, OP*);
5241 sv = va_arg(*args, SV*);
5243 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5244 sv = va_arg(*args, SV*);
5248 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5249 * that it has a PL_parser to play with while doing that, and also
5250 * that it doesn't mess with any existing parser, by creating a tmp
5251 * new parser with lex_start(). This won't actually be used for much,
5252 * since pp_require() will create another parser for the real work. */
5255 SAVEVPTR(PL_curcop);
5256 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5257 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5258 veop, modname, imop);
5263 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5269 PERL_ARGS_ASSERT_DOFILE;
5271 if (!force_builtin) {
5272 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
5273 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5274 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
5275 gv = gvp ? *gvp : NULL;
5279 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5280 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
5281 op_append_elem(OP_LIST, term,
5282 scalar(newUNOP(OP_RV2CV, 0,
5283 newGVOP(OP_GV, 0, gv)))));
5286 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5292 =head1 Optree construction
5294 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5296 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5297 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5298 be set automatically, and, shifted up eight bits, the eight bits of
5299 C<op_private>, except that the bit with value 1 or 2 is automatically
5300 set as required. I<listval> and I<subscript> supply the parameters of
5301 the slice; they are consumed by this function and become part of the
5302 constructed op tree.
5308 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5310 return newBINOP(OP_LSLICE, flags,
5311 list(force_list(subscript)),
5312 list(force_list(listval)) );
5316 S_is_list_assignment(pTHX_ register const OP *o)
5324 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5325 o = cUNOPo->op_first;
5327 flags = o->op_flags;
5329 if (type == OP_COND_EXPR) {
5330 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5331 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5336 yyerror("Assignment to both a list and a scalar");
5340 if (type == OP_LIST &&
5341 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5342 o->op_private & OPpLVAL_INTRO)
5345 if (type == OP_LIST || flags & OPf_PARENS ||
5346 type == OP_RV2AV || type == OP_RV2HV ||
5347 type == OP_ASLICE || type == OP_HSLICE)
5350 if (type == OP_PADAV || type == OP_PADHV)
5353 if (type == OP_RV2SV)
5360 Helper function for newASSIGNOP to detection commonality between the
5361 lhs and the rhs. Marks all variables with PL_generation. If it
5362 returns TRUE the assignment must be able to handle common variables.
5364 PERL_STATIC_INLINE bool
5365 S_aassign_common_vars(pTHX_ OP* o)
5368 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5369 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5370 if (curop->op_type == OP_GV) {
5371 GV *gv = cGVOPx_gv(curop);
5373 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5375 GvASSIGN_GENERATION_set(gv, PL_generation);
5377 else if (curop->op_type == OP_PADSV ||
5378 curop->op_type == OP_PADAV ||
5379 curop->op_type == OP_PADHV ||
5380 curop->op_type == OP_PADANY)
5382 if (PAD_COMPNAME_GEN(curop->op_targ)
5383 == (STRLEN)PL_generation)
5385 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5388 else if (curop->op_type == OP_RV2CV)
5390 else if (curop->op_type == OP_RV2SV ||
5391 curop->op_type == OP_RV2AV ||
5392 curop->op_type == OP_RV2HV ||
5393 curop->op_type == OP_RV2GV) {
5394 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5397 else if (curop->op_type == OP_PUSHRE) {
5399 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5400 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5402 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5404 GvASSIGN_GENERATION_set(gv, PL_generation);
5408 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5411 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5413 GvASSIGN_GENERATION_set(gv, PL_generation);
5421 if (curop->op_flags & OPf_KIDS) {
5422 if (aassign_common_vars(curop))
5430 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5432 Constructs, checks, and returns an assignment op. I<left> and I<right>
5433 supply the parameters of the assignment; they are consumed by this
5434 function and become part of the constructed op tree.
5436 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5437 a suitable conditional optree is constructed. If I<optype> is the opcode
5438 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5439 performs the binary operation and assigns the result to the left argument.
5440 Either way, if I<optype> is non-zero then I<flags> has no effect.
5442 If I<optype> is zero, then a plain scalar or list assignment is
5443 constructed. Which type of assignment it is is automatically determined.
5444 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5445 will be set automatically, and, shifted up eight bits, the eight bits
5446 of C<op_private>, except that the bit with value 1 or 2 is automatically
5453 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5459 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5460 return newLOGOP(optype, 0,
5461 op_lvalue(scalar(left), optype),
5462 newUNOP(OP_SASSIGN, 0, scalar(right)));
5465 return newBINOP(optype, OPf_STACKED,
5466 op_lvalue(scalar(left), optype), scalar(right));
5470 if (is_list_assignment(left)) {
5471 static const char no_list_state[] = "Initialization of state variables"
5472 " in list context currently forbidden";
5474 bool maybe_common_vars = TRUE;
5477 left = op_lvalue(left, OP_AASSIGN);
5478 curop = list(force_list(left));
5479 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5480 o->op_private = (U8)(0 | (flags >> 8));
5482 if ((left->op_type == OP_LIST
5483 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5485 OP* lop = ((LISTOP*)left)->op_first;
5486 maybe_common_vars = FALSE;
5488 if (lop->op_type == OP_PADSV ||
5489 lop->op_type == OP_PADAV ||
5490 lop->op_type == OP_PADHV ||
5491 lop->op_type == OP_PADANY) {
5492 if (!(lop->op_private & OPpLVAL_INTRO))
5493 maybe_common_vars = TRUE;
5495 if (lop->op_private & OPpPAD_STATE) {
5496 if (left->op_private & OPpLVAL_INTRO) {
5497 /* Each variable in state($a, $b, $c) = ... */
5500 /* Each state variable in
5501 (state $a, my $b, our $c, $d, undef) = ... */
5503 yyerror(no_list_state);
5505 /* Each my variable in
5506 (state $a, my $b, our $c, $d, undef) = ... */
5508 } else if (lop->op_type == OP_UNDEF ||
5509 lop->op_type == OP_PUSHMARK) {
5510 /* undef may be interesting in
5511 (state $a, undef, state $c) */
5513 /* Other ops in the list. */
5514 maybe_common_vars = TRUE;
5516 lop = lop->op_sibling;
5519 else if ((left->op_private & OPpLVAL_INTRO)
5520 && ( left->op_type == OP_PADSV
5521 || left->op_type == OP_PADAV
5522 || left->op_type == OP_PADHV
5523 || left->op_type == OP_PADANY))
5525 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5526 if (left->op_private & OPpPAD_STATE) {
5527 /* All single variable list context state assignments, hence
5537 yyerror(no_list_state);
5541 /* PL_generation sorcery:
5542 * an assignment like ($a,$b) = ($c,$d) is easier than
5543 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5544 * To detect whether there are common vars, the global var
5545 * PL_generation is incremented for each assign op we compile.
5546 * Then, while compiling the assign op, we run through all the
5547 * variables on both sides of the assignment, setting a spare slot
5548 * in each of them to PL_generation. If any of them already have
5549 * that value, we know we've got commonality. We could use a
5550 * single bit marker, but then we'd have to make 2 passes, first
5551 * to clear the flag, then to test and set it. To find somewhere
5552 * to store these values, evil chicanery is done with SvUVX().
5555 if (maybe_common_vars) {
5557 if (aassign_common_vars(o))
5558 o->op_private |= OPpASSIGN_COMMON;
5562 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5563 OP* tmpop = ((LISTOP*)right)->op_first;
5564 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5565 PMOP * const pm = (PMOP*)tmpop;
5566 if (left->op_type == OP_RV2AV &&
5567 !(left->op_private & OPpLVAL_INTRO) &&
5568 !(o->op_private & OPpASSIGN_COMMON) )
5570 tmpop = ((UNOP*)left)->op_first;
5571 if (tmpop->op_type == OP_GV
5573 && !pm->op_pmreplrootu.op_pmtargetoff
5575 && !pm->op_pmreplrootu.op_pmtargetgv
5579 pm->op_pmreplrootu.op_pmtargetoff
5580 = cPADOPx(tmpop)->op_padix;
5581 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5583 pm->op_pmreplrootu.op_pmtargetgv
5584 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5585 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5587 pm->op_pmflags |= PMf_ONCE;
5588 tmpop = cUNOPo->op_first; /* to list (nulled) */
5589 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5590 tmpop->op_sibling = NULL; /* don't free split */
5591 right->op_next = tmpop->op_next; /* fix starting loc */
5592 op_free(o); /* blow off assign */
5593 right->op_flags &= ~OPf_WANT;
5594 /* "I don't know and I don't care." */
5599 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5600 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5602 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5603 if (SvIOK(sv) && SvIVX(sv) == 0)
5604 sv_setiv(sv, PL_modcount+1);
5612 right = newOP(OP_UNDEF, 0);
5613 if (right->op_type == OP_READLINE) {
5614 right->op_flags |= OPf_STACKED;
5615 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5619 o = newBINOP(OP_SASSIGN, flags,
5620 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5626 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5628 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5629 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5630 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5631 If I<label> is non-null, it supplies the name of a label to attach to
5632 the state op; this function takes ownership of the memory pointed at by
5633 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5636 If I<o> is null, the state op is returned. Otherwise the state op is
5637 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5638 is consumed by this function and becomes part of the returned op tree.
5644 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5647 const U32 seq = intro_my();
5648 const U32 utf8 = flags & SVf_UTF8;
5653 NewOp(1101, cop, 1, COP);
5654 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5655 cop->op_type = OP_DBSTATE;
5656 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5659 cop->op_type = OP_NEXTSTATE;
5660 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5662 cop->op_flags = (U8)flags;
5663 CopHINTS_set(cop, PL_hints);
5665 cop->op_private |= NATIVE_HINTS;
5667 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5668 cop->op_next = (OP*)cop;
5671 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5672 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5674 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5676 PL_hints |= HINT_BLOCK_SCOPE;
5677 /* It seems that we need to defer freeing this pointer, as other parts
5678 of the grammar end up wanting to copy it after this op has been
5683 if (PL_parser && PL_parser->copline == NOLINE)
5684 CopLINE_set(cop, CopLINE(PL_curcop));
5686 CopLINE_set(cop, PL_parser->copline);
5688 PL_parser->copline = NOLINE;
5691 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5693 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5695 CopSTASH_set(cop, PL_curstash);
5697 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5698 /* this line can have a breakpoint - store the cop in IV */
5699 AV *av = CopFILEAVx(PL_curcop);
5701 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5702 if (svp && *svp != &PL_sv_undef ) {
5703 (void)SvIOK_on(*svp);
5704 SvIV_set(*svp, PTR2IV(cop));
5709 if (flags & OPf_SPECIAL)
5711 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5715 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5717 Constructs, checks, and returns a logical (flow control) op. I<type>
5718 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5719 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5720 the eight bits of C<op_private>, except that the bit with value 1 is
5721 automatically set. I<first> supplies the expression controlling the
5722 flow, and I<other> supplies the side (alternate) chain of ops; they are
5723 consumed by this function and become part of the constructed op tree.
5729 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5733 PERL_ARGS_ASSERT_NEWLOGOP;
5735 return new_logop(type, flags, &first, &other);
5739 S_search_const(pTHX_ OP *o)
5741 PERL_ARGS_ASSERT_SEARCH_CONST;
5743 switch (o->op_type) {
5747 if (o->op_flags & OPf_KIDS)
5748 return search_const(cUNOPo->op_first);
5755 if (!(o->op_flags & OPf_KIDS))
5757 kid = cLISTOPo->op_first;
5759 switch (kid->op_type) {
5763 kid = kid->op_sibling;
5766 if (kid != cLISTOPo->op_last)
5772 kid = cLISTOPo->op_last;
5774 return search_const(kid);
5782 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5790 int prepend_not = 0;
5792 PERL_ARGS_ASSERT_NEW_LOGOP;
5797 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5798 return newBINOP(type, flags, scalar(first), scalar(other));
5800 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5802 scalarboolean(first);
5803 /* optimize AND and OR ops that have NOTs as children */
5804 if (first->op_type == OP_NOT
5805 && (first->op_flags & OPf_KIDS)
5806 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5807 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5809 if (type == OP_AND || type == OP_OR) {
5815 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5817 prepend_not = 1; /* prepend a NOT op later */
5821 /* search for a constant op that could let us fold the test */
5822 if ((cstop = search_const(first))) {
5823 if (cstop->op_private & OPpCONST_STRICT)
5824 no_bareword_allowed(cstop);
5825 else if ((cstop->op_private & OPpCONST_BARE))
5826 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5827 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5828 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5829 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5831 if (other->op_type == OP_CONST)
5832 other->op_private |= OPpCONST_SHORTCIRCUIT;
5834 OP *newop = newUNOP(OP_NULL, 0, other);
5835 op_getmad(first, newop, '1');
5836 newop->op_targ = type; /* set "was" field */
5840 if (other->op_type == OP_LEAVE)
5841 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5842 else if (other->op_type == OP_MATCH
5843 || other->op_type == OP_SUBST
5844 || other->op_type == OP_TRANSR
5845 || other->op_type == OP_TRANS)
5846 /* Mark the op as being unbindable with =~ */
5847 other->op_flags |= OPf_SPECIAL;
5851 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5852 const OP *o2 = other;
5853 if ( ! (o2->op_type == OP_LIST
5854 && (( o2 = cUNOPx(o2)->op_first))
5855 && o2->op_type == OP_PUSHMARK
5856 && (( o2 = o2->op_sibling)) )
5859 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5860 || o2->op_type == OP_PADHV)
5861 && o2->op_private & OPpLVAL_INTRO
5862 && !(o2->op_private & OPpPAD_STATE))
5864 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5865 "Deprecated use of my() in false conditional");
5869 if (first->op_type == OP_CONST)
5870 first->op_private |= OPpCONST_SHORTCIRCUIT;
5872 first = newUNOP(OP_NULL, 0, first);
5873 op_getmad(other, first, '2');
5874 first->op_targ = type; /* set "was" field */
5881 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5882 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5884 const OP * const k1 = ((UNOP*)first)->op_first;
5885 const OP * const k2 = k1->op_sibling;
5887 switch (first->op_type)
5890 if (k2 && k2->op_type == OP_READLINE
5891 && (k2->op_flags & OPf_STACKED)
5892 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5894 warnop = k2->op_type;
5899 if (k1->op_type == OP_READDIR
5900 || k1->op_type == OP_GLOB
5901 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5902 || k1->op_type == OP_EACH
5903 || k1->op_type == OP_AEACH)
5905 warnop = ((k1->op_type == OP_NULL)
5906 ? (OPCODE)k1->op_targ : k1->op_type);
5911 const line_t oldline = CopLINE(PL_curcop);
5912 CopLINE_set(PL_curcop, PL_parser->copline);
5913 Perl_warner(aTHX_ packWARN(WARN_MISC),
5914 "Value of %s%s can be \"0\"; test with defined()",
5916 ((warnop == OP_READLINE || warnop == OP_GLOB)
5917 ? " construct" : "() operator"));
5918 CopLINE_set(PL_curcop, oldline);
5925 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5926 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5928 NewOp(1101, logop, 1, LOGOP);
5930 logop->op_type = (OPCODE)type;
5931 logop->op_ppaddr = PL_ppaddr[type];
5932 logop->op_first = first;
5933 logop->op_flags = (U8)(flags | OPf_KIDS);
5934 logop->op_other = LINKLIST(other);
5935 logop->op_private = (U8)(1 | (flags >> 8));
5937 /* establish postfix order */
5938 logop->op_next = LINKLIST(first);
5939 first->op_next = (OP*)logop;
5940 first->op_sibling = other;
5942 CHECKOP(type,logop);
5944 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5951 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5953 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5954 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5955 will be set automatically, and, shifted up eight bits, the eight bits of
5956 C<op_private>, except that the bit with value 1 is automatically set.
5957 I<first> supplies the expression selecting between the two branches,
5958 and I<trueop> and I<falseop> supply the branches; they are consumed by
5959 this function and become part of the constructed op tree.
5965 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5973 PERL_ARGS_ASSERT_NEWCONDOP;
5976 return newLOGOP(OP_AND, 0, first, trueop);
5978 return newLOGOP(OP_OR, 0, first, falseop);
5980 scalarboolean(first);
5981 if ((cstop = search_const(first))) {
5982 /* Left or right arm of the conditional? */
5983 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5984 OP *live = left ? trueop : falseop;
5985 OP *const dead = left ? falseop : trueop;
5986 if (cstop->op_private & OPpCONST_BARE &&
5987 cstop->op_private & OPpCONST_STRICT) {
5988 no_bareword_allowed(cstop);
5991 /* This is all dead code when PERL_MAD is not defined. */
5992 live = newUNOP(OP_NULL, 0, live);
5993 op_getmad(first, live, 'C');
5994 op_getmad(dead, live, left ? 'e' : 't');
5999 if (live->op_type == OP_LEAVE)
6000 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6001 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6002 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6003 /* Mark the op as being unbindable with =~ */
6004 live->op_flags |= OPf_SPECIAL;
6007 NewOp(1101, logop, 1, LOGOP);
6008 logop->op_type = OP_COND_EXPR;
6009 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6010 logop->op_first = first;
6011 logop->op_flags = (U8)(flags | OPf_KIDS);
6012 logop->op_private = (U8)(1 | (flags >> 8));
6013 logop->op_other = LINKLIST(trueop);
6014 logop->op_next = LINKLIST(falseop);
6016 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6019 /* establish postfix order */
6020 start = LINKLIST(first);
6021 first->op_next = (OP*)logop;
6023 first->op_sibling = trueop;
6024 trueop->op_sibling = falseop;
6025 o = newUNOP(OP_NULL, 0, (OP*)logop);
6027 trueop->op_next = falseop->op_next = o;
6034 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6036 Constructs and returns a C<range> op, with subordinate C<flip> and
6037 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
6038 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6039 for both the C<flip> and C<range> ops, except that the bit with value
6040 1 is automatically set. I<left> and I<right> supply the expressions
6041 controlling the endpoints of the range; they are consumed by this function
6042 and become part of the constructed op tree.
6048 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6057 PERL_ARGS_ASSERT_NEWRANGE;
6059 NewOp(1101, range, 1, LOGOP);
6061 range->op_type = OP_RANGE;
6062 range->op_ppaddr = PL_ppaddr[OP_RANGE];
6063 range->op_first = left;
6064 range->op_flags = OPf_KIDS;
6065 leftstart = LINKLIST(left);
6066 range->op_other = LINKLIST(right);
6067 range->op_private = (U8)(1 | (flags >> 8));
6069 left->op_sibling = right;
6071 range->op_next = (OP*)range;
6072 flip = newUNOP(OP_FLIP, flags, (OP*)range);
6073 flop = newUNOP(OP_FLOP, 0, flip);
6074 o = newUNOP(OP_NULL, 0, flop);
6076 range->op_next = leftstart;
6078 left->op_next = flip;
6079 right->op_next = flop;
6081 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6082 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6083 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6084 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6086 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6087 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6089 /* check barewords before they might be optimized aways */
6090 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6091 no_bareword_allowed(left);
6092 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6093 no_bareword_allowed(right);
6096 if (!flip->op_private || !flop->op_private)
6097 LINKLIST(o); /* blow off optimizer unless constant */
6103 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6105 Constructs, checks, and returns an op tree expressing a loop. This is
6106 only a loop in the control flow through the op tree; it does not have
6107 the heavyweight loop structure that allows exiting the loop by C<last>
6108 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
6109 top-level op, except that some bits will be set automatically as required.
6110 I<expr> supplies the expression controlling loop iteration, and I<block>
6111 supplies the body of the loop; they are consumed by this function and
6112 become part of the constructed op tree. I<debuggable> is currently
6113 unused and should always be 1.
6119 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6124 const bool once = block && block->op_flags & OPf_SPECIAL &&
6125 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
6127 PERL_UNUSED_ARG(debuggable);
6130 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6131 return block; /* do {} while 0 does once */
6132 if (expr->op_type == OP_READLINE
6133 || expr->op_type == OP_READDIR
6134 || expr->op_type == OP_GLOB
6135 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6136 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6137 expr = newUNOP(OP_DEFINED, 0,
6138 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6139 } else if (expr->op_flags & OPf_KIDS) {
6140 const OP * const k1 = ((UNOP*)expr)->op_first;
6141 const OP * const k2 = k1 ? k1->op_sibling : NULL;
6142 switch (expr->op_type) {
6144 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6145 && (k2->op_flags & OPf_STACKED)
6146 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6147 expr = newUNOP(OP_DEFINED, 0, expr);
6151 if (k1 && (k1->op_type == OP_READDIR
6152 || k1->op_type == OP_GLOB
6153 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6154 || k1->op_type == OP_EACH
6155 || k1->op_type == OP_AEACH))
6156 expr = newUNOP(OP_DEFINED, 0, expr);
6162 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6163 * op, in listop. This is wrong. [perl #27024] */
6165 block = newOP(OP_NULL, 0);
6166 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6167 o = new_logop(OP_AND, 0, &expr, &listop);
6170 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6172 if (once && o != listop)
6173 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6176 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
6178 o->op_flags |= flags;
6180 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
6185 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6187 Constructs, checks, and returns an op tree expressing a C<while> loop.
6188 This is a heavyweight loop, with structure that allows exiting the loop
6189 by C<last> and suchlike.
6191 I<loop> is an optional preconstructed C<enterloop> op to use in the
6192 loop; if it is null then a suitable op will be constructed automatically.
6193 I<expr> supplies the loop's controlling expression. I<block> supplies the
6194 main body of the loop, and I<cont> optionally supplies a C<continue> block
6195 that operates as a second half of the body. All of these optree inputs
6196 are consumed by this function and become part of the constructed op tree.
6198 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6199 op and, shifted up eight bits, the eight bits of C<op_private> for
6200 the C<leaveloop> op, except that (in both cases) some bits will be set
6201 automatically. I<debuggable> is currently unused and should always be 1.
6202 I<has_my> can be supplied as true to force the
6203 loop body to be enclosed in its own scope.
6209 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6210 OP *expr, OP *block, OP *cont, I32 has_my)
6219 PERL_UNUSED_ARG(debuggable);
6222 if (expr->op_type == OP_READLINE
6223 || expr->op_type == OP_READDIR
6224 || expr->op_type == OP_GLOB
6225 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6226 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6227 expr = newUNOP(OP_DEFINED, 0,
6228 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6229 } else if (expr->op_flags & OPf_KIDS) {
6230 const OP * const k1 = ((UNOP*)expr)->op_first;
6231 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6232 switch (expr->op_type) {
6234 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6235 && (k2->op_flags & OPf_STACKED)
6236 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6237 expr = newUNOP(OP_DEFINED, 0, expr);
6241 if (k1 && (k1->op_type == OP_READDIR
6242 || k1->op_type == OP_GLOB
6243 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6244 || k1->op_type == OP_EACH
6245 || k1->op_type == OP_AEACH))
6246 expr = newUNOP(OP_DEFINED, 0, expr);
6253 block = newOP(OP_NULL, 0);
6254 else if (cont || has_my) {
6255 block = op_scope(block);
6259 next = LINKLIST(cont);
6262 OP * const unstack = newOP(OP_UNSTACK, 0);
6265 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6269 listop = op_append_list(OP_LINESEQ, block, cont);
6271 redo = LINKLIST(listop);
6275 o = new_logop(OP_AND, 0, &expr, &listop);
6276 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6277 op_free(expr); /* oops, it's a while (0) */
6279 return NULL; /* listop already freed by new_logop */
6282 ((LISTOP*)listop)->op_last->op_next =
6283 (o == listop ? redo : LINKLIST(o));
6289 NewOp(1101,loop,1,LOOP);
6290 loop->op_type = OP_ENTERLOOP;
6291 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6292 loop->op_private = 0;
6293 loop->op_next = (OP*)loop;
6296 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6298 loop->op_redoop = redo;
6299 loop->op_lastop = o;
6300 o->op_private |= loopflags;
6303 loop->op_nextop = next;
6305 loop->op_nextop = o;
6307 o->op_flags |= flags;
6308 o->op_private |= (flags >> 8);
6313 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6315 Constructs, checks, and returns an op tree expressing a C<foreach>
6316 loop (iteration through a list of values). This is a heavyweight loop,
6317 with structure that allows exiting the loop by C<last> and suchlike.
6319 I<sv> optionally supplies the variable that will be aliased to each
6320 item in turn; if null, it defaults to C<$_> (either lexical or global).
6321 I<expr> supplies the list of values to iterate over. I<block> supplies
6322 the main body of the loop, and I<cont> optionally supplies a C<continue>
6323 block that operates as a second half of the body. All of these optree
6324 inputs are consumed by this function and become part of the constructed
6327 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6328 op and, shifted up eight bits, the eight bits of C<op_private> for
6329 the C<leaveloop> op, except that (in both cases) some bits will be set
6336 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6341 PADOFFSET padoff = 0;
6346 PERL_ARGS_ASSERT_NEWFOROP;
6349 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6350 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6351 sv->op_type = OP_RV2GV;
6352 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6354 /* The op_type check is needed to prevent a possible segfault
6355 * if the loop variable is undeclared and 'strict vars' is in
6356 * effect. This is illegal but is nonetheless parsed, so we
6357 * may reach this point with an OP_CONST where we're expecting
6360 if (cUNOPx(sv)->op_first->op_type == OP_GV
6361 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6362 iterpflags |= OPpITER_DEF;
6364 else if (sv->op_type == OP_PADSV) { /* private variable */
6365 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6366 padoff = sv->op_targ;
6376 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6378 SV *const namesv = PAD_COMPNAME_SV(padoff);
6380 const char *const name = SvPV_const(namesv, len);
6382 if (len == 2 && name[0] == '$' && name[1] == '_')
6383 iterpflags |= OPpITER_DEF;
6387 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6388 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6389 sv = newGVOP(OP_GV, 0, PL_defgv);
6394 iterpflags |= OPpITER_DEF;
6396 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6397 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6398 iterflags |= OPf_STACKED;
6400 else if (expr->op_type == OP_NULL &&
6401 (expr->op_flags & OPf_KIDS) &&
6402 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6404 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6405 * set the STACKED flag to indicate that these values are to be
6406 * treated as min/max values by 'pp_iterinit'.
6408 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6409 LOGOP* const range = (LOGOP*) flip->op_first;
6410 OP* const left = range->op_first;
6411 OP* const right = left->op_sibling;
6414 range->op_flags &= ~OPf_KIDS;
6415 range->op_first = NULL;
6417 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6418 listop->op_first->op_next = range->op_next;
6419 left->op_next = range->op_other;
6420 right->op_next = (OP*)listop;
6421 listop->op_next = listop->op_first;
6424 op_getmad(expr,(OP*)listop,'O');
6428 expr = (OP*)(listop);
6430 iterflags |= OPf_STACKED;
6433 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6436 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6437 op_append_elem(OP_LIST, expr, scalar(sv))));
6438 assert(!loop->op_next);
6439 /* for my $x () sets OPpLVAL_INTRO;
6440 * for our $x () sets OPpOUR_INTRO */
6441 loop->op_private = (U8)iterpflags;
6442 #ifndef PL_OP_SLAB_ALLOC
6443 if (DIFF(loop, OpSLOT(loop)->opslot_next)
6444 < SIZE_TO_PSIZE(sizeof(LOOP)))
6448 NewOp(1234,tmp,1,LOOP);
6449 Copy(loop,tmp,1,LISTOP);
6450 S_op_destroy(aTHX_ (OP*)loop);
6453 loop->op_targ = padoff;
6454 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6456 op_getmad(madsv, (OP*)loop, 'v');
6461 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6463 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6464 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6465 determining the target of the op; it is consumed by this function and
6466 become part of the constructed op tree.
6472 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6477 PERL_ARGS_ASSERT_NEWLOOPEX;
6479 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6481 if (type != OP_GOTO) {
6482 /* "last()" means "last" */
6483 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6484 o = newOP(type, OPf_SPECIAL);
6488 label->op_type == OP_CONST
6489 ? SvUTF8(((SVOP*)label)->op_sv)
6491 savesharedpv(label->op_type == OP_CONST
6492 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6496 op_getmad(label,o,'L');
6502 /* Check whether it's going to be a goto &function */
6503 if (label->op_type == OP_ENTERSUB
6504 && !(label->op_flags & OPf_STACKED))
6505 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6506 else if (label->op_type == OP_CONST) {
6507 SV * const sv = ((SVOP *)label)->op_sv;
6509 const char *s = SvPV_const(sv,l);
6510 if (l == strlen(s)) goto const_label;
6512 o = newUNOP(type, OPf_STACKED, label);
6514 PL_hints |= HINT_BLOCK_SCOPE;
6518 /* if the condition is a literal array or hash
6519 (or @{ ... } etc), make a reference to it.
6522 S_ref_array_or_hash(pTHX_ OP *cond)
6525 && (cond->op_type == OP_RV2AV
6526 || cond->op_type == OP_PADAV
6527 || cond->op_type == OP_RV2HV
6528 || cond->op_type == OP_PADHV))
6530 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6533 && (cond->op_type == OP_ASLICE
6534 || cond->op_type == OP_HSLICE)) {
6536 /* anonlist now needs a list from this op, was previously used in
6538 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6539 cond->op_flags |= OPf_WANT_LIST;
6541 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6548 /* These construct the optree fragments representing given()
6551 entergiven and enterwhen are LOGOPs; the op_other pointer
6552 points up to the associated leave op. We need this so we
6553 can put it in the context and make break/continue work.
6554 (Also, of course, pp_enterwhen will jump straight to
6555 op_other if the match fails.)
6559 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6560 I32 enter_opcode, I32 leave_opcode,
6561 PADOFFSET entertarg)
6567 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6569 NewOp(1101, enterop, 1, LOGOP);
6570 enterop->op_type = (Optype)enter_opcode;
6571 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6572 enterop->op_flags = (U8) OPf_KIDS;
6573 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6574 enterop->op_private = 0;
6576 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6579 enterop->op_first = scalar(cond);
6580 cond->op_sibling = block;
6582 o->op_next = LINKLIST(cond);
6583 cond->op_next = (OP *) enterop;
6586 /* This is a default {} block */
6587 enterop->op_first = block;
6588 enterop->op_flags |= OPf_SPECIAL;
6589 o ->op_flags |= OPf_SPECIAL;
6591 o->op_next = (OP *) enterop;
6594 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6595 entergiven and enterwhen both
6598 enterop->op_next = LINKLIST(block);
6599 block->op_next = enterop->op_other = o;
6604 /* Does this look like a boolean operation? For these purposes
6605 a boolean operation is:
6606 - a subroutine call [*]
6607 - a logical connective
6608 - a comparison operator
6609 - a filetest operator, with the exception of -s -M -A -C
6610 - defined(), exists() or eof()
6611 - /$re/ or $foo =~ /$re/
6613 [*] possibly surprising
6616 S_looks_like_bool(pTHX_ const OP *o)
6620 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6622 switch(o->op_type) {
6625 return looks_like_bool(cLOGOPo->op_first);
6629 looks_like_bool(cLOGOPo->op_first)
6630 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6635 o->op_flags & OPf_KIDS
6636 && looks_like_bool(cUNOPo->op_first));
6640 case OP_NOT: case OP_XOR:
6642 case OP_EQ: case OP_NE: case OP_LT:
6643 case OP_GT: case OP_LE: case OP_GE:
6645 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6646 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6648 case OP_SEQ: case OP_SNE: case OP_SLT:
6649 case OP_SGT: case OP_SLE: case OP_SGE:
6653 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6654 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6655 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6656 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6657 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6658 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6659 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6660 case OP_FTTEXT: case OP_FTBINARY:
6662 case OP_DEFINED: case OP_EXISTS:
6663 case OP_MATCH: case OP_EOF:
6670 /* Detect comparisons that have been optimized away */
6671 if (cSVOPo->op_sv == &PL_sv_yes
6672 || cSVOPo->op_sv == &PL_sv_no)
6685 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6687 Constructs, checks, and returns an op tree expressing a C<given> block.
6688 I<cond> supplies the expression that will be locally assigned to a lexical
6689 variable, and I<block> supplies the body of the C<given> construct; they
6690 are consumed by this function and become part of the constructed op tree.
6691 I<defsv_off> is the pad offset of the scalar lexical variable that will
6698 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6701 PERL_ARGS_ASSERT_NEWGIVENOP;
6702 return newGIVWHENOP(
6703 ref_array_or_hash(cond),
6705 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6710 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6712 Constructs, checks, and returns an op tree expressing a C<when> block.
6713 I<cond> supplies the test expression, and I<block> supplies the block
6714 that will be executed if the test evaluates to true; they are consumed
6715 by this function and become part of the constructed op tree. I<cond>
6716 will be interpreted DWIMically, often as a comparison against C<$_>,
6717 and may be null to generate a C<default> block.
6723 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6725 const bool cond_llb = (!cond || looks_like_bool(cond));
6728 PERL_ARGS_ASSERT_NEWWHENOP;
6733 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6735 scalar(ref_array_or_hash(cond)));
6738 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6742 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6743 const STRLEN len, const U32 flags)
6745 const char * const cvp = CvPROTO(cv);
6746 const STRLEN clen = CvPROTOLEN(cv);
6748 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6750 if (((!p != !cvp) /* One has prototype, one has not. */
6752 (flags & SVf_UTF8) == SvUTF8(cv)
6753 ? len != clen || memNE(cvp, p, len)
6755 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6757 : bytes_cmp_utf8((const U8 *)p, len,
6758 (const U8 *)cvp, clen)
6762 && ckWARN_d(WARN_PROTOTYPE)) {
6763 SV* const msg = sv_newmortal();
6767 gv_efullname3(name = sv_newmortal(), gv, NULL);
6768 sv_setpvs(msg, "Prototype mismatch:");
6770 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6772 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6773 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6776 sv_catpvs(msg, ": none");
6777 sv_catpvs(msg, " vs ");
6779 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6781 sv_catpvs(msg, "none");
6782 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6786 static void const_sv_xsub(pTHX_ CV* cv);
6790 =head1 Optree Manipulation Functions
6792 =for apidoc cv_const_sv
6794 If C<cv> is a constant sub eligible for inlining. returns the constant
6795 value returned by the sub. Otherwise, returns NULL.
6797 Constant subs can be created with C<newCONSTSUB> or as described in
6798 L<perlsub/"Constant Functions">.
6803 Perl_cv_const_sv(pTHX_ const CV *const cv)
6805 PERL_UNUSED_CONTEXT;
6808 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6810 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6813 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6814 * Can be called in 3 ways:
6817 * look for a single OP_CONST with attached value: return the value
6819 * cv && CvCLONE(cv) && !CvCONST(cv)
6821 * examine the clone prototype, and if contains only a single
6822 * OP_CONST referencing a pad const, or a single PADSV referencing
6823 * an outer lexical, return a non-zero value to indicate the CV is
6824 * a candidate for "constizing" at clone time
6828 * We have just cloned an anon prototype that was marked as a const
6829 * candidate. Try to grab the current value, and in the case of
6830 * PADSV, ignore it if it has multiple references. Return the value.
6834 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6845 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6846 o = cLISTOPo->op_first->op_sibling;
6848 for (; o; o = o->op_next) {
6849 const OPCODE type = o->op_type;
6851 if (sv && o->op_next == o)
6853 if (o->op_next != o) {
6854 if (type == OP_NEXTSTATE
6855 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6856 || type == OP_PUSHMARK)
6858 if (type == OP_DBSTATE)
6861 if (type == OP_LEAVESUB || type == OP_RETURN)
6865 if (type == OP_CONST && cSVOPo->op_sv)
6867 else if (cv && type == OP_CONST) {
6868 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6872 else if (cv && type == OP_PADSV) {
6873 if (CvCONST(cv)) { /* newly cloned anon */
6874 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6875 /* the candidate should have 1 ref from this pad and 1 ref
6876 * from the parent */
6877 if (!sv || SvREFCNT(sv) != 2)
6884 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6885 sv = &PL_sv_undef; /* an arbitrary non-null value */
6900 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6903 /* This would be the return value, but the return cannot be reached. */
6904 OP* pegop = newOP(OP_NULL, 0);
6907 PERL_UNUSED_ARG(floor);
6917 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6919 NORETURN_FUNCTION_END;
6924 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6926 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
6930 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
6931 OP *block, U32 flags)
6936 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6938 register CV *cv = NULL;
6940 const bool ec = PL_parser && PL_parser->error_count;
6941 /* If the subroutine has no body, no attributes, and no builtin attributes
6942 then it's just a sub declaration, and we may be able to get away with
6943 storing with a placeholder scalar in the symbol table, rather than a
6944 full GV and CV. If anything is present then it will take a full CV to
6946 const I32 gv_fetch_flags
6947 = ec ? GV_NOADD_NOINIT :
6948 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6950 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6952 const bool o_is_gv = flags & 1;
6953 const char * const name =
6954 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
6956 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
6959 assert(proto->op_type == OP_CONST);
6960 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6961 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6971 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6973 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6974 SV * const sv = sv_newmortal();
6975 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6976 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6977 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6978 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6980 } else if (PL_curstash) {
6981 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6984 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6988 if (!PL_madskills) {
6999 if (name && block) {
7000 const char *s = strrchr(name, ':');
7002 if (strEQ(s, "BEGIN")) {
7003 const char not_safe[] =
7004 "BEGIN not safe after errors--compilation aborted";
7005 if (PL_in_eval & EVAL_KEEPERR)
7006 Perl_croak(aTHX_ not_safe);
7008 /* force display of errors found but not reported */
7009 sv_catpv(ERRSV, not_safe);
7010 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
7018 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
7019 maximum a prototype before. */
7020 if (SvTYPE(gv) > SVt_NULL) {
7021 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
7024 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7025 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7028 sv_setiv(MUTABLE_SV(gv), -1);
7030 SvREFCNT_dec(PL_compcv);
7031 cv = PL_compcv = NULL;
7035 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7037 if (!block || !ps || *ps || attrs
7038 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7040 || block->op_type == OP_NULL
7045 const_sv = op_const_sv(block, NULL);
7048 const bool exists = CvROOT(cv) || CvXSUB(cv);
7050 /* if the subroutine doesn't exist and wasn't pre-declared
7051 * with a prototype, assume it will be AUTOLOADed,
7052 * skipping the prototype check
7054 if (exists || SvPOK(cv))
7055 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7056 /* already defined (or promised)? */
7057 if (exists || GvASSUMECV(gv)) {
7060 || block->op_type == OP_NULL
7063 if (CvFLAGS(PL_compcv)) {
7064 /* might have had built-in attrs applied */
7065 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7066 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7067 && ckWARN(WARN_MISC))
7068 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7070 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7071 & ~(CVf_LVALUE * pureperl));
7073 if (attrs) goto attrs;
7074 /* just a "sub foo;" when &foo is already defined */
7075 SAVEFREESV(PL_compcv);
7080 && block->op_type != OP_NULL
7083 const line_t oldline = CopLINE(PL_curcop);
7084 if (PL_parser && PL_parser->copline != NOLINE)
7085 CopLINE_set(PL_curcop, PL_parser->copline);
7086 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
7087 CopLINE_set(PL_curcop, oldline);
7089 if (!PL_minus_c) /* keep old one around for madskills */
7092 /* (PL_madskills unset in used file.) */
7100 SvREFCNT_inc_simple_void_NN(const_sv);
7102 assert(!CvROOT(cv) && !CvCONST(cv));
7104 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
7105 CvXSUBANY(cv).any_ptr = const_sv;
7106 CvXSUB(cv) = const_sv_xsub;
7112 cv = newCONSTSUB_flags(
7113 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7120 SvREFCNT_dec(PL_compcv);
7124 if (cv) { /* must reuse cv if autoloaded */
7125 /* transfer PL_compcv to cv */
7128 && block->op_type != OP_NULL
7131 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7132 AV *const temp_av = CvPADLIST(cv);
7133 CV *const temp_cv = CvOUTSIDE(cv);
7134 const cv_flags_t slabbed = CvSLABBED(cv);
7135 OP * const cvstart = CvSTART(cv);
7137 assert(!CvWEAKOUTSIDE(cv));
7138 assert(!CvCVGV_RC(cv));
7139 assert(CvGV(cv) == gv);
7142 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7143 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7144 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7145 CvPADLIST(cv) = CvPADLIST(PL_compcv);
7146 CvOUTSIDE(PL_compcv) = temp_cv;
7147 CvPADLIST(PL_compcv) = temp_av;
7148 CvSTART(cv) = CvSTART(PL_compcv);
7149 CvSTART(PL_compcv) = cvstart;
7150 if (slabbed) CvSLABBED_on(PL_compcv);
7151 else CvSLABBED_off(PL_compcv);
7153 if (CvFILE(cv) && CvDYNFILE(cv)) {
7154 Safefree(CvFILE(cv));
7156 CvFILE_set_from_cop(cv, PL_curcop);
7157 CvSTASH_set(cv, PL_curstash);
7159 /* inner references to PL_compcv must be fixed up ... */
7160 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7161 if (PERLDB_INTER)/* Advice debugger on the new sub. */
7162 ++PL_sub_generation;
7165 /* Might have had built-in attributes applied -- propagate them. */
7166 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7168 /* ... before we throw it away */
7169 SvREFCNT_dec(PL_compcv);
7177 if (strEQ(name, "import")) {
7178 PL_formfeed = MUTABLE_SV(cv);
7179 /* diag_listed_as: SKIPME */
7180 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
7184 if (HvENAME_HEK(GvSTASH(gv)))
7185 /* sub Foo::bar { (shift)+1 } */
7186 mro_method_changed_in(GvSTASH(gv));
7191 CvFILE_set_from_cop(cv, PL_curcop);
7192 CvSTASH_set(cv, PL_curstash);
7196 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7197 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7204 /* If we assign an optree to a PVCV, then we've defined a subroutine that
7205 the debugger could be able to set a breakpoint in, so signal to
7206 pp_entereval that it should not throw away any saved lines at scope
7209 PL_breakable_sub_gen++;
7210 /* This makes sub {}; work as expected. */
7211 if (block->op_type == OP_STUB) {
7212 OP* const newblock = newSTATEOP(0, NULL, 0);
7214 op_getmad(block,newblock,'B');
7220 else block->op_attached = 1;
7221 CvROOT(cv) = CvLVALUE(cv)
7222 ? newUNOP(OP_LEAVESUBLV, 0,
7223 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7224 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7225 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7226 OpREFCNT_set(CvROOT(cv), 1);
7227 #ifndef PL_OP_SLAB_ALLOC
7228 /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7229 itself has a refcount. */
7231 OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7233 CvSTART(cv) = LINKLIST(CvROOT(cv));
7234 CvROOT(cv)->op_next = 0;
7235 CALL_PEEP(CvSTART(cv));
7236 finalize_optree(CvROOT(cv));
7238 /* now that optimizer has done its work, adjust pad values */
7240 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7243 assert(!CvCONST(cv));
7244 if (ps && !*ps && op_const_sv(block, cv))
7250 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7251 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7252 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
7255 if (block && has_name) {
7256 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7257 SV * const tmpstr = sv_newmortal();
7258 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7259 GV_ADDMULTI, SVt_PVHV);
7261 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7264 (long)CopLINE(PL_curcop));
7265 gv_efullname3(tmpstr, gv, NULL);
7266 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7267 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7268 hv = GvHVn(db_postponed);
7269 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7270 CV * const pcv = GvCV(db_postponed);
7276 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7281 if (name && ! (PL_parser && PL_parser->error_count))
7282 process_special_blocks(name, gv, cv);
7287 PL_parser->copline = NOLINE;
7293 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
7296 const char *const colon = strrchr(fullname,':');
7297 const char *const name = colon ? colon + 1 : fullname;
7299 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7302 if (strEQ(name, "BEGIN")) {
7303 const I32 oldscope = PL_scopestack_ix;
7305 SAVECOPFILE(&PL_compiling);
7306 SAVECOPLINE(&PL_compiling);
7307 SAVEVPTR(PL_curcop);
7309 DEBUG_x( dump_sub(gv) );
7310 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7311 GvCV_set(gv,0); /* cv has been hijacked */
7312 call_list(oldscope, PL_beginav);
7314 CopHINTS_set(&PL_compiling, PL_hints);
7321 if strEQ(name, "END") {
7322 DEBUG_x( dump_sub(gv) );
7323 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7326 } else if (*name == 'U') {
7327 if (strEQ(name, "UNITCHECK")) {
7328 /* It's never too late to run a unitcheck block */
7329 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7333 } else if (*name == 'C') {
7334 if (strEQ(name, "CHECK")) {
7336 /* diag_listed_as: Too late to run %s block */
7337 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7338 "Too late to run CHECK block");
7339 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7343 } else if (*name == 'I') {
7344 if (strEQ(name, "INIT")) {
7346 /* diag_listed_as: Too late to run %s block */
7347 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7348 "Too late to run INIT block");
7349 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7355 DEBUG_x( dump_sub(gv) );
7356 GvCV_set(gv,0); /* cv has been hijacked */
7361 =for apidoc newCONSTSUB
7363 See L</newCONSTSUB_flags>.
7369 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7371 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7375 =for apidoc newCONSTSUB_flags
7377 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7378 eligible for inlining at compile-time.
7380 Currently, the only useful value for C<flags> is SVf_UTF8.
7382 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7383 which won't be called if used as a destructor, but will suppress the overhead
7384 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7391 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7397 const char *const file = CopFILE(PL_curcop);
7399 SV *const temp_sv = CopFILESV(PL_curcop);
7400 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
7405 if (IN_PERL_RUNTIME) {
7406 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7407 * an op shared between threads. Use a non-shared COP for our
7409 SAVEVPTR(PL_curcop);
7410 SAVECOMPILEWARNINGS();
7411 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7412 PL_curcop = &PL_compiling;
7414 SAVECOPLINE(PL_curcop);
7415 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7418 PL_hints &= ~HINT_BLOCK_SCOPE;
7421 SAVEGENERICSV(PL_curstash);
7422 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7425 /* file becomes the CvFILE. For an XS, it's usually static storage,
7426 and so doesn't get free()d. (It's expected to be from the C pre-
7427 processor __FILE__ directive). But we need a dynamically allocated one,
7428 and we need it to get freed. */
7429 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
7430 &sv, XS_DYNAMIC_FILENAME | flags);
7431 CvXSUBANY(cv).any_ptr = sv;
7440 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7441 const char *const filename, const char *const proto,
7444 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7445 return newXS_len_flags(
7446 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7451 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7452 XSUBADDR_t subaddr, const char *const filename,
7453 const char *const proto, SV **const_svp,
7458 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7461 GV * const gv = name
7463 name,len,GV_ADDMULTI|flags,SVt_PVCV
7466 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7467 GV_ADDMULTI | flags, SVt_PVCV);
7470 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7472 if ((cv = (name ? GvCV(gv) : NULL))) {
7474 /* just a cached method */
7478 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7479 /* already defined (or promised) */
7480 /* Redundant check that allows us to avoid creating an SV
7481 most of the time: */
7482 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7483 const line_t oldline = CopLINE(PL_curcop);
7484 if (PL_parser && PL_parser->copline != NOLINE)
7485 CopLINE_set(PL_curcop, PL_parser->copline);
7486 report_redefined_cv(newSVpvn_flags(
7487 name,len,(flags&SVf_UTF8)|SVs_TEMP
7490 CopLINE_set(PL_curcop, oldline);
7497 if (cv) /* must reuse cv if autoloaded */
7500 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7504 if (HvENAME_HEK(GvSTASH(gv)))
7505 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7511 (void)gv_fetchfile(filename);
7512 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7513 an external constant string */
7514 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7516 CvXSUB(cv) = subaddr;
7519 process_special_blocks(name, gv, cv);
7522 if (flags & XS_DYNAMIC_FILENAME) {
7523 CvFILE(cv) = savepv(filename);
7526 sv_setpv(MUTABLE_SV(cv), proto);
7531 Perl_newSTUB(pTHX_ GV *gv, bool fake)
7533 register CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7534 PERL_ARGS_ASSERT_NEWSTUB;
7538 if (!fake && HvENAME_HEK(GvSTASH(gv)))
7539 mro_method_changed_in(GvSTASH(gv));
7541 CvFILE_set_from_cop(cv, PL_curcop);
7542 CvSTASH_set(cv, PL_curstash);
7548 =for apidoc U||newXS
7550 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7551 static storage, as it is used directly as CvFILE(), without a copy being made.
7557 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7559 PERL_ARGS_ASSERT_NEWXS;
7560 return newXS_len_flags(
7561 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7570 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7575 OP* pegop = newOP(OP_NULL, 0);
7579 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7580 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7583 if ((cv = GvFORM(gv))) {
7584 if (ckWARN(WARN_REDEFINE)) {
7585 const line_t oldline = CopLINE(PL_curcop);
7586 if (PL_parser && PL_parser->copline != NOLINE)
7587 CopLINE_set(PL_curcop, PL_parser->copline);
7589 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7590 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7592 /* diag_listed_as: Format %s redefined */
7593 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7594 "Format STDOUT redefined");
7596 CopLINE_set(PL_curcop, oldline);
7603 CvFILE_set_from_cop(cv, PL_curcop);
7606 pad_tidy(padtidy_FORMAT);
7607 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7608 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7609 OpREFCNT_set(CvROOT(cv), 1);
7610 CvSTART(cv) = LINKLIST(CvROOT(cv));
7611 CvROOT(cv)->op_next = 0;
7612 CALL_PEEP(CvSTART(cv));
7613 finalize_optree(CvROOT(cv));
7616 op_getmad(o,pegop,'n');
7617 op_getmad_weak(block, pegop, 'b');
7622 PL_parser->copline = NOLINE;
7630 Perl_newANONLIST(pTHX_ OP *o)
7632 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7636 Perl_newANONHASH(pTHX_ OP *o)
7638 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7642 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7644 return newANONATTRSUB(floor, proto, NULL, block);
7648 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7650 return newUNOP(OP_REFGEN, 0,
7651 newSVOP(OP_ANONCODE, 0,
7652 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7656 Perl_oopsAV(pTHX_ OP *o)
7660 PERL_ARGS_ASSERT_OOPSAV;
7662 switch (o->op_type) {
7664 o->op_type = OP_PADAV;
7665 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7666 return ref(o, OP_RV2AV);
7669 o->op_type = OP_RV2AV;
7670 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7675 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7682 Perl_oopsHV(pTHX_ OP *o)
7686 PERL_ARGS_ASSERT_OOPSHV;
7688 switch (o->op_type) {
7691 o->op_type = OP_PADHV;
7692 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7693 return ref(o, OP_RV2HV);
7697 o->op_type = OP_RV2HV;
7698 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7703 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7710 Perl_newAVREF(pTHX_ OP *o)
7714 PERL_ARGS_ASSERT_NEWAVREF;
7716 if (o->op_type == OP_PADANY) {
7717 o->op_type = OP_PADAV;
7718 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7721 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7722 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7723 "Using an array as a reference is deprecated");
7725 return newUNOP(OP_RV2AV, 0, scalar(o));
7729 Perl_newGVREF(pTHX_ I32 type, OP *o)
7731 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7732 return newUNOP(OP_NULL, 0, o);
7733 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7737 Perl_newHVREF(pTHX_ OP *o)
7741 PERL_ARGS_ASSERT_NEWHVREF;
7743 if (o->op_type == OP_PADANY) {
7744 o->op_type = OP_PADHV;
7745 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7748 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7749 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7750 "Using a hash as a reference is deprecated");
7752 return newUNOP(OP_RV2HV, 0, scalar(o));
7756 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7758 return newUNOP(OP_RV2CV, flags, scalar(o));
7762 Perl_newSVREF(pTHX_ OP *o)
7766 PERL_ARGS_ASSERT_NEWSVREF;
7768 if (o->op_type == OP_PADANY) {
7769 o->op_type = OP_PADSV;
7770 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7773 return newUNOP(OP_RV2SV, 0, scalar(o));
7776 /* Check routines. See the comments at the top of this file for details
7777 * on when these are called */
7780 Perl_ck_anoncode(pTHX_ OP *o)
7782 PERL_ARGS_ASSERT_CK_ANONCODE;
7784 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7786 cSVOPo->op_sv = NULL;
7791 Perl_ck_bitop(pTHX_ OP *o)
7795 PERL_ARGS_ASSERT_CK_BITOP;
7797 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7798 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7799 && (o->op_type == OP_BIT_OR
7800 || o->op_type == OP_BIT_AND
7801 || o->op_type == OP_BIT_XOR))
7803 const OP * const left = cBINOPo->op_first;
7804 const OP * const right = left->op_sibling;
7805 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7806 (left->op_flags & OPf_PARENS) == 0) ||
7807 (OP_IS_NUMCOMPARE(right->op_type) &&
7808 (right->op_flags & OPf_PARENS) == 0))
7809 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7810 "Possible precedence problem on bitwise %c operator",
7811 o->op_type == OP_BIT_OR ? '|'
7812 : o->op_type == OP_BIT_AND ? '&' : '^'
7818 PERL_STATIC_INLINE bool
7819 is_dollar_bracket(pTHX_ const OP * const o)
7822 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7823 && (kid = cUNOPx(o)->op_first)
7824 && kid->op_type == OP_GV
7825 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7829 Perl_ck_cmp(pTHX_ OP *o)
7831 PERL_ARGS_ASSERT_CK_CMP;
7832 if (ckWARN(WARN_SYNTAX)) {
7833 const OP *kid = cUNOPo->op_first;
7836 is_dollar_bracket(aTHX_ kid)
7837 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
7839 || ( kid->op_type == OP_CONST
7840 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7843 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7849 Perl_ck_concat(pTHX_ OP *o)
7851 const OP * const kid = cUNOPo->op_first;
7853 PERL_ARGS_ASSERT_CK_CONCAT;
7854 PERL_UNUSED_CONTEXT;
7856 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7857 !(kUNOP->op_first->op_flags & OPf_MOD))
7858 o->op_flags |= OPf_STACKED;
7863 Perl_ck_spair(pTHX_ OP *o)
7867 PERL_ARGS_ASSERT_CK_SPAIR;
7869 if (o->op_flags & OPf_KIDS) {
7872 const OPCODE type = o->op_type;
7873 o = modkids(ck_fun(o), type);
7874 kid = cUNOPo->op_first;
7875 newop = kUNOP->op_first->op_sibling;
7877 const OPCODE type = newop->op_type;
7878 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7879 type == OP_PADAV || type == OP_PADHV ||
7880 type == OP_RV2AV || type == OP_RV2HV)
7884 op_getmad(kUNOP->op_first,newop,'K');
7886 op_free(kUNOP->op_first);
7888 kUNOP->op_first = newop;
7890 o->op_ppaddr = PL_ppaddr[++o->op_type];
7895 Perl_ck_delete(pTHX_ OP *o)
7897 PERL_ARGS_ASSERT_CK_DELETE;
7901 if (o->op_flags & OPf_KIDS) {
7902 OP * const kid = cUNOPo->op_first;
7903 switch (kid->op_type) {
7905 o->op_flags |= OPf_SPECIAL;
7908 o->op_private |= OPpSLICE;
7911 o->op_flags |= OPf_SPECIAL;
7916 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7919 if (kid->op_private & OPpLVAL_INTRO)
7920 o->op_private |= OPpLVAL_INTRO;
7927 Perl_ck_die(pTHX_ OP *o)
7929 PERL_ARGS_ASSERT_CK_DIE;
7932 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7938 Perl_ck_eof(pTHX_ OP *o)
7942 PERL_ARGS_ASSERT_CK_EOF;
7944 if (o->op_flags & OPf_KIDS) {
7946 if (cLISTOPo->op_first->op_type == OP_STUB) {
7948 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7950 op_getmad(o,newop,'O');
7957 kid = cLISTOPo->op_first;
7958 if (kid->op_type == OP_RV2GV)
7959 kid->op_private |= OPpALLOW_FAKE;
7965 Perl_ck_eval(pTHX_ OP *o)
7969 PERL_ARGS_ASSERT_CK_EVAL;
7971 PL_hints |= HINT_BLOCK_SCOPE;
7972 if (o->op_flags & OPf_KIDS) {
7973 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7976 o->op_flags &= ~OPf_KIDS;
7979 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7985 cUNOPo->op_first = 0;
7990 NewOp(1101, enter, 1, LOGOP);
7991 enter->op_type = OP_ENTERTRY;
7992 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7993 enter->op_private = 0;
7995 /* establish postfix order */
7996 enter->op_next = (OP*)enter;
7998 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7999 o->op_type = OP_LEAVETRY;
8000 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8001 enter->op_other = o;
8002 op_getmad(oldo,o,'O');
8011 const U8 priv = o->op_private;
8017 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8018 op_getmad(oldo,o,'O');
8020 o->op_targ = (PADOFFSET)PL_hints;
8021 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8022 if ((PL_hints & HINT_LOCALIZE_HH) != 0
8023 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8024 /* Store a copy of %^H that pp_entereval can pick up. */
8025 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8026 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8027 cUNOPo->op_first->op_sibling = hhop;
8028 o->op_private |= OPpEVAL_HAS_HH;
8030 if (!(o->op_private & OPpEVAL_BYTES)
8031 && FEATURE_UNIEVAL_IS_ENABLED)
8032 o->op_private |= OPpEVAL_UNICODE;
8037 Perl_ck_exit(pTHX_ OP *o)
8039 PERL_ARGS_ASSERT_CK_EXIT;
8042 HV * const table = GvHV(PL_hintgv);
8044 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
8045 if (svp && *svp && SvTRUE(*svp))
8046 o->op_private |= OPpEXIT_VMSISH;
8048 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
8054 Perl_ck_exec(pTHX_ OP *o)
8056 PERL_ARGS_ASSERT_CK_EXEC;
8058 if (o->op_flags & OPf_STACKED) {
8061 kid = cUNOPo->op_first->op_sibling;
8062 if (kid->op_type == OP_RV2GV)
8071 Perl_ck_exists(pTHX_ OP *o)
8075 PERL_ARGS_ASSERT_CK_EXISTS;
8078 if (o->op_flags & OPf_KIDS) {
8079 OP * const kid = cUNOPo->op_first;
8080 if (kid->op_type == OP_ENTERSUB) {
8081 (void) ref(kid, o->op_type);
8082 if (kid->op_type != OP_RV2CV
8083 && !(PL_parser && PL_parser->error_count))
8084 Perl_croak(aTHX_ "%s argument is not a subroutine name",
8086 o->op_private |= OPpEXISTS_SUB;
8088 else if (kid->op_type == OP_AELEM)
8089 o->op_flags |= OPf_SPECIAL;
8090 else if (kid->op_type != OP_HELEM)
8091 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
8099 Perl_ck_rvconst(pTHX_ register OP *o)
8102 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8104 PERL_ARGS_ASSERT_CK_RVCONST;
8106 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8107 if (o->op_type == OP_RV2CV)
8108 o->op_private &= ~1;
8110 if (kid->op_type == OP_CONST) {
8113 SV * const kidsv = kid->op_sv;
8115 /* Is it a constant from cv_const_sv()? */
8116 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8117 SV * const rsv = SvRV(kidsv);
8118 const svtype type = SvTYPE(rsv);
8119 const char *badtype = NULL;
8121 switch (o->op_type) {
8123 if (type > SVt_PVMG)
8124 badtype = "a SCALAR";
8127 if (type != SVt_PVAV)
8128 badtype = "an ARRAY";
8131 if (type != SVt_PVHV)
8135 if (type != SVt_PVCV)
8140 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
8143 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
8144 const char *badthing;
8145 switch (o->op_type) {
8147 badthing = "a SCALAR";
8150 badthing = "an ARRAY";
8153 badthing = "a HASH";
8161 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
8162 SVfARG(kidsv), badthing);
8165 * This is a little tricky. We only want to add the symbol if we
8166 * didn't add it in the lexer. Otherwise we get duplicate strict
8167 * warnings. But if we didn't add it in the lexer, we must at
8168 * least pretend like we wanted to add it even if it existed before,
8169 * or we get possible typo warnings. OPpCONST_ENTERED says
8170 * whether the lexer already added THIS instance of this symbol.
8172 iscv = (o->op_type == OP_RV2CV) * 2;
8174 gv = gv_fetchsv(kidsv,
8175 iscv | !(kid->op_private & OPpCONST_ENTERED),
8178 : o->op_type == OP_RV2SV
8180 : o->op_type == OP_RV2AV
8182 : o->op_type == OP_RV2HV
8185 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
8187 kid->op_type = OP_GV;
8188 SvREFCNT_dec(kid->op_sv);
8190 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
8191 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
8192 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
8194 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
8196 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
8198 kid->op_private = 0;
8199 kid->op_ppaddr = PL_ppaddr[OP_GV];
8200 /* FAKE globs in the symbol table cause weird bugs (#77810) */
8208 Perl_ck_ftst(pTHX_ OP *o)
8211 const I32 type = o->op_type;
8213 PERL_ARGS_ASSERT_CK_FTST;
8215 if (o->op_flags & OPf_REF) {
8218 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
8219 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8220 const OPCODE kidtype = kid->op_type;
8222 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8223 OP * const newop = newGVOP(type, OPf_REF,
8224 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
8226 op_getmad(o,newop,'O');
8232 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
8233 o->op_private |= OPpFT_ACCESS;
8234 if (PL_check[kidtype] == Perl_ck_ftst
8235 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
8236 o->op_private |= OPpFT_STACKED;
8237 kid->op_private |= OPpFT_STACKING;
8238 if (kidtype == OP_FTTTY && (
8239 !(kid->op_private & OPpFT_STACKED)
8240 || kid->op_private & OPpFT_AFTER_t
8242 o->op_private |= OPpFT_AFTER_t;
8251 if (type == OP_FTTTY)
8252 o = newGVOP(type, OPf_REF, PL_stdingv);
8254 o = newUNOP(type, 0, newDEFSVOP());
8255 op_getmad(oldo,o,'O');
8261 Perl_ck_fun(pTHX_ OP *o)
8264 const int type = o->op_type;
8265 register I32 oa = PL_opargs[type] >> OASHIFT;
8267 PERL_ARGS_ASSERT_CK_FUN;
8269 if (o->op_flags & OPf_STACKED) {
8270 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8273 return no_fh_allowed(o);
8276 if (o->op_flags & OPf_KIDS) {
8277 OP **tokid = &cLISTOPo->op_first;
8278 register OP *kid = cLISTOPo->op_first;
8281 bool seen_optional = FALSE;
8283 if (kid->op_type == OP_PUSHMARK ||
8284 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8286 tokid = &kid->op_sibling;
8287 kid = kid->op_sibling;
8289 if (kid && kid->op_type == OP_COREARGS) {
8290 bool optional = FALSE;
8293 if (oa & OA_OPTIONAL) optional = TRUE;
8296 if (optional) o->op_private |= numargs;
8301 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8302 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8303 *tokid = kid = newDEFSVOP();
8304 seen_optional = TRUE;
8309 sibl = kid->op_sibling;
8311 if (!sibl && kid->op_type == OP_STUB) {
8318 /* list seen where single (scalar) arg expected? */
8319 if (numargs == 1 && !(oa >> 4)
8320 && kid->op_type == OP_LIST && type != OP_SCALAR)
8322 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8335 if ((type == OP_PUSH || type == OP_UNSHIFT)
8336 && !kid->op_sibling)
8337 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8338 "Useless use of %s with no values",
8341 if (kid->op_type == OP_CONST &&
8342 (kid->op_private & OPpCONST_BARE))
8344 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
8345 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
8346 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8347 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8348 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8350 op_getmad(kid,newop,'K');
8355 kid->op_sibling = sibl;
8358 else if (kid->op_type == OP_CONST
8359 && ( !SvROK(cSVOPx_sv(kid))
8360 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8362 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8363 /* Defer checks to run-time if we have a scalar arg */
8364 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8365 op_lvalue(kid, type);
8369 if (kid->op_type == OP_CONST &&
8370 (kid->op_private & OPpCONST_BARE))
8372 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
8373 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
8374 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8375 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8376 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8378 op_getmad(kid,newop,'K');
8383 kid->op_sibling = sibl;
8386 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8387 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8388 op_lvalue(kid, type);
8392 OP * const newop = newUNOP(OP_NULL, 0, kid);
8393 kid->op_sibling = 0;
8395 newop->op_next = newop;
8397 kid->op_sibling = sibl;
8402 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8403 if (kid->op_type == OP_CONST &&
8404 (kid->op_private & OPpCONST_BARE))
8406 OP * const newop = newGVOP(OP_GV, 0,
8407 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8408 if (!(o->op_private & 1) && /* if not unop */
8409 kid == cLISTOPo->op_last)
8410 cLISTOPo->op_last = newop;
8412 op_getmad(kid,newop,'K');
8418 else if (kid->op_type == OP_READLINE) {
8419 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8420 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8423 I32 flags = OPf_SPECIAL;
8427 /* is this op a FH constructor? */
8428 if (is_handle_constructor(o,numargs)) {
8429 const char *name = NULL;
8432 bool want_dollar = TRUE;
8435 /* Set a flag to tell rv2gv to vivify
8436 * need to "prove" flag does not mean something
8437 * else already - NI-S 1999/05/07
8440 if (kid->op_type == OP_PADSV) {
8442 = PAD_COMPNAME_SV(kid->op_targ);
8443 name = SvPV_const(namesv, len);
8444 name_utf8 = SvUTF8(namesv);
8446 else if (kid->op_type == OP_RV2SV
8447 && kUNOP->op_first->op_type == OP_GV)
8449 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8451 len = GvNAMELEN(gv);
8452 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8454 else if (kid->op_type == OP_AELEM
8455 || kid->op_type == OP_HELEM)
8458 OP *op = ((BINOP*)kid)->op_first;
8462 const char * const a =
8463 kid->op_type == OP_AELEM ?
8465 if (((op->op_type == OP_RV2AV) ||
8466 (op->op_type == OP_RV2HV)) &&
8467 (firstop = ((UNOP*)op)->op_first) &&
8468 (firstop->op_type == OP_GV)) {
8469 /* packagevar $a[] or $h{} */
8470 GV * const gv = cGVOPx_gv(firstop);
8478 else if (op->op_type == OP_PADAV
8479 || op->op_type == OP_PADHV) {
8480 /* lexicalvar $a[] or $h{} */
8481 const char * const padname =
8482 PAD_COMPNAME_PV(op->op_targ);
8491 name = SvPV_const(tmpstr, len);
8492 name_utf8 = SvUTF8(tmpstr);
8497 name = "__ANONIO__";
8499 want_dollar = FALSE;
8501 op_lvalue(kid, type);
8505 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8506 namesv = PAD_SVl(targ);
8507 SvUPGRADE(namesv, SVt_PV);
8508 if (want_dollar && *name != '$')
8509 sv_setpvs(namesv, "$");
8510 sv_catpvn(namesv, name, len);
8511 if ( name_utf8 ) SvUTF8_on(namesv);
8514 kid->op_sibling = 0;
8515 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8516 kid->op_targ = targ;
8517 kid->op_private |= priv;
8519 kid->op_sibling = sibl;
8525 if ((type == OP_UNDEF || type == OP_POS)
8526 && numargs == 1 && !(oa >> 4)
8527 && kid->op_type == OP_LIST)
8528 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8529 op_lvalue(scalar(kid), type);
8533 tokid = &kid->op_sibling;
8534 kid = kid->op_sibling;
8537 if (kid && kid->op_type != OP_STUB)
8538 return too_many_arguments_pv(o,OP_DESC(o), 0);
8539 o->op_private |= numargs;
8541 /* FIXME - should the numargs move as for the PERL_MAD case? */
8542 o->op_private |= numargs;
8544 return too_many_arguments_pv(o,OP_DESC(o), 0);
8548 else if (PL_opargs[type] & OA_DEFGV) {
8550 OP *newop = newUNOP(type, 0, newDEFSVOP());
8551 op_getmad(o,newop,'O');
8554 /* Ordering of these two is important to keep f_map.t passing. */
8556 return newUNOP(type, 0, newDEFSVOP());
8561 while (oa & OA_OPTIONAL)
8563 if (oa && oa != OA_LIST)
8564 return too_few_arguments_pv(o,OP_DESC(o), 0);
8570 Perl_ck_glob(pTHX_ OP *o)
8574 const bool core = o->op_flags & OPf_SPECIAL;
8576 PERL_ARGS_ASSERT_CK_GLOB;
8579 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8580 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8582 if (core) gv = NULL;
8583 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8584 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8586 GV * const * const gvp =
8587 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
8588 gv = gvp ? *gvp : NULL;
8591 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8594 * \ null - const(wildcard)
8599 * \ mark - glob - rv2cv
8600 * | \ gv(CORE::GLOBAL::glob)
8602 * \ null - const(wildcard) - const(ix)
8604 o->op_flags |= OPf_SPECIAL;
8605 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8606 op_append_elem(OP_GLOB, o,
8607 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8608 o = newLISTOP(OP_LIST, 0, o, NULL);
8609 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8610 op_append_elem(OP_LIST, o,
8611 scalar(newUNOP(OP_RV2CV, 0,
8612 newGVOP(OP_GV, 0, gv)))));
8613 o = newUNOP(OP_NULL, 0, o);
8614 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8617 else o->op_flags &= ~OPf_SPECIAL;
8618 #if !defined(PERL_EXTERNAL_GLOB)
8621 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8622 newSVpvs("File::Glob"), NULL, NULL, NULL);
8625 #endif /* !PERL_EXTERNAL_GLOB */
8626 gv = newGVgen("main");
8628 #ifndef PERL_EXTERNAL_GLOB
8629 sv_setiv(GvSVn(gv),PL_glob_index++);
8631 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8637 Perl_ck_grep(pTHX_ OP *o)
8642 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8645 PERL_ARGS_ASSERT_CK_GREP;
8647 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8648 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8650 if (o->op_flags & OPf_STACKED) {
8653 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8654 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8655 return no_fh_allowed(o);
8656 for (k = kid; k; k = k->op_next) {
8659 NewOp(1101, gwop, 1, LOGOP);
8660 kid->op_next = (OP*)gwop;
8661 o->op_flags &= ~OPf_STACKED;
8663 kid = cLISTOPo->op_first->op_sibling;
8664 if (type == OP_MAPWHILE)
8669 if (PL_parser && PL_parser->error_count)
8671 kid = cLISTOPo->op_first->op_sibling;
8672 if (kid->op_type != OP_NULL)
8673 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8674 kid = kUNOP->op_first;
8677 NewOp(1101, gwop, 1, LOGOP);
8678 gwop->op_type = type;
8679 gwop->op_ppaddr = PL_ppaddr[type];
8680 gwop->op_first = listkids(o);
8681 gwop->op_flags |= OPf_KIDS;
8682 gwop->op_other = LINKLIST(kid);
8683 kid->op_next = (OP*)gwop;
8684 offset = pad_findmy_pvs("$_", 0);
8685 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8686 o->op_private = gwop->op_private = 0;
8687 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8690 o->op_private = gwop->op_private = OPpGREP_LEX;
8691 gwop->op_targ = o->op_targ = offset;
8694 kid = cLISTOPo->op_first->op_sibling;
8695 if (!kid || !kid->op_sibling)
8696 return too_few_arguments_pv(o,OP_DESC(o), 0);
8697 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8698 op_lvalue(kid, OP_GREPSTART);
8704 Perl_ck_index(pTHX_ OP *o)
8706 PERL_ARGS_ASSERT_CK_INDEX;
8708 if (o->op_flags & OPf_KIDS) {
8709 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8711 kid = kid->op_sibling; /* get past "big" */
8712 if (kid && kid->op_type == OP_CONST) {
8713 const bool save_taint = PL_tainted;
8714 fbm_compile(((SVOP*)kid)->op_sv, 0);
8715 PL_tainted = save_taint;
8722 Perl_ck_lfun(pTHX_ OP *o)
8724 const OPCODE type = o->op_type;
8726 PERL_ARGS_ASSERT_CK_LFUN;
8728 return modkids(ck_fun(o), type);
8732 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8734 PERL_ARGS_ASSERT_CK_DEFINED;
8736 if ((o->op_flags & OPf_KIDS)) {
8737 switch (cUNOPo->op_first->op_type) {
8740 case OP_AASSIGN: /* Is this a good idea? */
8741 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8742 "defined(@array) is deprecated");
8743 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8744 "\t(Maybe you should just omit the defined()?)\n");
8748 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8749 "defined(%%hash) is deprecated");
8750 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8751 "\t(Maybe you should just omit the defined()?)\n");
8762 Perl_ck_readline(pTHX_ OP *o)
8764 PERL_ARGS_ASSERT_CK_READLINE;
8766 if (o->op_flags & OPf_KIDS) {
8767 OP *kid = cLISTOPo->op_first;
8768 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
8772 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8774 op_getmad(o,newop,'O');
8784 Perl_ck_rfun(pTHX_ OP *o)
8786 const OPCODE type = o->op_type;
8788 PERL_ARGS_ASSERT_CK_RFUN;
8790 return refkids(ck_fun(o), type);
8794 Perl_ck_listiob(pTHX_ OP *o)
8798 PERL_ARGS_ASSERT_CK_LISTIOB;
8800 kid = cLISTOPo->op_first;
8803 kid = cLISTOPo->op_first;
8805 if (kid->op_type == OP_PUSHMARK)
8806 kid = kid->op_sibling;
8807 if (kid && o->op_flags & OPf_STACKED)
8808 kid = kid->op_sibling;
8809 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8810 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8811 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8812 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8813 cLISTOPo->op_first->op_sibling = kid;
8814 cLISTOPo->op_last = kid;
8815 kid = kid->op_sibling;
8820 op_append_elem(o->op_type, o, newDEFSVOP());
8822 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
8827 Perl_ck_smartmatch(pTHX_ OP *o)
8830 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8831 if (0 == (o->op_flags & OPf_SPECIAL)) {
8832 OP *first = cBINOPo->op_first;
8833 OP *second = first->op_sibling;
8835 /* Implicitly take a reference to an array or hash */
8836 first->op_sibling = NULL;
8837 first = cBINOPo->op_first = ref_array_or_hash(first);
8838 second = first->op_sibling = ref_array_or_hash(second);
8840 /* Implicitly take a reference to a regular expression */
8841 if (first->op_type == OP_MATCH) {
8842 first->op_type = OP_QR;
8843 first->op_ppaddr = PL_ppaddr[OP_QR];
8845 if (second->op_type == OP_MATCH) {
8846 second->op_type = OP_QR;
8847 second->op_ppaddr = PL_ppaddr[OP_QR];
8856 Perl_ck_sassign(pTHX_ OP *o)
8859 OP * const kid = cLISTOPo->op_first;
8861 PERL_ARGS_ASSERT_CK_SASSIGN;
8863 /* has a disposable target? */
8864 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8865 && !(kid->op_flags & OPf_STACKED)
8866 /* Cannot steal the second time! */
8867 && !(kid->op_private & OPpTARGET_MY)
8868 /* Keep the full thing for madskills */
8872 OP * const kkid = kid->op_sibling;
8874 /* Can just relocate the target. */
8875 if (kkid && kkid->op_type == OP_PADSV
8876 && !(kkid->op_private & OPpLVAL_INTRO))
8878 kid->op_targ = kkid->op_targ;
8880 /* Now we do not need PADSV and SASSIGN. */
8881 kid->op_sibling = o->op_sibling; /* NULL */
8882 cLISTOPo->op_first = NULL;
8885 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8889 if (kid->op_sibling) {
8890 OP *kkid = kid->op_sibling;
8891 /* For state variable assignment, kkid is a list op whose op_last
8893 if ((kkid->op_type == OP_PADSV ||
8894 (kkid->op_type == OP_LIST &&
8895 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8898 && (kkid->op_private & OPpLVAL_INTRO)
8899 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8900 const PADOFFSET target = kkid->op_targ;
8901 OP *const other = newOP(OP_PADSV,
8903 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8904 OP *const first = newOP(OP_NULL, 0);
8905 OP *const nullop = newCONDOP(0, first, o, other);
8906 OP *const condop = first->op_next;
8907 /* hijacking PADSTALE for uninitialized state variables */
8908 SvPADSTALE_on(PAD_SVl(target));
8910 condop->op_type = OP_ONCE;
8911 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8912 condop->op_targ = target;
8913 other->op_targ = target;
8915 /* Because we change the type of the op here, we will skip the
8916 assignment binop->op_last = binop->op_first->op_sibling; at the
8917 end of Perl_newBINOP(). So need to do it here. */
8918 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8927 Perl_ck_match(pTHX_ OP *o)
8931 PERL_ARGS_ASSERT_CK_MATCH;
8933 if (o->op_type != OP_QR && PL_compcv) {
8934 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8935 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8936 o->op_targ = offset;
8937 o->op_private |= OPpTARGET_MY;
8940 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8941 o->op_private |= OPpRUNTIME;
8946 Perl_ck_method(pTHX_ OP *o)
8948 OP * const kid = cUNOPo->op_first;
8950 PERL_ARGS_ASSERT_CK_METHOD;
8952 if (kid->op_type == OP_CONST) {
8953 SV* sv = kSVOP->op_sv;
8954 const char * const method = SvPVX_const(sv);
8955 if (!(strchr(method, ':') || strchr(method, '\''))) {
8957 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8958 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8961 kSVOP->op_sv = NULL;
8963 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8965 op_getmad(o,cmop,'O');
8976 Perl_ck_null(pTHX_ OP *o)
8978 PERL_ARGS_ASSERT_CK_NULL;
8979 PERL_UNUSED_CONTEXT;
8984 Perl_ck_open(pTHX_ OP *o)
8987 HV * const table = GvHV(PL_hintgv);
8989 PERL_ARGS_ASSERT_CK_OPEN;
8992 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8995 const char *d = SvPV_const(*svp, len);
8996 const I32 mode = mode_from_discipline(d, len);
8997 if (mode & O_BINARY)
8998 o->op_private |= OPpOPEN_IN_RAW;
8999 else if (mode & O_TEXT)
9000 o->op_private |= OPpOPEN_IN_CRLF;
9003 svp = hv_fetchs(table, "open_OUT", FALSE);
9006 const char *d = SvPV_const(*svp, len);
9007 const I32 mode = mode_from_discipline(d, len);
9008 if (mode & O_BINARY)
9009 o->op_private |= OPpOPEN_OUT_RAW;
9010 else if (mode & O_TEXT)
9011 o->op_private |= OPpOPEN_OUT_CRLF;
9014 if (o->op_type == OP_BACKTICK) {
9015 if (!(o->op_flags & OPf_KIDS)) {
9016 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
9018 op_getmad(o,newop,'O');
9027 /* In case of three-arg dup open remove strictness
9028 * from the last arg if it is a bareword. */
9029 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9030 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
9034 if ((last->op_type == OP_CONST) && /* The bareword. */
9035 (last->op_private & OPpCONST_BARE) &&
9036 (last->op_private & OPpCONST_STRICT) &&
9037 (oa = first->op_sibling) && /* The fh. */
9038 (oa = oa->op_sibling) && /* The mode. */
9039 (oa->op_type == OP_CONST) &&
9040 SvPOK(((SVOP*)oa)->op_sv) &&
9041 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9042 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
9043 (last == oa->op_sibling)) /* The bareword. */
9044 last->op_private &= ~OPpCONST_STRICT;
9050 Perl_ck_repeat(pTHX_ OP *o)
9052 PERL_ARGS_ASSERT_CK_REPEAT;
9054 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9055 o->op_private |= OPpREPEAT_DOLIST;
9056 cBINOPo->op_first = force_list(cBINOPo->op_first);
9064 Perl_ck_require(pTHX_ OP *o)
9069 PERL_ARGS_ASSERT_CK_REQUIRE;
9071 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
9072 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9074 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9075 SV * const sv = kid->op_sv;
9076 U32 was_readonly = SvREADONLY(sv);
9083 sv_force_normal_flags(sv, 0);
9084 assert(!SvREADONLY(sv));
9094 for (; s < end; s++) {
9095 if (*s == ':' && s[1] == ':') {
9097 Move(s+2, s+1, end - s - 1, char);
9102 sv_catpvs(sv, ".pm");
9103 SvFLAGS(sv) |= was_readonly;
9107 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
9108 /* handle override, if any */
9109 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
9110 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
9111 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
9112 gv = gvp ? *gvp : NULL;
9116 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
9118 if (o->op_flags & OPf_KIDS) {
9119 kid = cUNOPo->op_first;
9120 cUNOPo->op_first = NULL;
9128 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
9129 op_append_elem(OP_LIST, kid,
9130 scalar(newUNOP(OP_RV2CV, 0,
9133 op_getmad(o,newop,'O');
9137 return scalar(ck_fun(o));
9141 Perl_ck_return(pTHX_ OP *o)
9146 PERL_ARGS_ASSERT_CK_RETURN;
9148 kid = cLISTOPo->op_first->op_sibling;
9149 if (CvLVALUE(PL_compcv)) {
9150 for (; kid; kid = kid->op_sibling)
9151 op_lvalue(kid, OP_LEAVESUBLV);
9158 Perl_ck_select(pTHX_ OP *o)
9163 PERL_ARGS_ASSERT_CK_SELECT;
9165 if (o->op_flags & OPf_KIDS) {
9166 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9167 if (kid && kid->op_sibling) {
9168 o->op_type = OP_SSELECT;
9169 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9171 return fold_constants(op_integerize(op_std_init(o)));
9175 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9176 if (kid && kid->op_type == OP_RV2GV)
9177 kid->op_private &= ~HINT_STRICT_REFS;
9182 Perl_ck_shift(pTHX_ OP *o)
9185 const I32 type = o->op_type;
9187 PERL_ARGS_ASSERT_CK_SHIFT;
9189 if (!(o->op_flags & OPf_KIDS)) {
9192 if (!CvUNIQUE(PL_compcv)) {
9193 o->op_flags |= OPf_SPECIAL;
9197 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
9200 OP * const oldo = o;
9201 o = newUNOP(type, 0, scalar(argop));
9202 op_getmad(oldo,o,'O');
9207 return newUNOP(type, 0, scalar(argop));
9210 return scalar(ck_fun(o));
9214 Perl_ck_sort(pTHX_ OP *o)
9219 PERL_ARGS_ASSERT_CK_SORT;
9221 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
9222 HV * const hinthv = GvHV(PL_hintgv);
9224 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
9226 const I32 sorthints = (I32)SvIV(*svp);
9227 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
9228 o->op_private |= OPpSORT_QSORT;
9229 if ((sorthints & HINT_SORT_STABLE) != 0)
9230 o->op_private |= OPpSORT_STABLE;
9235 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
9237 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9238 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
9240 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9242 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9244 if (kid->op_type == OP_SCOPE) {
9248 else if (kid->op_type == OP_LEAVE) {
9249 if (o->op_type == OP_SORT) {
9250 op_null(kid); /* wipe out leave */
9253 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
9254 if (k->op_next == kid)
9256 /* don't descend into loops */
9257 else if (k->op_type == OP_ENTERLOOP
9258 || k->op_type == OP_ENTERITER)
9260 k = cLOOPx(k)->op_lastop;
9265 kid->op_next = 0; /* just disconnect the leave */
9266 k = kLISTOP->op_first;
9271 if (o->op_type == OP_SORT) {
9272 /* provide scalar context for comparison function/block */
9278 o->op_flags |= OPf_SPECIAL;
9281 firstkid = firstkid->op_sibling;
9284 /* provide list context for arguments */
9285 if (o->op_type == OP_SORT)
9292 S_simplify_sort(pTHX_ OP *o)
9295 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9301 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9303 if (!(o->op_flags & OPf_STACKED))
9305 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9306 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
9307 kid = kUNOP->op_first; /* get past null */
9308 if (kid->op_type != OP_SCOPE)
9310 kid = kLISTOP->op_last; /* get past scope */
9311 switch(kid->op_type) {
9319 k = kid; /* remember this node*/
9320 if (kBINOP->op_first->op_type != OP_RV2SV)
9322 kid = kBINOP->op_first; /* get past cmp */
9323 if (kUNOP->op_first->op_type != OP_GV)
9325 kid = kUNOP->op_first; /* get past rv2sv */
9327 if (GvSTASH(gv) != PL_curstash)
9329 gvname = GvNAME(gv);
9330 if (*gvname == 'a' && gvname[1] == '\0')
9332 else if (*gvname == 'b' && gvname[1] == '\0')
9337 kid = k; /* back to cmp */
9338 if (kBINOP->op_last->op_type != OP_RV2SV)
9340 kid = kBINOP->op_last; /* down to 2nd arg */
9341 if (kUNOP->op_first->op_type != OP_GV)
9343 kid = kUNOP->op_first; /* get past rv2sv */
9345 if (GvSTASH(gv) != PL_curstash)
9347 gvname = GvNAME(gv);
9349 ? !(*gvname == 'a' && gvname[1] == '\0')
9350 : !(*gvname == 'b' && gvname[1] == '\0'))
9352 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9354 o->op_private |= OPpSORT_DESCEND;
9355 if (k->op_type == OP_NCMP)
9356 o->op_private |= OPpSORT_NUMERIC;
9357 if (k->op_type == OP_I_NCMP)
9358 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9359 kid = cLISTOPo->op_first->op_sibling;
9360 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9362 op_getmad(kid,o,'S'); /* then delete it */
9364 op_free(kid); /* then delete it */
9369 Perl_ck_split(pTHX_ OP *o)
9374 PERL_ARGS_ASSERT_CK_SPLIT;
9376 if (o->op_flags & OPf_STACKED)
9377 return no_fh_allowed(o);
9379 kid = cLISTOPo->op_first;
9380 if (kid->op_type != OP_NULL)
9381 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9382 kid = kid->op_sibling;
9383 op_free(cLISTOPo->op_first);
9385 cLISTOPo->op_first = kid;
9387 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9388 cLISTOPo->op_last = kid; /* There was only one element previously */
9391 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9392 OP * const sibl = kid->op_sibling;
9393 kid->op_sibling = 0;
9394 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
9395 if (cLISTOPo->op_first == cLISTOPo->op_last)
9396 cLISTOPo->op_last = kid;
9397 cLISTOPo->op_first = kid;
9398 kid->op_sibling = sibl;
9401 kid->op_type = OP_PUSHRE;
9402 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9404 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9405 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9406 "Use of /g modifier is meaningless in split");
9409 if (!kid->op_sibling)
9410 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9412 kid = kid->op_sibling;
9415 if (!kid->op_sibling)
9416 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9417 assert(kid->op_sibling);
9419 kid = kid->op_sibling;
9422 if (kid->op_sibling)
9423 return too_many_arguments_pv(o,OP_DESC(o), 0);
9429 Perl_ck_join(pTHX_ OP *o)
9431 const OP * const kid = cLISTOPo->op_first->op_sibling;
9433 PERL_ARGS_ASSERT_CK_JOIN;
9435 if (kid && kid->op_type == OP_MATCH) {
9436 if (ckWARN(WARN_SYNTAX)) {
9437 const REGEXP *re = PM_GETRE(kPMOP);
9439 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9440 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9441 : newSVpvs_flags( "STRING", SVs_TEMP );
9442 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9443 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9444 SVfARG(msg), SVfARG(msg));
9451 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9453 Examines an op, which is expected to identify a subroutine at runtime,
9454 and attempts to determine at compile time which subroutine it identifies.
9455 This is normally used during Perl compilation to determine whether
9456 a prototype can be applied to a function call. I<cvop> is the op
9457 being considered, normally an C<rv2cv> op. A pointer to the identified
9458 subroutine is returned, if it could be determined statically, and a null
9459 pointer is returned if it was not possible to determine statically.
9461 Currently, the subroutine can be identified statically if the RV that the
9462 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9463 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9464 suitable if the constant value must be an RV pointing to a CV. Details of
9465 this process may change in future versions of Perl. If the C<rv2cv> op
9466 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9467 the subroutine statically: this flag is used to suppress compile-time
9468 magic on a subroutine call, forcing it to use default runtime behaviour.
9470 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9471 of a GV reference is modified. If a GV was examined and its CV slot was
9472 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9473 If the op is not optimised away, and the CV slot is later populated with
9474 a subroutine having a prototype, that flag eventually triggers the warning
9475 "called too early to check prototype".
9477 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9478 of returning a pointer to the subroutine it returns a pointer to the
9479 GV giving the most appropriate name for the subroutine in this context.
9480 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9481 (C<CvANON>) subroutine that is referenced through a GV it will be the
9482 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9483 A null pointer is returned as usual if there is no statically-determinable
9490 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9495 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9496 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9497 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9498 if (cvop->op_type != OP_RV2CV)
9500 if (cvop->op_private & OPpENTERSUB_AMPER)
9502 if (!(cvop->op_flags & OPf_KIDS))
9504 rvop = cUNOPx(cvop)->op_first;
9505 switch (rvop->op_type) {
9507 gv = cGVOPx_gv(rvop);
9510 if (flags & RV2CVOPCV_MARK_EARLY)
9511 rvop->op_private |= OPpEARLY_CV;
9516 SV *rv = cSVOPx_sv(rvop);
9526 if (SvTYPE((SV*)cv) != SVt_PVCV)
9528 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9529 if (!CvANON(cv) || !gv)
9538 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9540 Performs the default fixup of the arguments part of an C<entersub>
9541 op tree. This consists of applying list context to each of the
9542 argument ops. This is the standard treatment used on a call marked
9543 with C<&>, or a method call, or a call through a subroutine reference,
9544 or any other call where the callee can't be identified at compile time,
9545 or a call where the callee has no prototype.
9551 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9554 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9555 aop = cUNOPx(entersubop)->op_first;
9556 if (!aop->op_sibling)
9557 aop = cUNOPx(aop)->op_first;
9558 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9559 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9561 op_lvalue(aop, OP_ENTERSUB);
9568 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9570 Performs the fixup of the arguments part of an C<entersub> op tree
9571 based on a subroutine prototype. This makes various modifications to
9572 the argument ops, from applying context up to inserting C<refgen> ops,
9573 and checking the number and syntactic types of arguments, as directed by
9574 the prototype. This is the standard treatment used on a subroutine call,
9575 not marked with C<&>, where the callee can be identified at compile time
9576 and has a prototype.
9578 I<protosv> supplies the subroutine prototype to be applied to the call.
9579 It may be a normal defined scalar, of which the string value will be used.
9580 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9581 that has been cast to C<SV*>) which has a prototype. The prototype
9582 supplied, in whichever form, does not need to match the actual callee
9583 referenced by the op tree.
9585 If the argument ops disagree with the prototype, for example by having
9586 an unacceptable number of arguments, a valid op tree is returned anyway.
9587 The error is reflected in the parser state, normally resulting in a single
9588 exception at the top level of parsing which covers all the compilation
9589 errors that occurred. In the error message, the callee is referred to
9590 by the name defined by the I<namegv> parameter.
9596 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9599 const char *proto, *proto_end;
9600 OP *aop, *prev, *cvop;
9603 I32 contextclass = 0;
9604 const char *e = NULL;
9605 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9606 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9607 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
9608 "flags=%lx", (unsigned long) SvFLAGS(protosv));
9609 if (SvTYPE(protosv) == SVt_PVCV)
9610 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9611 else proto = SvPV(protosv, proto_len);
9612 proto_end = proto + proto_len;
9613 aop = cUNOPx(entersubop)->op_first;
9614 if (!aop->op_sibling)
9615 aop = cUNOPx(aop)->op_first;
9617 aop = aop->op_sibling;
9618 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9619 while (aop != cvop) {
9621 if (PL_madskills && aop->op_type == OP_STUB) {
9622 aop = aop->op_sibling;
9625 if (PL_madskills && aop->op_type == OP_NULL)
9626 o3 = ((UNOP*)aop)->op_first;
9630 if (proto >= proto_end)
9631 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
9639 /* _ must be at the end */
9640 if (proto[1] && !strchr(";@%", proto[1]))
9655 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9657 arg == 1 ? "block or sub {}" : "sub {}",
9658 gv_ename(namegv), 0, o3);
9661 /* '*' allows any scalar type, including bareword */
9664 if (o3->op_type == OP_RV2GV)
9665 goto wrapref; /* autoconvert GLOB -> GLOBref */
9666 else if (o3->op_type == OP_CONST)
9667 o3->op_private &= ~OPpCONST_STRICT;
9668 else if (o3->op_type == OP_ENTERSUB) {
9669 /* accidental subroutine, revert to bareword */
9670 OP *gvop = ((UNOP*)o3)->op_first;
9671 if (gvop && gvop->op_type == OP_NULL) {
9672 gvop = ((UNOP*)gvop)->op_first;
9674 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9677 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9678 (gvop = ((UNOP*)gvop)->op_first) &&
9679 gvop->op_type == OP_GV)
9681 GV * const gv = cGVOPx_gv(gvop);
9682 OP * const sibling = aop->op_sibling;
9683 SV * const n = newSVpvs("");
9685 OP * const oldaop = aop;
9689 gv_fullname4(n, gv, "", FALSE);
9690 aop = newSVOP(OP_CONST, 0, n);
9691 op_getmad(oldaop,aop,'O');
9692 prev->op_sibling = aop;
9693 aop->op_sibling = sibling;
9703 if (o3->op_type == OP_RV2AV ||
9704 o3->op_type == OP_PADAV ||
9705 o3->op_type == OP_RV2HV ||
9706 o3->op_type == OP_PADHV
9721 if (contextclass++ == 0) {
9722 e = strchr(proto, ']');
9723 if (!e || e == proto)
9732 const char *p = proto;
9733 const char *const end = proto;
9736 /* \[$] accepts any scalar lvalue */
9738 && Perl_op_lvalue_flags(aTHX_
9740 OP_READ, /* not entersub */
9743 bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
9745 gv_ename(namegv), 0, o3);
9750 if (o3->op_type == OP_RV2GV)
9753 bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
9756 if (o3->op_type == OP_ENTERSUB)
9759 bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
9763 if (o3->op_type == OP_RV2SV ||
9764 o3->op_type == OP_PADSV ||
9765 o3->op_type == OP_HELEM ||
9766 o3->op_type == OP_AELEM)
9768 if (!contextclass) {
9769 /* \$ accepts any scalar lvalue */
9770 if (Perl_op_lvalue_flags(aTHX_
9772 OP_READ, /* not entersub */
9775 bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
9779 if (o3->op_type == OP_RV2AV ||
9780 o3->op_type == OP_PADAV)
9783 bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
9786 if (o3->op_type == OP_RV2HV ||
9787 o3->op_type == OP_PADHV)
9790 bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
9794 OP* const kid = aop;
9795 OP* const sib = kid->op_sibling;
9796 kid->op_sibling = 0;
9797 aop = newUNOP(OP_REFGEN, 0, kid);
9798 aop->op_sibling = sib;
9799 prev->op_sibling = aop;
9801 if (contextclass && e) {
9816 SV* const tmpsv = sv_newmortal();
9817 gv_efullname3(tmpsv, namegv, NULL);
9818 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9819 SVfARG(tmpsv), SVfARG(protosv));
9823 op_lvalue(aop, OP_ENTERSUB);
9825 aop = aop->op_sibling;
9827 if (aop == cvop && *proto == '_') {
9828 /* generate an access to $_ */
9830 aop->op_sibling = prev->op_sibling;
9831 prev->op_sibling = aop; /* instead of cvop */
9833 if (!optional && proto_end > proto &&
9834 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9835 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
9840 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9842 Performs the fixup of the arguments part of an C<entersub> op tree either
9843 based on a subroutine prototype or using default list-context processing.
9844 This is the standard treatment used on a subroutine call, not marked
9845 with C<&>, where the callee can be identified at compile time.
9847 I<protosv> supplies the subroutine prototype to be applied to the call,
9848 or indicates that there is no prototype. It may be a normal scalar,
9849 in which case if it is defined then the string value will be used
9850 as a prototype, and if it is undefined then there is no prototype.
9851 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9852 that has been cast to C<SV*>), of which the prototype will be used if it
9853 has one. The prototype (or lack thereof) supplied, in whichever form,
9854 does not need to match the actual callee referenced by the op tree.
9856 If the argument ops disagree with the prototype, for example by having
9857 an unacceptable number of arguments, a valid op tree is returned anyway.
9858 The error is reflected in the parser state, normally resulting in a single
9859 exception at the top level of parsing which covers all the compilation
9860 errors that occurred. In the error message, the callee is referred to
9861 by the name defined by the I<namegv> parameter.
9867 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9868 GV *namegv, SV *protosv)
9870 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9871 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9872 return ck_entersub_args_proto(entersubop, namegv, protosv);
9874 return ck_entersub_args_list(entersubop);
9878 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9880 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9881 OP *aop = cUNOPx(entersubop)->op_first;
9883 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9887 if (!aop->op_sibling)
9888 aop = cUNOPx(aop)->op_first;
9889 aop = aop->op_sibling;
9890 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9891 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9892 aop = aop->op_sibling;
9895 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
9897 op_free(entersubop);
9898 switch(GvNAME(namegv)[2]) {
9899 case 'F': return newSVOP(OP_CONST, 0,
9900 newSVpv(CopFILE(PL_curcop),0));
9901 case 'L': return newSVOP(
9904 "%"IVdf, (IV)CopLINE(PL_curcop)
9907 case 'P': return newSVOP(OP_CONST, 0,
9909 ? newSVhek(HvNAME_HEK(PL_curstash))
9920 bool seenarg = FALSE;
9922 if (!aop->op_sibling)
9923 aop = cUNOPx(aop)->op_first;
9926 aop = aop->op_sibling;
9927 prev->op_sibling = NULL;
9930 prev=cvop, cvop = cvop->op_sibling)
9932 if (PL_madskills && cvop->op_sibling
9933 && cvop->op_type != OP_STUB) seenarg = TRUE
9936 prev->op_sibling = NULL;
9937 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9939 if (aop == cvop) aop = NULL;
9940 op_free(entersubop);
9942 if (opnum == OP_ENTEREVAL
9943 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9944 flags |= OPpEVAL_BYTES <<8;
9946 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9948 case OA_BASEOP_OR_UNOP:
9950 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9954 if (!PL_madskills || seenarg)
9956 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
9959 return opnum == OP_RUNCV
9960 ? newPVOP(OP_RUNCV,0,NULL)
9963 return convert(opnum,0,aop);
9971 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9973 Retrieves the function that will be used to fix up a call to I<cv>.
9974 Specifically, the function is applied to an C<entersub> op tree for a
9975 subroutine call, not marked with C<&>, where the callee can be identified
9976 at compile time as I<cv>.
9978 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9979 argument for it is returned in I<*ckobj_p>. The function is intended
9980 to be called in this manner:
9982 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9984 In this call, I<entersubop> is a pointer to the C<entersub> op,
9985 which may be replaced by the check function, and I<namegv> is a GV
9986 supplying the name that should be used by the check function to refer
9987 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9988 It is permitted to apply the check function in non-standard situations,
9989 such as to a call to a different subroutine or to a method call.
9991 By default, the function is
9992 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9993 and the SV parameter is I<cv> itself. This implements standard
9994 prototype processing. It can be changed, for a particular subroutine,
9995 by L</cv_set_call_checker>.
10001 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10004 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10005 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10007 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10008 *ckobj_p = callmg->mg_obj;
10010 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
10011 *ckobj_p = (SV*)cv;
10016 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10018 Sets the function that will be used to fix up a call to I<cv>.
10019 Specifically, the function is applied to an C<entersub> op tree for a
10020 subroutine call, not marked with C<&>, where the callee can be identified
10021 at compile time as I<cv>.
10023 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10024 for it is supplied in I<ckobj>. The function is intended to be called
10027 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10029 In this call, I<entersubop> is a pointer to the C<entersub> op,
10030 which may be replaced by the check function, and I<namegv> is a GV
10031 supplying the name that should be used by the check function to refer
10032 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10033 It is permitted to apply the check function in non-standard situations,
10034 such as to a call to a different subroutine or to a method call.
10036 The current setting for a particular CV can be retrieved by
10037 L</cv_get_call_checker>.
10043 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10045 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10046 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10047 if (SvMAGICAL((SV*)cv))
10048 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10051 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10052 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10053 if (callmg->mg_flags & MGf_REFCOUNTED) {
10054 SvREFCNT_dec(callmg->mg_obj);
10055 callmg->mg_flags &= ~MGf_REFCOUNTED;
10057 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10058 callmg->mg_obj = ckobj;
10059 if (ckobj != (SV*)cv) {
10060 SvREFCNT_inc_simple_void_NN(ckobj);
10061 callmg->mg_flags |= MGf_REFCOUNTED;
10063 callmg->mg_flags |= MGf_COPY;
10068 Perl_ck_subr(pTHX_ OP *o)
10074 PERL_ARGS_ASSERT_CK_SUBR;
10076 aop = cUNOPx(o)->op_first;
10077 if (!aop->op_sibling)
10078 aop = cUNOPx(aop)->op_first;
10079 aop = aop->op_sibling;
10080 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10081 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10082 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10084 o->op_private &= ~1;
10085 o->op_private |= OPpENTERSUB_HASTARG;
10086 o->op_private |= (PL_hints & HINT_STRICT_REFS);
10087 if (PERLDB_SUB && PL_curstash != PL_debstash)
10088 o->op_private |= OPpENTERSUB_DB;
10089 if (cvop->op_type == OP_RV2CV) {
10090 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10092 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10093 if (aop->op_type == OP_CONST)
10094 aop->op_private &= ~OPpCONST_STRICT;
10095 else if (aop->op_type == OP_LIST) {
10096 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10097 if (sib && sib->op_type == OP_CONST)
10098 sib->op_private &= ~OPpCONST_STRICT;
10103 return ck_entersub_args_list(o);
10105 Perl_call_checker ckfun;
10107 cv_get_call_checker(cv, &ckfun, &ckobj);
10108 return ckfun(aTHX_ o, namegv, ckobj);
10113 Perl_ck_svconst(pTHX_ OP *o)
10115 PERL_ARGS_ASSERT_CK_SVCONST;
10116 PERL_UNUSED_CONTEXT;
10117 SvREADONLY_on(cSVOPo->op_sv);
10122 Perl_ck_chdir(pTHX_ OP *o)
10124 PERL_ARGS_ASSERT_CK_CHDIR;
10125 if (o->op_flags & OPf_KIDS) {
10126 SVOP * const kid = (SVOP*)cUNOPo->op_first;
10128 if (kid && kid->op_type == OP_CONST &&
10129 (kid->op_private & OPpCONST_BARE))
10131 o->op_flags |= OPf_SPECIAL;
10132 kid->op_private &= ~OPpCONST_STRICT;
10139 Perl_ck_trunc(pTHX_ OP *o)
10141 PERL_ARGS_ASSERT_CK_TRUNC;
10143 if (o->op_flags & OPf_KIDS) {
10144 SVOP *kid = (SVOP*)cUNOPo->op_first;
10146 if (kid->op_type == OP_NULL)
10147 kid = (SVOP*)kid->op_sibling;
10148 if (kid && kid->op_type == OP_CONST &&
10149 (kid->op_private & OPpCONST_BARE))
10151 o->op_flags |= OPf_SPECIAL;
10152 kid->op_private &= ~OPpCONST_STRICT;
10159 Perl_ck_substr(pTHX_ OP *o)
10161 PERL_ARGS_ASSERT_CK_SUBSTR;
10164 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
10165 OP *kid = cLISTOPo->op_first;
10167 if (kid->op_type == OP_NULL)
10168 kid = kid->op_sibling;
10170 kid->op_flags |= OPf_MOD;
10177 Perl_ck_tell(pTHX_ OP *o)
10179 PERL_ARGS_ASSERT_CK_TELL;
10181 if (o->op_flags & OPf_KIDS) {
10182 OP *kid = cLISTOPo->op_first;
10183 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
10184 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
10190 Perl_ck_each(pTHX_ OP *o)
10193 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
10194 const unsigned orig_type = o->op_type;
10195 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
10196 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
10197 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
10198 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
10200 PERL_ARGS_ASSERT_CK_EACH;
10203 switch (kid->op_type) {
10209 CHANGE_TYPE(o, array_type);
10212 if (kid->op_private == OPpCONST_BARE
10213 || !SvROK(cSVOPx_sv(kid))
10214 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
10215 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
10217 /* we let ck_fun handle it */
10220 CHANGE_TYPE(o, ref_type);
10224 /* if treating as a reference, defer additional checks to runtime */
10225 return o->op_type == ref_type ? o : ck_fun(o);
10229 Perl_ck_length(pTHX_ OP *o)
10231 PERL_ARGS_ASSERT_CK_LENGTH;
10235 if (ckWARN(WARN_SYNTAX)) {
10236 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
10240 const bool hash = kid->op_type == OP_PADHV
10241 || kid->op_type == OP_RV2HV;
10242 switch (kid->op_type) {
10246 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10252 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10254 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10256 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10263 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10264 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10266 name, hash ? "keys " : "", name
10269 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10270 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10272 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10273 "length() used on @array (did you mean \"scalar(@array)\"?)");
10280 /* caller is supposed to assign the return to the
10281 container of the rep_op var */
10283 S_opt_scalarhv(pTHX_ OP *rep_op) {
10287 PERL_ARGS_ASSERT_OPT_SCALARHV;
10289 NewOp(1101, unop, 1, UNOP);
10290 unop->op_type = (OPCODE)OP_BOOLKEYS;
10291 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
10292 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
10293 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
10294 unop->op_first = rep_op;
10295 unop->op_next = rep_op->op_next;
10296 rep_op->op_next = (OP*)unop;
10297 rep_op->op_flags|=(OPf_REF | OPf_MOD);
10298 unop->op_sibling = rep_op->op_sibling;
10299 rep_op->op_sibling = NULL;
10300 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
10301 if (rep_op->op_type == OP_PADHV) {
10302 rep_op->op_flags &= ~OPf_WANT_SCALAR;
10303 rep_op->op_flags |= OPf_WANT_LIST;
10308 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10309 and modify the optree to make them work inplace */
10312 S_inplace_aassign(pTHX_ OP *o) {
10314 OP *modop, *modop_pushmark;
10316 OP *oleft, *oleft_pushmark;
10318 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10320 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10322 assert(cUNOPo->op_first->op_type == OP_NULL);
10323 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10324 assert(modop_pushmark->op_type == OP_PUSHMARK);
10325 modop = modop_pushmark->op_sibling;
10327 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10330 /* no other operation except sort/reverse */
10331 if (modop->op_sibling)
10334 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10335 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10337 if (modop->op_flags & OPf_STACKED) {
10338 /* skip sort subroutine/block */
10339 assert(oright->op_type == OP_NULL);
10340 oright = oright->op_sibling;
10343 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10344 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10345 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10346 oleft = oleft_pushmark->op_sibling;
10348 /* Check the lhs is an array */
10350 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10351 || oleft->op_sibling
10352 || (oleft->op_private & OPpLVAL_INTRO)
10356 /* Only one thing on the rhs */
10357 if (oright->op_sibling)
10360 /* check the array is the same on both sides */
10361 if (oleft->op_type == OP_RV2AV) {
10362 if (oright->op_type != OP_RV2AV
10363 || !cUNOPx(oright)->op_first
10364 || cUNOPx(oright)->op_first->op_type != OP_GV
10365 || cUNOPx(oleft )->op_first->op_type != OP_GV
10366 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10367 cGVOPx_gv(cUNOPx(oright)->op_first)
10371 else if (oright->op_type != OP_PADAV
10372 || oright->op_targ != oleft->op_targ
10376 /* This actually is an inplace assignment */
10378 modop->op_private |= OPpSORT_INPLACE;
10380 /* transfer MODishness etc from LHS arg to RHS arg */
10381 oright->op_flags = oleft->op_flags;
10383 /* remove the aassign op and the lhs */
10385 op_null(oleft_pushmark);
10386 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10387 op_null(cUNOPx(oleft)->op_first);
10391 #define MAX_DEFERRED 4
10394 if (defer_ix == (MAX_DEFERRED-1)) { \
10395 CALL_RPEEP(defer_queue[defer_base]); \
10396 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10399 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
10401 /* A peephole optimizer. We visit the ops in the order they're to execute.
10402 * See the comments at the top of this file for more details about when
10403 * peep() is called */
10406 Perl_rpeep(pTHX_ register OP *o)
10409 register OP* oldop = NULL;
10410 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10411 int defer_base = 0;
10414 if (!o || o->op_opt)
10418 SAVEVPTR(PL_curcop);
10419 for (;; o = o->op_next) {
10420 if (o && o->op_opt)
10423 while (defer_ix >= 0)
10424 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
10428 /* By default, this op has now been optimised. A couple of cases below
10429 clear this again. */
10432 switch (o->op_type) {
10434 PL_curcop = ((COP*)o); /* for warnings */
10437 PL_curcop = ((COP*)o); /* for warnings */
10439 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10440 to carry two labels. For now, take the easier option, and skip
10441 this optimisation if the first NEXTSTATE has a label. */
10442 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10443 OP *nextop = o->op_next;
10444 while (nextop && nextop->op_type == OP_NULL)
10445 nextop = nextop->op_next;
10447 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10448 COP *firstcop = (COP *)o;
10449 COP *secondcop = (COP *)nextop;
10450 /* We want the COP pointed to by o (and anything else) to
10451 become the next COP down the line. */
10452 cop_free(firstcop);
10454 firstcop->op_next = secondcop->op_next;
10456 /* Now steal all its pointers, and duplicate the other
10458 firstcop->cop_line = secondcop->cop_line;
10459 #ifdef USE_ITHREADS
10460 firstcop->cop_stashoff = secondcop->cop_stashoff;
10461 firstcop->cop_file = secondcop->cop_file;
10463 firstcop->cop_stash = secondcop->cop_stash;
10464 firstcop->cop_filegv = secondcop->cop_filegv;
10466 firstcop->cop_hints = secondcop->cop_hints;
10467 firstcop->cop_seq = secondcop->cop_seq;
10468 firstcop->cop_warnings = secondcop->cop_warnings;
10469 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10471 #ifdef USE_ITHREADS
10472 secondcop->cop_stashoff = 0;
10473 secondcop->cop_file = NULL;
10475 secondcop->cop_stash = NULL;
10476 secondcop->cop_filegv = NULL;
10478 secondcop->cop_warnings = NULL;
10479 secondcop->cop_hints_hash = NULL;
10481 /* If we use op_null(), and hence leave an ex-COP, some
10482 warnings are misreported. For example, the compile-time
10483 error in 'use strict; no strict refs;' */
10484 secondcop->op_type = OP_NULL;
10485 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10491 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10492 if (o->op_next->op_private & OPpTARGET_MY) {
10493 if (o->op_flags & OPf_STACKED) /* chained concats */
10494 break; /* ignore_optimization */
10496 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10497 o->op_targ = o->op_next->op_targ;
10498 o->op_next->op_targ = 0;
10499 o->op_private |= OPpTARGET_MY;
10502 op_null(o->op_next);
10506 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10507 break; /* Scalar stub must produce undef. List stub is noop */
10511 if (o->op_targ == OP_NEXTSTATE
10512 || o->op_targ == OP_DBSTATE)
10514 PL_curcop = ((COP*)o);
10516 /* XXX: We avoid setting op_seq here to prevent later calls
10517 to rpeep() from mistakenly concluding that optimisation
10518 has already occurred. This doesn't fix the real problem,
10519 though (See 20010220.007). AMS 20010719 */
10520 /* op_seq functionality is now replaced by op_opt */
10527 if (oldop && o->op_next) {
10528 oldop->op_next = o->op_next;
10536 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10537 OP* const pop = (o->op_type == OP_PADAV) ?
10538 o->op_next : o->op_next->op_next;
10540 if (pop && pop->op_type == OP_CONST &&
10541 ((PL_op = pop->op_next)) &&
10542 pop->op_next->op_type == OP_AELEM &&
10543 !(pop->op_next->op_private &
10544 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10545 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10548 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10549 no_bareword_allowed(pop);
10550 if (o->op_type == OP_GV)
10551 op_null(o->op_next);
10552 op_null(pop->op_next);
10554 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10555 o->op_next = pop->op_next->op_next;
10556 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10557 o->op_private = (U8)i;
10558 if (o->op_type == OP_GV) {
10561 o->op_type = OP_AELEMFAST;
10564 o->op_type = OP_AELEMFAST_LEX;
10569 if (o->op_next->op_type == OP_RV2SV) {
10570 if (!(o->op_next->op_private & OPpDEREF)) {
10571 op_null(o->op_next);
10572 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10574 o->op_next = o->op_next->op_next;
10575 o->op_type = OP_GVSV;
10576 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10579 else if (o->op_next->op_type == OP_READLINE
10580 && o->op_next->op_next->op_type == OP_CONCAT
10581 && (o->op_next->op_next->op_flags & OPf_STACKED))
10583 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10584 o->op_type = OP_RCATLINE;
10585 o->op_flags |= OPf_STACKED;
10586 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10587 op_null(o->op_next->op_next);
10588 op_null(o->op_next);
10598 fop = cUNOP->op_first;
10606 fop = cLOGOP->op_first;
10607 sop = fop->op_sibling;
10608 while (cLOGOP->op_other->op_type == OP_NULL)
10609 cLOGOP->op_other = cLOGOP->op_other->op_next;
10610 while (o->op_next && ( o->op_type == o->op_next->op_type
10611 || o->op_next->op_type == OP_NULL))
10612 o->op_next = o->op_next->op_next;
10613 DEFER(cLOGOP->op_other);
10617 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10619 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10624 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10625 while (nop && nop->op_next) {
10626 switch (nop->op_next->op_type) {
10631 lop = nop = nop->op_next;
10634 nop = nop->op_next;
10642 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
10643 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10644 cLOGOP->op_first = opt_scalarhv(fop);
10645 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10646 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10662 while (cLOGOP->op_other->op_type == OP_NULL)
10663 cLOGOP->op_other = cLOGOP->op_other->op_next;
10664 DEFER(cLOGOP->op_other);
10669 while (cLOOP->op_redoop->op_type == OP_NULL)
10670 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10671 while (cLOOP->op_nextop->op_type == OP_NULL)
10672 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10673 while (cLOOP->op_lastop->op_type == OP_NULL)
10674 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10675 /* a while(1) loop doesn't have an op_next that escapes the
10676 * loop, so we have to explicitly follow the op_lastop to
10677 * process the rest of the code */
10678 DEFER(cLOOP->op_lastop);
10682 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10683 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10684 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10685 cPMOP->op_pmstashstartu.op_pmreplstart
10686 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10687 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10691 /* check that RHS of sort is a single plain array */
10692 OP *oright = cUNOPo->op_first;
10693 if (!oright || oright->op_type != OP_PUSHMARK)
10696 if (o->op_private & OPpSORT_INPLACE)
10699 /* reverse sort ... can be optimised. */
10700 if (!cUNOPo->op_sibling) {
10701 /* Nothing follows us on the list. */
10702 OP * const reverse = o->op_next;
10704 if (reverse->op_type == OP_REVERSE &&
10705 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10706 OP * const pushmark = cUNOPx(reverse)->op_first;
10707 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10708 && (cUNOPx(pushmark)->op_sibling == o)) {
10709 /* reverse -> pushmark -> sort */
10710 o->op_private |= OPpSORT_REVERSE;
10712 pushmark->op_next = oright->op_next;
10722 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10724 LISTOP *enter, *exlist;
10726 if (o->op_private & OPpSORT_INPLACE)
10729 enter = (LISTOP *) o->op_next;
10732 if (enter->op_type == OP_NULL) {
10733 enter = (LISTOP *) enter->op_next;
10737 /* for $a (...) will have OP_GV then OP_RV2GV here.
10738 for (...) just has an OP_GV. */
10739 if (enter->op_type == OP_GV) {
10740 gvop = (OP *) enter;
10741 enter = (LISTOP *) enter->op_next;
10744 if (enter->op_type == OP_RV2GV) {
10745 enter = (LISTOP *) enter->op_next;
10751 if (enter->op_type != OP_ENTERITER)
10754 iter = enter->op_next;
10755 if (!iter || iter->op_type != OP_ITER)
10758 expushmark = enter->op_first;
10759 if (!expushmark || expushmark->op_type != OP_NULL
10760 || expushmark->op_targ != OP_PUSHMARK)
10763 exlist = (LISTOP *) expushmark->op_sibling;
10764 if (!exlist || exlist->op_type != OP_NULL
10765 || exlist->op_targ != OP_LIST)
10768 if (exlist->op_last != o) {
10769 /* Mmm. Was expecting to point back to this op. */
10772 theirmark = exlist->op_first;
10773 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10776 if (theirmark->op_sibling != o) {
10777 /* There's something between the mark and the reverse, eg
10778 for (1, reverse (...))
10783 ourmark = ((LISTOP *)o)->op_first;
10784 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10787 ourlast = ((LISTOP *)o)->op_last;
10788 if (!ourlast || ourlast->op_next != o)
10791 rv2av = ourmark->op_sibling;
10792 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10793 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10794 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10795 /* We're just reversing a single array. */
10796 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10797 enter->op_flags |= OPf_STACKED;
10800 /* We don't have control over who points to theirmark, so sacrifice
10802 theirmark->op_next = ourmark->op_next;
10803 theirmark->op_flags = ourmark->op_flags;
10804 ourlast->op_next = gvop ? gvop : (OP *) enter;
10807 enter->op_private |= OPpITER_REVERSED;
10808 iter->op_private |= OPpITER_REVERSED;
10815 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10816 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10821 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10823 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
10825 sv = newRV((SV *)PL_compcv);
10829 o->op_type = OP_CONST;
10830 o->op_ppaddr = PL_ppaddr[OP_CONST];
10831 o->op_flags |= OPf_SPECIAL;
10832 cSVOPo->op_sv = sv;
10837 if (OP_GIMME(o,0) == G_VOID) {
10838 OP *right = cBINOP->op_first;
10840 OP *left = right->op_sibling;
10841 if (left->op_type == OP_SUBSTR
10842 && (left->op_private & 7) < 4) {
10844 cBINOP->op_first = left;
10845 right->op_sibling =
10846 cBINOPx(left)->op_first->op_sibling;
10847 cBINOPx(left)->op_first->op_sibling = right;
10848 left->op_private |= OPpSUBSTR_REPL_FIRST;
10850 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10857 Perl_cpeep_t cpeep =
10858 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10860 cpeep(aTHX_ o, oldop);
10871 Perl_peep(pTHX_ register OP *o)
10877 =head1 Custom Operators
10879 =for apidoc Ao||custom_op_xop
10880 Return the XOP structure for a given custom op. This function should be
10881 considered internal to OP_NAME and the other access macros: use them instead.
10887 Perl_custom_op_xop(pTHX_ const OP *o)
10893 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10895 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10896 assert(o->op_type == OP_CUSTOM);
10898 /* This is wrong. It assumes a function pointer can be cast to IV,
10899 * which isn't guaranteed, but this is what the old custom OP code
10900 * did. In principle it should be safer to Copy the bytes of the
10901 * pointer into a PV: since the new interface is hidden behind
10902 * functions, this can be changed later if necessary. */
10903 /* Change custom_op_xop if this ever happens */
10904 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10907 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10909 /* assume noone will have just registered a desc */
10910 if (!he && PL_custom_op_names &&
10911 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10916 /* XXX does all this need to be shared mem? */
10917 Newxz(xop, 1, XOP);
10918 pv = SvPV(HeVAL(he), l);
10919 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10920 if (PL_custom_op_descs &&
10921 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10923 pv = SvPV(HeVAL(he), l);
10924 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10926 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10930 if (!he) return &xop_null;
10932 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10937 =for apidoc Ao||custom_op_register
10938 Register a custom op. See L<perlguts/"Custom Operators">.
10944 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10948 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10950 /* see the comment in custom_op_xop */
10951 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10953 if (!PL_custom_ops)
10954 PL_custom_ops = newHV();
10956 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10957 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10961 =head1 Functions in file op.c
10963 =for apidoc core_prototype
10964 This function assigns the prototype of the named core function to C<sv>, or
10965 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10966 NULL if the core function has no prototype. C<code> is a code as returned
10967 by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
10973 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10976 int i = 0, n = 0, seen_question = 0, defgv = 0;
10978 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10979 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10980 bool nullret = FALSE;
10982 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10984 assert (code && code != -KEY_CORE);
10986 if (!sv) sv = sv_newmortal();
10988 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10990 switch (code < 0 ? -code : code) {
10991 case KEY_and : case KEY_chop: case KEY_chomp:
10992 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
10993 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
10994 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
10995 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
10996 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
10997 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
10998 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
10999 case KEY_x : case KEY_xor :
11000 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
11001 case KEY_glob: retsetpvs("_;", OP_GLOB);
11002 case KEY_keys: retsetpvs("+", OP_KEYS);
11003 case KEY_values: retsetpvs("+", OP_VALUES);
11004 case KEY_each: retsetpvs("+", OP_EACH);
11005 case KEY_push: retsetpvs("+@", OP_PUSH);
11006 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
11007 case KEY_pop: retsetpvs(";+", OP_POP);
11008 case KEY_shift: retsetpvs(";+", OP_SHIFT);
11009 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
11011 retsetpvs("+;$$@", OP_SPLICE);
11012 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
11014 case KEY_evalbytes:
11015 name = "entereval"; break;
11023 while (i < MAXO) { /* The slow way. */
11024 if (strEQ(name, PL_op_name[i])
11025 || strEQ(name, PL_op_desc[i]))
11027 if (nullret) { assert(opnum); *opnum = i; return NULL; }
11034 defgv = PL_opargs[i] & OA_DEFGV;
11035 oa = PL_opargs[i] >> OASHIFT;
11037 if (oa & OA_OPTIONAL && !seen_question && (
11038 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
11043 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
11044 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
11045 /* But globs are already references (kinda) */
11046 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
11050 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
11051 && !scalar_mod_type(NULL, i)) {
11056 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
11060 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
11061 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
11062 str[n-1] = '_'; defgv = 0;
11066 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
11068 sv_setpvn(sv, str, n - 1);
11069 if (opnum) *opnum = i;
11074 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
11077 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
11080 PERL_ARGS_ASSERT_CORESUB_OP;
11084 return op_append_elem(OP_LINESEQ,
11087 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
11091 case OP_SELECT: /* which represents OP_SSELECT as well */
11096 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
11097 newSVOP(OP_CONST, 0, newSVuv(1))
11099 coresub_op(newSVuv((UV)OP_SSELECT), 0,
11101 coresub_op(coreargssv, 0, OP_SELECT)
11105 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
11107 return op_append_elem(
11110 opnum == OP_WANTARRAY || opnum == OP_RUNCV
11111 ? OPpOFFBYONE << 8 : 0)
11113 case OA_BASEOP_OR_UNOP:
11114 if (opnum == OP_ENTEREVAL) {
11115 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
11116 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
11118 else o = newUNOP(opnum,0,argop);
11119 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
11122 if (is_handle_constructor(o, 1))
11123 argop->op_private |= OPpCOREARGS_DEREF1;
11124 if (scalar_mod_type(NULL, opnum))
11125 argop->op_private |= OPpCOREARGS_SCALARMOD;
11129 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
11130 if (is_handle_constructor(o, 2))
11131 argop->op_private |= OPpCOREARGS_DEREF2;
11132 if (opnum == OP_SUBSTR) {
11133 o->op_private |= OPpMAYBE_LVSUB;
11142 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
11143 SV * const *new_const_svp)
11145 const char *hvname;
11146 bool is_const = !!CvCONST(old_cv);
11147 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
11149 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
11151 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
11153 /* They are 2 constant subroutines generated from
11154 the same constant. This probably means that
11155 they are really the "same" proxy subroutine
11156 instantiated in 2 places. Most likely this is
11157 when a constant is exported twice. Don't warn.
11160 (ckWARN(WARN_REDEFINE)
11162 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
11163 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
11164 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
11165 strEQ(hvname, "autouse"))
11169 && ckWARN_d(WARN_REDEFINE)
11170 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
11173 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11175 ? "Constant subroutine %"SVf" redefined"
11176 : "Subroutine %"SVf" redefined",
11181 =head1 Hook manipulation
11183 These functions provide convenient and thread-safe means of manipulating
11190 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
11192 Puts a C function into the chain of check functions for a specified op
11193 type. This is the preferred way to manipulate the L</PL_check> array.
11194 I<opcode> specifies which type of op is to be affected. I<new_checker>
11195 is a pointer to the C function that is to be added to that opcode's
11196 check chain, and I<old_checker_p> points to the storage location where a
11197 pointer to the next function in the chain will be stored. The value of
11198 I<new_pointer> is written into the L</PL_check> array, while the value
11199 previously stored there is written to I<*old_checker_p>.
11201 L</PL_check> is global to an entire process, and a module wishing to
11202 hook op checking may find itself invoked more than once per process,
11203 typically in different threads. To handle that situation, this function
11204 is idempotent. The location I<*old_checker_p> must initially (once
11205 per process) contain a null pointer. A C variable of static duration
11206 (declared at file scope, typically also marked C<static> to give
11207 it internal linkage) will be implicitly initialised appropriately,
11208 if it does not have an explicit initialiser. This function will only
11209 actually modify the check chain if it finds I<*old_checker_p> to be null.
11210 This function is also thread safe on the small scale. It uses appropriate
11211 locking to avoid race conditions in accessing L</PL_check>.
11213 When this function is called, the function referenced by I<new_checker>
11214 must be ready to be called, except for I<*old_checker_p> being unfilled.
11215 In a threading situation, I<new_checker> may be called immediately,
11216 even before this function has returned. I<*old_checker_p> will always
11217 be appropriately set before I<new_checker> is called. If I<new_checker>
11218 decides not to do anything special with an op that it is given (which
11219 is the usual case for most uses of op check hooking), it must chain the
11220 check function referenced by I<*old_checker_p>.
11222 If you want to influence compilation of calls to a specific subroutine,
11223 then use L</cv_set_call_checker> rather than hooking checking of all
11230 Perl_wrap_op_checker(pTHX_ Optype opcode,
11231 Perl_check_t new_checker, Perl_check_t *old_checker_p)
11235 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
11236 if (*old_checker_p) return;
11237 OP_CHECK_MUTEX_LOCK;
11238 if (!*old_checker_p) {
11239 *old_checker_p = PL_check[opcode];
11240 PL_check[opcode] = new_checker;
11242 OP_CHECK_MUTEX_UNLOCK;
11247 /* Efficient sub that returns a constant scalar value. */
11249 const_sv_xsub(pTHX_ CV* cv)
11253 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
11257 /* diag_listed_as: SKIPME */
11258 Perl_croak(aTHX_ "usage: %s::%s()",
11259 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
11272 * c-indentation-style: bsd
11273 * c-basic-offset: 4
11274 * indent-tabs-mode: nil
11277 * ex: set ts=8 sts=4 sw=4 et: