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) {
303 * In the following definition, the ", (OP*)0" is just to make the compiler
304 * think the expression is of the right type: croak actually does a Siglongjmp.
306 #define CHECKOP(type,o) \
307 ((PL_op_mask && PL_op_mask[type]) \
308 ? ( op_free((OP*)o), \
309 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
311 : PL_check[type](aTHX_ (OP*)o))
313 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
315 #define CHANGE_TYPE(o,type) \
317 o->op_type = (OPCODE)type; \
318 o->op_ppaddr = PL_ppaddr[type]; \
322 S_gv_ename(pTHX_ GV *gv)
324 SV* const tmpsv = sv_newmortal();
326 PERL_ARGS_ASSERT_GV_ENAME;
328 gv_efullname3(tmpsv, gv, NULL);
333 S_no_fh_allowed(pTHX_ OP *o)
335 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
337 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
343 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
345 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
346 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
347 SvUTF8(namesv) | flags);
352 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
354 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
355 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
360 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
362 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
364 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
369 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
371 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
373 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
374 SvUTF8(namesv) | flags);
379 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
381 PERL_ARGS_ASSERT_BAD_TYPE_PV;
383 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
384 (int)n, name, t, OP_DESC(kid)), flags);
388 S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
390 PERL_ARGS_ASSERT_BAD_TYPE_SV;
392 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
393 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
397 S_no_bareword_allowed(pTHX_ OP *o)
399 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
402 return; /* various ok barewords are hidden in extra OP_NULL */
403 qerror(Perl_mess(aTHX_
404 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
406 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
409 /* "register" allocation */
412 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
416 const bool is_our = (PL_parser->in_my == KEY_our);
418 PERL_ARGS_ASSERT_ALLOCMY;
420 if (flags & ~SVf_UTF8)
421 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
424 /* Until we're using the length for real, cross check that we're being
426 assert(strlen(name) == len);
428 /* complain about "my $<special_var>" etc etc */
432 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
433 (name[1] == '_' && (*name == '$' || len > 2))))
435 /* name[2] is true if strlen(name) > 2 */
436 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
437 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
438 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
439 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
440 PL_parser->in_my == KEY_state ? "state" : "my"));
442 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
443 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
447 /* allocate a spare slot and store the name in that slot */
449 off = pad_add_name_pvn(name, len,
450 (is_our ? padadd_OUR :
451 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
452 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
453 PL_parser->in_my_stash,
455 /* $_ is always in main::, even with our */
456 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
460 /* anon sub prototypes contains state vars should always be cloned,
461 * otherwise the state var would be shared between anon subs */
463 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
464 CvCLONE_on(PL_compcv);
470 =for apidoc alloccopstash
472 Available only under threaded builds, this function allocates an entry in
473 C<PL_stashpad> for the stash passed to it.
480 Perl_alloccopstash(pTHX_ HV *hv)
482 PADOFFSET off = 0, o = 1;
483 bool found_slot = FALSE;
485 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
487 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
489 for (; o < PL_stashpadmax; ++o) {
490 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
491 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
492 found_slot = TRUE, off = o;
495 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
496 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
497 off = PL_stashpadmax;
498 PL_stashpadmax += 10;
501 PL_stashpad[PL_stashpadix = off] = hv;
506 /* free the body of an op without examining its contents.
507 * Always use this rather than FreeOp directly */
510 S_op_destroy(pTHX_ OP *o)
512 if (o->op_latefree) {
520 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
522 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
528 Perl_op_free(pTHX_ OP *o)
535 if (o->op_latefreed) {
542 if (o->op_private & OPpREFCOUNTED) {
553 refcnt = OpREFCNT_dec(o);
556 /* Need to find and remove any pattern match ops from the list
557 we maintain for reset(). */
558 find_and_forget_pmops(o);
568 /* Call the op_free hook if it has been set. Do it now so that it's called
569 * at the right time for refcounted ops, but still before all of the kids
573 if (o->op_flags & OPf_KIDS) {
574 register OP *kid, *nextkid;
575 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
576 nextkid = kid->op_sibling; /* Get before next freeing kid */
581 #ifdef PERL_DEBUG_READONLY_OPS
585 /* COP* is not cleared by op_clear() so that we may track line
586 * numbers etc even after null() */
587 if (type == OP_NEXTSTATE || type == OP_DBSTATE
588 || (type == OP_NULL /* the COP might have been null'ed */
589 && ((OPCODE)o->op_targ == OP_NEXTSTATE
590 || (OPCODE)o->op_targ == OP_DBSTATE))) {
595 type = (OPCODE)o->op_targ;
598 if (o->op_latefree) {
604 #ifdef DEBUG_LEAKING_SCALARS
611 Perl_op_clear(pTHX_ OP *o)
616 PERL_ARGS_ASSERT_OP_CLEAR;
619 mad_free(o->op_madprop);
624 switch (o->op_type) {
625 case OP_NULL: /* Was holding old type, if any. */
626 if (PL_madskills && o->op_targ != OP_NULL) {
627 o->op_type = (Optype)o->op_targ;
632 case OP_ENTEREVAL: /* Was holding hints. */
636 if (!(o->op_flags & OPf_REF)
637 || (PL_check[o->op_type] != Perl_ck_ftst))
644 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
649 /* It's possible during global destruction that the GV is freed
650 before the optree. Whilst the SvREFCNT_inc is happy to bump from
651 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
652 will trigger an assertion failure, because the entry to sv_clear
653 checks that the scalar is not already freed. A check of for
654 !SvIS_FREED(gv) turns out to be invalid, because during global
655 destruction the reference count can be forced down to zero
656 (with SVf_BREAK set). In which case raising to 1 and then
657 dropping to 0 triggers cleanup before it should happen. I
658 *think* that this might actually be a general, systematic,
659 weakness of the whole idea of SVf_BREAK, in that code *is*
660 allowed to raise and lower references during global destruction,
661 so any *valid* code that happens to do this during global
662 destruction might well trigger premature cleanup. */
663 bool still_valid = gv && SvREFCNT(gv);
666 SvREFCNT_inc_simple_void(gv);
668 if (cPADOPo->op_padix > 0) {
669 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
670 * may still exist on the pad */
671 pad_swipe(cPADOPo->op_padix, TRUE);
672 cPADOPo->op_padix = 0;
675 SvREFCNT_dec(cSVOPo->op_sv);
676 cSVOPo->op_sv = NULL;
679 int try_downgrade = SvREFCNT(gv) == 2;
682 gv_try_downgrade(gv);
686 case OP_METHOD_NAMED:
689 SvREFCNT_dec(cSVOPo->op_sv);
690 cSVOPo->op_sv = NULL;
693 Even if op_clear does a pad_free for the target of the op,
694 pad_free doesn't actually remove the sv that exists in the pad;
695 instead it lives on. This results in that it could be reused as
696 a target later on when the pad was reallocated.
699 pad_swipe(o->op_targ,1);
708 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
713 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
715 if (cPADOPo->op_padix > 0) {
716 pad_swipe(cPADOPo->op_padix, TRUE);
717 cPADOPo->op_padix = 0;
720 SvREFCNT_dec(cSVOPo->op_sv);
721 cSVOPo->op_sv = NULL;
725 PerlMemShared_free(cPVOPo->op_pv);
726 cPVOPo->op_pv = NULL;
730 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
734 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
735 /* No GvIN_PAD_off here, because other references may still
736 * exist on the pad */
737 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
740 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
746 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
747 op_free(cPMOPo->op_code_list);
748 cPMOPo->op_code_list = NULL;
749 forget_pmop(cPMOPo, 1);
750 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
751 /* we use the same protection as the "SAFE" version of the PM_ macros
752 * here since sv_clean_all might release some PMOPs
753 * after PL_regex_padav has been cleared
754 * and the clearing of PL_regex_padav needs to
755 * happen before sv_clean_all
758 if(PL_regex_pad) { /* We could be in destruction */
759 const IV offset = (cPMOPo)->op_pmoffset;
760 ReREFCNT_dec(PM_GETRE(cPMOPo));
761 PL_regex_pad[offset] = &PL_sv_undef;
762 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
766 ReREFCNT_dec(PM_GETRE(cPMOPo));
767 PM_SETRE(cPMOPo, NULL);
773 if (o->op_targ > 0) {
774 pad_free(o->op_targ);
780 S_cop_free(pTHX_ COP* cop)
782 PERL_ARGS_ASSERT_COP_FREE;
785 if (! specialWARN(cop->cop_warnings))
786 PerlMemShared_free(cop->cop_warnings);
787 cophh_free(CopHINTHASH_get(cop));
791 S_forget_pmop(pTHX_ PMOP *const o
797 HV * const pmstash = PmopSTASH(o);
799 PERL_ARGS_ASSERT_FORGET_PMOP;
801 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
802 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
804 PMOP **const array = (PMOP**) mg->mg_ptr;
805 U32 count = mg->mg_len / sizeof(PMOP**);
810 /* Found it. Move the entry at the end to overwrite it. */
811 array[i] = array[--count];
812 mg->mg_len = count * sizeof(PMOP**);
813 /* Could realloc smaller at this point always, but probably
814 not worth it. Probably worth free()ing if we're the
817 Safefree(mg->mg_ptr);
834 S_find_and_forget_pmops(pTHX_ OP *o)
836 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
838 if (o->op_flags & OPf_KIDS) {
839 OP *kid = cUNOPo->op_first;
841 switch (kid->op_type) {
846 forget_pmop((PMOP*)kid, 0);
848 find_and_forget_pmops(kid);
849 kid = kid->op_sibling;
855 Perl_op_null(pTHX_ OP *o)
859 PERL_ARGS_ASSERT_OP_NULL;
861 if (o->op_type == OP_NULL)
865 o->op_targ = o->op_type;
866 o->op_type = OP_NULL;
867 o->op_ppaddr = PL_ppaddr[OP_NULL];
871 Perl_op_refcnt_lock(pTHX)
879 Perl_op_refcnt_unlock(pTHX)
886 /* Contextualizers */
889 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
891 Applies a syntactic context to an op tree representing an expression.
892 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
893 or C<G_VOID> to specify the context to apply. The modified op tree
900 Perl_op_contextualize(pTHX_ OP *o, I32 context)
902 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
904 case G_SCALAR: return scalar(o);
905 case G_ARRAY: return list(o);
906 case G_VOID: return scalarvoid(o);
908 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
915 =head1 Optree Manipulation Functions
917 =for apidoc Am|OP*|op_linklist|OP *o
918 This function is the implementation of the L</LINKLIST> macro. It should
919 not be called directly.
925 Perl_op_linklist(pTHX_ OP *o)
929 PERL_ARGS_ASSERT_OP_LINKLIST;
934 /* establish postfix order */
935 first = cUNOPo->op_first;
938 o->op_next = LINKLIST(first);
941 if (kid->op_sibling) {
942 kid->op_next = LINKLIST(kid->op_sibling);
943 kid = kid->op_sibling;
957 S_scalarkids(pTHX_ OP *o)
959 if (o && o->op_flags & OPf_KIDS) {
961 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
968 S_scalarboolean(pTHX_ OP *o)
972 PERL_ARGS_ASSERT_SCALARBOOLEAN;
974 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
975 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
976 if (ckWARN(WARN_SYNTAX)) {
977 const line_t oldline = CopLINE(PL_curcop);
979 if (PL_parser && PL_parser->copline != NOLINE)
980 CopLINE_set(PL_curcop, PL_parser->copline);
981 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
982 CopLINE_set(PL_curcop, oldline);
989 Perl_scalar(pTHX_ OP *o)
994 /* assumes no premature commitment */
995 if (!o || (PL_parser && PL_parser->error_count)
996 || (o->op_flags & OPf_WANT)
997 || o->op_type == OP_RETURN)
1002 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1004 switch (o->op_type) {
1006 scalar(cBINOPo->op_first);
1011 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1021 if (o->op_flags & OPf_KIDS) {
1022 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1028 kid = cLISTOPo->op_first;
1030 kid = kid->op_sibling;
1033 OP *sib = kid->op_sibling;
1034 if (sib && kid->op_type != OP_LEAVEWHEN)
1040 PL_curcop = &PL_compiling;
1045 kid = cLISTOPo->op_first;
1048 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1055 Perl_scalarvoid(pTHX_ OP *o)
1059 const char* useless = NULL;
1060 U32 useless_is_utf8 = 0;
1064 PERL_ARGS_ASSERT_SCALARVOID;
1066 /* trailing mad null ops don't count as "there" for void processing */
1068 o->op_type != OP_NULL &&
1070 o->op_sibling->op_type == OP_NULL)
1073 for (sib = o->op_sibling;
1074 sib && sib->op_type == OP_NULL;
1075 sib = sib->op_sibling) ;
1081 if (o->op_type == OP_NEXTSTATE
1082 || o->op_type == OP_DBSTATE
1083 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1084 || o->op_targ == OP_DBSTATE)))
1085 PL_curcop = (COP*)o; /* for warning below */
1087 /* assumes no premature commitment */
1088 want = o->op_flags & OPf_WANT;
1089 if ((want && want != OPf_WANT_SCALAR)
1090 || (PL_parser && PL_parser->error_count)
1091 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1096 if ((o->op_private & OPpTARGET_MY)
1097 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1099 return scalar(o); /* As if inside SASSIGN */
1102 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1104 switch (o->op_type) {
1106 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1110 if (o->op_flags & OPf_STACKED)
1114 if (o->op_private == 4)
1139 case OP_AELEMFAST_LEX:
1158 case OP_GETSOCKNAME:
1159 case OP_GETPEERNAME:
1164 case OP_GETPRIORITY:
1189 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1190 /* Otherwise it's "Useless use of grep iterator" */
1191 useless = OP_DESC(o);
1195 kid = cLISTOPo->op_first;
1196 if (kid && kid->op_type == OP_PUSHRE
1198 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1200 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1202 useless = OP_DESC(o);
1206 kid = cUNOPo->op_first;
1207 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1208 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1211 useless = "negative pattern binding (!~)";
1215 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1216 useless = "non-destructive substitution (s///r)";
1220 useless = "non-destructive transliteration (tr///r)";
1227 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1228 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1229 useless = "a variable";
1234 if (cSVOPo->op_private & OPpCONST_STRICT)
1235 no_bareword_allowed(o);
1237 if (ckWARN(WARN_VOID)) {
1238 /* don't warn on optimised away booleans, eg
1239 * use constant Foo, 5; Foo || print; */
1240 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1242 /* the constants 0 and 1 are permitted as they are
1243 conventionally used as dummies in constructs like
1244 1 while some_condition_with_side_effects; */
1245 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1247 else if (SvPOK(sv)) {
1248 /* perl4's way of mixing documentation and code
1249 (before the invention of POD) was based on a
1250 trick to mix nroff and perl code. The trick was
1251 built upon these three nroff macros being used in
1252 void context. The pink camel has the details in
1253 the script wrapman near page 319. */
1254 const char * const maybe_macro = SvPVX_const(sv);
1255 if (strnEQ(maybe_macro, "di", 2) ||
1256 strnEQ(maybe_macro, "ds", 2) ||
1257 strnEQ(maybe_macro, "ig", 2))
1260 SV * const dsv = newSVpvs("");
1261 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1263 pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1264 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1266 useless = SvPV_nolen(msv);
1267 useless_is_utf8 = SvUTF8(msv);
1270 else if (SvOK(sv)) {
1271 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1272 "a constant (%"SVf")", sv));
1273 useless = SvPV_nolen(msv);
1276 useless = "a constant (undef)";
1279 op_null(o); /* don't execute or even remember it */
1283 o->op_type = OP_PREINC; /* pre-increment is faster */
1284 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1288 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1289 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1293 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1294 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1298 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1299 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1304 UNOP *refgen, *rv2cv;
1307 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1310 rv2gv = ((BINOP *)o)->op_last;
1311 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1314 refgen = (UNOP *)((BINOP *)o)->op_first;
1316 if (!refgen || refgen->op_type != OP_REFGEN)
1319 exlist = (LISTOP *)refgen->op_first;
1320 if (!exlist || exlist->op_type != OP_NULL
1321 || exlist->op_targ != OP_LIST)
1324 if (exlist->op_first->op_type != OP_PUSHMARK)
1327 rv2cv = (UNOP*)exlist->op_last;
1329 if (rv2cv->op_type != OP_RV2CV)
1332 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1333 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1334 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1336 o->op_private |= OPpASSIGN_CV_TO_GV;
1337 rv2gv->op_private |= OPpDONT_INIT_GV;
1338 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1350 kid = cLOGOPo->op_first;
1351 if (kid->op_type == OP_NOT
1352 && (kid->op_flags & OPf_KIDS)
1354 if (o->op_type == OP_AND) {
1356 o->op_ppaddr = PL_ppaddr[OP_OR];
1358 o->op_type = OP_AND;
1359 o->op_ppaddr = PL_ppaddr[OP_AND];
1368 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1373 if (o->op_flags & OPf_STACKED)
1380 if (!(o->op_flags & OPf_KIDS))
1391 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1401 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1402 newSVpvn_flags(useless, strlen(useless),
1403 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1408 S_listkids(pTHX_ OP *o)
1410 if (o && o->op_flags & OPf_KIDS) {
1412 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1419 Perl_list(pTHX_ OP *o)
1424 /* assumes no premature commitment */
1425 if (!o || (o->op_flags & OPf_WANT)
1426 || (PL_parser && PL_parser->error_count)
1427 || o->op_type == OP_RETURN)
1432 if ((o->op_private & OPpTARGET_MY)
1433 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1435 return o; /* As if inside SASSIGN */
1438 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1440 switch (o->op_type) {
1443 list(cBINOPo->op_first);
1448 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1456 if (!(o->op_flags & OPf_KIDS))
1458 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1459 list(cBINOPo->op_first);
1460 return gen_constant_list(o);
1467 kid = cLISTOPo->op_first;
1469 kid = kid->op_sibling;
1472 OP *sib = kid->op_sibling;
1473 if (sib && kid->op_type != OP_LEAVEWHEN)
1479 PL_curcop = &PL_compiling;
1483 kid = cLISTOPo->op_first;
1490 S_scalarseq(pTHX_ OP *o)
1494 const OPCODE type = o->op_type;
1496 if (type == OP_LINESEQ || type == OP_SCOPE ||
1497 type == OP_LEAVE || type == OP_LEAVETRY)
1500 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1501 if (kid->op_sibling) {
1505 PL_curcop = &PL_compiling;
1507 o->op_flags &= ~OPf_PARENS;
1508 if (PL_hints & HINT_BLOCK_SCOPE)
1509 o->op_flags |= OPf_PARENS;
1512 o = newOP(OP_STUB, 0);
1517 S_modkids(pTHX_ OP *o, I32 type)
1519 if (o && o->op_flags & OPf_KIDS) {
1521 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1522 op_lvalue(kid, type);
1528 =for apidoc finalize_optree
1530 This function finalizes the optree. Should be called directly after
1531 the complete optree is built. It does some additional
1532 checking which can't be done in the normal ck_xxx functions and makes
1533 the tree thread-safe.
1538 Perl_finalize_optree(pTHX_ OP* o)
1540 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1543 SAVEVPTR(PL_curcop);
1551 S_finalize_op(pTHX_ OP* o)
1553 PERL_ARGS_ASSERT_FINALIZE_OP;
1555 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1557 /* Make sure mad ops are also thread-safe */
1558 MADPROP *mp = o->op_madprop;
1560 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1561 OP *prop_op = (OP *) mp->mad_val;
1562 /* We only need "Relocate sv to the pad for thread safety.", but this
1563 easiest way to make sure it traverses everything */
1564 if (prop_op->op_type == OP_CONST)
1565 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1566 finalize_op(prop_op);
1573 switch (o->op_type) {
1576 PL_curcop = ((COP*)o); /* for warnings */
1580 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1581 && ckWARN(WARN_SYNTAX))
1583 if (o->op_sibling->op_sibling) {
1584 const OPCODE type = o->op_sibling->op_sibling->op_type;
1585 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1586 const line_t oldline = CopLINE(PL_curcop);
1587 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1588 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1589 "Statement unlikely to be reached");
1590 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1591 "\t(Maybe you meant system() when you said exec()?)\n");
1592 CopLINE_set(PL_curcop, oldline);
1599 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1600 GV * const gv = cGVOPo_gv;
1601 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1602 /* XXX could check prototype here instead of just carping */
1603 SV * const sv = sv_newmortal();
1604 gv_efullname3(sv, gv, NULL);
1605 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1606 "%"SVf"() called too early to check prototype",
1613 if (cSVOPo->op_private & OPpCONST_STRICT)
1614 no_bareword_allowed(o);
1618 case OP_METHOD_NAMED:
1619 /* Relocate sv to the pad for thread safety.
1620 * Despite being a "constant", the SV is written to,
1621 * for reference counts, sv_upgrade() etc. */
1622 if (cSVOPo->op_sv) {
1623 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1624 if (o->op_type != OP_METHOD_NAMED &&
1625 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1627 /* If op_sv is already a PADTMP/MY then it is being used by
1628 * some pad, so make a copy. */
1629 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1630 SvREADONLY_on(PAD_SVl(ix));
1631 SvREFCNT_dec(cSVOPo->op_sv);
1633 else if (o->op_type != OP_METHOD_NAMED
1634 && cSVOPo->op_sv == &PL_sv_undef) {
1635 /* PL_sv_undef is hack - it's unsafe to store it in the
1636 AV that is the pad, because av_fetch treats values of
1637 PL_sv_undef as a "free" AV entry and will merrily
1638 replace them with a new SV, causing pad_alloc to think
1639 that this pad slot is free. (When, clearly, it is not)
1641 SvOK_off(PAD_SVl(ix));
1642 SvPADTMP_on(PAD_SVl(ix));
1643 SvREADONLY_on(PAD_SVl(ix));
1646 SvREFCNT_dec(PAD_SVl(ix));
1647 SvPADTMP_on(cSVOPo->op_sv);
1648 PAD_SETSV(ix, cSVOPo->op_sv);
1649 /* XXX I don't know how this isn't readonly already. */
1650 SvREADONLY_on(PAD_SVl(ix));
1652 cSVOPo->op_sv = NULL;
1663 const char *key = NULL;
1666 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1669 /* Make the CONST have a shared SV */
1670 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1671 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1672 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1673 key = SvPV_const(sv, keylen);
1674 lexname = newSVpvn_share(key,
1675 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1681 if ((o->op_private & (OPpLVAL_INTRO)))
1684 rop = (UNOP*)((BINOP*)o)->op_first;
1685 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1687 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1688 if (!SvPAD_TYPED(lexname))
1690 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1691 if (!fields || !GvHV(*fields))
1693 key = SvPV_const(*svp, keylen);
1694 if (!hv_fetch(GvHV(*fields), key,
1695 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1696 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1697 "in variable %"SVf" of type %"HEKf,
1698 SVfARG(*svp), SVfARG(lexname),
1699 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1711 SVOP *first_key_op, *key_op;
1713 if ((o->op_private & (OPpLVAL_INTRO))
1714 /* I bet there's always a pushmark... */
1715 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1716 /* hmmm, no optimization if list contains only one key. */
1718 rop = (UNOP*)((LISTOP*)o)->op_last;
1719 if (rop->op_type != OP_RV2HV)
1721 if (rop->op_first->op_type == OP_PADSV)
1722 /* @$hash{qw(keys here)} */
1723 rop = (UNOP*)rop->op_first;
1725 /* @{$hash}{qw(keys here)} */
1726 if (rop->op_first->op_type == OP_SCOPE
1727 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1729 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1735 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1736 if (!SvPAD_TYPED(lexname))
1738 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1739 if (!fields || !GvHV(*fields))
1741 /* Again guessing that the pushmark can be jumped over.... */
1742 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1743 ->op_first->op_sibling;
1744 for (key_op = first_key_op; key_op;
1745 key_op = (SVOP*)key_op->op_sibling) {
1746 if (key_op->op_type != OP_CONST)
1748 svp = cSVOPx_svp(key_op);
1749 key = SvPV_const(*svp, keylen);
1750 if (!hv_fetch(GvHV(*fields), key,
1751 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1752 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1753 "in variable %"SVf" of type %"HEKf,
1754 SVfARG(*svp), SVfARG(lexname),
1755 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1761 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1762 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1769 if (o->op_flags & OPf_KIDS) {
1771 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1777 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1779 Propagate lvalue ("modifiable") context to an op and its children.
1780 I<type> represents the context type, roughly based on the type of op that
1781 would do the modifying, although C<local()> is represented by OP_NULL,
1782 because it has no op type of its own (it is signalled by a flag on
1785 This function detects things that can't be modified, such as C<$x+1>, and
1786 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1787 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1789 It also flags things that need to behave specially in an lvalue context,
1790 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1796 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1800 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1803 if (!o || (PL_parser && PL_parser->error_count))
1806 if ((o->op_private & OPpTARGET_MY)
1807 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1812 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1814 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1816 switch (o->op_type) {
1821 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1825 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1826 !(o->op_flags & OPf_STACKED)) {
1827 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1828 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1829 poses, so we need it clear. */
1830 o->op_private &= ~1;
1831 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1832 assert(cUNOPo->op_first->op_type == OP_NULL);
1833 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1836 else { /* lvalue subroutine call */
1837 o->op_private |= OPpLVAL_INTRO
1838 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1839 PL_modcount = RETURN_UNLIMITED_NUMBER;
1840 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1841 /* Potential lvalue context: */
1842 o->op_private |= OPpENTERSUB_INARGS;
1845 else { /* Compile-time error message: */
1846 OP *kid = cUNOPo->op_first;
1849 if (kid->op_type != OP_PUSHMARK) {
1850 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1852 "panic: unexpected lvalue entersub "
1853 "args: type/targ %ld:%"UVuf,
1854 (long)kid->op_type, (UV)kid->op_targ);
1855 kid = kLISTOP->op_first;
1857 while (kid->op_sibling)
1858 kid = kid->op_sibling;
1859 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1860 break; /* Postpone until runtime */
1863 kid = kUNOP->op_first;
1864 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1865 kid = kUNOP->op_first;
1866 if (kid->op_type == OP_NULL)
1868 "Unexpected constant lvalue entersub "
1869 "entry via type/targ %ld:%"UVuf,
1870 (long)kid->op_type, (UV)kid->op_targ);
1871 if (kid->op_type != OP_GV) {
1875 cv = GvCV(kGVOP_gv);
1885 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1886 /* grep, foreach, subcalls, refgen */
1887 if (type == OP_GREPSTART || type == OP_ENTERSUB
1888 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1890 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1891 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1893 : (o->op_type == OP_ENTERSUB
1894 ? "non-lvalue subroutine call"
1896 type ? PL_op_desc[type] : "local"));
1910 case OP_RIGHT_SHIFT:
1919 if (!(o->op_flags & OPf_STACKED))
1926 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1927 op_lvalue(kid, type);
1932 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1933 PL_modcount = RETURN_UNLIMITED_NUMBER;
1934 return o; /* Treat \(@foo) like ordinary list. */
1938 if (scalar_mod_type(o, type))
1940 ref(cUNOPo->op_first, o->op_type);
1944 if (type == OP_LEAVESUBLV)
1945 o->op_private |= OPpMAYBE_LVSUB;
1951 PL_modcount = RETURN_UNLIMITED_NUMBER;
1954 PL_hints |= HINT_BLOCK_SCOPE;
1955 if (type == OP_LEAVESUBLV)
1956 o->op_private |= OPpMAYBE_LVSUB;
1960 ref(cUNOPo->op_first, o->op_type);
1964 PL_hints |= HINT_BLOCK_SCOPE;
1973 case OP_AELEMFAST_LEX:
1980 PL_modcount = RETURN_UNLIMITED_NUMBER;
1981 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1982 return o; /* Treat \(@foo) like ordinary list. */
1983 if (scalar_mod_type(o, type))
1985 if (type == OP_LEAVESUBLV)
1986 o->op_private |= OPpMAYBE_LVSUB;
1990 if (!type) /* local() */
1991 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1992 PAD_COMPNAME_SV(o->op_targ));
2001 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2005 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2011 if (type == OP_LEAVESUBLV)
2012 o->op_private |= OPpMAYBE_LVSUB;
2013 pad_free(o->op_targ);
2014 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
2015 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
2016 if (o->op_flags & OPf_KIDS)
2017 op_lvalue(cBINOPo->op_first->op_sibling, type);
2022 ref(cBINOPo->op_first, o->op_type);
2023 if (type == OP_ENTERSUB &&
2024 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2025 o->op_private |= OPpLVAL_DEFER;
2026 if (type == OP_LEAVESUBLV)
2027 o->op_private |= OPpMAYBE_LVSUB;
2037 if (o->op_flags & OPf_KIDS)
2038 op_lvalue(cLISTOPo->op_last, type);
2043 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2045 else if (!(o->op_flags & OPf_KIDS))
2047 if (o->op_targ != OP_LIST) {
2048 op_lvalue(cBINOPo->op_first, type);
2054 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2055 /* elements might be in void context because the list is
2056 in scalar context or because they are attribute sub calls */
2057 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2058 op_lvalue(kid, type);
2062 if (type != OP_LEAVESUBLV)
2064 break; /* op_lvalue()ing was handled by ck_return() */
2070 /* [20011101.069] File test operators interpret OPf_REF to mean that
2071 their argument is a filehandle; thus \stat(".") should not set
2073 if (type == OP_REFGEN &&
2074 PL_check[o->op_type] == Perl_ck_ftst)
2077 if (type != OP_LEAVESUBLV)
2078 o->op_flags |= OPf_MOD;
2080 if (type == OP_AASSIGN || type == OP_SASSIGN)
2081 o->op_flags |= OPf_SPECIAL|OPf_REF;
2082 else if (!type) { /* local() */
2085 o->op_private |= OPpLVAL_INTRO;
2086 o->op_flags &= ~OPf_SPECIAL;
2087 PL_hints |= HINT_BLOCK_SCOPE;
2092 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2093 "Useless localization of %s", OP_DESC(o));
2096 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2097 && type != OP_LEAVESUBLV)
2098 o->op_flags |= OPf_REF;
2103 S_scalar_mod_type(const OP *o, I32 type)
2108 if (o && o->op_type == OP_RV2GV)
2132 case OP_RIGHT_SHIFT:
2153 S_is_handle_constructor(const OP *o, I32 numargs)
2155 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2157 switch (o->op_type) {
2165 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2178 S_refkids(pTHX_ OP *o, I32 type)
2180 if (o && o->op_flags & OPf_KIDS) {
2182 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2189 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2194 PERL_ARGS_ASSERT_DOREF;
2196 if (!o || (PL_parser && PL_parser->error_count))
2199 switch (o->op_type) {
2201 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2202 !(o->op_flags & OPf_STACKED)) {
2203 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2204 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2205 assert(cUNOPo->op_first->op_type == OP_NULL);
2206 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2207 o->op_flags |= OPf_SPECIAL;
2208 o->op_private &= ~1;
2210 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2211 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2212 : type == OP_RV2HV ? OPpDEREF_HV
2214 o->op_flags |= OPf_MOD;
2220 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2221 doref(kid, type, set_op_ref);
2224 if (type == OP_DEFINED)
2225 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2226 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2229 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2230 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2231 : type == OP_RV2HV ? OPpDEREF_HV
2233 o->op_flags |= OPf_MOD;
2240 o->op_flags |= OPf_REF;
2243 if (type == OP_DEFINED)
2244 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2245 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2251 o->op_flags |= OPf_REF;
2256 if (!(o->op_flags & OPf_KIDS))
2258 doref(cBINOPo->op_first, type, set_op_ref);
2262 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2263 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2264 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2265 : type == OP_RV2HV ? OPpDEREF_HV
2267 o->op_flags |= OPf_MOD;
2277 if (!(o->op_flags & OPf_KIDS))
2279 doref(cLISTOPo->op_last, type, set_op_ref);
2289 S_dup_attrlist(pTHX_ OP *o)
2294 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2296 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2297 * where the first kid is OP_PUSHMARK and the remaining ones
2298 * are OP_CONST. We need to push the OP_CONST values.
2300 if (o->op_type == OP_CONST)
2301 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2303 else if (o->op_type == OP_NULL)
2307 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2309 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2310 if (o->op_type == OP_CONST)
2311 rop = op_append_elem(OP_LIST, rop,
2312 newSVOP(OP_CONST, o->op_flags,
2313 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2320 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2325 PERL_ARGS_ASSERT_APPLY_ATTRS;
2327 /* fake up C<use attributes $pkg,$rv,@attrs> */
2328 ENTER; /* need to protect against side-effects of 'use' */
2329 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2331 #define ATTRSMODULE "attributes"
2332 #define ATTRSMODULE_PM "attributes.pm"
2335 /* Don't force the C<use> if we don't need it. */
2336 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2337 if (svp && *svp != &PL_sv_undef)
2338 NOOP; /* already in %INC */
2340 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2341 newSVpvs(ATTRSMODULE), NULL);
2344 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2345 newSVpvs(ATTRSMODULE),
2347 op_prepend_elem(OP_LIST,
2348 newSVOP(OP_CONST, 0, stashsv),
2349 op_prepend_elem(OP_LIST,
2350 newSVOP(OP_CONST, 0,
2352 dup_attrlist(attrs))));
2358 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2361 OP *pack, *imop, *arg;
2364 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2369 assert(target->op_type == OP_PADSV ||
2370 target->op_type == OP_PADHV ||
2371 target->op_type == OP_PADAV);
2373 /* Ensure that attributes.pm is loaded. */
2374 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2376 /* Need package name for method call. */
2377 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2379 /* Build up the real arg-list. */
2380 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2382 arg = newOP(OP_PADSV, 0);
2383 arg->op_targ = target->op_targ;
2384 arg = op_prepend_elem(OP_LIST,
2385 newSVOP(OP_CONST, 0, stashsv),
2386 op_prepend_elem(OP_LIST,
2387 newUNOP(OP_REFGEN, 0,
2388 op_lvalue(arg, OP_REFGEN)),
2389 dup_attrlist(attrs)));
2391 /* Fake up a method call to import */
2392 meth = newSVpvs_share("import");
2393 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2394 op_append_elem(OP_LIST,
2395 op_prepend_elem(OP_LIST, pack, list(arg)),
2396 newSVOP(OP_METHOD_NAMED, 0, meth)));
2398 /* Combine the ops. */
2399 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2403 =notfor apidoc apply_attrs_string
2405 Attempts to apply a list of attributes specified by the C<attrstr> and
2406 C<len> arguments to the subroutine identified by the C<cv> argument which
2407 is expected to be associated with the package identified by the C<stashpv>
2408 argument (see L<attributes>). It gets this wrong, though, in that it
2409 does not correctly identify the boundaries of the individual attribute
2410 specifications within C<attrstr>. This is not really intended for the
2411 public API, but has to be listed here for systems such as AIX which
2412 need an explicit export list for symbols. (It's called from XS code
2413 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2414 to respect attribute syntax properly would be welcome.
2420 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2421 const char *attrstr, STRLEN len)
2425 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2428 len = strlen(attrstr);
2432 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2434 const char * const sstr = attrstr;
2435 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2436 attrs = op_append_elem(OP_LIST, attrs,
2437 newSVOP(OP_CONST, 0,
2438 newSVpvn(sstr, attrstr-sstr)));
2442 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2443 newSVpvs(ATTRSMODULE),
2444 NULL, op_prepend_elem(OP_LIST,
2445 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2446 op_prepend_elem(OP_LIST,
2447 newSVOP(OP_CONST, 0,
2448 newRV(MUTABLE_SV(cv))),
2453 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2457 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2459 PERL_ARGS_ASSERT_MY_KID;
2461 if (!o || (PL_parser && PL_parser->error_count))
2465 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2466 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2470 if (type == OP_LIST) {
2472 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2473 my_kid(kid, attrs, imopsp);
2475 } else if (type == OP_UNDEF
2481 } else if (type == OP_RV2SV || /* "our" declaration */
2483 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2484 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2485 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2487 PL_parser->in_my == KEY_our
2489 : PL_parser->in_my == KEY_state ? "state" : "my"));
2491 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2492 PL_parser->in_my = FALSE;
2493 PL_parser->in_my_stash = NULL;
2494 apply_attrs(GvSTASH(gv),
2495 (type == OP_RV2SV ? GvSV(gv) :
2496 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2497 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2500 o->op_private |= OPpOUR_INTRO;
2503 else if (type != OP_PADSV &&
2506 type != OP_PUSHMARK)
2508 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2510 PL_parser->in_my == KEY_our
2512 : PL_parser->in_my == KEY_state ? "state" : "my"));
2515 else if (attrs && type != OP_PUSHMARK) {
2518 PL_parser->in_my = FALSE;
2519 PL_parser->in_my_stash = NULL;
2521 /* check for C<my Dog $spot> when deciding package */
2522 stash = PAD_COMPNAME_TYPE(o->op_targ);
2524 stash = PL_curstash;
2525 apply_attrs_my(stash, o, attrs, imopsp);
2527 o->op_flags |= OPf_MOD;
2528 o->op_private |= OPpLVAL_INTRO;
2530 o->op_private |= OPpPAD_STATE;
2535 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2539 int maybe_scalar = 0;
2541 PERL_ARGS_ASSERT_MY_ATTRS;
2543 /* [perl #17376]: this appears to be premature, and results in code such as
2544 C< our(%x); > executing in list mode rather than void mode */
2546 if (o->op_flags & OPf_PARENS)
2556 o = my_kid(o, attrs, &rops);
2558 if (maybe_scalar && o->op_type == OP_PADSV) {
2559 o = scalar(op_append_list(OP_LIST, rops, o));
2560 o->op_private |= OPpLVAL_INTRO;
2563 /* The listop in rops might have a pushmark at the beginning,
2564 which will mess up list assignment. */
2565 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2566 if (rops->op_type == OP_LIST &&
2567 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2569 OP * const pushmark = lrops->op_first;
2570 lrops->op_first = pushmark->op_sibling;
2573 o = op_append_list(OP_LIST, o, rops);
2576 PL_parser->in_my = FALSE;
2577 PL_parser->in_my_stash = NULL;
2582 Perl_sawparens(pTHX_ OP *o)
2584 PERL_UNUSED_CONTEXT;
2586 o->op_flags |= OPf_PARENS;
2591 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2595 const OPCODE ltype = left->op_type;
2596 const OPCODE rtype = right->op_type;
2598 PERL_ARGS_ASSERT_BIND_MATCH;
2600 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2601 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2603 const char * const desc
2605 rtype == OP_SUBST || rtype == OP_TRANS
2606 || rtype == OP_TRANSR
2608 ? (int)rtype : OP_MATCH];
2609 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2612 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2613 ? cUNOPx(left)->op_first->op_type == OP_GV
2614 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2615 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2618 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2621 Perl_warner(aTHX_ packWARN(WARN_MISC),
2622 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2625 const char * const sample = (isary
2626 ? "@array" : "%hash");
2627 Perl_warner(aTHX_ packWARN(WARN_MISC),
2628 "Applying %s to %s will act on scalar(%s)",
2629 desc, sample, sample);
2633 if (rtype == OP_CONST &&
2634 cSVOPx(right)->op_private & OPpCONST_BARE &&
2635 cSVOPx(right)->op_private & OPpCONST_STRICT)
2637 no_bareword_allowed(right);
2640 /* !~ doesn't make sense with /r, so error on it for now */
2641 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2643 yyerror("Using !~ with s///r doesn't make sense");
2644 if (rtype == OP_TRANSR && type == OP_NOT)
2645 yyerror("Using !~ with tr///r doesn't make sense");
2647 ismatchop = (rtype == OP_MATCH ||
2648 rtype == OP_SUBST ||
2649 rtype == OP_TRANS || rtype == OP_TRANSR)
2650 && !(right->op_flags & OPf_SPECIAL);
2651 if (ismatchop && right->op_private & OPpTARGET_MY) {
2653 right->op_private &= ~OPpTARGET_MY;
2655 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2658 right->op_flags |= OPf_STACKED;
2659 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2660 ! (rtype == OP_TRANS &&
2661 right->op_private & OPpTRANS_IDENTICAL) &&
2662 ! (rtype == OP_SUBST &&
2663 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2664 newleft = op_lvalue(left, rtype);
2667 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2668 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2670 o = op_prepend_elem(rtype, scalar(newleft), right);
2672 return newUNOP(OP_NOT, 0, scalar(o));
2676 return bind_match(type, left,
2677 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
2681 Perl_invert(pTHX_ OP *o)
2685 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2689 =for apidoc Amx|OP *|op_scope|OP *o
2691 Wraps up an op tree with some additional ops so that at runtime a dynamic
2692 scope will be created. The original ops run in the new dynamic scope,
2693 and then, provided that they exit normally, the scope will be unwound.
2694 The additional ops used to create and unwind the dynamic scope will
2695 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2696 instead if the ops are simple enough to not need the full dynamic scope
2703 Perl_op_scope(pTHX_ OP *o)
2707 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2708 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2709 o->op_type = OP_LEAVE;
2710 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2712 else if (o->op_type == OP_LINESEQ) {
2714 o->op_type = OP_SCOPE;
2715 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2716 kid = ((LISTOP*)o)->op_first;
2717 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2720 /* The following deals with things like 'do {1 for 1}' */
2721 kid = kid->op_sibling;
2723 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2728 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2734 Perl_block_start(pTHX_ int full)
2737 const int retval = PL_savestack_ix;
2739 pad_block_start(full);
2741 PL_hints &= ~HINT_BLOCK_SCOPE;
2742 SAVECOMPILEWARNINGS();
2743 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2745 CALL_BLOCK_HOOKS(bhk_start, full);
2751 Perl_block_end(pTHX_ I32 floor, OP *seq)
2754 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2755 OP* retval = scalarseq(seq);
2757 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2760 CopHINTS_set(&PL_compiling, PL_hints);
2762 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2765 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2771 =head1 Compile-time scope hooks
2773 =for apidoc Aox||blockhook_register
2775 Register a set of hooks to be called when the Perl lexical scope changes
2776 at compile time. See L<perlguts/"Compile-time scope hooks">.
2782 Perl_blockhook_register(pTHX_ BHK *hk)
2784 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2786 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2793 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2794 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2795 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2798 OP * const o = newOP(OP_PADSV, 0);
2799 o->op_targ = offset;
2805 Perl_newPROG(pTHX_ OP *o)
2809 PERL_ARGS_ASSERT_NEWPROG;
2816 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2817 ((PL_in_eval & EVAL_KEEPERR)
2818 ? OPf_SPECIAL : 0), o);
2820 cx = &cxstack[cxstack_ix];
2821 assert(CxTYPE(cx) == CXt_EVAL);
2823 if ((cx->blk_gimme & G_WANT) == G_VOID)
2824 scalarvoid(PL_eval_root);
2825 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2828 scalar(PL_eval_root);
2830 /* don't use LINKLIST, since PL_eval_root might indirect through
2831 * a rather expensive function call and LINKLIST evaluates its
2832 * argument more than once */
2833 PL_eval_start = op_linklist(PL_eval_root);
2834 PL_eval_root->op_private |= OPpREFCOUNTED;
2835 OpREFCNT_set(PL_eval_root, 1);
2836 PL_eval_root->op_next = 0;
2837 i = PL_savestack_ix;
2840 CALL_PEEP(PL_eval_start);
2841 finalize_optree(PL_eval_root);
2843 PL_savestack_ix = i;
2846 if (o->op_type == OP_STUB) {
2847 PL_comppad_name = 0;
2849 S_op_destroy(aTHX_ o);
2852 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2853 PL_curcop = &PL_compiling;
2854 PL_main_start = LINKLIST(PL_main_root);
2855 PL_main_root->op_private |= OPpREFCOUNTED;
2856 OpREFCNT_set(PL_main_root, 1);
2857 PL_main_root->op_next = 0;
2858 CALL_PEEP(PL_main_start);
2859 finalize_optree(PL_main_root);
2862 /* Register with debugger */
2864 CV * const cv = get_cvs("DB::postponed", 0);
2868 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2870 call_sv(MUTABLE_SV(cv), G_DISCARD);
2877 Perl_localize(pTHX_ OP *o, I32 lex)
2881 PERL_ARGS_ASSERT_LOCALIZE;
2883 if (o->op_flags & OPf_PARENS)
2884 /* [perl #17376]: this appears to be premature, and results in code such as
2885 C< our(%x); > executing in list mode rather than void mode */
2892 if ( PL_parser->bufptr > PL_parser->oldbufptr
2893 && PL_parser->bufptr[-1] == ','
2894 && ckWARN(WARN_PARENTHESIS))
2896 char *s = PL_parser->bufptr;
2899 /* some heuristics to detect a potential error */
2900 while (*s && (strchr(", \t\n", *s)))
2904 if (*s && strchr("@$%*", *s) && *++s
2905 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2908 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2910 while (*s && (strchr(", \t\n", *s)))
2916 if (sigil && (*s == ';' || *s == '=')) {
2917 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2918 "Parentheses missing around \"%s\" list",
2920 ? (PL_parser->in_my == KEY_our
2922 : PL_parser->in_my == KEY_state
2932 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2933 PL_parser->in_my = FALSE;
2934 PL_parser->in_my_stash = NULL;
2939 Perl_jmaybe(pTHX_ OP *o)
2941 PERL_ARGS_ASSERT_JMAYBE;
2943 if (o->op_type == OP_LIST) {
2945 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2946 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2951 PERL_STATIC_INLINE OP *
2952 S_op_std_init(pTHX_ OP *o)
2954 I32 type = o->op_type;
2956 PERL_ARGS_ASSERT_OP_STD_INIT;
2958 if (PL_opargs[type] & OA_RETSCALAR)
2960 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2961 o->op_targ = pad_alloc(type, SVs_PADTMP);
2966 PERL_STATIC_INLINE OP *
2967 S_op_integerize(pTHX_ OP *o)
2969 I32 type = o->op_type;
2971 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2973 /* integerize op, unless it happens to be C<-foo>.
2974 * XXX should pp_i_negate() do magic string negation instead? */
2975 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2976 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2977 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2980 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2983 if (type == OP_NEGATE)
2984 /* XXX might want a ck_negate() for this */
2985 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2991 S_fold_constants(pTHX_ register OP *o)
2994 register OP * VOL curop;
2996 VOL I32 type = o->op_type;
3001 SV * const oldwarnhook = PL_warnhook;
3002 SV * const olddiehook = PL_diehook;
3006 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3008 if (!(PL_opargs[type] & OA_FOLDCONST))
3022 /* XXX what about the numeric ops? */
3023 if (IN_LOCALE_COMPILETIME)
3027 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3030 if (PL_parser && PL_parser->error_count)
3031 goto nope; /* Don't try to run w/ errors */
3033 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3034 const OPCODE type = curop->op_type;
3035 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3037 type != OP_SCALAR &&
3039 type != OP_PUSHMARK)
3045 curop = LINKLIST(o);
3046 old_next = o->op_next;
3050 oldscope = PL_scopestack_ix;
3051 create_eval_scope(G_FAKINGEVAL);
3053 /* Verify that we don't need to save it: */
3054 assert(PL_curcop == &PL_compiling);
3055 StructCopy(&PL_compiling, ¬_compiling, COP);
3056 PL_curcop = ¬_compiling;
3057 /* The above ensures that we run with all the correct hints of the
3058 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3059 assert(IN_PERL_RUNTIME);
3060 PL_warnhook = PERL_WARNHOOK_FATAL;
3067 sv = *(PL_stack_sp--);
3068 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3070 /* Can't simply swipe the SV from the pad, because that relies on
3071 the op being freed "real soon now". Under MAD, this doesn't
3072 happen (see the #ifdef below). */
3075 pad_swipe(o->op_targ, FALSE);
3078 else if (SvTEMP(sv)) { /* grab mortal temp? */
3079 SvREFCNT_inc_simple_void(sv);
3084 /* Something tried to die. Abandon constant folding. */
3085 /* Pretend the error never happened. */
3087 o->op_next = old_next;
3091 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3092 PL_warnhook = oldwarnhook;
3093 PL_diehook = olddiehook;
3094 /* XXX note that this croak may fail as we've already blown away
3095 * the stack - eg any nested evals */
3096 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3099 PL_warnhook = oldwarnhook;
3100 PL_diehook = olddiehook;
3101 PL_curcop = &PL_compiling;
3103 if (PL_scopestack_ix > oldscope)
3104 delete_eval_scope();
3113 if (type == OP_RV2GV)
3114 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3116 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3117 op_getmad(o,newop,'f');
3125 S_gen_constant_list(pTHX_ register OP *o)
3129 const I32 oldtmps_floor = PL_tmps_floor;
3132 if (PL_parser && PL_parser->error_count)
3133 return o; /* Don't attempt to run with errors */
3135 PL_op = curop = LINKLIST(o);
3138 Perl_pp_pushmark(aTHX);
3141 assert (!(curop->op_flags & OPf_SPECIAL));
3142 assert(curop->op_type == OP_RANGE);
3143 Perl_pp_anonlist(aTHX);
3144 PL_tmps_floor = oldtmps_floor;
3146 o->op_type = OP_RV2AV;
3147 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3148 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3149 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3150 o->op_opt = 0; /* needs to be revisited in rpeep() */
3151 curop = ((UNOP*)o)->op_first;
3152 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3154 op_getmad(curop,o,'O');
3163 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3166 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3167 if (!o || o->op_type != OP_LIST)
3168 o = newLISTOP(OP_LIST, 0, o, NULL);
3170 o->op_flags &= ~OPf_WANT;
3172 if (!(PL_opargs[type] & OA_MARK))
3173 op_null(cLISTOPo->op_first);
3175 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3176 if (kid2 && kid2->op_type == OP_COREARGS) {
3177 op_null(cLISTOPo->op_first);
3178 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3182 o->op_type = (OPCODE)type;
3183 o->op_ppaddr = PL_ppaddr[type];
3184 o->op_flags |= flags;
3186 o = CHECKOP(type, o);
3187 if (o->op_type != (unsigned)type)
3190 return fold_constants(op_integerize(op_std_init(o)));
3194 =head1 Optree Manipulation Functions
3197 /* List constructors */
3200 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3202 Append an item to the list of ops contained directly within a list-type
3203 op, returning the lengthened list. I<first> is the list-type op,
3204 and I<last> is the op to append to the list. I<optype> specifies the
3205 intended opcode for the list. If I<first> is not already a list of the
3206 right type, it will be upgraded into one. If either I<first> or I<last>
3207 is null, the other is returned unchanged.
3213 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3221 if (first->op_type != (unsigned)type
3222 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3224 return newLISTOP(type, 0, first, last);
3227 if (first->op_flags & OPf_KIDS)
3228 ((LISTOP*)first)->op_last->op_sibling = last;
3230 first->op_flags |= OPf_KIDS;
3231 ((LISTOP*)first)->op_first = last;
3233 ((LISTOP*)first)->op_last = last;
3238 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3240 Concatenate the lists of ops contained directly within two list-type ops,
3241 returning the combined list. I<first> and I<last> are the list-type ops
3242 to concatenate. I<optype> specifies the intended opcode for the list.
3243 If either I<first> or I<last> is not already a list of the right type,
3244 it will be upgraded into one. If either I<first> or I<last> is null,
3245 the other is returned unchanged.
3251 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3259 if (first->op_type != (unsigned)type)
3260 return op_prepend_elem(type, first, last);
3262 if (last->op_type != (unsigned)type)
3263 return op_append_elem(type, first, last);
3265 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3266 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3267 first->op_flags |= (last->op_flags & OPf_KIDS);
3270 if (((LISTOP*)last)->op_first && first->op_madprop) {
3271 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3273 while (mp->mad_next)
3275 mp->mad_next = first->op_madprop;
3278 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3281 first->op_madprop = last->op_madprop;
3282 last->op_madprop = 0;
3285 S_op_destroy(aTHX_ last);
3291 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3293 Prepend an item to the list of ops contained directly within a list-type
3294 op, returning the lengthened list. I<first> is the op to prepend to the
3295 list, and I<last> is the list-type op. I<optype> specifies the intended
3296 opcode for the list. If I<last> is not already a list of the right type,
3297 it will be upgraded into one. If either I<first> or I<last> is null,
3298 the other is returned unchanged.
3304 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3312 if (last->op_type == (unsigned)type) {
3313 if (type == OP_LIST) { /* already a PUSHMARK there */
3314 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3315 ((LISTOP*)last)->op_first->op_sibling = first;
3316 if (!(first->op_flags & OPf_PARENS))
3317 last->op_flags &= ~OPf_PARENS;
3320 if (!(last->op_flags & OPf_KIDS)) {
3321 ((LISTOP*)last)->op_last = first;
3322 last->op_flags |= OPf_KIDS;
3324 first->op_sibling = ((LISTOP*)last)->op_first;
3325 ((LISTOP*)last)->op_first = first;
3327 last->op_flags |= OPf_KIDS;
3331 return newLISTOP(type, 0, first, last);
3339 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3342 Newxz(tk, 1, TOKEN);
3343 tk->tk_type = (OPCODE)optype;
3344 tk->tk_type = 12345;
3346 tk->tk_mad = madprop;
3351 Perl_token_free(pTHX_ TOKEN* tk)
3353 PERL_ARGS_ASSERT_TOKEN_FREE;
3355 if (tk->tk_type != 12345)
3357 mad_free(tk->tk_mad);
3362 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3367 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3369 if (tk->tk_type != 12345) {
3370 Perl_warner(aTHX_ packWARN(WARN_MISC),
3371 "Invalid TOKEN object ignored");
3378 /* faked up qw list? */
3380 tm->mad_type == MAD_SV &&
3381 SvPVX((SV *)tm->mad_val)[0] == 'q')
3388 /* pretend constant fold didn't happen? */
3389 if (mp->mad_key == 'f' &&
3390 (o->op_type == OP_CONST ||
3391 o->op_type == OP_GV) )
3393 token_getmad(tk,(OP*)mp->mad_val,slot);
3407 if (mp->mad_key == 'X')
3408 mp->mad_key = slot; /* just change the first one */
3418 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3427 /* pretend constant fold didn't happen? */
3428 if (mp->mad_key == 'f' &&
3429 (o->op_type == OP_CONST ||
3430 o->op_type == OP_GV) )
3432 op_getmad(from,(OP*)mp->mad_val,slot);
3439 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3442 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3448 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3457 /* pretend constant fold didn't happen? */
3458 if (mp->mad_key == 'f' &&
3459 (o->op_type == OP_CONST ||
3460 o->op_type == OP_GV) )
3462 op_getmad(from,(OP*)mp->mad_val,slot);
3469 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3472 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3476 PerlIO_printf(PerlIO_stderr(),
3477 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3483 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3501 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3505 addmad(tm, &(o->op_madprop), slot);
3509 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3530 Perl_newMADsv(pTHX_ char key, SV* sv)
3532 PERL_ARGS_ASSERT_NEWMADSV;
3534 return newMADPROP(key, MAD_SV, sv, 0);
3538 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3540 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3543 mp->mad_vlen = vlen;
3544 mp->mad_type = type;
3546 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3551 Perl_mad_free(pTHX_ MADPROP* mp)
3553 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3557 mad_free(mp->mad_next);
3558 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3559 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3560 switch (mp->mad_type) {
3564 Safefree((char*)mp->mad_val);
3567 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3568 op_free((OP*)mp->mad_val);
3571 sv_free(MUTABLE_SV(mp->mad_val));
3574 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3577 PerlMemShared_free(mp);
3583 =head1 Optree construction
3585 =for apidoc Am|OP *|newNULLLIST
3587 Constructs, checks, and returns a new C<stub> op, which represents an
3588 empty list expression.
3594 Perl_newNULLLIST(pTHX)
3596 return newOP(OP_STUB, 0);
3600 S_force_list(pTHX_ OP *o)
3602 if (!o || o->op_type != OP_LIST)
3603 o = newLISTOP(OP_LIST, 0, o, NULL);
3609 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3611 Constructs, checks, and returns an op of any list type. I<type> is
3612 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3613 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3614 supply up to two ops to be direct children of the list op; they are
3615 consumed by this function and become part of the constructed op tree.
3621 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3626 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3628 NewOp(1101, listop, 1, LISTOP);
3630 listop->op_type = (OPCODE)type;
3631 listop->op_ppaddr = PL_ppaddr[type];
3634 listop->op_flags = (U8)flags;
3638 else if (!first && last)
3641 first->op_sibling = last;
3642 listop->op_first = first;
3643 listop->op_last = last;
3644 if (type == OP_LIST) {
3645 OP* const pushop = newOP(OP_PUSHMARK, 0);
3646 pushop->op_sibling = first;
3647 listop->op_first = pushop;
3648 listop->op_flags |= OPf_KIDS;
3650 listop->op_last = pushop;
3653 return CHECKOP(type, listop);
3657 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3659 Constructs, checks, and returns an op of any base type (any type that
3660 has no extra fields). I<type> is the opcode. I<flags> gives the
3661 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3668 Perl_newOP(pTHX_ I32 type, I32 flags)
3673 if (type == -OP_ENTEREVAL) {
3674 type = OP_ENTEREVAL;
3675 flags |= OPpEVAL_BYTES<<8;
3678 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3679 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3680 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3681 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3683 NewOp(1101, o, 1, OP);
3684 o->op_type = (OPCODE)type;
3685 o->op_ppaddr = PL_ppaddr[type];
3686 o->op_flags = (U8)flags;
3688 o->op_latefreed = 0;
3692 o->op_private = (U8)(0 | (flags >> 8));
3693 if (PL_opargs[type] & OA_RETSCALAR)
3695 if (PL_opargs[type] & OA_TARGET)
3696 o->op_targ = pad_alloc(type, SVs_PADTMP);
3697 return CHECKOP(type, o);
3701 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3703 Constructs, checks, and returns an op of any unary type. I<type> is
3704 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3705 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3706 bits, the eight bits of C<op_private>, except that the bit with value 1
3707 is automatically set. I<first> supplies an optional op to be the direct
3708 child of the unary op; it is consumed by this function and become part
3709 of the constructed op tree.
3715 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3720 if (type == -OP_ENTEREVAL) {
3721 type = OP_ENTEREVAL;
3722 flags |= OPpEVAL_BYTES<<8;
3725 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3726 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3727 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3728 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3729 || type == OP_SASSIGN
3730 || type == OP_ENTERTRY
3731 || type == OP_NULL );
3734 first = newOP(OP_STUB, 0);
3735 if (PL_opargs[type] & OA_MARK)
3736 first = force_list(first);
3738 NewOp(1101, unop, 1, UNOP);
3739 unop->op_type = (OPCODE)type;
3740 unop->op_ppaddr = PL_ppaddr[type];
3741 unop->op_first = first;
3742 unop->op_flags = (U8)(flags | OPf_KIDS);
3743 unop->op_private = (U8)(1 | (flags >> 8));
3744 unop = (UNOP*) CHECKOP(type, unop);
3748 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3752 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3754 Constructs, checks, and returns an op of any binary type. I<type>
3755 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3756 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3757 the eight bits of C<op_private>, except that the bit with value 1 or
3758 2 is automatically set as required. I<first> and I<last> supply up to
3759 two ops to be the direct children of the binary op; they are consumed
3760 by this function and become part of the constructed op tree.
3766 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3771 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3772 || type == OP_SASSIGN || type == OP_NULL );
3774 NewOp(1101, binop, 1, BINOP);
3777 first = newOP(OP_NULL, 0);
3779 binop->op_type = (OPCODE)type;
3780 binop->op_ppaddr = PL_ppaddr[type];
3781 binop->op_first = first;
3782 binop->op_flags = (U8)(flags | OPf_KIDS);
3785 binop->op_private = (U8)(1 | (flags >> 8));
3788 binop->op_private = (U8)(2 | (flags >> 8));
3789 first->op_sibling = last;
3792 binop = (BINOP*)CHECKOP(type, binop);
3793 if (binop->op_next || binop->op_type != (OPCODE)type)
3796 binop->op_last = binop->op_first->op_sibling;
3798 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3801 static int uvcompare(const void *a, const void *b)
3802 __attribute__nonnull__(1)
3803 __attribute__nonnull__(2)
3804 __attribute__pure__;
3805 static int uvcompare(const void *a, const void *b)
3807 if (*((const UV *)a) < (*(const UV *)b))
3809 if (*((const UV *)a) > (*(const UV *)b))
3811 if (*((const UV *)a+1) < (*(const UV *)b+1))
3813 if (*((const UV *)a+1) > (*(const UV *)b+1))
3819 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3822 SV * const tstr = ((SVOP*)expr)->op_sv;
3825 (repl->op_type == OP_NULL)
3826 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3828 ((SVOP*)repl)->op_sv;
3831 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3832 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3836 register short *tbl;
3838 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3839 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3840 I32 del = o->op_private & OPpTRANS_DELETE;
3843 PERL_ARGS_ASSERT_PMTRANS;
3845 PL_hints |= HINT_BLOCK_SCOPE;
3848 o->op_private |= OPpTRANS_FROM_UTF;
3851 o->op_private |= OPpTRANS_TO_UTF;
3853 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3854 SV* const listsv = newSVpvs("# comment\n");
3856 const U8* tend = t + tlen;
3857 const U8* rend = r + rlen;
3871 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3872 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3875 const U32 flags = UTF8_ALLOW_DEFAULT;
3879 t = tsave = bytes_to_utf8(t, &len);
3882 if (!to_utf && rlen) {
3884 r = rsave = bytes_to_utf8(r, &len);
3888 /* There are several snags with this code on EBCDIC:
3889 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3890 2. scan_const() in toke.c has encoded chars in native encoding which makes
3891 ranges at least in EBCDIC 0..255 range the bottom odd.
3895 U8 tmpbuf[UTF8_MAXBYTES+1];
3898 Newx(cp, 2*tlen, UV);
3900 transv = newSVpvs("");
3902 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3904 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3906 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3910 cp[2*i+1] = cp[2*i];
3914 qsort(cp, i, 2*sizeof(UV), uvcompare);
3915 for (j = 0; j < i; j++) {
3917 diff = val - nextmin;
3919 t = uvuni_to_utf8(tmpbuf,nextmin);
3920 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3922 U8 range_mark = UTF_TO_NATIVE(0xff);
3923 t = uvuni_to_utf8(tmpbuf, val - 1);
3924 sv_catpvn(transv, (char *)&range_mark, 1);
3925 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3932 t = uvuni_to_utf8(tmpbuf,nextmin);
3933 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3935 U8 range_mark = UTF_TO_NATIVE(0xff);
3936 sv_catpvn(transv, (char *)&range_mark, 1);
3938 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3939 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3940 t = (const U8*)SvPVX_const(transv);
3941 tlen = SvCUR(transv);
3945 else if (!rlen && !del) {
3946 r = t; rlen = tlen; rend = tend;
3949 if ((!rlen && !del) || t == r ||
3950 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3952 o->op_private |= OPpTRANS_IDENTICAL;
3956 while (t < tend || tfirst <= tlast) {
3957 /* see if we need more "t" chars */
3958 if (tfirst > tlast) {
3959 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3961 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3963 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3970 /* now see if we need more "r" chars */
3971 if (rfirst > rlast) {
3973 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3975 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3977 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3986 rfirst = rlast = 0xffffffff;
3990 /* now see which range will peter our first, if either. */
3991 tdiff = tlast - tfirst;
3992 rdiff = rlast - rfirst;
3999 if (rfirst == 0xffffffff) {
4000 diff = tdiff; /* oops, pretend rdiff is infinite */
4002 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4003 (long)tfirst, (long)tlast);
4005 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4009 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4010 (long)tfirst, (long)(tfirst + diff),
4013 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4014 (long)tfirst, (long)rfirst);
4016 if (rfirst + diff > max)
4017 max = rfirst + diff;
4019 grows = (tfirst < rfirst &&
4020 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4032 else if (max > 0xff)
4037 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4039 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4040 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4041 PAD_SETSV(cPADOPo->op_padix, swash);
4043 SvREADONLY_on(swash);
4045 cSVOPo->op_sv = swash;
4047 SvREFCNT_dec(listsv);
4048 SvREFCNT_dec(transv);
4050 if (!del && havefinal && rlen)
4051 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4052 newSVuv((UV)final), 0);
4055 o->op_private |= OPpTRANS_GROWS;
4061 op_getmad(expr,o,'e');
4062 op_getmad(repl,o,'r');
4070 tbl = (short*)PerlMemShared_calloc(
4071 (o->op_private & OPpTRANS_COMPLEMENT) &&
4072 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4074 cPVOPo->op_pv = (char*)tbl;
4076 for (i = 0; i < (I32)tlen; i++)
4078 for (i = 0, j = 0; i < 256; i++) {
4080 if (j >= (I32)rlen) {
4089 if (i < 128 && r[j] >= 128)
4099 o->op_private |= OPpTRANS_IDENTICAL;
4101 else if (j >= (I32)rlen)
4106 PerlMemShared_realloc(tbl,
4107 (0x101+rlen-j) * sizeof(short));
4108 cPVOPo->op_pv = (char*)tbl;
4110 tbl[0x100] = (short)(rlen - j);
4111 for (i=0; i < (I32)rlen - j; i++)
4112 tbl[0x101+i] = r[j+i];
4116 if (!rlen && !del) {
4119 o->op_private |= OPpTRANS_IDENTICAL;
4121 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4122 o->op_private |= OPpTRANS_IDENTICAL;
4124 for (i = 0; i < 256; i++)
4126 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4127 if (j >= (I32)rlen) {
4129 if (tbl[t[i]] == -1)
4135 if (tbl[t[i]] == -1) {
4136 if (t[i] < 128 && r[j] >= 128)
4143 if(del && rlen == tlen) {
4144 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4145 } else if(rlen > tlen) {
4146 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4150 o->op_private |= OPpTRANS_GROWS;
4152 op_getmad(expr,o,'e');
4153 op_getmad(repl,o,'r');
4163 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4165 Constructs, checks, and returns an op of any pattern matching type.
4166 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4167 and, shifted up eight bits, the eight bits of C<op_private>.
4173 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4178 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4180 NewOp(1101, pmop, 1, PMOP);
4181 pmop->op_type = (OPCODE)type;
4182 pmop->op_ppaddr = PL_ppaddr[type];
4183 pmop->op_flags = (U8)flags;
4184 pmop->op_private = (U8)(0 | (flags >> 8));
4186 if (PL_hints & HINT_RE_TAINT)
4187 pmop->op_pmflags |= PMf_RETAINT;
4188 if (IN_LOCALE_COMPILETIME) {
4189 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4191 else if ((! (PL_hints & HINT_BYTES))
4192 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4193 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4195 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4197 if (PL_hints & HINT_RE_FLAGS) {
4198 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4199 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4201 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4202 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4203 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4205 if (reflags && SvOK(reflags)) {
4206 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4212 assert(SvPOK(PL_regex_pad[0]));
4213 if (SvCUR(PL_regex_pad[0])) {
4214 /* Pop off the "packed" IV from the end. */
4215 SV *const repointer_list = PL_regex_pad[0];
4216 const char *p = SvEND(repointer_list) - sizeof(IV);
4217 const IV offset = *((IV*)p);
4219 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4221 SvEND_set(repointer_list, p);
4223 pmop->op_pmoffset = offset;
4224 /* This slot should be free, so assert this: */
4225 assert(PL_regex_pad[offset] == &PL_sv_undef);
4227 SV * const repointer = &PL_sv_undef;
4228 av_push(PL_regex_padav, repointer);
4229 pmop->op_pmoffset = av_len(PL_regex_padav);
4230 PL_regex_pad = AvARRAY(PL_regex_padav);
4234 return CHECKOP(type, pmop);
4237 /* Given some sort of match op o, and an expression expr containing a
4238 * pattern, either compile expr into a regex and attach it to o (if it's
4239 * constant), or convert expr into a runtime regcomp op sequence (if it's
4242 * isreg indicates that the pattern is part of a regex construct, eg
4243 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4244 * split "pattern", which aren't. In the former case, expr will be a list
4245 * if the pattern contains more than one term (eg /a$b/) or if it contains
4246 * a replacement, ie s/// or tr///.
4248 * When the pattern has been compiled within a new anon CV (for
4249 * qr/(?{...})/ ), then floor indicates the savestack level just before
4250 * the new sub was created
4254 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4259 I32 repl_has_vars = 0;
4261 bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4262 bool is_compiletime;
4265 PERL_ARGS_ASSERT_PMRUNTIME;
4267 /* for s/// and tr///, last element in list is the replacement; pop it */
4269 if (is_trans || o->op_type == OP_SUBST) {
4271 repl = cLISTOPx(expr)->op_last;
4272 kid = cLISTOPx(expr)->op_first;
4273 while (kid->op_sibling != repl)
4274 kid = kid->op_sibling;
4275 kid->op_sibling = NULL;
4276 cLISTOPx(expr)->op_last = kid;
4279 /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4282 OP* const oe = expr;
4283 assert(expr->op_type == OP_LIST);
4284 assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4285 assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4286 expr = cLISTOPx(oe)->op_last;
4287 cLISTOPx(oe)->op_first->op_sibling = NULL;
4288 cLISTOPx(oe)->op_last = NULL;
4291 return pmtrans(o, expr, repl);
4294 /* find whether we have any runtime or code elements;
4295 * at the same time, temporarily set the op_next of each DO block;
4296 * then when we LINKLIST, this will cause the DO blocks to be excluded
4297 * from the op_next chain (and from having LINKLIST recursively
4298 * applied to them). We fix up the DOs specially later */
4302 if (expr->op_type == OP_LIST) {
4304 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4305 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4307 assert(!o->op_next && o->op_sibling);
4308 o->op_next = o->op_sibling;
4310 else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4314 else if (expr->op_type != OP_CONST)
4319 /* fix up DO blocks; treat each one as a separate little sub */
4321 if (expr->op_type == OP_LIST) {
4323 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4324 if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4326 o->op_next = NULL; /* undo temporary hack from above */
4329 if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4330 LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
4332 assert(leave->op_first->op_type == OP_ENTER);
4333 assert(leave->op_first->op_sibling);
4334 o->op_next = leave->op_first->op_sibling;
4336 assert(leave->op_flags & OPf_KIDS);
4337 assert(leave->op_last->op_next = (OP*)leave);
4338 leave->op_next = NULL; /* stop on last op */
4339 op_null((OP*)leave);
4343 OP *scope = cLISTOPo->op_first;
4344 assert(scope->op_type == OP_SCOPE);
4345 assert(scope->op_flags & OPf_KIDS);
4346 scope->op_next = NULL; /* stop on last op */
4349 /* have to peep the DOs individually as we've removed it from
4350 * the op_next chain */
4353 /* runtime finalizes as part of finalizing whole tree */
4358 PL_hints |= HINT_BLOCK_SCOPE;
4360 assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4362 if (is_compiletime) {
4363 U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4364 regexp_engine const *eng = current_re_engine();
4366 if (o->op_flags & OPf_SPECIAL)
4367 rx_flags |= RXf_SPLIT;
4369 if (!has_code || !eng->op_comp) {
4370 /* compile-time simple constant pattern */
4372 if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4373 /* whoops! we guessed that a qr// had a code block, but we
4374 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4375 * that isn't required now. Note that we have to be pretty
4376 * confident that nothing used that CV's pad while the
4377 * regex was parsed */
4378 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
4380 pm->op_pmflags &= ~PMf_HAS_CV;
4385 ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4386 rx_flags, pm->op_pmflags)
4387 : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4388 rx_flags, pm->op_pmflags)
4391 op_getmad(expr,(OP*)pm,'e');
4397 /* compile-time pattern that includes literal code blocks */
4398 REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4399 rx_flags, pm->op_pmflags);
4401 if (pm->op_pmflags & PMf_HAS_CV) {
4403 /* this QR op (and the anon sub we embed it in) is never
4404 * actually executed. It's just a placeholder where we can
4405 * squirrel away expr in op_code_list without the peephole
4406 * optimiser etc processing it for a second time */
4407 OP *qr = newPMOP(OP_QR, 0);
4408 ((PMOP*)qr)->op_code_list = expr;
4410 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4411 SvREFCNT_inc_simple_void(PL_compcv);
4412 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4413 ((struct regexp *)SvANY(re))->qr_anoncv = cv;
4415 /* attach the anon CV to the pad so that
4416 * pad_fixup_inner_anons() can find it */
4417 (void)pad_add_anon(cv, o->op_type);
4418 SvREFCNT_inc_simple_void(cv);
4421 pm->op_code_list = expr;
4426 /* runtime pattern: build chain of regcomp etc ops */
4428 PADOFFSET cv_targ = 0;
4430 reglist = isreg && expr->op_type == OP_LIST;
4435 pm->op_code_list = expr;
4436 /* don't free op_code_list; its ops are embedded elsewhere too */
4437 pm->op_pmflags |= PMf_CODELIST_PRIVATE;
4440 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4441 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4443 : OP_REGCMAYBE),0,expr);
4445 if (pm->op_pmflags & PMf_HAS_CV) {
4446 /* we have a runtime qr with literal code. This means
4447 * that the qr// has been wrapped in a new CV, which
4448 * means that runtime consts, vars etc will have been compiled
4449 * against a new pad. So... we need to execute those ops
4450 * within the environment of the new CV. So wrap them in a call
4451 * to a new anon sub. i.e. for
4455 * we build an anon sub that looks like
4457 * sub { "a", $b, '(?{...})' }
4459 * and call it, passing the returned list to regcomp.
4460 * Or to put it another way, the list of ops that get executed
4464 * ------ -------------------
4465 * pushmark (for regcomp)
4466 * pushmark (for entersub)
4467 * pushmark (for refgen)
4471 * regcreset regcreset
4473 * const("a") const("a")
4475 * const("(?{...})") const("(?{...})")
4480 SvREFCNT_inc_simple_void(PL_compcv);
4481 /* these lines are just an unrolled newANONATTRSUB */
4482 expr = newSVOP(OP_ANONCODE, 0,
4483 MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
4484 cv_targ = expr->op_targ;
4485 expr = newUNOP(OP_REFGEN, 0, expr);
4487 expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
4490 NewOp(1101, rcop, 1, LOGOP);
4491 rcop->op_type = OP_REGCOMP;
4492 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4493 rcop->op_first = scalar(expr);
4494 rcop->op_flags |= OPf_KIDS
4495 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4496 | (reglist ? OPf_STACKED : 0);
4497 rcop->op_private = 0;
4499 rcop->op_targ = cv_targ;
4501 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4502 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4504 /* establish postfix order */
4505 if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
4507 rcop->op_next = expr;
4508 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4511 rcop->op_next = LINKLIST(expr);
4512 expr->op_next = (OP*)rcop;
4515 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4520 if (pm->op_pmflags & PMf_EVAL) {
4522 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4523 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4525 else if (repl->op_type == OP_CONST)
4529 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4530 if (curop->op_type == OP_SCOPE
4531 || curop->op_type == OP_LEAVE
4532 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4533 if (curop->op_type == OP_GV) {
4534 GV * const gv = cGVOPx_gv(curop);
4536 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4539 else if (curop->op_type == OP_RV2CV)
4541 else if (curop->op_type == OP_RV2SV ||
4542 curop->op_type == OP_RV2AV ||
4543 curop->op_type == OP_RV2HV ||
4544 curop->op_type == OP_RV2GV) {
4545 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4548 else if (curop->op_type == OP_PADSV ||
4549 curop->op_type == OP_PADAV ||
4550 curop->op_type == OP_PADHV ||
4551 curop->op_type == OP_PADANY)
4555 else if (curop->op_type == OP_PUSHRE)
4556 NOOP; /* Okay here, dangerous in newASSIGNOP */
4566 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4568 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4569 op_prepend_elem(o->op_type, scalar(repl), o);
4572 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4573 pm->op_pmflags |= PMf_MAYBE_CONST;
4575 NewOp(1101, rcop, 1, LOGOP);
4576 rcop->op_type = OP_SUBSTCONT;
4577 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4578 rcop->op_first = scalar(repl);
4579 rcop->op_flags |= OPf_KIDS;
4580 rcop->op_private = 1;
4583 /* establish postfix order */
4584 rcop->op_next = LINKLIST(repl);
4585 repl->op_next = (OP*)rcop;
4587 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4588 assert(!(pm->op_pmflags & PMf_ONCE));
4589 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4598 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4600 Constructs, checks, and returns an op of any type that involves an
4601 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4602 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4603 takes ownership of one reference to it.
4609 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4614 PERL_ARGS_ASSERT_NEWSVOP;
4616 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4617 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4618 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4620 NewOp(1101, svop, 1, SVOP);
4621 svop->op_type = (OPCODE)type;
4622 svop->op_ppaddr = PL_ppaddr[type];
4624 svop->op_next = (OP*)svop;
4625 svop->op_flags = (U8)flags;
4626 if (PL_opargs[type] & OA_RETSCALAR)
4628 if (PL_opargs[type] & OA_TARGET)
4629 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4630 return CHECKOP(type, svop);
4636 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4638 Constructs, checks, and returns an op of any type that involves a
4639 reference to a pad element. I<type> is the opcode. I<flags> gives the
4640 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4641 is populated with I<sv>; this function takes ownership of one reference
4644 This function only exists if Perl has been compiled to use ithreads.
4650 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4655 PERL_ARGS_ASSERT_NEWPADOP;
4657 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4658 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4659 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4661 NewOp(1101, padop, 1, PADOP);
4662 padop->op_type = (OPCODE)type;
4663 padop->op_ppaddr = PL_ppaddr[type];
4664 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4665 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4666 PAD_SETSV(padop->op_padix, sv);
4669 padop->op_next = (OP*)padop;
4670 padop->op_flags = (U8)flags;
4671 if (PL_opargs[type] & OA_RETSCALAR)
4673 if (PL_opargs[type] & OA_TARGET)
4674 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4675 return CHECKOP(type, padop);
4678 #endif /* !USE_ITHREADS */
4681 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4683 Constructs, checks, and returns an op of any type that involves an
4684 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4685 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4686 reference; calling this function does not transfer ownership of any
4693 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4697 PERL_ARGS_ASSERT_NEWGVOP;
4701 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4703 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4708 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4710 Constructs, checks, and returns an op of any type that involves an
4711 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4712 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4713 must have been allocated using L</PerlMemShared_malloc>; the memory will
4714 be freed when the op is destroyed.
4720 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4723 const bool utf8 = cBOOL(flags & SVf_UTF8);
4728 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4730 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4732 NewOp(1101, pvop, 1, PVOP);
4733 pvop->op_type = (OPCODE)type;
4734 pvop->op_ppaddr = PL_ppaddr[type];
4736 pvop->op_next = (OP*)pvop;
4737 pvop->op_flags = (U8)flags;
4738 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4739 if (PL_opargs[type] & OA_RETSCALAR)
4741 if (PL_opargs[type] & OA_TARGET)
4742 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4743 return CHECKOP(type, pvop);
4751 Perl_package(pTHX_ OP *o)
4754 SV *const sv = cSVOPo->op_sv;
4759 PERL_ARGS_ASSERT_PACKAGE;
4761 SAVEGENERICSV(PL_curstash);
4762 save_item(PL_curstname);
4764 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4766 sv_setsv(PL_curstname, sv);
4768 PL_hints |= HINT_BLOCK_SCOPE;
4769 PL_parser->copline = NOLINE;
4770 PL_parser->expect = XSTATE;
4775 if (!PL_madskills) {
4780 pegop = newOP(OP_NULL,0);
4781 op_getmad(o,pegop,'P');
4787 Perl_package_version( pTHX_ OP *v )
4790 U32 savehints = PL_hints;
4791 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4792 PL_hints &= ~HINT_STRICT_VARS;
4793 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4794 PL_hints = savehints;
4803 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4810 OP *pegop = newOP(OP_NULL,0);
4812 SV *use_version = NULL;
4814 PERL_ARGS_ASSERT_UTILIZE;
4816 if (idop->op_type != OP_CONST)
4817 Perl_croak(aTHX_ "Module name must be constant");
4820 op_getmad(idop,pegop,'U');
4825 SV * const vesv = ((SVOP*)version)->op_sv;
4828 op_getmad(version,pegop,'V');
4829 if (!arg && !SvNIOKp(vesv)) {
4836 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4837 Perl_croak(aTHX_ "Version number must be a constant number");
4839 /* Make copy of idop so we don't free it twice */
4840 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4842 /* Fake up a method call to VERSION */
4843 meth = newSVpvs_share("VERSION");
4844 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4845 op_append_elem(OP_LIST,
4846 op_prepend_elem(OP_LIST, pack, list(version)),
4847 newSVOP(OP_METHOD_NAMED, 0, meth)));
4851 /* Fake up an import/unimport */
4852 if (arg && arg->op_type == OP_STUB) {
4854 op_getmad(arg,pegop,'S');
4855 imop = arg; /* no import on explicit () */
4857 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4858 imop = NULL; /* use 5.0; */
4860 use_version = ((SVOP*)idop)->op_sv;
4862 idop->op_private |= OPpCONST_NOVER;
4868 op_getmad(arg,pegop,'A');
4870 /* Make copy of idop so we don't free it twice */
4871 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4873 /* Fake up a method call to import/unimport */
4875 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4876 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4877 op_append_elem(OP_LIST,
4878 op_prepend_elem(OP_LIST, pack, list(arg)),
4879 newSVOP(OP_METHOD_NAMED, 0, meth)));
4882 /* Fake up the BEGIN {}, which does its thing immediately. */
4884 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4887 op_append_elem(OP_LINESEQ,
4888 op_append_elem(OP_LINESEQ,
4889 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4890 newSTATEOP(0, NULL, veop)),
4891 newSTATEOP(0, NULL, imop) ));
4895 * feature bundle that corresponds to the required version. */
4896 use_version = sv_2mortal(new_version(use_version));
4897 S_enable_feature_bundle(aTHX_ use_version);
4899 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4900 if (vcmp(use_version,
4901 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4902 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4903 PL_hints |= HINT_STRICT_REFS;
4904 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4905 PL_hints |= HINT_STRICT_SUBS;
4906 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4907 PL_hints |= HINT_STRICT_VARS;
4909 /* otherwise they are off */
4911 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4912 PL_hints &= ~HINT_STRICT_REFS;
4913 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4914 PL_hints &= ~HINT_STRICT_SUBS;
4915 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4916 PL_hints &= ~HINT_STRICT_VARS;
4920 /* The "did you use incorrect case?" warning used to be here.
4921 * The problem is that on case-insensitive filesystems one
4922 * might get false positives for "use" (and "require"):
4923 * "use Strict" or "require CARP" will work. This causes
4924 * portability problems for the script: in case-strict
4925 * filesystems the script will stop working.
4927 * The "incorrect case" warning checked whether "use Foo"
4928 * imported "Foo" to your namespace, but that is wrong, too:
4929 * there is no requirement nor promise in the language that
4930 * a Foo.pm should or would contain anything in package "Foo".
4932 * There is very little Configure-wise that can be done, either:
4933 * the case-sensitivity of the build filesystem of Perl does not
4934 * help in guessing the case-sensitivity of the runtime environment.
4937 PL_hints |= HINT_BLOCK_SCOPE;
4938 PL_parser->copline = NOLINE;
4939 PL_parser->expect = XSTATE;
4940 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4941 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4945 if (!PL_madskills) {
4946 /* FIXME - don't allocate pegop if !PL_madskills */
4955 =head1 Embedding Functions
4957 =for apidoc load_module
4959 Loads the module whose name is pointed to by the string part of name.
4960 Note that the actual module name, not its filename, should be given.
4961 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4962 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4963 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4964 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4965 arguments can be used to specify arguments to the module's import()
4966 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4967 terminated with a final NULL pointer. Note that this list can only
4968 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4969 Otherwise at least a single NULL pointer to designate the default
4970 import list is required.
4972 The reference count for each specified C<SV*> parameter is decremented.
4977 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4981 PERL_ARGS_ASSERT_LOAD_MODULE;
4983 va_start(args, ver);
4984 vload_module(flags, name, ver, &args);
4988 #ifdef PERL_IMPLICIT_CONTEXT
4990 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4994 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4995 va_start(args, ver);
4996 vload_module(flags, name, ver, &args);
5002 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5006 OP * const modname = newSVOP(OP_CONST, 0, name);
5008 PERL_ARGS_ASSERT_VLOAD_MODULE;
5010 modname->op_private |= OPpCONST_BARE;
5012 veop = newSVOP(OP_CONST, 0, ver);
5016 if (flags & PERL_LOADMOD_NOIMPORT) {
5017 imop = sawparens(newNULLLIST());
5019 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5020 imop = va_arg(*args, OP*);
5025 sv = va_arg(*args, SV*);
5027 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5028 sv = va_arg(*args, SV*);
5032 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5033 * that it has a PL_parser to play with while doing that, and also
5034 * that it doesn't mess with any existing parser, by creating a tmp
5035 * new parser with lex_start(). This won't actually be used for much,
5036 * since pp_require() will create another parser for the real work. */
5039 SAVEVPTR(PL_curcop);
5040 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5041 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5042 veop, modname, imop);
5047 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5053 PERL_ARGS_ASSERT_DOFILE;
5055 if (!force_builtin) {
5056 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
5057 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5058 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
5059 gv = gvp ? *gvp : NULL;
5063 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5064 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
5065 op_append_elem(OP_LIST, term,
5066 scalar(newUNOP(OP_RV2CV, 0,
5067 newGVOP(OP_GV, 0, gv)))));
5070 doop = newUNOP(OP_DOFILE, 0, scalar(term));
5076 =head1 Optree construction
5078 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5080 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
5081 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5082 be set automatically, and, shifted up eight bits, the eight bits of
5083 C<op_private>, except that the bit with value 1 or 2 is automatically
5084 set as required. I<listval> and I<subscript> supply the parameters of
5085 the slice; they are consumed by this function and become part of the
5086 constructed op tree.
5092 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5094 return newBINOP(OP_LSLICE, flags,
5095 list(force_list(subscript)),
5096 list(force_list(listval)) );
5100 S_is_list_assignment(pTHX_ register const OP *o)
5108 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5109 o = cUNOPo->op_first;
5111 flags = o->op_flags;
5113 if (type == OP_COND_EXPR) {
5114 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5115 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5120 yyerror("Assignment to both a list and a scalar");
5124 if (type == OP_LIST &&
5125 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5126 o->op_private & OPpLVAL_INTRO)
5129 if (type == OP_LIST || flags & OPf_PARENS ||
5130 type == OP_RV2AV || type == OP_RV2HV ||
5131 type == OP_ASLICE || type == OP_HSLICE)
5134 if (type == OP_PADAV || type == OP_PADHV)
5137 if (type == OP_RV2SV)
5144 Helper function for newASSIGNOP to detection commonality between the
5145 lhs and the rhs. Marks all variables with PL_generation. If it
5146 returns TRUE the assignment must be able to handle common variables.
5148 PERL_STATIC_INLINE bool
5149 S_aassign_common_vars(pTHX_ OP* o)
5152 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5153 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5154 if (curop->op_type == OP_GV) {
5155 GV *gv = cGVOPx_gv(curop);
5157 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5159 GvASSIGN_GENERATION_set(gv, PL_generation);
5161 else if (curop->op_type == OP_PADSV ||
5162 curop->op_type == OP_PADAV ||
5163 curop->op_type == OP_PADHV ||
5164 curop->op_type == OP_PADANY)
5166 if (PAD_COMPNAME_GEN(curop->op_targ)
5167 == (STRLEN)PL_generation)
5169 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5172 else if (curop->op_type == OP_RV2CV)
5174 else if (curop->op_type == OP_RV2SV ||
5175 curop->op_type == OP_RV2AV ||
5176 curop->op_type == OP_RV2HV ||
5177 curop->op_type == OP_RV2GV) {
5178 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5181 else if (curop->op_type == OP_PUSHRE) {
5183 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5184 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5186 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5188 GvASSIGN_GENERATION_set(gv, PL_generation);
5192 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5195 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5197 GvASSIGN_GENERATION_set(gv, PL_generation);
5205 if (curop->op_flags & OPf_KIDS) {
5206 if (aassign_common_vars(curop))
5214 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5216 Constructs, checks, and returns an assignment op. I<left> and I<right>
5217 supply the parameters of the assignment; they are consumed by this
5218 function and become part of the constructed op tree.
5220 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5221 a suitable conditional optree is constructed. If I<optype> is the opcode
5222 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5223 performs the binary operation and assigns the result to the left argument.
5224 Either way, if I<optype> is non-zero then I<flags> has no effect.
5226 If I<optype> is zero, then a plain scalar or list assignment is
5227 constructed. Which type of assignment it is is automatically determined.
5228 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5229 will be set automatically, and, shifted up eight bits, the eight bits
5230 of C<op_private>, except that the bit with value 1 or 2 is automatically
5237 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5243 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5244 return newLOGOP(optype, 0,
5245 op_lvalue(scalar(left), optype),
5246 newUNOP(OP_SASSIGN, 0, scalar(right)));
5249 return newBINOP(optype, OPf_STACKED,
5250 op_lvalue(scalar(left), optype), scalar(right));
5254 if (is_list_assignment(left)) {
5255 static const char no_list_state[] = "Initialization of state variables"
5256 " in list context currently forbidden";
5258 bool maybe_common_vars = TRUE;
5261 left = op_lvalue(left, OP_AASSIGN);
5262 curop = list(force_list(left));
5263 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5264 o->op_private = (U8)(0 | (flags >> 8));
5266 if ((left->op_type == OP_LIST
5267 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5269 OP* lop = ((LISTOP*)left)->op_first;
5270 maybe_common_vars = FALSE;
5272 if (lop->op_type == OP_PADSV ||
5273 lop->op_type == OP_PADAV ||
5274 lop->op_type == OP_PADHV ||
5275 lop->op_type == OP_PADANY) {
5276 if (!(lop->op_private & OPpLVAL_INTRO))
5277 maybe_common_vars = TRUE;
5279 if (lop->op_private & OPpPAD_STATE) {
5280 if (left->op_private & OPpLVAL_INTRO) {
5281 /* Each variable in state($a, $b, $c) = ... */
5284 /* Each state variable in
5285 (state $a, my $b, our $c, $d, undef) = ... */
5287 yyerror(no_list_state);
5289 /* Each my variable in
5290 (state $a, my $b, our $c, $d, undef) = ... */
5292 } else if (lop->op_type == OP_UNDEF ||
5293 lop->op_type == OP_PUSHMARK) {
5294 /* undef may be interesting in
5295 (state $a, undef, state $c) */
5297 /* Other ops in the list. */
5298 maybe_common_vars = TRUE;
5300 lop = lop->op_sibling;
5303 else if ((left->op_private & OPpLVAL_INTRO)
5304 && ( left->op_type == OP_PADSV
5305 || left->op_type == OP_PADAV
5306 || left->op_type == OP_PADHV
5307 || left->op_type == OP_PADANY))
5309 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5310 if (left->op_private & OPpPAD_STATE) {
5311 /* All single variable list context state assignments, hence
5321 yyerror(no_list_state);
5325 /* PL_generation sorcery:
5326 * an assignment like ($a,$b) = ($c,$d) is easier than
5327 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5328 * To detect whether there are common vars, the global var
5329 * PL_generation is incremented for each assign op we compile.
5330 * Then, while compiling the assign op, we run through all the
5331 * variables on both sides of the assignment, setting a spare slot
5332 * in each of them to PL_generation. If any of them already have
5333 * that value, we know we've got commonality. We could use a
5334 * single bit marker, but then we'd have to make 2 passes, first
5335 * to clear the flag, then to test and set it. To find somewhere
5336 * to store these values, evil chicanery is done with SvUVX().
5339 if (maybe_common_vars) {
5341 if (aassign_common_vars(o))
5342 o->op_private |= OPpASSIGN_COMMON;
5346 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5347 OP* tmpop = ((LISTOP*)right)->op_first;
5348 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5349 PMOP * const pm = (PMOP*)tmpop;
5350 if (left->op_type == OP_RV2AV &&
5351 !(left->op_private & OPpLVAL_INTRO) &&
5352 !(o->op_private & OPpASSIGN_COMMON) )
5354 tmpop = ((UNOP*)left)->op_first;
5355 if (tmpop->op_type == OP_GV
5357 && !pm->op_pmreplrootu.op_pmtargetoff
5359 && !pm->op_pmreplrootu.op_pmtargetgv
5363 pm->op_pmreplrootu.op_pmtargetoff
5364 = cPADOPx(tmpop)->op_padix;
5365 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5367 pm->op_pmreplrootu.op_pmtargetgv
5368 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5369 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5371 pm->op_pmflags |= PMf_ONCE;
5372 tmpop = cUNOPo->op_first; /* to list (nulled) */
5373 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5374 tmpop->op_sibling = NULL; /* don't free split */
5375 right->op_next = tmpop->op_next; /* fix starting loc */
5376 op_free(o); /* blow off assign */
5377 right->op_flags &= ~OPf_WANT;
5378 /* "I don't know and I don't care." */
5383 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5384 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5386 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5387 if (SvIOK(sv) && SvIVX(sv) == 0)
5388 sv_setiv(sv, PL_modcount+1);
5396 right = newOP(OP_UNDEF, 0);
5397 if (right->op_type == OP_READLINE) {
5398 right->op_flags |= OPf_STACKED;
5399 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5403 o = newBINOP(OP_SASSIGN, flags,
5404 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5410 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5412 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5413 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5414 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5415 If I<label> is non-null, it supplies the name of a label to attach to
5416 the state op; this function takes ownership of the memory pointed at by
5417 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5420 If I<o> is null, the state op is returned. Otherwise the state op is
5421 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5422 is consumed by this function and becomes part of the returned op tree.
5428 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5431 const U32 seq = intro_my();
5432 const U32 utf8 = flags & SVf_UTF8;
5437 NewOp(1101, cop, 1, COP);
5438 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5439 cop->op_type = OP_DBSTATE;
5440 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5443 cop->op_type = OP_NEXTSTATE;
5444 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5446 cop->op_flags = (U8)flags;
5447 CopHINTS_set(cop, PL_hints);
5449 cop->op_private |= NATIVE_HINTS;
5451 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5452 cop->op_next = (OP*)cop;
5455 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5456 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5458 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5460 PL_hints |= HINT_BLOCK_SCOPE;
5461 /* It seems that we need to defer freeing this pointer, as other parts
5462 of the grammar end up wanting to copy it after this op has been
5467 if (PL_parser && PL_parser->copline == NOLINE)
5468 CopLINE_set(cop, CopLINE(PL_curcop));
5470 CopLINE_set(cop, PL_parser->copline);
5472 PL_parser->copline = NOLINE;
5475 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5477 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5479 CopSTASH_set(cop, PL_curstash);
5481 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5482 /* this line can have a breakpoint - store the cop in IV */
5483 AV *av = CopFILEAVx(PL_curcop);
5485 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5486 if (svp && *svp != &PL_sv_undef ) {
5487 (void)SvIOK_on(*svp);
5488 SvIV_set(*svp, PTR2IV(cop));
5493 if (flags & OPf_SPECIAL)
5495 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5499 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5501 Constructs, checks, and returns a logical (flow control) op. I<type>
5502 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5503 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5504 the eight bits of C<op_private>, except that the bit with value 1 is
5505 automatically set. I<first> supplies the expression controlling the
5506 flow, and I<other> supplies the side (alternate) chain of ops; they are
5507 consumed by this function and become part of the constructed op tree.
5513 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5517 PERL_ARGS_ASSERT_NEWLOGOP;
5519 return new_logop(type, flags, &first, &other);
5523 S_search_const(pTHX_ OP *o)
5525 PERL_ARGS_ASSERT_SEARCH_CONST;
5527 switch (o->op_type) {
5531 if (o->op_flags & OPf_KIDS)
5532 return search_const(cUNOPo->op_first);
5539 if (!(o->op_flags & OPf_KIDS))
5541 kid = cLISTOPo->op_first;
5543 switch (kid->op_type) {
5547 kid = kid->op_sibling;
5550 if (kid != cLISTOPo->op_last)
5556 kid = cLISTOPo->op_last;
5558 return search_const(kid);
5566 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5574 int prepend_not = 0;
5576 PERL_ARGS_ASSERT_NEW_LOGOP;
5581 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5582 return newBINOP(type, flags, scalar(first), scalar(other));
5584 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5586 scalarboolean(first);
5587 /* optimize AND and OR ops that have NOTs as children */
5588 if (first->op_type == OP_NOT
5589 && (first->op_flags & OPf_KIDS)
5590 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5591 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5593 if (type == OP_AND || type == OP_OR) {
5599 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5601 prepend_not = 1; /* prepend a NOT op later */
5605 /* search for a constant op that could let us fold the test */
5606 if ((cstop = search_const(first))) {
5607 if (cstop->op_private & OPpCONST_STRICT)
5608 no_bareword_allowed(cstop);
5609 else if ((cstop->op_private & OPpCONST_BARE))
5610 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5611 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5612 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5613 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5615 if (other->op_type == OP_CONST)
5616 other->op_private |= OPpCONST_SHORTCIRCUIT;
5618 OP *newop = newUNOP(OP_NULL, 0, other);
5619 op_getmad(first, newop, '1');
5620 newop->op_targ = type; /* set "was" field */
5624 if (other->op_type == OP_LEAVE)
5625 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5626 else if (other->op_type == OP_MATCH
5627 || other->op_type == OP_SUBST
5628 || other->op_type == OP_TRANSR
5629 || other->op_type == OP_TRANS)
5630 /* Mark the op as being unbindable with =~ */
5631 other->op_flags |= OPf_SPECIAL;
5635 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5636 const OP *o2 = other;
5637 if ( ! (o2->op_type == OP_LIST
5638 && (( o2 = cUNOPx(o2)->op_first))
5639 && o2->op_type == OP_PUSHMARK
5640 && (( o2 = o2->op_sibling)) )
5643 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5644 || o2->op_type == OP_PADHV)
5645 && o2->op_private & OPpLVAL_INTRO
5646 && !(o2->op_private & OPpPAD_STATE))
5648 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5649 "Deprecated use of my() in false conditional");
5653 if (first->op_type == OP_CONST)
5654 first->op_private |= OPpCONST_SHORTCIRCUIT;
5656 first = newUNOP(OP_NULL, 0, first);
5657 op_getmad(other, first, '2');
5658 first->op_targ = type; /* set "was" field */
5665 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5666 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5668 const OP * const k1 = ((UNOP*)first)->op_first;
5669 const OP * const k2 = k1->op_sibling;
5671 switch (first->op_type)
5674 if (k2 && k2->op_type == OP_READLINE
5675 && (k2->op_flags & OPf_STACKED)
5676 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5678 warnop = k2->op_type;
5683 if (k1->op_type == OP_READDIR
5684 || k1->op_type == OP_GLOB
5685 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5686 || k1->op_type == OP_EACH
5687 || k1->op_type == OP_AEACH)
5689 warnop = ((k1->op_type == OP_NULL)
5690 ? (OPCODE)k1->op_targ : k1->op_type);
5695 const line_t oldline = CopLINE(PL_curcop);
5696 CopLINE_set(PL_curcop, PL_parser->copline);
5697 Perl_warner(aTHX_ packWARN(WARN_MISC),
5698 "Value of %s%s can be \"0\"; test with defined()",
5700 ((warnop == OP_READLINE || warnop == OP_GLOB)
5701 ? " construct" : "() operator"));
5702 CopLINE_set(PL_curcop, oldline);
5709 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5710 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5712 NewOp(1101, logop, 1, LOGOP);
5714 logop->op_type = (OPCODE)type;
5715 logop->op_ppaddr = PL_ppaddr[type];
5716 logop->op_first = first;
5717 logop->op_flags = (U8)(flags | OPf_KIDS);
5718 logop->op_other = LINKLIST(other);
5719 logop->op_private = (U8)(1 | (flags >> 8));
5721 /* establish postfix order */
5722 logop->op_next = LINKLIST(first);
5723 first->op_next = (OP*)logop;
5724 first->op_sibling = other;
5726 CHECKOP(type,logop);
5728 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5735 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5737 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5738 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5739 will be set automatically, and, shifted up eight bits, the eight bits of
5740 C<op_private>, except that the bit with value 1 is automatically set.
5741 I<first> supplies the expression selecting between the two branches,
5742 and I<trueop> and I<falseop> supply the branches; they are consumed by
5743 this function and become part of the constructed op tree.
5749 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5757 PERL_ARGS_ASSERT_NEWCONDOP;
5760 return newLOGOP(OP_AND, 0, first, trueop);
5762 return newLOGOP(OP_OR, 0, first, falseop);
5764 scalarboolean(first);
5765 if ((cstop = search_const(first))) {
5766 /* Left or right arm of the conditional? */
5767 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5768 OP *live = left ? trueop : falseop;
5769 OP *const dead = left ? falseop : trueop;
5770 if (cstop->op_private & OPpCONST_BARE &&
5771 cstop->op_private & OPpCONST_STRICT) {
5772 no_bareword_allowed(cstop);
5775 /* This is all dead code when PERL_MAD is not defined. */
5776 live = newUNOP(OP_NULL, 0, live);
5777 op_getmad(first, live, 'C');
5778 op_getmad(dead, live, left ? 'e' : 't');
5783 if (live->op_type == OP_LEAVE)
5784 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5785 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5786 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5787 /* Mark the op as being unbindable with =~ */
5788 live->op_flags |= OPf_SPECIAL;
5791 NewOp(1101, logop, 1, LOGOP);
5792 logop->op_type = OP_COND_EXPR;
5793 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5794 logop->op_first = first;
5795 logop->op_flags = (U8)(flags | OPf_KIDS);
5796 logop->op_private = (U8)(1 | (flags >> 8));
5797 logop->op_other = LINKLIST(trueop);
5798 logop->op_next = LINKLIST(falseop);
5800 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5803 /* establish postfix order */
5804 start = LINKLIST(first);
5805 first->op_next = (OP*)logop;
5807 first->op_sibling = trueop;
5808 trueop->op_sibling = falseop;
5809 o = newUNOP(OP_NULL, 0, (OP*)logop);
5811 trueop->op_next = falseop->op_next = o;
5818 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5820 Constructs and returns a C<range> op, with subordinate C<flip> and
5821 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5822 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5823 for both the C<flip> and C<range> ops, except that the bit with value
5824 1 is automatically set. I<left> and I<right> supply the expressions
5825 controlling the endpoints of the range; they are consumed by this function
5826 and become part of the constructed op tree.
5832 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5841 PERL_ARGS_ASSERT_NEWRANGE;
5843 NewOp(1101, range, 1, LOGOP);
5845 range->op_type = OP_RANGE;
5846 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5847 range->op_first = left;
5848 range->op_flags = OPf_KIDS;
5849 leftstart = LINKLIST(left);
5850 range->op_other = LINKLIST(right);
5851 range->op_private = (U8)(1 | (flags >> 8));
5853 left->op_sibling = right;
5855 range->op_next = (OP*)range;
5856 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5857 flop = newUNOP(OP_FLOP, 0, flip);
5858 o = newUNOP(OP_NULL, 0, flop);
5860 range->op_next = leftstart;
5862 left->op_next = flip;
5863 right->op_next = flop;
5865 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5866 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5867 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5868 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5870 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5871 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5873 /* check barewords before they might be optimized aways */
5874 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5875 no_bareword_allowed(left);
5876 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5877 no_bareword_allowed(right);
5880 if (!flip->op_private || !flop->op_private)
5881 LINKLIST(o); /* blow off optimizer unless constant */
5887 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5889 Constructs, checks, and returns an op tree expressing a loop. This is
5890 only a loop in the control flow through the op tree; it does not have
5891 the heavyweight loop structure that allows exiting the loop by C<last>
5892 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5893 top-level op, except that some bits will be set automatically as required.
5894 I<expr> supplies the expression controlling loop iteration, and I<block>
5895 supplies the body of the loop; they are consumed by this function and
5896 become part of the constructed op tree. I<debuggable> is currently
5897 unused and should always be 1.
5903 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5908 const bool once = block && block->op_flags & OPf_SPECIAL &&
5909 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5911 PERL_UNUSED_ARG(debuggable);
5914 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5915 return block; /* do {} while 0 does once */
5916 if (expr->op_type == OP_READLINE
5917 || expr->op_type == OP_READDIR
5918 || expr->op_type == OP_GLOB
5919 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
5920 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5921 expr = newUNOP(OP_DEFINED, 0,
5922 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5923 } else if (expr->op_flags & OPf_KIDS) {
5924 const OP * const k1 = ((UNOP*)expr)->op_first;
5925 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5926 switch (expr->op_type) {
5928 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5929 && (k2->op_flags & OPf_STACKED)
5930 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5931 expr = newUNOP(OP_DEFINED, 0, expr);
5935 if (k1 && (k1->op_type == OP_READDIR
5936 || k1->op_type == OP_GLOB
5937 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5938 || k1->op_type == OP_EACH
5939 || k1->op_type == OP_AEACH))
5940 expr = newUNOP(OP_DEFINED, 0, expr);
5946 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5947 * op, in listop. This is wrong. [perl #27024] */
5949 block = newOP(OP_NULL, 0);
5950 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5951 o = new_logop(OP_AND, 0, &expr, &listop);
5954 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5956 if (once && o != listop)
5957 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5960 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5962 o->op_flags |= flags;
5964 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5969 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5971 Constructs, checks, and returns an op tree expressing a C<while> loop.
5972 This is a heavyweight loop, with structure that allows exiting the loop
5973 by C<last> and suchlike.
5975 I<loop> is an optional preconstructed C<enterloop> op to use in the
5976 loop; if it is null then a suitable op will be constructed automatically.
5977 I<expr> supplies the loop's controlling expression. I<block> supplies the
5978 main body of the loop, and I<cont> optionally supplies a C<continue> block
5979 that operates as a second half of the body. All of these optree inputs
5980 are consumed by this function and become part of the constructed op tree.
5982 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5983 op and, shifted up eight bits, the eight bits of C<op_private> for
5984 the C<leaveloop> op, except that (in both cases) some bits will be set
5985 automatically. I<debuggable> is currently unused and should always be 1.
5986 I<has_my> can be supplied as true to force the
5987 loop body to be enclosed in its own scope.
5993 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5994 OP *expr, OP *block, OP *cont, I32 has_my)
6003 PERL_UNUSED_ARG(debuggable);
6006 if (expr->op_type == OP_READLINE
6007 || expr->op_type == OP_READDIR
6008 || expr->op_type == OP_GLOB
6009 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6010 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6011 expr = newUNOP(OP_DEFINED, 0,
6012 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6013 } else if (expr->op_flags & OPf_KIDS) {
6014 const OP * const k1 = ((UNOP*)expr)->op_first;
6015 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6016 switch (expr->op_type) {
6018 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6019 && (k2->op_flags & OPf_STACKED)
6020 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6021 expr = newUNOP(OP_DEFINED, 0, expr);
6025 if (k1 && (k1->op_type == OP_READDIR
6026 || k1->op_type == OP_GLOB
6027 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6028 || k1->op_type == OP_EACH
6029 || k1->op_type == OP_AEACH))
6030 expr = newUNOP(OP_DEFINED, 0, expr);
6037 block = newOP(OP_NULL, 0);
6038 else if (cont || has_my) {
6039 block = op_scope(block);
6043 next = LINKLIST(cont);
6046 OP * const unstack = newOP(OP_UNSTACK, 0);
6049 cont = op_append_elem(OP_LINESEQ, cont, unstack);
6053 listop = op_append_list(OP_LINESEQ, block, cont);
6055 redo = LINKLIST(listop);
6059 o = new_logop(OP_AND, 0, &expr, &listop);
6060 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6061 op_free(expr); /* oops, it's a while (0) */
6063 return NULL; /* listop already freed by new_logop */
6066 ((LISTOP*)listop)->op_last->op_next =
6067 (o == listop ? redo : LINKLIST(o));
6073 NewOp(1101,loop,1,LOOP);
6074 loop->op_type = OP_ENTERLOOP;
6075 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6076 loop->op_private = 0;
6077 loop->op_next = (OP*)loop;
6080 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6082 loop->op_redoop = redo;
6083 loop->op_lastop = o;
6084 o->op_private |= loopflags;
6087 loop->op_nextop = next;
6089 loop->op_nextop = o;
6091 o->op_flags |= flags;
6092 o->op_private |= (flags >> 8);
6097 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6099 Constructs, checks, and returns an op tree expressing a C<foreach>
6100 loop (iteration through a list of values). This is a heavyweight loop,
6101 with structure that allows exiting the loop by C<last> and suchlike.
6103 I<sv> optionally supplies the variable that will be aliased to each
6104 item in turn; if null, it defaults to C<$_> (either lexical or global).
6105 I<expr> supplies the list of values to iterate over. I<block> supplies
6106 the main body of the loop, and I<cont> optionally supplies a C<continue>
6107 block that operates as a second half of the body. All of these optree
6108 inputs are consumed by this function and become part of the constructed
6111 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6112 op and, shifted up eight bits, the eight bits of C<op_private> for
6113 the C<leaveloop> op, except that (in both cases) some bits will be set
6120 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6125 PADOFFSET padoff = 0;
6130 PERL_ARGS_ASSERT_NEWFOROP;
6133 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
6134 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6135 sv->op_type = OP_RV2GV;
6136 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6138 /* The op_type check is needed to prevent a possible segfault
6139 * if the loop variable is undeclared and 'strict vars' is in
6140 * effect. This is illegal but is nonetheless parsed, so we
6141 * may reach this point with an OP_CONST where we're expecting
6144 if (cUNOPx(sv)->op_first->op_type == OP_GV
6145 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6146 iterpflags |= OPpITER_DEF;
6148 else if (sv->op_type == OP_PADSV) { /* private variable */
6149 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6150 padoff = sv->op_targ;
6160 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6162 SV *const namesv = PAD_COMPNAME_SV(padoff);
6164 const char *const name = SvPV_const(namesv, len);
6166 if (len == 2 && name[0] == '$' && name[1] == '_')
6167 iterpflags |= OPpITER_DEF;
6171 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6172 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6173 sv = newGVOP(OP_GV, 0, PL_defgv);
6178 iterpflags |= OPpITER_DEF;
6180 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6181 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6182 iterflags |= OPf_STACKED;
6184 else if (expr->op_type == OP_NULL &&
6185 (expr->op_flags & OPf_KIDS) &&
6186 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6188 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6189 * set the STACKED flag to indicate that these values are to be
6190 * treated as min/max values by 'pp_iterinit'.
6192 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6193 LOGOP* const range = (LOGOP*) flip->op_first;
6194 OP* const left = range->op_first;
6195 OP* const right = left->op_sibling;
6198 range->op_flags &= ~OPf_KIDS;
6199 range->op_first = NULL;
6201 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6202 listop->op_first->op_next = range->op_next;
6203 left->op_next = range->op_other;
6204 right->op_next = (OP*)listop;
6205 listop->op_next = listop->op_first;
6208 op_getmad(expr,(OP*)listop,'O');
6212 expr = (OP*)(listop);
6214 iterflags |= OPf_STACKED;
6217 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6220 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6221 op_append_elem(OP_LIST, expr, scalar(sv))));
6222 assert(!loop->op_next);
6223 /* for my $x () sets OPpLVAL_INTRO;
6224 * for our $x () sets OPpOUR_INTRO */
6225 loop->op_private = (U8)iterpflags;
6226 #ifdef PL_OP_SLAB_ALLOC
6229 NewOp(1234,tmp,1,LOOP);
6230 Copy(loop,tmp,1,LISTOP);
6231 S_op_destroy(aTHX_ (OP*)loop);
6235 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6237 loop->op_targ = padoff;
6238 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6240 op_getmad(madsv, (OP*)loop, 'v');
6245 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6247 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6248 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6249 determining the target of the op; it is consumed by this function and
6250 become part of the constructed op tree.
6256 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6261 PERL_ARGS_ASSERT_NEWLOOPEX;
6263 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6265 if (type != OP_GOTO) {
6266 /* "last()" means "last" */
6267 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6268 o = newOP(type, OPf_SPECIAL);
6272 label->op_type == OP_CONST
6273 ? SvUTF8(((SVOP*)label)->op_sv)
6275 savesharedpv(label->op_type == OP_CONST
6276 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6280 op_getmad(label,o,'L');
6286 /* Check whether it's going to be a goto &function */
6287 if (label->op_type == OP_ENTERSUB
6288 && !(label->op_flags & OPf_STACKED))
6289 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6290 else if (label->op_type == OP_CONST) {
6291 SV * const sv = ((SVOP *)label)->op_sv;
6293 const char *s = SvPV_const(sv,l);
6294 if (l == strlen(s)) goto const_label;
6296 o = newUNOP(type, OPf_STACKED, label);
6298 PL_hints |= HINT_BLOCK_SCOPE;
6302 /* if the condition is a literal array or hash
6303 (or @{ ... } etc), make a reference to it.
6306 S_ref_array_or_hash(pTHX_ OP *cond)
6309 && (cond->op_type == OP_RV2AV
6310 || cond->op_type == OP_PADAV
6311 || cond->op_type == OP_RV2HV
6312 || cond->op_type == OP_PADHV))
6314 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6317 && (cond->op_type == OP_ASLICE
6318 || cond->op_type == OP_HSLICE)) {
6320 /* anonlist now needs a list from this op, was previously used in
6322 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6323 cond->op_flags |= OPf_WANT_LIST;
6325 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6332 /* These construct the optree fragments representing given()
6335 entergiven and enterwhen are LOGOPs; the op_other pointer
6336 points up to the associated leave op. We need this so we
6337 can put it in the context and make break/continue work.
6338 (Also, of course, pp_enterwhen will jump straight to
6339 op_other if the match fails.)
6343 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6344 I32 enter_opcode, I32 leave_opcode,
6345 PADOFFSET entertarg)
6351 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6353 NewOp(1101, enterop, 1, LOGOP);
6354 enterop->op_type = (Optype)enter_opcode;
6355 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6356 enterop->op_flags = (U8) OPf_KIDS;
6357 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6358 enterop->op_private = 0;
6360 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6363 enterop->op_first = scalar(cond);
6364 cond->op_sibling = block;
6366 o->op_next = LINKLIST(cond);
6367 cond->op_next = (OP *) enterop;
6370 /* This is a default {} block */
6371 enterop->op_first = block;
6372 enterop->op_flags |= OPf_SPECIAL;
6373 o ->op_flags |= OPf_SPECIAL;
6375 o->op_next = (OP *) enterop;
6378 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6379 entergiven and enterwhen both
6382 enterop->op_next = LINKLIST(block);
6383 block->op_next = enterop->op_other = o;
6388 /* Does this look like a boolean operation? For these purposes
6389 a boolean operation is:
6390 - a subroutine call [*]
6391 - a logical connective
6392 - a comparison operator
6393 - a filetest operator, with the exception of -s -M -A -C
6394 - defined(), exists() or eof()
6395 - /$re/ or $foo =~ /$re/
6397 [*] possibly surprising
6400 S_looks_like_bool(pTHX_ const OP *o)
6404 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6406 switch(o->op_type) {
6409 return looks_like_bool(cLOGOPo->op_first);
6413 looks_like_bool(cLOGOPo->op_first)
6414 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6419 o->op_flags & OPf_KIDS
6420 && looks_like_bool(cUNOPo->op_first));
6424 case OP_NOT: case OP_XOR:
6426 case OP_EQ: case OP_NE: case OP_LT:
6427 case OP_GT: case OP_LE: case OP_GE:
6429 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6430 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6432 case OP_SEQ: case OP_SNE: case OP_SLT:
6433 case OP_SGT: case OP_SLE: case OP_SGE:
6437 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6438 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6439 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6440 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6441 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6442 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6443 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6444 case OP_FTTEXT: case OP_FTBINARY:
6446 case OP_DEFINED: case OP_EXISTS:
6447 case OP_MATCH: case OP_EOF:
6454 /* Detect comparisons that have been optimized away */
6455 if (cSVOPo->op_sv == &PL_sv_yes
6456 || cSVOPo->op_sv == &PL_sv_no)
6469 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6471 Constructs, checks, and returns an op tree expressing a C<given> block.
6472 I<cond> supplies the expression that will be locally assigned to a lexical
6473 variable, and I<block> supplies the body of the C<given> construct; they
6474 are consumed by this function and become part of the constructed op tree.
6475 I<defsv_off> is the pad offset of the scalar lexical variable that will
6482 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6485 PERL_ARGS_ASSERT_NEWGIVENOP;
6486 return newGIVWHENOP(
6487 ref_array_or_hash(cond),
6489 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6494 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6496 Constructs, checks, and returns an op tree expressing a C<when> block.
6497 I<cond> supplies the test expression, and I<block> supplies the block
6498 that will be executed if the test evaluates to true; they are consumed
6499 by this function and become part of the constructed op tree. I<cond>
6500 will be interpreted DWIMically, often as a comparison against C<$_>,
6501 and may be null to generate a C<default> block.
6507 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6509 const bool cond_llb = (!cond || looks_like_bool(cond));
6512 PERL_ARGS_ASSERT_NEWWHENOP;
6517 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6519 scalar(ref_array_or_hash(cond)));
6522 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6526 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6527 const STRLEN len, const U32 flags)
6529 const char * const cvp = CvPROTO(cv);
6530 const STRLEN clen = CvPROTOLEN(cv);
6532 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6534 if (((!p != !cvp) /* One has prototype, one has not. */
6536 (flags & SVf_UTF8) == SvUTF8(cv)
6537 ? len != clen || memNE(cvp, p, len)
6539 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6541 : bytes_cmp_utf8((const U8 *)p, len,
6542 (const U8 *)cvp, clen)
6546 && ckWARN_d(WARN_PROTOTYPE)) {
6547 SV* const msg = sv_newmortal();
6551 gv_efullname3(name = sv_newmortal(), gv, NULL);
6552 sv_setpvs(msg, "Prototype mismatch:");
6554 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6556 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6557 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6560 sv_catpvs(msg, ": none");
6561 sv_catpvs(msg, " vs ");
6563 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6565 sv_catpvs(msg, "none");
6566 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6570 static void const_sv_xsub(pTHX_ CV* cv);
6574 =head1 Optree Manipulation Functions
6576 =for apidoc cv_const_sv
6578 If C<cv> is a constant sub eligible for inlining. returns the constant
6579 value returned by the sub. Otherwise, returns NULL.
6581 Constant subs can be created with C<newCONSTSUB> or as described in
6582 L<perlsub/"Constant Functions">.
6587 Perl_cv_const_sv(pTHX_ const CV *const cv)
6589 PERL_UNUSED_CONTEXT;
6592 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6594 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6597 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6598 * Can be called in 3 ways:
6601 * look for a single OP_CONST with attached value: return the value
6603 * cv && CvCLONE(cv) && !CvCONST(cv)
6605 * examine the clone prototype, and if contains only a single
6606 * OP_CONST referencing a pad const, or a single PADSV referencing
6607 * an outer lexical, return a non-zero value to indicate the CV is
6608 * a candidate for "constizing" at clone time
6612 * We have just cloned an anon prototype that was marked as a const
6613 * candidate. Try to grab the current value, and in the case of
6614 * PADSV, ignore it if it has multiple references. Return the value.
6618 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6629 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6630 o = cLISTOPo->op_first->op_sibling;
6632 for (; o; o = o->op_next) {
6633 const OPCODE type = o->op_type;
6635 if (sv && o->op_next == o)
6637 if (o->op_next != o) {
6638 if (type == OP_NEXTSTATE
6639 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6640 || type == OP_PUSHMARK)
6642 if (type == OP_DBSTATE)
6645 if (type == OP_LEAVESUB || type == OP_RETURN)
6649 if (type == OP_CONST && cSVOPo->op_sv)
6651 else if (cv && type == OP_CONST) {
6652 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6656 else if (cv && type == OP_PADSV) {
6657 if (CvCONST(cv)) { /* newly cloned anon */
6658 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6659 /* the candidate should have 1 ref from this pad and 1 ref
6660 * from the parent */
6661 if (!sv || SvREFCNT(sv) != 2)
6668 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6669 sv = &PL_sv_undef; /* an arbitrary non-null value */
6684 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6687 /* This would be the return value, but the return cannot be reached. */
6688 OP* pegop = newOP(OP_NULL, 0);
6691 PERL_UNUSED_ARG(floor);
6701 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6703 NORETURN_FUNCTION_END;
6708 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6710 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
6714 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
6715 OP *block, U32 flags)
6720 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6722 register CV *cv = NULL;
6724 /* If the subroutine has no body, no attributes, and no builtin attributes
6725 then it's just a sub declaration, and we may be able to get away with
6726 storing with a placeholder scalar in the symbol table, rather than a
6727 full GV and CV. If anything is present then it will take a full CV to
6729 const I32 gv_fetch_flags
6730 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6732 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6734 const bool o_is_gv = flags & 1;
6735 const char * const name =
6736 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
6738 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
6741 assert(proto->op_type == OP_CONST);
6742 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6743 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6753 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6755 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6756 SV * const sv = sv_newmortal();
6757 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6758 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6759 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6760 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6762 } else if (PL_curstash) {
6763 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6766 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6770 if (!PL_madskills) {
6779 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6780 maximum a prototype before. */
6781 if (SvTYPE(gv) > SVt_NULL) {
6782 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6785 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6786 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6789 sv_setiv(MUTABLE_SV(gv), -1);
6791 SvREFCNT_dec(PL_compcv);
6792 cv = PL_compcv = NULL;
6796 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6798 if (!block || !ps || *ps || attrs
6799 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6801 || block->op_type == OP_NULL
6806 const_sv = op_const_sv(block, NULL);
6809 const bool exists = CvROOT(cv) || CvXSUB(cv);
6811 /* if the subroutine doesn't exist and wasn't pre-declared
6812 * with a prototype, assume it will be AUTOLOADed,
6813 * skipping the prototype check
6815 if (exists || SvPOK(cv))
6816 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6817 /* already defined (or promised)? */
6818 if (exists || GvASSUMECV(gv)) {
6821 || block->op_type == OP_NULL
6824 if (CvFLAGS(PL_compcv)) {
6825 /* might have had built-in attrs applied */
6826 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6827 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6828 && ckWARN(WARN_MISC))
6829 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6831 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6832 & ~(CVf_LVALUE * pureperl));
6834 if (attrs) goto attrs;
6835 /* just a "sub foo;" when &foo is already defined */
6836 SAVEFREESV(PL_compcv);
6841 && block->op_type != OP_NULL
6844 const line_t oldline = CopLINE(PL_curcop);
6845 if (PL_parser && PL_parser->copline != NOLINE)
6846 CopLINE_set(PL_curcop, PL_parser->copline);
6847 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
6848 CopLINE_set(PL_curcop, oldline);
6850 if (!PL_minus_c) /* keep old one around for madskills */
6853 /* (PL_madskills unset in used file.) */
6862 SvREFCNT_inc_simple_void_NN(const_sv);
6864 assert(!CvROOT(cv) && !CvCONST(cv));
6865 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6866 CvXSUBANY(cv).any_ptr = const_sv;
6867 CvXSUB(cv) = const_sv_xsub;
6873 cv = newCONSTSUB_flags(
6874 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
6879 (CvGV(cv) && GvSTASH(CvGV(cv)))
6884 if (HvENAME_HEK(stash))
6885 mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
6889 SvREFCNT_dec(PL_compcv);
6893 if (cv) { /* must reuse cv if autoloaded */
6894 /* transfer PL_compcv to cv */
6897 && block->op_type != OP_NULL
6900 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6901 AV *const temp_av = CvPADLIST(cv);
6902 CV *const temp_cv = CvOUTSIDE(cv);
6904 assert(!CvWEAKOUTSIDE(cv));
6905 assert(!CvCVGV_RC(cv));
6906 assert(CvGV(cv) == gv);
6909 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6910 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6911 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6912 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6913 CvOUTSIDE(PL_compcv) = temp_cv;
6914 CvPADLIST(PL_compcv) = temp_av;
6916 if (CvFILE(cv) && CvDYNFILE(cv)) {
6917 Safefree(CvFILE(cv));
6919 CvFILE_set_from_cop(cv, PL_curcop);
6920 CvSTASH_set(cv, PL_curstash);
6922 /* inner references to PL_compcv must be fixed up ... */
6923 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6924 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6925 ++PL_sub_generation;
6928 /* Might have had built-in attributes applied -- propagate them. */
6929 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6931 /* ... before we throw it away */
6932 SvREFCNT_dec(PL_compcv);
6940 if (strEQ(name, "import")) {
6941 PL_formfeed = MUTABLE_SV(cv);
6942 /* diag_listed_as: SKIPME */
6943 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6947 if (HvENAME_HEK(GvSTASH(gv)))
6948 /* sub Foo::bar { (shift)+1 } */
6949 mro_method_changed_in(GvSTASH(gv));
6954 CvFILE_set_from_cop(cv, PL_curcop);
6955 CvSTASH_set(cv, PL_curstash);
6959 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6960 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
6963 if (PL_parser && PL_parser->error_count) {
6967 const char *s = strrchr(name, ':');
6969 if (strEQ(s, "BEGIN")) {
6970 const char not_safe[] =
6971 "BEGIN not safe after errors--compilation aborted";
6972 if (PL_in_eval & EVAL_KEEPERR)
6973 Perl_croak(aTHX_ not_safe);
6975 /* force display of errors found but not reported */
6976 sv_catpv(ERRSV, not_safe);
6977 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6986 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6987 the debugger could be able to set a breakpoint in, so signal to
6988 pp_entereval that it should not throw away any saved lines at scope
6991 PL_breakable_sub_gen++;
6992 /* This makes sub {}; work as expected. */
6993 if (block->op_type == OP_STUB) {
6994 OP* const newblock = newSTATEOP(0, NULL, 0);
6996 op_getmad(block,newblock,'B');
7002 else block->op_attached = 1;
7003 CvROOT(cv) = CvLVALUE(cv)
7004 ? newUNOP(OP_LEAVESUBLV, 0,
7005 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7006 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7007 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7008 OpREFCNT_set(CvROOT(cv), 1);
7009 CvSTART(cv) = LINKLIST(CvROOT(cv));
7010 CvROOT(cv)->op_next = 0;
7011 CALL_PEEP(CvSTART(cv));
7012 finalize_optree(CvROOT(cv));
7014 /* now that optimizer has done its work, adjust pad values */
7016 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7019 assert(!CvCONST(cv));
7020 if (ps && !*ps && op_const_sv(block, cv))
7026 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7027 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
7028 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
7031 if (block && has_name) {
7032 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7033 SV * const tmpstr = sv_newmortal();
7034 GV * const db_postponed = gv_fetchpvs("DB::postponed",
7035 GV_ADDMULTI, SVt_PVHV);
7037 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7040 (long)CopLINE(PL_curcop));
7041 gv_efullname3(tmpstr, gv, NULL);
7042 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7043 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7044 hv = GvHVn(db_postponed);
7045 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7046 CV * const pcv = GvCV(db_postponed);
7052 call_sv(MUTABLE_SV(pcv), G_DISCARD);
7057 if (name && ! (PL_parser && PL_parser->error_count))
7058 process_special_blocks(name, gv, cv);
7063 PL_parser->copline = NOLINE;
7069 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
7072 const char *const colon = strrchr(fullname,':');
7073 const char *const name = colon ? colon + 1 : fullname;
7075 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
7078 if (strEQ(name, "BEGIN")) {
7079 const I32 oldscope = PL_scopestack_ix;
7081 SAVECOPFILE(&PL_compiling);
7082 SAVECOPLINE(&PL_compiling);
7083 SAVEVPTR(PL_curcop);
7085 DEBUG_x( dump_sub(gv) );
7086 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
7087 GvCV_set(gv,0); /* cv has been hijacked */
7088 call_list(oldscope, PL_beginav);
7090 CopHINTS_set(&PL_compiling, PL_hints);
7097 if strEQ(name, "END") {
7098 DEBUG_x( dump_sub(gv) );
7099 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
7102 } else if (*name == 'U') {
7103 if (strEQ(name, "UNITCHECK")) {
7104 /* It's never too late to run a unitcheck block */
7105 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
7109 } else if (*name == 'C') {
7110 if (strEQ(name, "CHECK")) {
7112 /* diag_listed_as: Too late to run %s block */
7113 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7114 "Too late to run CHECK block");
7115 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
7119 } else if (*name == 'I') {
7120 if (strEQ(name, "INIT")) {
7122 /* diag_listed_as: Too late to run %s block */
7123 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
7124 "Too late to run INIT block");
7125 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
7131 DEBUG_x( dump_sub(gv) );
7132 GvCV_set(gv,0); /* cv has been hijacked */
7137 =for apidoc newCONSTSUB
7139 See L</newCONSTSUB_flags>.
7145 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
7147 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
7151 =for apidoc newCONSTSUB_flags
7153 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
7154 eligible for inlining at compile-time.
7156 Currently, the only useful value for C<flags> is SVf_UTF8.
7158 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
7159 which won't be called if used as a destructor, but will suppress the overhead
7160 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
7167 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
7173 const char *const file = CopFILE(PL_curcop);
7175 SV *const temp_sv = CopFILESV(PL_curcop);
7176 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
7181 if (IN_PERL_RUNTIME) {
7182 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7183 * an op shared between threads. Use a non-shared COP for our
7185 SAVEVPTR(PL_curcop);
7186 SAVECOMPILEWARNINGS();
7187 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7188 PL_curcop = &PL_compiling;
7190 SAVECOPLINE(PL_curcop);
7191 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7194 PL_hints &= ~HINT_BLOCK_SCOPE;
7197 SAVEGENERICSV(PL_curstash);
7198 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7201 /* file becomes the CvFILE. For an XS, it's usually static storage,
7202 and so doesn't get free()d. (It's expected to be from the C pre-
7203 processor __FILE__ directive). But we need a dynamically allocated one,
7204 and we need it to get freed. */
7205 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
7206 &sv, XS_DYNAMIC_FILENAME | flags);
7207 CvXSUBANY(cv).any_ptr = sv;
7216 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7217 const char *const filename, const char *const proto,
7220 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7221 return newXS_len_flags(
7222 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7227 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7228 XSUBADDR_t subaddr, const char *const filename,
7229 const char *const proto, SV **const_svp,
7234 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7237 GV * const gv = name
7239 name,len,GV_ADDMULTI|flags,SVt_PVCV
7242 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7243 GV_ADDMULTI | flags, SVt_PVCV);
7246 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7248 if ((cv = (name ? GvCV(gv) : NULL))) {
7250 /* just a cached method */
7254 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7255 /* already defined (or promised) */
7256 /* Redundant check that allows us to avoid creating an SV
7257 most of the time: */
7258 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7259 const line_t oldline = CopLINE(PL_curcop);
7260 if (PL_parser && PL_parser->copline != NOLINE)
7261 CopLINE_set(PL_curcop, PL_parser->copline);
7262 report_redefined_cv(newSVpvn_flags(
7263 name,len,(flags&SVf_UTF8)|SVs_TEMP
7266 CopLINE_set(PL_curcop, oldline);
7273 if (cv) /* must reuse cv if autoloaded */
7276 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7280 if (HvENAME_HEK(GvSTASH(gv)))
7281 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7287 (void)gv_fetchfile(filename);
7288 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7289 an external constant string */
7290 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7292 CvXSUB(cv) = subaddr;
7295 process_special_blocks(name, gv, cv);
7298 if (flags & XS_DYNAMIC_FILENAME) {
7299 CvFILE(cv) = savepv(filename);
7302 sv_setpv(MUTABLE_SV(cv), proto);
7307 =for apidoc U||newXS
7309 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7310 static storage, as it is used directly as CvFILE(), without a copy being made.
7316 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7318 PERL_ARGS_ASSERT_NEWXS;
7319 return newXS_len_flags(
7320 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7329 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7334 OP* pegop = newOP(OP_NULL, 0);
7338 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7339 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7342 if ((cv = GvFORM(gv))) {
7343 if (ckWARN(WARN_REDEFINE)) {
7344 const line_t oldline = CopLINE(PL_curcop);
7345 if (PL_parser && PL_parser->copline != NOLINE)
7346 CopLINE_set(PL_curcop, PL_parser->copline);
7348 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7349 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7351 /* diag_listed_as: Format %s redefined */
7352 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7353 "Format STDOUT redefined");
7355 CopLINE_set(PL_curcop, oldline);
7362 CvFILE_set_from_cop(cv, PL_curcop);
7365 pad_tidy(padtidy_FORMAT);
7366 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7367 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7368 OpREFCNT_set(CvROOT(cv), 1);
7369 CvSTART(cv) = LINKLIST(CvROOT(cv));
7370 CvROOT(cv)->op_next = 0;
7371 CALL_PEEP(CvSTART(cv));
7372 finalize_optree(CvROOT(cv));
7374 op_getmad(o,pegop,'n');
7375 op_getmad_weak(block, pegop, 'b');
7380 PL_parser->copline = NOLINE;
7388 Perl_newANONLIST(pTHX_ OP *o)
7390 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7394 Perl_newANONHASH(pTHX_ OP *o)
7396 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7400 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7402 return newANONATTRSUB(floor, proto, NULL, block);
7406 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7408 return newUNOP(OP_REFGEN, 0,
7409 newSVOP(OP_ANONCODE, 0,
7410 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7414 Perl_oopsAV(pTHX_ OP *o)
7418 PERL_ARGS_ASSERT_OOPSAV;
7420 switch (o->op_type) {
7422 o->op_type = OP_PADAV;
7423 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7424 return ref(o, OP_RV2AV);
7427 o->op_type = OP_RV2AV;
7428 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7433 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7440 Perl_oopsHV(pTHX_ OP *o)
7444 PERL_ARGS_ASSERT_OOPSHV;
7446 switch (o->op_type) {
7449 o->op_type = OP_PADHV;
7450 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7451 return ref(o, OP_RV2HV);
7455 o->op_type = OP_RV2HV;
7456 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7461 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7468 Perl_newAVREF(pTHX_ OP *o)
7472 PERL_ARGS_ASSERT_NEWAVREF;
7474 if (o->op_type == OP_PADANY) {
7475 o->op_type = OP_PADAV;
7476 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7479 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7480 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7481 "Using an array as a reference is deprecated");
7483 return newUNOP(OP_RV2AV, 0, scalar(o));
7487 Perl_newGVREF(pTHX_ I32 type, OP *o)
7489 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7490 return newUNOP(OP_NULL, 0, o);
7491 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7495 Perl_newHVREF(pTHX_ OP *o)
7499 PERL_ARGS_ASSERT_NEWHVREF;
7501 if (o->op_type == OP_PADANY) {
7502 o->op_type = OP_PADHV;
7503 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7506 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7507 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7508 "Using a hash as a reference is deprecated");
7510 return newUNOP(OP_RV2HV, 0, scalar(o));
7514 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7516 return newUNOP(OP_RV2CV, flags, scalar(o));
7520 Perl_newSVREF(pTHX_ OP *o)
7524 PERL_ARGS_ASSERT_NEWSVREF;
7526 if (o->op_type == OP_PADANY) {
7527 o->op_type = OP_PADSV;
7528 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7531 return newUNOP(OP_RV2SV, 0, scalar(o));
7534 /* Check routines. See the comments at the top of this file for details
7535 * on when these are called */
7538 Perl_ck_anoncode(pTHX_ OP *o)
7540 PERL_ARGS_ASSERT_CK_ANONCODE;
7542 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7544 cSVOPo->op_sv = NULL;
7549 Perl_ck_bitop(pTHX_ OP *o)
7553 PERL_ARGS_ASSERT_CK_BITOP;
7555 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7556 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7557 && (o->op_type == OP_BIT_OR
7558 || o->op_type == OP_BIT_AND
7559 || o->op_type == OP_BIT_XOR))
7561 const OP * const left = cBINOPo->op_first;
7562 const OP * const right = left->op_sibling;
7563 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7564 (left->op_flags & OPf_PARENS) == 0) ||
7565 (OP_IS_NUMCOMPARE(right->op_type) &&
7566 (right->op_flags & OPf_PARENS) == 0))
7567 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7568 "Possible precedence problem on bitwise %c operator",
7569 o->op_type == OP_BIT_OR ? '|'
7570 : o->op_type == OP_BIT_AND ? '&' : '^'
7576 PERL_STATIC_INLINE bool
7577 is_dollar_bracket(pTHX_ const OP * const o)
7580 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7581 && (kid = cUNOPx(o)->op_first)
7582 && kid->op_type == OP_GV
7583 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7587 Perl_ck_cmp(pTHX_ OP *o)
7589 PERL_ARGS_ASSERT_CK_CMP;
7590 if (ckWARN(WARN_SYNTAX)) {
7591 const OP *kid = cUNOPo->op_first;
7594 is_dollar_bracket(aTHX_ kid)
7595 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
7597 || ( kid->op_type == OP_CONST
7598 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7600 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7601 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7607 Perl_ck_concat(pTHX_ OP *o)
7609 const OP * const kid = cUNOPo->op_first;
7611 PERL_ARGS_ASSERT_CK_CONCAT;
7612 PERL_UNUSED_CONTEXT;
7614 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7615 !(kUNOP->op_first->op_flags & OPf_MOD))
7616 o->op_flags |= OPf_STACKED;
7621 Perl_ck_spair(pTHX_ OP *o)
7625 PERL_ARGS_ASSERT_CK_SPAIR;
7627 if (o->op_flags & OPf_KIDS) {
7630 const OPCODE type = o->op_type;
7631 o = modkids(ck_fun(o), type);
7632 kid = cUNOPo->op_first;
7633 newop = kUNOP->op_first->op_sibling;
7635 const OPCODE type = newop->op_type;
7636 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7637 type == OP_PADAV || type == OP_PADHV ||
7638 type == OP_RV2AV || type == OP_RV2HV)
7642 op_getmad(kUNOP->op_first,newop,'K');
7644 op_free(kUNOP->op_first);
7646 kUNOP->op_first = newop;
7648 o->op_ppaddr = PL_ppaddr[++o->op_type];
7653 Perl_ck_delete(pTHX_ OP *o)
7655 PERL_ARGS_ASSERT_CK_DELETE;
7659 if (o->op_flags & OPf_KIDS) {
7660 OP * const kid = cUNOPo->op_first;
7661 switch (kid->op_type) {
7663 o->op_flags |= OPf_SPECIAL;
7666 o->op_private |= OPpSLICE;
7669 o->op_flags |= OPf_SPECIAL;
7674 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7677 if (kid->op_private & OPpLVAL_INTRO)
7678 o->op_private |= OPpLVAL_INTRO;
7685 Perl_ck_die(pTHX_ OP *o)
7687 PERL_ARGS_ASSERT_CK_DIE;
7690 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7696 Perl_ck_eof(pTHX_ OP *o)
7700 PERL_ARGS_ASSERT_CK_EOF;
7702 if (o->op_flags & OPf_KIDS) {
7704 if (cLISTOPo->op_first->op_type == OP_STUB) {
7706 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7708 op_getmad(o,newop,'O');
7715 kid = cLISTOPo->op_first;
7716 if (kid->op_type == OP_RV2GV)
7717 kid->op_private |= OPpALLOW_FAKE;
7723 Perl_ck_eval(pTHX_ OP *o)
7727 PERL_ARGS_ASSERT_CK_EVAL;
7729 PL_hints |= HINT_BLOCK_SCOPE;
7730 if (o->op_flags & OPf_KIDS) {
7731 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7734 o->op_flags &= ~OPf_KIDS;
7737 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7743 cUNOPo->op_first = 0;
7748 NewOp(1101, enter, 1, LOGOP);
7749 enter->op_type = OP_ENTERTRY;
7750 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7751 enter->op_private = 0;
7753 /* establish postfix order */
7754 enter->op_next = (OP*)enter;
7756 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7757 o->op_type = OP_LEAVETRY;
7758 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7759 enter->op_other = o;
7760 op_getmad(oldo,o,'O');
7769 const U8 priv = o->op_private;
7775 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
7776 op_getmad(oldo,o,'O');
7778 o->op_targ = (PADOFFSET)PL_hints;
7779 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7780 if ((PL_hints & HINT_LOCALIZE_HH) != 0
7781 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
7782 /* Store a copy of %^H that pp_entereval can pick up. */
7783 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7784 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7785 cUNOPo->op_first->op_sibling = hhop;
7786 o->op_private |= OPpEVAL_HAS_HH;
7788 if (!(o->op_private & OPpEVAL_BYTES)
7789 && FEATURE_UNIEVAL_IS_ENABLED)
7790 o->op_private |= OPpEVAL_UNICODE;
7795 Perl_ck_exit(pTHX_ OP *o)
7797 PERL_ARGS_ASSERT_CK_EXIT;
7800 HV * const table = GvHV(PL_hintgv);
7802 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7803 if (svp && *svp && SvTRUE(*svp))
7804 o->op_private |= OPpEXIT_VMSISH;
7806 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7812 Perl_ck_exec(pTHX_ OP *o)
7814 PERL_ARGS_ASSERT_CK_EXEC;
7816 if (o->op_flags & OPf_STACKED) {
7819 kid = cUNOPo->op_first->op_sibling;
7820 if (kid->op_type == OP_RV2GV)
7829 Perl_ck_exists(pTHX_ OP *o)
7833 PERL_ARGS_ASSERT_CK_EXISTS;
7836 if (o->op_flags & OPf_KIDS) {
7837 OP * const kid = cUNOPo->op_first;
7838 if (kid->op_type == OP_ENTERSUB) {
7839 (void) ref(kid, o->op_type);
7840 if (kid->op_type != OP_RV2CV
7841 && !(PL_parser && PL_parser->error_count))
7842 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7844 o->op_private |= OPpEXISTS_SUB;
7846 else if (kid->op_type == OP_AELEM)
7847 o->op_flags |= OPf_SPECIAL;
7848 else if (kid->op_type != OP_HELEM)
7849 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7857 Perl_ck_rvconst(pTHX_ register OP *o)
7860 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7862 PERL_ARGS_ASSERT_CK_RVCONST;
7864 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7865 if (o->op_type == OP_RV2CV)
7866 o->op_private &= ~1;
7868 if (kid->op_type == OP_CONST) {
7871 SV * const kidsv = kid->op_sv;
7873 /* Is it a constant from cv_const_sv()? */
7874 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7875 SV * const rsv = SvRV(kidsv);
7876 const svtype type = SvTYPE(rsv);
7877 const char *badtype = NULL;
7879 switch (o->op_type) {
7881 if (type > SVt_PVMG)
7882 badtype = "a SCALAR";
7885 if (type != SVt_PVAV)
7886 badtype = "an ARRAY";
7889 if (type != SVt_PVHV)
7893 if (type != SVt_PVCV)
7898 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7901 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7902 const char *badthing;
7903 switch (o->op_type) {
7905 badthing = "a SCALAR";
7908 badthing = "an ARRAY";
7911 badthing = "a HASH";
7919 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7920 SVfARG(kidsv), badthing);
7923 * This is a little tricky. We only want to add the symbol if we
7924 * didn't add it in the lexer. Otherwise we get duplicate strict
7925 * warnings. But if we didn't add it in the lexer, we must at
7926 * least pretend like we wanted to add it even if it existed before,
7927 * or we get possible typo warnings. OPpCONST_ENTERED says
7928 * whether the lexer already added THIS instance of this symbol.
7930 iscv = (o->op_type == OP_RV2CV) * 2;
7932 gv = gv_fetchsv(kidsv,
7933 iscv | !(kid->op_private & OPpCONST_ENTERED),
7936 : o->op_type == OP_RV2SV
7938 : o->op_type == OP_RV2AV
7940 : o->op_type == OP_RV2HV
7943 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7945 kid->op_type = OP_GV;
7946 SvREFCNT_dec(kid->op_sv);
7948 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7949 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7950 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7952 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7954 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7956 kid->op_private = 0;
7957 kid->op_ppaddr = PL_ppaddr[OP_GV];
7958 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7966 Perl_ck_ftst(pTHX_ OP *o)
7969 const I32 type = o->op_type;
7971 PERL_ARGS_ASSERT_CK_FTST;
7973 if (o->op_flags & OPf_REF) {
7976 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7977 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7978 const OPCODE kidtype = kid->op_type;
7980 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7981 OP * const newop = newGVOP(type, OPf_REF,
7982 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7984 op_getmad(o,newop,'O');
7990 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7991 o->op_private |= OPpFT_ACCESS;
7992 if (PL_check[kidtype] == Perl_ck_ftst
7993 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7994 o->op_private |= OPpFT_STACKED;
7995 kid->op_private |= OPpFT_STACKING;
7996 if (kidtype == OP_FTTTY && (
7997 !(kid->op_private & OPpFT_STACKED)
7998 || kid->op_private & OPpFT_AFTER_t
8000 o->op_private |= OPpFT_AFTER_t;
8009 if (type == OP_FTTTY)
8010 o = newGVOP(type, OPf_REF, PL_stdingv);
8012 o = newUNOP(type, 0, newDEFSVOP());
8013 op_getmad(oldo,o,'O');
8019 Perl_ck_fun(pTHX_ OP *o)
8022 const int type = o->op_type;
8023 register I32 oa = PL_opargs[type] >> OASHIFT;
8025 PERL_ARGS_ASSERT_CK_FUN;
8027 if (o->op_flags & OPf_STACKED) {
8028 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
8031 return no_fh_allowed(o);
8034 if (o->op_flags & OPf_KIDS) {
8035 OP **tokid = &cLISTOPo->op_first;
8036 register OP *kid = cLISTOPo->op_first;
8039 bool seen_optional = FALSE;
8041 if (kid->op_type == OP_PUSHMARK ||
8042 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
8044 tokid = &kid->op_sibling;
8045 kid = kid->op_sibling;
8047 if (kid && kid->op_type == OP_COREARGS) {
8048 bool optional = FALSE;
8051 if (oa & OA_OPTIONAL) optional = TRUE;
8054 if (optional) o->op_private |= numargs;
8059 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
8060 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
8061 *tokid = kid = newDEFSVOP();
8062 seen_optional = TRUE;
8067 sibl = kid->op_sibling;
8069 if (!sibl && kid->op_type == OP_STUB) {
8076 /* list seen where single (scalar) arg expected? */
8077 if (numargs == 1 && !(oa >> 4)
8078 && kid->op_type == OP_LIST && type != OP_SCALAR)
8080 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8093 if ((type == OP_PUSH || type == OP_UNSHIFT)
8094 && !kid->op_sibling)
8095 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8096 "Useless use of %s with no values",
8099 if (kid->op_type == OP_CONST &&
8100 (kid->op_private & OPpCONST_BARE))
8102 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
8103 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
8104 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8105 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
8106 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8108 op_getmad(kid,newop,'K');
8113 kid->op_sibling = sibl;
8116 else if (kid->op_type == OP_CONST
8117 && ( !SvROK(cSVOPx_sv(kid))
8118 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
8120 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
8121 /* Defer checks to run-time if we have a scalar arg */
8122 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
8123 op_lvalue(kid, type);
8127 if (kid->op_type == OP_CONST &&
8128 (kid->op_private & OPpCONST_BARE))
8130 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
8131 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
8132 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8133 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
8134 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
8136 op_getmad(kid,newop,'K');
8141 kid->op_sibling = sibl;
8144 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
8145 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
8146 op_lvalue(kid, type);
8150 OP * const newop = newUNOP(OP_NULL, 0, kid);
8151 kid->op_sibling = 0;
8153 newop->op_next = newop;
8155 kid->op_sibling = sibl;
8160 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
8161 if (kid->op_type == OP_CONST &&
8162 (kid->op_private & OPpCONST_BARE))
8164 OP * const newop = newGVOP(OP_GV, 0,
8165 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
8166 if (!(o->op_private & 1) && /* if not unop */
8167 kid == cLISTOPo->op_last)
8168 cLISTOPo->op_last = newop;
8170 op_getmad(kid,newop,'K');
8176 else if (kid->op_type == OP_READLINE) {
8177 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8178 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8181 I32 flags = OPf_SPECIAL;
8185 /* is this op a FH constructor? */
8186 if (is_handle_constructor(o,numargs)) {
8187 const char *name = NULL;
8190 bool want_dollar = TRUE;
8193 /* Set a flag to tell rv2gv to vivify
8194 * need to "prove" flag does not mean something
8195 * else already - NI-S 1999/05/07
8198 if (kid->op_type == OP_PADSV) {
8200 = PAD_COMPNAME_SV(kid->op_targ);
8201 name = SvPV_const(namesv, len);
8202 name_utf8 = SvUTF8(namesv);
8204 else if (kid->op_type == OP_RV2SV
8205 && kUNOP->op_first->op_type == OP_GV)
8207 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8209 len = GvNAMELEN(gv);
8210 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8212 else if (kid->op_type == OP_AELEM
8213 || kid->op_type == OP_HELEM)
8216 OP *op = ((BINOP*)kid)->op_first;
8220 const char * const a =
8221 kid->op_type == OP_AELEM ?
8223 if (((op->op_type == OP_RV2AV) ||
8224 (op->op_type == OP_RV2HV)) &&
8225 (firstop = ((UNOP*)op)->op_first) &&
8226 (firstop->op_type == OP_GV)) {
8227 /* packagevar $a[] or $h{} */
8228 GV * const gv = cGVOPx_gv(firstop);
8236 else if (op->op_type == OP_PADAV
8237 || op->op_type == OP_PADHV) {
8238 /* lexicalvar $a[] or $h{} */
8239 const char * const padname =
8240 PAD_COMPNAME_PV(op->op_targ);
8249 name = SvPV_const(tmpstr, len);
8250 name_utf8 = SvUTF8(tmpstr);
8255 name = "__ANONIO__";
8257 want_dollar = FALSE;
8259 op_lvalue(kid, type);
8263 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8264 namesv = PAD_SVl(targ);
8265 SvUPGRADE(namesv, SVt_PV);
8266 if (want_dollar && *name != '$')
8267 sv_setpvs(namesv, "$");
8268 sv_catpvn(namesv, name, len);
8269 if ( name_utf8 ) SvUTF8_on(namesv);
8272 kid->op_sibling = 0;
8273 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8274 kid->op_targ = targ;
8275 kid->op_private |= priv;
8277 kid->op_sibling = sibl;
8283 if ((type == OP_UNDEF || type == OP_POS)
8284 && numargs == 1 && !(oa >> 4)
8285 && kid->op_type == OP_LIST)
8286 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8287 op_lvalue(scalar(kid), type);
8291 tokid = &kid->op_sibling;
8292 kid = kid->op_sibling;
8295 if (kid && kid->op_type != OP_STUB)
8296 return too_many_arguments_pv(o,OP_DESC(o), 0);
8297 o->op_private |= numargs;
8299 /* FIXME - should the numargs move as for the PERL_MAD case? */
8300 o->op_private |= numargs;
8302 return too_many_arguments_pv(o,OP_DESC(o), 0);
8306 else if (PL_opargs[type] & OA_DEFGV) {
8308 OP *newop = newUNOP(type, 0, newDEFSVOP());
8309 op_getmad(o,newop,'O');
8312 /* Ordering of these two is important to keep f_map.t passing. */
8314 return newUNOP(type, 0, newDEFSVOP());
8319 while (oa & OA_OPTIONAL)
8321 if (oa && oa != OA_LIST)
8322 return too_few_arguments_pv(o,OP_DESC(o), 0);
8328 Perl_ck_glob(pTHX_ OP *o)
8332 const bool core = o->op_flags & OPf_SPECIAL;
8334 PERL_ARGS_ASSERT_CK_GLOB;
8337 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8338 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8340 if (core) gv = NULL;
8341 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8342 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8344 GV * const * const gvp =
8345 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
8346 gv = gvp ? *gvp : NULL;
8349 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8352 * \ null - const(wildcard)
8357 * \ mark - glob - rv2cv
8358 * | \ gv(CORE::GLOBAL::glob)
8360 * \ null - const(wildcard) - const(ix)
8362 o->op_flags |= OPf_SPECIAL;
8363 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8364 op_append_elem(OP_GLOB, o,
8365 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8366 o = newLISTOP(OP_LIST, 0, o, NULL);
8367 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8368 op_append_elem(OP_LIST, o,
8369 scalar(newUNOP(OP_RV2CV, 0,
8370 newGVOP(OP_GV, 0, gv)))));
8371 o = newUNOP(OP_NULL, 0, o);
8372 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8375 else o->op_flags &= ~OPf_SPECIAL;
8376 #if !defined(PERL_EXTERNAL_GLOB)
8379 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8380 newSVpvs("File::Glob"), NULL, NULL, NULL);
8383 #endif /* !PERL_EXTERNAL_GLOB */
8384 gv = newGVgen("main");
8386 #ifndef PERL_EXTERNAL_GLOB
8387 sv_setiv(GvSVn(gv),PL_glob_index++);
8389 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8395 Perl_ck_grep(pTHX_ OP *o)
8400 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8403 PERL_ARGS_ASSERT_CK_GREP;
8405 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8406 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8408 if (o->op_flags & OPf_STACKED) {
8411 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8412 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8413 return no_fh_allowed(o);
8414 for (k = kid; k; k = k->op_next) {
8417 NewOp(1101, gwop, 1, LOGOP);
8418 kid->op_next = (OP*)gwop;
8419 o->op_flags &= ~OPf_STACKED;
8421 kid = cLISTOPo->op_first->op_sibling;
8422 if (type == OP_MAPWHILE)
8427 if (PL_parser && PL_parser->error_count)
8429 kid = cLISTOPo->op_first->op_sibling;
8430 if (kid->op_type != OP_NULL)
8431 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8432 kid = kUNOP->op_first;
8435 NewOp(1101, gwop, 1, LOGOP);
8436 gwop->op_type = type;
8437 gwop->op_ppaddr = PL_ppaddr[type];
8438 gwop->op_first = listkids(o);
8439 gwop->op_flags |= OPf_KIDS;
8440 gwop->op_other = LINKLIST(kid);
8441 kid->op_next = (OP*)gwop;
8442 offset = pad_findmy_pvs("$_", 0);
8443 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8444 o->op_private = gwop->op_private = 0;
8445 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8448 o->op_private = gwop->op_private = OPpGREP_LEX;
8449 gwop->op_targ = o->op_targ = offset;
8452 kid = cLISTOPo->op_first->op_sibling;
8453 if (!kid || !kid->op_sibling)
8454 return too_few_arguments_pv(o,OP_DESC(o), 0);
8455 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8456 op_lvalue(kid, OP_GREPSTART);
8462 Perl_ck_index(pTHX_ OP *o)
8464 PERL_ARGS_ASSERT_CK_INDEX;
8466 if (o->op_flags & OPf_KIDS) {
8467 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8469 kid = kid->op_sibling; /* get past "big" */
8470 if (kid && kid->op_type == OP_CONST) {
8471 const bool save_taint = PL_tainted;
8472 fbm_compile(((SVOP*)kid)->op_sv, 0);
8473 PL_tainted = save_taint;
8480 Perl_ck_lfun(pTHX_ OP *o)
8482 const OPCODE type = o->op_type;
8484 PERL_ARGS_ASSERT_CK_LFUN;
8486 return modkids(ck_fun(o), type);
8490 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8492 PERL_ARGS_ASSERT_CK_DEFINED;
8494 if ((o->op_flags & OPf_KIDS)) {
8495 switch (cUNOPo->op_first->op_type) {
8498 case OP_AASSIGN: /* Is this a good idea? */
8499 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8500 "defined(@array) is deprecated");
8501 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8502 "\t(Maybe you should just omit the defined()?)\n");
8506 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8507 "defined(%%hash) is deprecated");
8508 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8509 "\t(Maybe you should just omit the defined()?)\n");
8520 Perl_ck_readline(pTHX_ OP *o)
8522 PERL_ARGS_ASSERT_CK_READLINE;
8524 if (o->op_flags & OPf_KIDS) {
8525 OP *kid = cLISTOPo->op_first;
8526 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
8530 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8532 op_getmad(o,newop,'O');
8542 Perl_ck_rfun(pTHX_ OP *o)
8544 const OPCODE type = o->op_type;
8546 PERL_ARGS_ASSERT_CK_RFUN;
8548 return refkids(ck_fun(o), type);
8552 Perl_ck_listiob(pTHX_ OP *o)
8556 PERL_ARGS_ASSERT_CK_LISTIOB;
8558 kid = cLISTOPo->op_first;
8561 kid = cLISTOPo->op_first;
8563 if (kid->op_type == OP_PUSHMARK)
8564 kid = kid->op_sibling;
8565 if (kid && o->op_flags & OPf_STACKED)
8566 kid = kid->op_sibling;
8567 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8568 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8569 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8570 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8571 cLISTOPo->op_first->op_sibling = kid;
8572 cLISTOPo->op_last = kid;
8573 kid = kid->op_sibling;
8578 op_append_elem(o->op_type, o, newDEFSVOP());
8580 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
8585 Perl_ck_smartmatch(pTHX_ OP *o)
8588 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8589 if (0 == (o->op_flags & OPf_SPECIAL)) {
8590 OP *first = cBINOPo->op_first;
8591 OP *second = first->op_sibling;
8593 /* Implicitly take a reference to an array or hash */
8594 first->op_sibling = NULL;
8595 first = cBINOPo->op_first = ref_array_or_hash(first);
8596 second = first->op_sibling = ref_array_or_hash(second);
8598 /* Implicitly take a reference to a regular expression */
8599 if (first->op_type == OP_MATCH) {
8600 first->op_type = OP_QR;
8601 first->op_ppaddr = PL_ppaddr[OP_QR];
8603 if (second->op_type == OP_MATCH) {
8604 second->op_type = OP_QR;
8605 second->op_ppaddr = PL_ppaddr[OP_QR];
8614 Perl_ck_sassign(pTHX_ OP *o)
8617 OP * const kid = cLISTOPo->op_first;
8619 PERL_ARGS_ASSERT_CK_SASSIGN;
8621 /* has a disposable target? */
8622 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8623 && !(kid->op_flags & OPf_STACKED)
8624 /* Cannot steal the second time! */
8625 && !(kid->op_private & OPpTARGET_MY)
8626 /* Keep the full thing for madskills */
8630 OP * const kkid = kid->op_sibling;
8632 /* Can just relocate the target. */
8633 if (kkid && kkid->op_type == OP_PADSV
8634 && !(kkid->op_private & OPpLVAL_INTRO))
8636 kid->op_targ = kkid->op_targ;
8638 /* Now we do not need PADSV and SASSIGN. */
8639 kid->op_sibling = o->op_sibling; /* NULL */
8640 cLISTOPo->op_first = NULL;
8643 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8647 if (kid->op_sibling) {
8648 OP *kkid = kid->op_sibling;
8649 /* For state variable assignment, kkid is a list op whose op_last
8651 if ((kkid->op_type == OP_PADSV ||
8652 (kkid->op_type == OP_LIST &&
8653 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8656 && (kkid->op_private & OPpLVAL_INTRO)
8657 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8658 const PADOFFSET target = kkid->op_targ;
8659 OP *const other = newOP(OP_PADSV,
8661 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8662 OP *const first = newOP(OP_NULL, 0);
8663 OP *const nullop = newCONDOP(0, first, o, other);
8664 OP *const condop = first->op_next;
8665 /* hijacking PADSTALE for uninitialized state variables */
8666 SvPADSTALE_on(PAD_SVl(target));
8668 condop->op_type = OP_ONCE;
8669 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8670 condop->op_targ = target;
8671 other->op_targ = target;
8673 /* Because we change the type of the op here, we will skip the
8674 assignment binop->op_last = binop->op_first->op_sibling; at the
8675 end of Perl_newBINOP(). So need to do it here. */
8676 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8685 Perl_ck_match(pTHX_ OP *o)
8689 PERL_ARGS_ASSERT_CK_MATCH;
8691 if (o->op_type != OP_QR && PL_compcv) {
8692 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8693 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8694 o->op_targ = offset;
8695 o->op_private |= OPpTARGET_MY;
8698 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8699 o->op_private |= OPpRUNTIME;
8704 Perl_ck_method(pTHX_ OP *o)
8706 OP * const kid = cUNOPo->op_first;
8708 PERL_ARGS_ASSERT_CK_METHOD;
8710 if (kid->op_type == OP_CONST) {
8711 SV* sv = kSVOP->op_sv;
8712 const char * const method = SvPVX_const(sv);
8713 if (!(strchr(method, ':') || strchr(method, '\''))) {
8715 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8716 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8719 kSVOP->op_sv = NULL;
8721 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8723 op_getmad(o,cmop,'O');
8734 Perl_ck_null(pTHX_ OP *o)
8736 PERL_ARGS_ASSERT_CK_NULL;
8737 PERL_UNUSED_CONTEXT;
8742 Perl_ck_open(pTHX_ OP *o)
8745 HV * const table = GvHV(PL_hintgv);
8747 PERL_ARGS_ASSERT_CK_OPEN;
8750 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8753 const char *d = SvPV_const(*svp, len);
8754 const I32 mode = mode_from_discipline(d, len);
8755 if (mode & O_BINARY)
8756 o->op_private |= OPpOPEN_IN_RAW;
8757 else if (mode & O_TEXT)
8758 o->op_private |= OPpOPEN_IN_CRLF;
8761 svp = hv_fetchs(table, "open_OUT", FALSE);
8764 const char *d = SvPV_const(*svp, len);
8765 const I32 mode = mode_from_discipline(d, len);
8766 if (mode & O_BINARY)
8767 o->op_private |= OPpOPEN_OUT_RAW;
8768 else if (mode & O_TEXT)
8769 o->op_private |= OPpOPEN_OUT_CRLF;
8772 if (o->op_type == OP_BACKTICK) {
8773 if (!(o->op_flags & OPf_KIDS)) {
8774 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8776 op_getmad(o,newop,'O');
8785 /* In case of three-arg dup open remove strictness
8786 * from the last arg if it is a bareword. */
8787 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8788 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8792 if ((last->op_type == OP_CONST) && /* The bareword. */
8793 (last->op_private & OPpCONST_BARE) &&
8794 (last->op_private & OPpCONST_STRICT) &&
8795 (oa = first->op_sibling) && /* The fh. */
8796 (oa = oa->op_sibling) && /* The mode. */
8797 (oa->op_type == OP_CONST) &&
8798 SvPOK(((SVOP*)oa)->op_sv) &&
8799 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8800 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8801 (last == oa->op_sibling)) /* The bareword. */
8802 last->op_private &= ~OPpCONST_STRICT;
8808 Perl_ck_repeat(pTHX_ OP *o)
8810 PERL_ARGS_ASSERT_CK_REPEAT;
8812 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8813 o->op_private |= OPpREPEAT_DOLIST;
8814 cBINOPo->op_first = force_list(cBINOPo->op_first);
8822 Perl_ck_require(pTHX_ OP *o)
8827 PERL_ARGS_ASSERT_CK_REQUIRE;
8829 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8830 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8832 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8833 SV * const sv = kid->op_sv;
8834 U32 was_readonly = SvREADONLY(sv);
8841 sv_force_normal_flags(sv, 0);
8842 assert(!SvREADONLY(sv));
8852 for (; s < end; s++) {
8853 if (*s == ':' && s[1] == ':') {
8855 Move(s+2, s+1, end - s - 1, char);
8860 sv_catpvs(sv, ".pm");
8861 SvFLAGS(sv) |= was_readonly;
8865 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8866 /* handle override, if any */
8867 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8868 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8869 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8870 gv = gvp ? *gvp : NULL;
8874 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8876 if (o->op_flags & OPf_KIDS) {
8877 kid = cUNOPo->op_first;
8878 cUNOPo->op_first = NULL;
8886 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
8887 op_append_elem(OP_LIST, kid,
8888 scalar(newUNOP(OP_RV2CV, 0,
8891 op_getmad(o,newop,'O');
8895 return scalar(ck_fun(o));
8899 Perl_ck_return(pTHX_ OP *o)
8904 PERL_ARGS_ASSERT_CK_RETURN;
8906 kid = cLISTOPo->op_first->op_sibling;
8907 if (CvLVALUE(PL_compcv)) {
8908 for (; kid; kid = kid->op_sibling)
8909 op_lvalue(kid, OP_LEAVESUBLV);
8916 Perl_ck_select(pTHX_ OP *o)
8921 PERL_ARGS_ASSERT_CK_SELECT;
8923 if (o->op_flags & OPf_KIDS) {
8924 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8925 if (kid && kid->op_sibling) {
8926 o->op_type = OP_SSELECT;
8927 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8929 return fold_constants(op_integerize(op_std_init(o)));
8933 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8934 if (kid && kid->op_type == OP_RV2GV)
8935 kid->op_private &= ~HINT_STRICT_REFS;
8940 Perl_ck_shift(pTHX_ OP *o)
8943 const I32 type = o->op_type;
8945 PERL_ARGS_ASSERT_CK_SHIFT;
8947 if (!(o->op_flags & OPf_KIDS)) {
8950 if (!CvUNIQUE(PL_compcv)) {
8951 o->op_flags |= OPf_SPECIAL;
8955 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8958 OP * const oldo = o;
8959 o = newUNOP(type, 0, scalar(argop));
8960 op_getmad(oldo,o,'O');
8965 return newUNOP(type, 0, scalar(argop));
8968 return scalar(ck_fun(o));
8972 Perl_ck_sort(pTHX_ OP *o)
8977 PERL_ARGS_ASSERT_CK_SORT;
8979 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8980 HV * const hinthv = GvHV(PL_hintgv);
8982 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8984 const I32 sorthints = (I32)SvIV(*svp);
8985 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8986 o->op_private |= OPpSORT_QSORT;
8987 if ((sorthints & HINT_SORT_STABLE) != 0)
8988 o->op_private |= OPpSORT_STABLE;
8993 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8995 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8996 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8998 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
9000 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
9002 if (kid->op_type == OP_SCOPE) {
9006 else if (kid->op_type == OP_LEAVE) {
9007 if (o->op_type == OP_SORT) {
9008 op_null(kid); /* wipe out leave */
9011 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
9012 if (k->op_next == kid)
9014 /* don't descend into loops */
9015 else if (k->op_type == OP_ENTERLOOP
9016 || k->op_type == OP_ENTERITER)
9018 k = cLOOPx(k)->op_lastop;
9023 kid->op_next = 0; /* just disconnect the leave */
9024 k = kLISTOP->op_first;
9029 if (o->op_type == OP_SORT) {
9030 /* provide scalar context for comparison function/block */
9036 o->op_flags |= OPf_SPECIAL;
9039 firstkid = firstkid->op_sibling;
9042 /* provide list context for arguments */
9043 if (o->op_type == OP_SORT)
9050 S_simplify_sort(pTHX_ OP *o)
9053 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
9059 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
9061 if (!(o->op_flags & OPf_STACKED))
9063 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
9064 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
9065 kid = kUNOP->op_first; /* get past null */
9066 if (kid->op_type != OP_SCOPE)
9068 kid = kLISTOP->op_last; /* get past scope */
9069 switch(kid->op_type) {
9077 k = kid; /* remember this node*/
9078 if (kBINOP->op_first->op_type != OP_RV2SV)
9080 kid = kBINOP->op_first; /* get past cmp */
9081 if (kUNOP->op_first->op_type != OP_GV)
9083 kid = kUNOP->op_first; /* get past rv2sv */
9085 if (GvSTASH(gv) != PL_curstash)
9087 gvname = GvNAME(gv);
9088 if (*gvname == 'a' && gvname[1] == '\0')
9090 else if (*gvname == 'b' && gvname[1] == '\0')
9095 kid = k; /* back to cmp */
9096 if (kBINOP->op_last->op_type != OP_RV2SV)
9098 kid = kBINOP->op_last; /* down to 2nd arg */
9099 if (kUNOP->op_first->op_type != OP_GV)
9101 kid = kUNOP->op_first; /* get past rv2sv */
9103 if (GvSTASH(gv) != PL_curstash)
9105 gvname = GvNAME(gv);
9107 ? !(*gvname == 'a' && gvname[1] == '\0')
9108 : !(*gvname == 'b' && gvname[1] == '\0'))
9110 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
9112 o->op_private |= OPpSORT_DESCEND;
9113 if (k->op_type == OP_NCMP)
9114 o->op_private |= OPpSORT_NUMERIC;
9115 if (k->op_type == OP_I_NCMP)
9116 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
9117 kid = cLISTOPo->op_first->op_sibling;
9118 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
9120 op_getmad(kid,o,'S'); /* then delete it */
9122 op_free(kid); /* then delete it */
9127 Perl_ck_split(pTHX_ OP *o)
9132 PERL_ARGS_ASSERT_CK_SPLIT;
9134 if (o->op_flags & OPf_STACKED)
9135 return no_fh_allowed(o);
9137 kid = cLISTOPo->op_first;
9138 if (kid->op_type != OP_NULL)
9139 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
9140 kid = kid->op_sibling;
9141 op_free(cLISTOPo->op_first);
9143 cLISTOPo->op_first = kid;
9145 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
9146 cLISTOPo->op_last = kid; /* There was only one element previously */
9149 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
9150 OP * const sibl = kid->op_sibling;
9151 kid->op_sibling = 0;
9152 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
9153 if (cLISTOPo->op_first == cLISTOPo->op_last)
9154 cLISTOPo->op_last = kid;
9155 cLISTOPo->op_first = kid;
9156 kid->op_sibling = sibl;
9159 kid->op_type = OP_PUSHRE;
9160 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
9162 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
9163 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9164 "Use of /g modifier is meaningless in split");
9167 if (!kid->op_sibling)
9168 op_append_elem(OP_SPLIT, o, newDEFSVOP());
9170 kid = kid->op_sibling;
9173 if (!kid->op_sibling)
9174 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9175 assert(kid->op_sibling);
9177 kid = kid->op_sibling;
9180 if (kid->op_sibling)
9181 return too_many_arguments_pv(o,OP_DESC(o), 0);
9187 Perl_ck_join(pTHX_ OP *o)
9189 const OP * const kid = cLISTOPo->op_first->op_sibling;
9191 PERL_ARGS_ASSERT_CK_JOIN;
9193 if (kid && kid->op_type == OP_MATCH) {
9194 if (ckWARN(WARN_SYNTAX)) {
9195 const REGEXP *re = PM_GETRE(kPMOP);
9197 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9198 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9199 : newSVpvs_flags( "STRING", SVs_TEMP );
9200 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9201 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9202 SVfARG(msg), SVfARG(msg));
9209 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9211 Examines an op, which is expected to identify a subroutine at runtime,
9212 and attempts to determine at compile time which subroutine it identifies.
9213 This is normally used during Perl compilation to determine whether
9214 a prototype can be applied to a function call. I<cvop> is the op
9215 being considered, normally an C<rv2cv> op. A pointer to the identified
9216 subroutine is returned, if it could be determined statically, and a null
9217 pointer is returned if it was not possible to determine statically.
9219 Currently, the subroutine can be identified statically if the RV that the
9220 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9221 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9222 suitable if the constant value must be an RV pointing to a CV. Details of
9223 this process may change in future versions of Perl. If the C<rv2cv> op
9224 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9225 the subroutine statically: this flag is used to suppress compile-time
9226 magic on a subroutine call, forcing it to use default runtime behaviour.
9228 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9229 of a GV reference is modified. If a GV was examined and its CV slot was
9230 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9231 If the op is not optimised away, and the CV slot is later populated with
9232 a subroutine having a prototype, that flag eventually triggers the warning
9233 "called too early to check prototype".
9235 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9236 of returning a pointer to the subroutine it returns a pointer to the
9237 GV giving the most appropriate name for the subroutine in this context.
9238 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9239 (C<CvANON>) subroutine that is referenced through a GV it will be the
9240 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9241 A null pointer is returned as usual if there is no statically-determinable
9248 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9253 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9254 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9255 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9256 if (cvop->op_type != OP_RV2CV)
9258 if (cvop->op_private & OPpENTERSUB_AMPER)
9260 if (!(cvop->op_flags & OPf_KIDS))
9262 rvop = cUNOPx(cvop)->op_first;
9263 switch (rvop->op_type) {
9265 gv = cGVOPx_gv(rvop);
9268 if (flags & RV2CVOPCV_MARK_EARLY)
9269 rvop->op_private |= OPpEARLY_CV;
9274 SV *rv = cSVOPx_sv(rvop);
9284 if (SvTYPE((SV*)cv) != SVt_PVCV)
9286 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9287 if (!CvANON(cv) || !gv)
9296 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9298 Performs the default fixup of the arguments part of an C<entersub>
9299 op tree. This consists of applying list context to each of the
9300 argument ops. This is the standard treatment used on a call marked
9301 with C<&>, or a method call, or a call through a subroutine reference,
9302 or any other call where the callee can't be identified at compile time,
9303 or a call where the callee has no prototype.
9309 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9312 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9313 aop = cUNOPx(entersubop)->op_first;
9314 if (!aop->op_sibling)
9315 aop = cUNOPx(aop)->op_first;
9316 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9317 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9319 op_lvalue(aop, OP_ENTERSUB);
9326 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9328 Performs the fixup of the arguments part of an C<entersub> op tree
9329 based on a subroutine prototype. This makes various modifications to
9330 the argument ops, from applying context up to inserting C<refgen> ops,
9331 and checking the number and syntactic types of arguments, as directed by
9332 the prototype. This is the standard treatment used on a subroutine call,
9333 not marked with C<&>, where the callee can be identified at compile time
9334 and has a prototype.
9336 I<protosv> supplies the subroutine prototype to be applied to the call.
9337 It may be a normal defined scalar, of which the string value will be used.
9338 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9339 that has been cast to C<SV*>) which has a prototype. The prototype
9340 supplied, in whichever form, does not need to match the actual callee
9341 referenced by the op tree.
9343 If the argument ops disagree with the prototype, for example by having
9344 an unacceptable number of arguments, a valid op tree is returned anyway.
9345 The error is reflected in the parser state, normally resulting in a single
9346 exception at the top level of parsing which covers all the compilation
9347 errors that occurred. In the error message, the callee is referred to
9348 by the name defined by the I<namegv> parameter.
9354 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9357 const char *proto, *proto_end;
9358 OP *aop, *prev, *cvop;
9361 I32 contextclass = 0;
9362 const char *e = NULL;
9363 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9364 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9365 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
9366 "flags=%lx", (unsigned long) SvFLAGS(protosv));
9367 if (SvTYPE(protosv) == SVt_PVCV)
9368 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9369 else proto = SvPV(protosv, proto_len);
9370 proto_end = proto + proto_len;
9371 aop = cUNOPx(entersubop)->op_first;
9372 if (!aop->op_sibling)
9373 aop = cUNOPx(aop)->op_first;
9375 aop = aop->op_sibling;
9376 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9377 while (aop != cvop) {
9379 if (PL_madskills && aop->op_type == OP_STUB) {
9380 aop = aop->op_sibling;
9383 if (PL_madskills && aop->op_type == OP_NULL)
9384 o3 = ((UNOP*)aop)->op_first;
9388 if (proto >= proto_end)
9389 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
9397 /* _ must be at the end */
9398 if (proto[1] && !strchr(";@%", proto[1]))
9413 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9415 arg == 1 ? "block or sub {}" : "sub {}",
9416 gv_ename(namegv), 0, o3);
9419 /* '*' allows any scalar type, including bareword */
9422 if (o3->op_type == OP_RV2GV)
9423 goto wrapref; /* autoconvert GLOB -> GLOBref */
9424 else if (o3->op_type == OP_CONST)
9425 o3->op_private &= ~OPpCONST_STRICT;
9426 else if (o3->op_type == OP_ENTERSUB) {
9427 /* accidental subroutine, revert to bareword */
9428 OP *gvop = ((UNOP*)o3)->op_first;
9429 if (gvop && gvop->op_type == OP_NULL) {
9430 gvop = ((UNOP*)gvop)->op_first;
9432 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9435 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9436 (gvop = ((UNOP*)gvop)->op_first) &&
9437 gvop->op_type == OP_GV)
9439 GV * const gv = cGVOPx_gv(gvop);
9440 OP * const sibling = aop->op_sibling;
9441 SV * const n = newSVpvs("");
9443 OP * const oldaop = aop;
9447 gv_fullname4(n, gv, "", FALSE);
9448 aop = newSVOP(OP_CONST, 0, n);
9449 op_getmad(oldaop,aop,'O');
9450 prev->op_sibling = aop;
9451 aop->op_sibling = sibling;
9461 if (o3->op_type == OP_RV2AV ||
9462 o3->op_type == OP_PADAV ||
9463 o3->op_type == OP_RV2HV ||
9464 o3->op_type == OP_PADHV
9479 if (contextclass++ == 0) {
9480 e = strchr(proto, ']');
9481 if (!e || e == proto)
9490 const char *p = proto;
9491 const char *const end = proto;
9494 /* \[$] accepts any scalar lvalue */
9496 && Perl_op_lvalue_flags(aTHX_
9498 OP_READ, /* not entersub */
9501 bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
9503 gv_ename(namegv), 0, o3);
9508 if (o3->op_type == OP_RV2GV)
9511 bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
9514 if (o3->op_type == OP_ENTERSUB)
9517 bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
9521 if (o3->op_type == OP_RV2SV ||
9522 o3->op_type == OP_PADSV ||
9523 o3->op_type == OP_HELEM ||
9524 o3->op_type == OP_AELEM)
9526 if (!contextclass) {
9527 /* \$ accepts any scalar lvalue */
9528 if (Perl_op_lvalue_flags(aTHX_
9530 OP_READ, /* not entersub */
9533 bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
9537 if (o3->op_type == OP_RV2AV ||
9538 o3->op_type == OP_PADAV)
9541 bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
9544 if (o3->op_type == OP_RV2HV ||
9545 o3->op_type == OP_PADHV)
9548 bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
9552 OP* const kid = aop;
9553 OP* const sib = kid->op_sibling;
9554 kid->op_sibling = 0;
9555 aop = newUNOP(OP_REFGEN, 0, kid);
9556 aop->op_sibling = sib;
9557 prev->op_sibling = aop;
9559 if (contextclass && e) {
9574 SV* const tmpsv = sv_newmortal();
9575 gv_efullname3(tmpsv, namegv, NULL);
9576 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9577 SVfARG(tmpsv), SVfARG(protosv));
9581 op_lvalue(aop, OP_ENTERSUB);
9583 aop = aop->op_sibling;
9585 if (aop == cvop && *proto == '_') {
9586 /* generate an access to $_ */
9588 aop->op_sibling = prev->op_sibling;
9589 prev->op_sibling = aop; /* instead of cvop */
9591 if (!optional && proto_end > proto &&
9592 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9593 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
9598 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9600 Performs the fixup of the arguments part of an C<entersub> op tree either
9601 based on a subroutine prototype or using default list-context processing.
9602 This is the standard treatment used on a subroutine call, not marked
9603 with C<&>, where the callee can be identified at compile time.
9605 I<protosv> supplies the subroutine prototype to be applied to the call,
9606 or indicates that there is no prototype. It may be a normal scalar,
9607 in which case if it is defined then the string value will be used
9608 as a prototype, and if it is undefined then there is no prototype.
9609 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9610 that has been cast to C<SV*>), of which the prototype will be used if it
9611 has one. The prototype (or lack thereof) supplied, in whichever form,
9612 does not need to match the actual callee referenced by the op tree.
9614 If the argument ops disagree with the prototype, for example by having
9615 an unacceptable number of arguments, a valid op tree is returned anyway.
9616 The error is reflected in the parser state, normally resulting in a single
9617 exception at the top level of parsing which covers all the compilation
9618 errors that occurred. In the error message, the callee is referred to
9619 by the name defined by the I<namegv> parameter.
9625 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9626 GV *namegv, SV *protosv)
9628 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9629 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9630 return ck_entersub_args_proto(entersubop, namegv, protosv);
9632 return ck_entersub_args_list(entersubop);
9636 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9638 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9639 OP *aop = cUNOPx(entersubop)->op_first;
9641 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9645 if (!aop->op_sibling)
9646 aop = cUNOPx(aop)->op_first;
9647 aop = aop->op_sibling;
9648 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9649 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9650 aop = aop->op_sibling;
9653 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
9655 op_free(entersubop);
9656 switch(GvNAME(namegv)[2]) {
9657 case 'F': return newSVOP(OP_CONST, 0,
9658 newSVpv(CopFILE(PL_curcop),0));
9659 case 'L': return newSVOP(
9662 "%"IVdf, (IV)CopLINE(PL_curcop)
9665 case 'P': return newSVOP(OP_CONST, 0,
9667 ? newSVhek(HvNAME_HEK(PL_curstash))
9678 bool seenarg = FALSE;
9680 if (!aop->op_sibling)
9681 aop = cUNOPx(aop)->op_first;
9684 aop = aop->op_sibling;
9685 prev->op_sibling = NULL;
9688 prev=cvop, cvop = cvop->op_sibling)
9690 if (PL_madskills && cvop->op_sibling
9691 && cvop->op_type != OP_STUB) seenarg = TRUE
9694 prev->op_sibling = NULL;
9695 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9697 if (aop == cvop) aop = NULL;
9698 op_free(entersubop);
9700 if (opnum == OP_ENTEREVAL
9701 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9702 flags |= OPpEVAL_BYTES <<8;
9704 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9706 case OA_BASEOP_OR_UNOP:
9708 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9712 if (!PL_madskills || seenarg)
9714 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
9717 return opnum == OP_RUNCV
9718 ? newPVOP(OP_RUNCV,0,NULL)
9721 return convert(opnum,0,aop);
9729 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9731 Retrieves the function that will be used to fix up a call to I<cv>.
9732 Specifically, the function is applied to an C<entersub> op tree for a
9733 subroutine call, not marked with C<&>, where the callee can be identified
9734 at compile time as I<cv>.
9736 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9737 argument for it is returned in I<*ckobj_p>. The function is intended
9738 to be called in this manner:
9740 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9742 In this call, I<entersubop> is a pointer to the C<entersub> op,
9743 which may be replaced by the check function, and I<namegv> is a GV
9744 supplying the name that should be used by the check function to refer
9745 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9746 It is permitted to apply the check function in non-standard situations,
9747 such as to a call to a different subroutine or to a method call.
9749 By default, the function is
9750 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9751 and the SV parameter is I<cv> itself. This implements standard
9752 prototype processing. It can be changed, for a particular subroutine,
9753 by L</cv_set_call_checker>.
9759 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9762 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9763 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9765 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9766 *ckobj_p = callmg->mg_obj;
9768 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9774 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9776 Sets the function that will be used to fix up a call to I<cv>.
9777 Specifically, the function is applied to an C<entersub> op tree for a
9778 subroutine call, not marked with C<&>, where the callee can be identified
9779 at compile time as I<cv>.
9781 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9782 for it is supplied in I<ckobj>. The function is intended to be called
9785 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9787 In this call, I<entersubop> is a pointer to the C<entersub> op,
9788 which may be replaced by the check function, and I<namegv> is a GV
9789 supplying the name that should be used by the check function to refer
9790 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9791 It is permitted to apply the check function in non-standard situations,
9792 such as to a call to a different subroutine or to a method call.
9794 The current setting for a particular CV can be retrieved by
9795 L</cv_get_call_checker>.
9801 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9803 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9804 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9805 if (SvMAGICAL((SV*)cv))
9806 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9809 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9810 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9811 if (callmg->mg_flags & MGf_REFCOUNTED) {
9812 SvREFCNT_dec(callmg->mg_obj);
9813 callmg->mg_flags &= ~MGf_REFCOUNTED;
9815 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9816 callmg->mg_obj = ckobj;
9817 if (ckobj != (SV*)cv) {
9818 SvREFCNT_inc_simple_void_NN(ckobj);
9819 callmg->mg_flags |= MGf_REFCOUNTED;
9821 callmg->mg_flags |= MGf_COPY;
9826 Perl_ck_subr(pTHX_ OP *o)
9832 PERL_ARGS_ASSERT_CK_SUBR;
9834 aop = cUNOPx(o)->op_first;
9835 if (!aop->op_sibling)
9836 aop = cUNOPx(aop)->op_first;
9837 aop = aop->op_sibling;
9838 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9839 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9840 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9842 o->op_private &= ~1;
9843 o->op_private |= OPpENTERSUB_HASTARG;
9844 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9845 if (PERLDB_SUB && PL_curstash != PL_debstash)
9846 o->op_private |= OPpENTERSUB_DB;
9847 if (cvop->op_type == OP_RV2CV) {
9848 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9850 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9851 if (aop->op_type == OP_CONST)
9852 aop->op_private &= ~OPpCONST_STRICT;
9853 else if (aop->op_type == OP_LIST) {
9854 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9855 if (sib && sib->op_type == OP_CONST)
9856 sib->op_private &= ~OPpCONST_STRICT;
9861 return ck_entersub_args_list(o);
9863 Perl_call_checker ckfun;
9865 cv_get_call_checker(cv, &ckfun, &ckobj);
9866 return ckfun(aTHX_ o, namegv, ckobj);
9871 Perl_ck_svconst(pTHX_ OP *o)
9873 PERL_ARGS_ASSERT_CK_SVCONST;
9874 PERL_UNUSED_CONTEXT;
9875 SvREADONLY_on(cSVOPo->op_sv);
9880 Perl_ck_chdir(pTHX_ OP *o)
9882 PERL_ARGS_ASSERT_CK_CHDIR;
9883 if (o->op_flags & OPf_KIDS) {
9884 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9886 if (kid && kid->op_type == OP_CONST &&
9887 (kid->op_private & OPpCONST_BARE))
9889 o->op_flags |= OPf_SPECIAL;
9890 kid->op_private &= ~OPpCONST_STRICT;
9897 Perl_ck_trunc(pTHX_ OP *o)
9899 PERL_ARGS_ASSERT_CK_TRUNC;
9901 if (o->op_flags & OPf_KIDS) {
9902 SVOP *kid = (SVOP*)cUNOPo->op_first;
9904 if (kid->op_type == OP_NULL)
9905 kid = (SVOP*)kid->op_sibling;
9906 if (kid && kid->op_type == OP_CONST &&
9907 (kid->op_private & OPpCONST_BARE))
9909 o->op_flags |= OPf_SPECIAL;
9910 kid->op_private &= ~OPpCONST_STRICT;
9917 Perl_ck_substr(pTHX_ OP *o)
9919 PERL_ARGS_ASSERT_CK_SUBSTR;
9922 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9923 OP *kid = cLISTOPo->op_first;
9925 if (kid->op_type == OP_NULL)
9926 kid = kid->op_sibling;
9928 kid->op_flags |= OPf_MOD;
9935 Perl_ck_tell(pTHX_ OP *o)
9937 PERL_ARGS_ASSERT_CK_TELL;
9939 if (o->op_flags & OPf_KIDS) {
9940 OP *kid = cLISTOPo->op_first;
9941 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
9942 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9948 Perl_ck_each(pTHX_ OP *o)
9951 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9952 const unsigned orig_type = o->op_type;
9953 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9954 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9955 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9956 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9958 PERL_ARGS_ASSERT_CK_EACH;
9961 switch (kid->op_type) {
9967 CHANGE_TYPE(o, array_type);
9970 if (kid->op_private == OPpCONST_BARE
9971 || !SvROK(cSVOPx_sv(kid))
9972 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9973 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9975 /* we let ck_fun handle it */
9978 CHANGE_TYPE(o, ref_type);
9982 /* if treating as a reference, defer additional checks to runtime */
9983 return o->op_type == ref_type ? o : ck_fun(o);
9987 Perl_ck_length(pTHX_ OP *o)
9989 PERL_ARGS_ASSERT_CK_LENGTH;
9993 if (ckWARN(WARN_SYNTAX)) {
9994 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9998 const bool hash = kid->op_type == OP_PADHV
9999 || kid->op_type == OP_RV2HV;
10000 switch (kid->op_type) {
10004 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
10010 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
10012 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
10014 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
10021 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10022 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
10024 name, hash ? "keys " : "", name
10027 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10028 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
10030 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10031 "length() used on @array (did you mean \"scalar(@array)\"?)");
10038 /* caller is supposed to assign the return to the
10039 container of the rep_op var */
10041 S_opt_scalarhv(pTHX_ OP *rep_op) {
10045 PERL_ARGS_ASSERT_OPT_SCALARHV;
10047 NewOp(1101, unop, 1, UNOP);
10048 unop->op_type = (OPCODE)OP_BOOLKEYS;
10049 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
10050 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
10051 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
10052 unop->op_first = rep_op;
10053 unop->op_next = rep_op->op_next;
10054 rep_op->op_next = (OP*)unop;
10055 rep_op->op_flags|=(OPf_REF | OPf_MOD);
10056 unop->op_sibling = rep_op->op_sibling;
10057 rep_op->op_sibling = NULL;
10058 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
10059 if (rep_op->op_type == OP_PADHV) {
10060 rep_op->op_flags &= ~OPf_WANT_SCALAR;
10061 rep_op->op_flags |= OPf_WANT_LIST;
10066 /* Check for in place reverse and sort assignments like "@a = reverse @a"
10067 and modify the optree to make them work inplace */
10070 S_inplace_aassign(pTHX_ OP *o) {
10072 OP *modop, *modop_pushmark;
10074 OP *oleft, *oleft_pushmark;
10076 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
10078 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
10080 assert(cUNOPo->op_first->op_type == OP_NULL);
10081 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
10082 assert(modop_pushmark->op_type == OP_PUSHMARK);
10083 modop = modop_pushmark->op_sibling;
10085 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
10088 /* no other operation except sort/reverse */
10089 if (modop->op_sibling)
10092 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
10093 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
10095 if (modop->op_flags & OPf_STACKED) {
10096 /* skip sort subroutine/block */
10097 assert(oright->op_type == OP_NULL);
10098 oright = oright->op_sibling;
10101 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
10102 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
10103 assert(oleft_pushmark->op_type == OP_PUSHMARK);
10104 oleft = oleft_pushmark->op_sibling;
10106 /* Check the lhs is an array */
10108 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
10109 || oleft->op_sibling
10110 || (oleft->op_private & OPpLVAL_INTRO)
10114 /* Only one thing on the rhs */
10115 if (oright->op_sibling)
10118 /* check the array is the same on both sides */
10119 if (oleft->op_type == OP_RV2AV) {
10120 if (oright->op_type != OP_RV2AV
10121 || !cUNOPx(oright)->op_first
10122 || cUNOPx(oright)->op_first->op_type != OP_GV
10123 || cUNOPx(oleft )->op_first->op_type != OP_GV
10124 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
10125 cGVOPx_gv(cUNOPx(oright)->op_first)
10129 else if (oright->op_type != OP_PADAV
10130 || oright->op_targ != oleft->op_targ
10134 /* This actually is an inplace assignment */
10136 modop->op_private |= OPpSORT_INPLACE;
10138 /* transfer MODishness etc from LHS arg to RHS arg */
10139 oright->op_flags = oleft->op_flags;
10141 /* remove the aassign op and the lhs */
10143 op_null(oleft_pushmark);
10144 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
10145 op_null(cUNOPx(oleft)->op_first);
10149 #define MAX_DEFERRED 4
10152 if (defer_ix == (MAX_DEFERRED-1)) { \
10153 CALL_RPEEP(defer_queue[defer_base]); \
10154 defer_base = (defer_base + 1) % MAX_DEFERRED; \
10157 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
10159 /* A peephole optimizer. We visit the ops in the order they're to execute.
10160 * See the comments at the top of this file for more details about when
10161 * peep() is called */
10164 Perl_rpeep(pTHX_ register OP *o)
10167 register OP* oldop = NULL;
10168 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
10169 int defer_base = 0;
10172 if (!o || o->op_opt)
10176 SAVEVPTR(PL_curcop);
10177 for (;; o = o->op_next) {
10178 if (o && o->op_opt)
10181 while (defer_ix >= 0)
10182 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
10186 /* By default, this op has now been optimised. A couple of cases below
10187 clear this again. */
10190 switch (o->op_type) {
10192 PL_curcop = ((COP*)o); /* for warnings */
10195 PL_curcop = ((COP*)o); /* for warnings */
10197 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10198 to carry two labels. For now, take the easier option, and skip
10199 this optimisation if the first NEXTSTATE has a label. */
10200 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10201 OP *nextop = o->op_next;
10202 while (nextop && nextop->op_type == OP_NULL)
10203 nextop = nextop->op_next;
10205 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10206 COP *firstcop = (COP *)o;
10207 COP *secondcop = (COP *)nextop;
10208 /* We want the COP pointed to by o (and anything else) to
10209 become the next COP down the line. */
10210 cop_free(firstcop);
10212 firstcop->op_next = secondcop->op_next;
10214 /* Now steal all its pointers, and duplicate the other
10216 firstcop->cop_line = secondcop->cop_line;
10217 #ifdef USE_ITHREADS
10218 firstcop->cop_stashoff = secondcop->cop_stashoff;
10219 firstcop->cop_file = secondcop->cop_file;
10221 firstcop->cop_stash = secondcop->cop_stash;
10222 firstcop->cop_filegv = secondcop->cop_filegv;
10224 firstcop->cop_hints = secondcop->cop_hints;
10225 firstcop->cop_seq = secondcop->cop_seq;
10226 firstcop->cop_warnings = secondcop->cop_warnings;
10227 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10229 #ifdef USE_ITHREADS
10230 secondcop->cop_stashoff = 0;
10231 secondcop->cop_file = NULL;
10233 secondcop->cop_stash = NULL;
10234 secondcop->cop_filegv = NULL;
10236 secondcop->cop_warnings = NULL;
10237 secondcop->cop_hints_hash = NULL;
10239 /* If we use op_null(), and hence leave an ex-COP, some
10240 warnings are misreported. For example, the compile-time
10241 error in 'use strict; no strict refs;' */
10242 secondcop->op_type = OP_NULL;
10243 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10249 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10250 if (o->op_next->op_private & OPpTARGET_MY) {
10251 if (o->op_flags & OPf_STACKED) /* chained concats */
10252 break; /* ignore_optimization */
10254 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10255 o->op_targ = o->op_next->op_targ;
10256 o->op_next->op_targ = 0;
10257 o->op_private |= OPpTARGET_MY;
10260 op_null(o->op_next);
10264 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10265 break; /* Scalar stub must produce undef. List stub is noop */
10269 if (o->op_targ == OP_NEXTSTATE
10270 || o->op_targ == OP_DBSTATE)
10272 PL_curcop = ((COP*)o);
10274 /* XXX: We avoid setting op_seq here to prevent later calls
10275 to rpeep() from mistakenly concluding that optimisation
10276 has already occurred. This doesn't fix the real problem,
10277 though (See 20010220.007). AMS 20010719 */
10278 /* op_seq functionality is now replaced by op_opt */
10285 if (oldop && o->op_next) {
10286 oldop->op_next = o->op_next;
10294 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10295 OP* const pop = (o->op_type == OP_PADAV) ?
10296 o->op_next : o->op_next->op_next;
10298 if (pop && pop->op_type == OP_CONST &&
10299 ((PL_op = pop->op_next)) &&
10300 pop->op_next->op_type == OP_AELEM &&
10301 !(pop->op_next->op_private &
10302 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10303 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10306 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10307 no_bareword_allowed(pop);
10308 if (o->op_type == OP_GV)
10309 op_null(o->op_next);
10310 op_null(pop->op_next);
10312 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10313 o->op_next = pop->op_next->op_next;
10314 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10315 o->op_private = (U8)i;
10316 if (o->op_type == OP_GV) {
10319 o->op_type = OP_AELEMFAST;
10322 o->op_type = OP_AELEMFAST_LEX;
10327 if (o->op_next->op_type == OP_RV2SV) {
10328 if (!(o->op_next->op_private & OPpDEREF)) {
10329 op_null(o->op_next);
10330 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10332 o->op_next = o->op_next->op_next;
10333 o->op_type = OP_GVSV;
10334 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10337 else if (o->op_next->op_type == OP_READLINE
10338 && o->op_next->op_next->op_type == OP_CONCAT
10339 && (o->op_next->op_next->op_flags & OPf_STACKED))
10341 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10342 o->op_type = OP_RCATLINE;
10343 o->op_flags |= OPf_STACKED;
10344 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10345 op_null(o->op_next->op_next);
10346 op_null(o->op_next);
10356 fop = cUNOP->op_first;
10364 fop = cLOGOP->op_first;
10365 sop = fop->op_sibling;
10366 while (cLOGOP->op_other->op_type == OP_NULL)
10367 cLOGOP->op_other = cLOGOP->op_other->op_next;
10368 while (o->op_next && ( o->op_type == o->op_next->op_type
10369 || o->op_next->op_type == OP_NULL))
10370 o->op_next = o->op_next->op_next;
10371 DEFER(cLOGOP->op_other);
10375 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10377 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10382 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10383 while (nop && nop->op_next) {
10384 switch (nop->op_next->op_type) {
10389 lop = nop = nop->op_next;
10392 nop = nop->op_next;
10400 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
10401 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10402 cLOGOP->op_first = opt_scalarhv(fop);
10403 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10404 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10420 while (cLOGOP->op_other->op_type == OP_NULL)
10421 cLOGOP->op_other = cLOGOP->op_other->op_next;
10422 DEFER(cLOGOP->op_other);
10427 while (cLOOP->op_redoop->op_type == OP_NULL)
10428 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10429 while (cLOOP->op_nextop->op_type == OP_NULL)
10430 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10431 while (cLOOP->op_lastop->op_type == OP_NULL)
10432 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10433 /* a while(1) loop doesn't have an op_next that escapes the
10434 * loop, so we have to explicitly follow the op_lastop to
10435 * process the rest of the code */
10436 DEFER(cLOOP->op_lastop);
10440 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10441 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10442 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10443 cPMOP->op_pmstashstartu.op_pmreplstart
10444 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10445 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10449 /* check that RHS of sort is a single plain array */
10450 OP *oright = cUNOPo->op_first;
10451 if (!oright || oright->op_type != OP_PUSHMARK)
10454 if (o->op_private & OPpSORT_INPLACE)
10457 /* reverse sort ... can be optimised. */
10458 if (!cUNOPo->op_sibling) {
10459 /* Nothing follows us on the list. */
10460 OP * const reverse = o->op_next;
10462 if (reverse->op_type == OP_REVERSE &&
10463 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10464 OP * const pushmark = cUNOPx(reverse)->op_first;
10465 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10466 && (cUNOPx(pushmark)->op_sibling == o)) {
10467 /* reverse -> pushmark -> sort */
10468 o->op_private |= OPpSORT_REVERSE;
10470 pushmark->op_next = oright->op_next;
10480 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10482 LISTOP *enter, *exlist;
10484 if (o->op_private & OPpSORT_INPLACE)
10487 enter = (LISTOP *) o->op_next;
10490 if (enter->op_type == OP_NULL) {
10491 enter = (LISTOP *) enter->op_next;
10495 /* for $a (...) will have OP_GV then OP_RV2GV here.
10496 for (...) just has an OP_GV. */
10497 if (enter->op_type == OP_GV) {
10498 gvop = (OP *) enter;
10499 enter = (LISTOP *) enter->op_next;
10502 if (enter->op_type == OP_RV2GV) {
10503 enter = (LISTOP *) enter->op_next;
10509 if (enter->op_type != OP_ENTERITER)
10512 iter = enter->op_next;
10513 if (!iter || iter->op_type != OP_ITER)
10516 expushmark = enter->op_first;
10517 if (!expushmark || expushmark->op_type != OP_NULL
10518 || expushmark->op_targ != OP_PUSHMARK)
10521 exlist = (LISTOP *) expushmark->op_sibling;
10522 if (!exlist || exlist->op_type != OP_NULL
10523 || exlist->op_targ != OP_LIST)
10526 if (exlist->op_last != o) {
10527 /* Mmm. Was expecting to point back to this op. */
10530 theirmark = exlist->op_first;
10531 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10534 if (theirmark->op_sibling != o) {
10535 /* There's something between the mark and the reverse, eg
10536 for (1, reverse (...))
10541 ourmark = ((LISTOP *)o)->op_first;
10542 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10545 ourlast = ((LISTOP *)o)->op_last;
10546 if (!ourlast || ourlast->op_next != o)
10549 rv2av = ourmark->op_sibling;
10550 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10551 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10552 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10553 /* We're just reversing a single array. */
10554 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10555 enter->op_flags |= OPf_STACKED;
10558 /* We don't have control over who points to theirmark, so sacrifice
10560 theirmark->op_next = ourmark->op_next;
10561 theirmark->op_flags = ourmark->op_flags;
10562 ourlast->op_next = gvop ? gvop : (OP *) enter;
10565 enter->op_private |= OPpITER_REVERSED;
10566 iter->op_private |= OPpITER_REVERSED;
10573 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10574 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10579 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10581 if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
10583 sv = newRV((SV *)PL_compcv);
10587 o->op_type = OP_CONST;
10588 o->op_ppaddr = PL_ppaddr[OP_CONST];
10589 o->op_flags |= OPf_SPECIAL;
10590 cSVOPo->op_sv = sv;
10595 if (OP_GIMME(o,0) == G_VOID) {
10596 OP *right = cBINOP->op_first;
10598 OP *left = right->op_sibling;
10599 if (left->op_type == OP_SUBSTR
10600 && (left->op_private & 7) < 4) {
10602 cBINOP->op_first = left;
10603 right->op_sibling =
10604 cBINOPx(left)->op_first->op_sibling;
10605 cBINOPx(left)->op_first->op_sibling = right;
10606 left->op_private |= OPpSUBSTR_REPL_FIRST;
10608 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10615 Perl_cpeep_t cpeep =
10616 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10618 cpeep(aTHX_ o, oldop);
10629 Perl_peep(pTHX_ register OP *o)
10635 =head1 Custom Operators
10637 =for apidoc Ao||custom_op_xop
10638 Return the XOP structure for a given custom op. This function should be
10639 considered internal to OP_NAME and the other access macros: use them instead.
10645 Perl_custom_op_xop(pTHX_ const OP *o)
10651 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10653 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10654 assert(o->op_type == OP_CUSTOM);
10656 /* This is wrong. It assumes a function pointer can be cast to IV,
10657 * which isn't guaranteed, but this is what the old custom OP code
10658 * did. In principle it should be safer to Copy the bytes of the
10659 * pointer into a PV: since the new interface is hidden behind
10660 * functions, this can be changed later if necessary. */
10661 /* Change custom_op_xop if this ever happens */
10662 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10665 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10667 /* assume noone will have just registered a desc */
10668 if (!he && PL_custom_op_names &&
10669 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10674 /* XXX does all this need to be shared mem? */
10675 Newxz(xop, 1, XOP);
10676 pv = SvPV(HeVAL(he), l);
10677 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10678 if (PL_custom_op_descs &&
10679 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10681 pv = SvPV(HeVAL(he), l);
10682 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10684 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10688 if (!he) return &xop_null;
10690 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10695 =for apidoc Ao||custom_op_register
10696 Register a custom op. See L<perlguts/"Custom Operators">.
10702 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10706 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10708 /* see the comment in custom_op_xop */
10709 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10711 if (!PL_custom_ops)
10712 PL_custom_ops = newHV();
10714 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10715 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10719 =head1 Functions in file op.c
10721 =for apidoc core_prototype
10722 This function assigns the prototype of the named core function to C<sv>, or
10723 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10724 NULL if the core function has no prototype. C<code> is a code as returned
10725 by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
10731 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10734 int i = 0, n = 0, seen_question = 0, defgv = 0;
10736 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10737 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10738 bool nullret = FALSE;
10740 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10742 assert (code && code != -KEY_CORE);
10744 if (!sv) sv = sv_newmortal();
10746 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10748 switch (code < 0 ? -code : code) {
10749 case KEY_and : case KEY_chop: case KEY_chomp:
10750 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
10751 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
10752 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
10753 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
10754 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
10755 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
10756 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
10757 case KEY_x : case KEY_xor :
10758 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10759 case KEY_glob: retsetpvs("_;", OP_GLOB);
10760 case KEY_keys: retsetpvs("+", OP_KEYS);
10761 case KEY_values: retsetpvs("+", OP_VALUES);
10762 case KEY_each: retsetpvs("+", OP_EACH);
10763 case KEY_push: retsetpvs("+@", OP_PUSH);
10764 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10765 case KEY_pop: retsetpvs(";+", OP_POP);
10766 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10767 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
10769 retsetpvs("+;$$@", OP_SPLICE);
10770 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10772 case KEY_evalbytes:
10773 name = "entereval"; break;
10781 while (i < MAXO) { /* The slow way. */
10782 if (strEQ(name, PL_op_name[i])
10783 || strEQ(name, PL_op_desc[i]))
10785 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10792 defgv = PL_opargs[i] & OA_DEFGV;
10793 oa = PL_opargs[i] >> OASHIFT;
10795 if (oa & OA_OPTIONAL && !seen_question && (
10796 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10801 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10802 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10803 /* But globs are already references (kinda) */
10804 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10808 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10809 && !scalar_mod_type(NULL, i)) {
10814 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
10818 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10819 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10820 str[n-1] = '_'; defgv = 0;
10824 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10826 sv_setpvn(sv, str, n - 1);
10827 if (opnum) *opnum = i;
10832 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10835 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10838 PERL_ARGS_ASSERT_CORESUB_OP;
10842 return op_append_elem(OP_LINESEQ,
10845 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10849 case OP_SELECT: /* which represents OP_SSELECT as well */
10854 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10855 newSVOP(OP_CONST, 0, newSVuv(1))
10857 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10859 coresub_op(coreargssv, 0, OP_SELECT)
10863 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10865 return op_append_elem(
10868 opnum == OP_WANTARRAY || opnum == OP_RUNCV
10869 ? OPpOFFBYONE << 8 : 0)
10871 case OA_BASEOP_OR_UNOP:
10872 if (opnum == OP_ENTEREVAL) {
10873 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
10874 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
10876 else o = newUNOP(opnum,0,argop);
10877 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10880 if (is_handle_constructor(o, 1))
10881 argop->op_private |= OPpCOREARGS_DEREF1;
10882 if (scalar_mod_type(NULL, opnum))
10883 argop->op_private |= OPpCOREARGS_SCALARMOD;
10887 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
10888 if (is_handle_constructor(o, 2))
10889 argop->op_private |= OPpCOREARGS_DEREF2;
10890 if (opnum == OP_SUBSTR) {
10891 o->op_private |= OPpMAYBE_LVSUB;
10900 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
10901 SV * const *new_const_svp)
10903 const char *hvname;
10904 bool is_const = !!CvCONST(old_cv);
10905 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
10907 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
10909 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
10911 /* They are 2 constant subroutines generated from
10912 the same constant. This probably means that
10913 they are really the "same" proxy subroutine
10914 instantiated in 2 places. Most likely this is
10915 when a constant is exported twice. Don't warn.
10918 (ckWARN(WARN_REDEFINE)
10920 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
10921 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
10922 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
10923 strEQ(hvname, "autouse"))
10927 && ckWARN_d(WARN_REDEFINE)
10928 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
10931 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10933 ? "Constant subroutine %"SVf" redefined"
10934 : "Subroutine %"SVf" redefined",
10939 =head1 Hook manipulation
10941 These functions provide convenient and thread-safe means of manipulating
10948 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
10950 Puts a C function into the chain of check functions for a specified op
10951 type. This is the preferred way to manipulate the L</PL_check> array.
10952 I<opcode> specifies which type of op is to be affected. I<new_checker>
10953 is a pointer to the C function that is to be added to that opcode's
10954 check chain, and I<old_checker_p> points to the storage location where a
10955 pointer to the next function in the chain will be stored. The value of
10956 I<new_pointer> is written into the L</PL_check> array, while the value
10957 previously stored there is written to I<*old_checker_p>.
10959 L</PL_check> is global to an entire process, and a module wishing to
10960 hook op checking may find itself invoked more than once per process,
10961 typically in different threads. To handle that situation, this function
10962 is idempotent. The location I<*old_checker_p> must initially (once
10963 per process) contain a null pointer. A C variable of static duration
10964 (declared at file scope, typically also marked C<static> to give
10965 it internal linkage) will be implicitly initialised appropriately,
10966 if it does not have an explicit initialiser. This function will only
10967 actually modify the check chain if it finds I<*old_checker_p> to be null.
10968 This function is also thread safe on the small scale. It uses appropriate
10969 locking to avoid race conditions in accessing L</PL_check>.
10971 When this function is called, the function referenced by I<new_checker>
10972 must be ready to be called, except for I<*old_checker_p> being unfilled.
10973 In a threading situation, I<new_checker> may be called immediately,
10974 even before this function has returned. I<*old_checker_p> will always
10975 be appropriately set before I<new_checker> is called. If I<new_checker>
10976 decides not to do anything special with an op that it is given (which
10977 is the usual case for most uses of op check hooking), it must chain the
10978 check function referenced by I<*old_checker_p>.
10980 If you want to influence compilation of calls to a specific subroutine,
10981 then use L</cv_set_call_checker> rather than hooking checking of all
10988 Perl_wrap_op_checker(pTHX_ Optype opcode,
10989 Perl_check_t new_checker, Perl_check_t *old_checker_p)
10993 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
10994 if (*old_checker_p) return;
10995 OP_CHECK_MUTEX_LOCK;
10996 if (!*old_checker_p) {
10997 *old_checker_p = PL_check[opcode];
10998 PL_check[opcode] = new_checker;
11000 OP_CHECK_MUTEX_UNLOCK;
11005 /* Efficient sub that returns a constant scalar value. */
11007 const_sv_xsub(pTHX_ CV* cv)
11011 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
11015 /* diag_listed_as: SKIPME */
11016 Perl_croak(aTHX_ "usage: %s::%s()",
11017 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
11030 * c-indentation-style: bsd
11031 * c-basic-offset: 4
11032 * indent-tabs-mode: nil
11035 * ex: set ts=8 sts=4 sw=4 et: