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"
107 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
108 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
109 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
111 #if defined(PL_OP_SLAB_ALLOC)
113 #ifdef PERL_DEBUG_READONLY_OPS
114 # define PERL_SLAB_SIZE 4096
115 # include <sys/mman.h>
118 #ifndef PERL_SLAB_SIZE
119 #define PERL_SLAB_SIZE 2048
123 Perl_Slab_Alloc(pTHX_ size_t sz)
127 * To make incrementing use count easy PL_OpSlab is an I32 *
128 * To make inserting the link to slab PL_OpPtr is I32 **
129 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
130 * Add an overhead for pointer to slab and round up as a number of pointers
132 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
133 if ((PL_OpSpace -= sz) < 0) {
134 #ifdef PERL_DEBUG_READONLY_OPS
135 /* We need to allocate chunk by chunk so that we can control the VM
137 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
138 MAP_ANON|MAP_PRIVATE, -1, 0);
140 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
141 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
143 if(PL_OpPtr == MAP_FAILED) {
144 perror("mmap failed");
149 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
154 /* We reserve the 0'th I32 sized chunk as a use count */
155 PL_OpSlab = (I32 *) PL_OpPtr;
156 /* Reduce size by the use count word, and by the size we need.
157 * Latter is to mimic the '-=' in the if() above
159 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
160 /* Allocation pointer starts at the top.
161 Theory: because we build leaves before trunk allocating at end
162 means that at run time access is cache friendly upward
164 PL_OpPtr += PERL_SLAB_SIZE;
166 #ifdef PERL_DEBUG_READONLY_OPS
167 /* We remember this slab. */
168 /* This implementation isn't efficient, but it is simple. */
169 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
170 PL_slabs[PL_slab_count++] = PL_OpSlab;
171 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
174 assert( PL_OpSpace >= 0 );
175 /* Move the allocation pointer down */
177 assert( PL_OpPtr > (I32 **) PL_OpSlab );
178 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
179 (*PL_OpSlab)++; /* Increment use count of slab */
180 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
181 assert( *PL_OpSlab > 0 );
182 return (void *)(PL_OpPtr + 1);
185 #ifdef PERL_DEBUG_READONLY_OPS
187 Perl_pending_Slabs_to_ro(pTHX) {
188 /* Turn all the allocated op slabs read only. */
189 U32 count = PL_slab_count;
190 I32 **const slabs = PL_slabs;
192 /* Reset the array of pending OP slabs, as we're about to turn this lot
193 read only. Also, do it ahead of the loop in case the warn triggers,
194 and a warn handler has an eval */
199 /* Force a new slab for any further allocation. */
203 void *const start = slabs[count];
204 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
205 if(mprotect(start, size, PROT_READ)) {
206 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
207 start, (unsigned long) size, errno);
215 S_Slab_to_rw(pTHX_ void *op)
217 I32 * const * const ptr = (I32 **) op;
218 I32 * const slab = ptr[-1];
220 PERL_ARGS_ASSERT_SLAB_TO_RW;
222 assert( ptr-1 > (I32 **) slab );
223 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
225 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
226 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
227 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
232 Perl_op_refcnt_inc(pTHX_ OP *o)
243 Perl_op_refcnt_dec(pTHX_ OP *o)
245 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
250 # define Slab_to_rw(op)
254 Perl_Slab_Free(pTHX_ void *op)
256 I32 * const * const ptr = (I32 **) op;
257 I32 * const slab = ptr[-1];
258 PERL_ARGS_ASSERT_SLAB_FREE;
259 assert( ptr-1 > (I32 **) slab );
260 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
263 if (--(*slab) == 0) {
265 # define PerlMemShared PerlMem
268 #ifdef PERL_DEBUG_READONLY_OPS
269 U32 count = PL_slab_count;
270 /* Need to remove this slab from our list of slabs */
273 if (PL_slabs[count] == slab) {
275 /* Found it. Move the entry at the end to overwrite it. */
276 DEBUG_m(PerlIO_printf(Perl_debug_log,
277 "Deallocate %p by moving %p from %lu to %lu\n",
279 PL_slabs[PL_slab_count - 1],
280 PL_slab_count, count));
281 PL_slabs[count] = PL_slabs[--PL_slab_count];
282 /* Could realloc smaller at this point, but probably not
284 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
285 perror("munmap failed");
293 PerlMemShared_free(slab);
295 if (slab == PL_OpSlab) {
302 * In the following definition, the ", (OP*)0" is just to make the compiler
303 * think the expression is of the right type: croak actually does a Siglongjmp.
305 #define CHECKOP(type,o) \
306 ((PL_op_mask && PL_op_mask[type]) \
307 ? ( op_free((OP*)o), \
308 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
310 : PL_check[type](aTHX_ (OP*)o))
312 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
314 #define CHANGE_TYPE(o,type) \
316 o->op_type = (OPCODE)type; \
317 o->op_ppaddr = PL_ppaddr[type]; \
321 S_gv_ename(pTHX_ GV *gv)
323 SV* const tmpsv = sv_newmortal();
325 PERL_ARGS_ASSERT_GV_ENAME;
327 gv_efullname3(tmpsv, gv, NULL);
332 S_no_fh_allowed(pTHX_ OP *o)
334 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
336 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
342 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
344 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
345 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
346 SvUTF8(namesv) | flags);
351 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
353 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
354 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
359 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
361 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
363 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
368 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
370 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
372 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
373 SvUTF8(namesv) | flags);
378 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
380 PERL_ARGS_ASSERT_BAD_TYPE_PV;
382 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
383 (int)n, name, t, OP_DESC(kid)), flags);
387 S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
389 PERL_ARGS_ASSERT_BAD_TYPE_SV;
391 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
392 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
396 S_no_bareword_allowed(pTHX_ OP *o)
398 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
401 return; /* various ok barewords are hidden in extra OP_NULL */
402 qerror(Perl_mess(aTHX_
403 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
405 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
408 /* "register" allocation */
411 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
415 const bool is_our = (PL_parser->in_my == KEY_our);
417 PERL_ARGS_ASSERT_ALLOCMY;
419 if (flags & ~SVf_UTF8)
420 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
423 /* Until we're using the length for real, cross check that we're being
425 assert(strlen(name) == len);
427 /* complain about "my $<special_var>" etc etc */
431 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
432 (name[1] == '_' && (*name == '$' || len > 2))))
434 /* name[2] is true if strlen(name) > 2 */
435 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
436 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
437 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
438 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
439 PL_parser->in_my == KEY_state ? "state" : "my"));
441 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
442 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
446 /* allocate a spare slot and store the name in that slot */
448 off = pad_add_name_pvn(name, len,
449 (is_our ? padadd_OUR :
450 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
451 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
452 PL_parser->in_my_stash,
454 /* $_ is always in main::, even with our */
455 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
459 /* anon sub prototypes contains state vars should always be cloned,
460 * otherwise the state var would be shared between anon subs */
462 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
463 CvCLONE_on(PL_compcv);
470 Perl_alloccopstash(pTHX_ HV *hv)
472 PADOFFSET off = 0, o = 1;
473 bool found_slot = FALSE;
475 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
477 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
479 for (; o < PL_stashpadmax; ++o) {
480 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
481 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
482 found_slot = TRUE, off = o;
485 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
486 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
487 off = PL_stashpadmax;
488 PL_stashpadmax += 10;
491 PL_stashpad[PL_stashpadix = off] = hv;
496 /* free the body of an op without examining its contents.
497 * Always use this rather than FreeOp directly */
500 S_op_destroy(pTHX_ OP *o)
502 if (o->op_latefree) {
510 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
512 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
518 Perl_op_free(pTHX_ OP *o)
525 if (o->op_latefreed) {
532 if (o->op_private & OPpREFCOUNTED) {
543 refcnt = OpREFCNT_dec(o);
546 /* Need to find and remove any pattern match ops from the list
547 we maintain for reset(). */
548 find_and_forget_pmops(o);
558 /* Call the op_free hook if it has been set. Do it now so that it's called
559 * at the right time for refcounted ops, but still before all of the kids
563 if (o->op_flags & OPf_KIDS) {
564 register OP *kid, *nextkid;
565 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
566 nextkid = kid->op_sibling; /* Get before next freeing kid */
571 #ifdef PERL_DEBUG_READONLY_OPS
575 /* COP* is not cleared by op_clear() so that we may track line
576 * numbers etc even after null() */
577 if (type == OP_NEXTSTATE || type == OP_DBSTATE
578 || (type == OP_NULL /* the COP might have been null'ed */
579 && ((OPCODE)o->op_targ == OP_NEXTSTATE
580 || (OPCODE)o->op_targ == OP_DBSTATE))) {
585 type = (OPCODE)o->op_targ;
588 if (o->op_latefree) {
594 #ifdef DEBUG_LEAKING_SCALARS
601 Perl_op_clear(pTHX_ OP *o)
606 PERL_ARGS_ASSERT_OP_CLEAR;
609 mad_free(o->op_madprop);
614 switch (o->op_type) {
615 case OP_NULL: /* Was holding old type, if any. */
616 if (PL_madskills && o->op_targ != OP_NULL) {
617 o->op_type = (Optype)o->op_targ;
622 case OP_ENTEREVAL: /* Was holding hints. */
626 if (!(o->op_flags & OPf_REF)
627 || (PL_check[o->op_type] != Perl_ck_ftst))
634 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
639 /* It's possible during global destruction that the GV is freed
640 before the optree. Whilst the SvREFCNT_inc is happy to bump from
641 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
642 will trigger an assertion failure, because the entry to sv_clear
643 checks that the scalar is not already freed. A check of for
644 !SvIS_FREED(gv) turns out to be invalid, because during global
645 destruction the reference count can be forced down to zero
646 (with SVf_BREAK set). In which case raising to 1 and then
647 dropping to 0 triggers cleanup before it should happen. I
648 *think* that this might actually be a general, systematic,
649 weakness of the whole idea of SVf_BREAK, in that code *is*
650 allowed to raise and lower references during global destruction,
651 so any *valid* code that happens to do this during global
652 destruction might well trigger premature cleanup. */
653 bool still_valid = gv && SvREFCNT(gv);
656 SvREFCNT_inc_simple_void(gv);
658 if (cPADOPo->op_padix > 0) {
659 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
660 * may still exist on the pad */
661 pad_swipe(cPADOPo->op_padix, TRUE);
662 cPADOPo->op_padix = 0;
665 SvREFCNT_dec(cSVOPo->op_sv);
666 cSVOPo->op_sv = NULL;
669 int try_downgrade = SvREFCNT(gv) == 2;
672 gv_try_downgrade(gv);
676 case OP_METHOD_NAMED:
679 SvREFCNT_dec(cSVOPo->op_sv);
680 cSVOPo->op_sv = NULL;
683 Even if op_clear does a pad_free for the target of the op,
684 pad_free doesn't actually remove the sv that exists in the pad;
685 instead it lives on. This results in that it could be reused as
686 a target later on when the pad was reallocated.
689 pad_swipe(o->op_targ,1);
698 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
703 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
705 if (cPADOPo->op_padix > 0) {
706 pad_swipe(cPADOPo->op_padix, TRUE);
707 cPADOPo->op_padix = 0;
710 SvREFCNT_dec(cSVOPo->op_sv);
711 cSVOPo->op_sv = NULL;
715 PerlMemShared_free(cPVOPo->op_pv);
716 cPVOPo->op_pv = NULL;
720 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
724 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
725 /* No GvIN_PAD_off here, because other references may still
726 * exist on the pad */
727 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
730 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
736 forget_pmop(cPMOPo, 1);
737 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
738 /* we use the same protection as the "SAFE" version of the PM_ macros
739 * here since sv_clean_all might release some PMOPs
740 * after PL_regex_padav has been cleared
741 * and the clearing of PL_regex_padav needs to
742 * happen before sv_clean_all
745 if(PL_regex_pad) { /* We could be in destruction */
746 const IV offset = (cPMOPo)->op_pmoffset;
747 ReREFCNT_dec(PM_GETRE(cPMOPo));
748 PL_regex_pad[offset] = &PL_sv_undef;
749 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
753 ReREFCNT_dec(PM_GETRE(cPMOPo));
754 PM_SETRE(cPMOPo, NULL);
760 if (o->op_targ > 0) {
761 pad_free(o->op_targ);
767 S_cop_free(pTHX_ COP* cop)
769 PERL_ARGS_ASSERT_COP_FREE;
772 if (! specialWARN(cop->cop_warnings))
773 PerlMemShared_free(cop->cop_warnings);
774 cophh_free(CopHINTHASH_get(cop));
778 S_forget_pmop(pTHX_ PMOP *const o
784 HV * const pmstash = PmopSTASH(o);
786 PERL_ARGS_ASSERT_FORGET_PMOP;
788 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
789 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
791 PMOP **const array = (PMOP**) mg->mg_ptr;
792 U32 count = mg->mg_len / sizeof(PMOP**);
797 /* Found it. Move the entry at the end to overwrite it. */
798 array[i] = array[--count];
799 mg->mg_len = count * sizeof(PMOP**);
800 /* Could realloc smaller at this point always, but probably
801 not worth it. Probably worth free()ing if we're the
804 Safefree(mg->mg_ptr);
821 S_find_and_forget_pmops(pTHX_ OP *o)
823 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
825 if (o->op_flags & OPf_KIDS) {
826 OP *kid = cUNOPo->op_first;
828 switch (kid->op_type) {
833 forget_pmop((PMOP*)kid, 0);
835 find_and_forget_pmops(kid);
836 kid = kid->op_sibling;
842 Perl_op_null(pTHX_ OP *o)
846 PERL_ARGS_ASSERT_OP_NULL;
848 if (o->op_type == OP_NULL)
852 o->op_targ = o->op_type;
853 o->op_type = OP_NULL;
854 o->op_ppaddr = PL_ppaddr[OP_NULL];
858 Perl_op_refcnt_lock(pTHX)
866 Perl_op_refcnt_unlock(pTHX)
873 /* Contextualizers */
876 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
878 Applies a syntactic context to an op tree representing an expression.
879 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
880 or C<G_VOID> to specify the context to apply. The modified op tree
887 Perl_op_contextualize(pTHX_ OP *o, I32 context)
889 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
891 case G_SCALAR: return scalar(o);
892 case G_ARRAY: return list(o);
893 case G_VOID: return scalarvoid(o);
895 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
902 =head1 Optree Manipulation Functions
904 =for apidoc Am|OP*|op_linklist|OP *o
905 This function is the implementation of the L</LINKLIST> macro. It should
906 not be called directly.
912 Perl_op_linklist(pTHX_ OP *o)
916 PERL_ARGS_ASSERT_OP_LINKLIST;
921 /* establish postfix order */
922 first = cUNOPo->op_first;
925 o->op_next = LINKLIST(first);
928 if (kid->op_sibling) {
929 kid->op_next = LINKLIST(kid->op_sibling);
930 kid = kid->op_sibling;
944 S_scalarkids(pTHX_ OP *o)
946 if (o && o->op_flags & OPf_KIDS) {
948 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
955 S_scalarboolean(pTHX_ OP *o)
959 PERL_ARGS_ASSERT_SCALARBOOLEAN;
961 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
962 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
963 if (ckWARN(WARN_SYNTAX)) {
964 const line_t oldline = CopLINE(PL_curcop);
966 if (PL_parser && PL_parser->copline != NOLINE)
967 CopLINE_set(PL_curcop, PL_parser->copline);
968 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
969 CopLINE_set(PL_curcop, oldline);
976 Perl_scalar(pTHX_ OP *o)
981 /* assumes no premature commitment */
982 if (!o || (PL_parser && PL_parser->error_count)
983 || (o->op_flags & OPf_WANT)
984 || o->op_type == OP_RETURN)
989 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
991 switch (o->op_type) {
993 scalar(cBINOPo->op_first);
998 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1008 if (o->op_flags & OPf_KIDS) {
1009 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1015 kid = cLISTOPo->op_first;
1017 kid = kid->op_sibling;
1020 OP *sib = kid->op_sibling;
1021 if (sib && kid->op_type != OP_LEAVEWHEN)
1027 PL_curcop = &PL_compiling;
1032 kid = cLISTOPo->op_first;
1035 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1042 Perl_scalarvoid(pTHX_ OP *o)
1046 const char* useless = NULL;
1047 U32 useless_is_utf8 = 0;
1051 PERL_ARGS_ASSERT_SCALARVOID;
1053 /* trailing mad null ops don't count as "there" for void processing */
1055 o->op_type != OP_NULL &&
1057 o->op_sibling->op_type == OP_NULL)
1060 for (sib = o->op_sibling;
1061 sib && sib->op_type == OP_NULL;
1062 sib = sib->op_sibling) ;
1068 if (o->op_type == OP_NEXTSTATE
1069 || o->op_type == OP_DBSTATE
1070 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1071 || o->op_targ == OP_DBSTATE)))
1072 PL_curcop = (COP*)o; /* for warning below */
1074 /* assumes no premature commitment */
1075 want = o->op_flags & OPf_WANT;
1076 if ((want && want != OPf_WANT_SCALAR)
1077 || (PL_parser && PL_parser->error_count)
1078 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1083 if ((o->op_private & OPpTARGET_MY)
1084 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1086 return scalar(o); /* As if inside SASSIGN */
1089 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1091 switch (o->op_type) {
1093 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1097 if (o->op_flags & OPf_STACKED)
1101 if (o->op_private == 4)
1126 case OP_AELEMFAST_LEX:
1145 case OP_GETSOCKNAME:
1146 case OP_GETPEERNAME:
1151 case OP_GETPRIORITY:
1176 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1177 /* Otherwise it's "Useless use of grep iterator" */
1178 useless = OP_DESC(o);
1182 kid = cLISTOPo->op_first;
1183 if (kid && kid->op_type == OP_PUSHRE
1185 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1187 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1189 useless = OP_DESC(o);
1193 kid = cUNOPo->op_first;
1194 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1195 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1198 useless = "negative pattern binding (!~)";
1202 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1203 useless = "non-destructive substitution (s///r)";
1207 useless = "non-destructive transliteration (tr///r)";
1214 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1215 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1216 useless = "a variable";
1221 if (cSVOPo->op_private & OPpCONST_STRICT)
1222 no_bareword_allowed(o);
1224 if (ckWARN(WARN_VOID)) {
1225 /* don't warn on optimised away booleans, eg
1226 * use constant Foo, 5; Foo || print; */
1227 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1229 /* the constants 0 and 1 are permitted as they are
1230 conventionally used as dummies in constructs like
1231 1 while some_condition_with_side_effects; */
1232 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1234 else if (SvPOK(sv)) {
1235 /* perl4's way of mixing documentation and code
1236 (before the invention of POD) was based on a
1237 trick to mix nroff and perl code. The trick was
1238 built upon these three nroff macros being used in
1239 void context. The pink camel has the details in
1240 the script wrapman near page 319. */
1241 const char * const maybe_macro = SvPVX_const(sv);
1242 if (strnEQ(maybe_macro, "di", 2) ||
1243 strnEQ(maybe_macro, "ds", 2) ||
1244 strnEQ(maybe_macro, "ig", 2))
1247 SV * const dsv = newSVpvs("");
1248 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1250 pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1251 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1253 useless = SvPV_nolen(msv);
1254 useless_is_utf8 = SvUTF8(msv);
1257 else if (SvOK(sv)) {
1258 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1259 "a constant (%"SVf")", sv));
1260 useless = SvPV_nolen(msv);
1263 useless = "a constant (undef)";
1266 op_null(o); /* don't execute or even remember it */
1270 o->op_type = OP_PREINC; /* pre-increment is faster */
1271 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1275 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1276 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1280 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1281 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1285 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1286 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1291 UNOP *refgen, *rv2cv;
1294 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1297 rv2gv = ((BINOP *)o)->op_last;
1298 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1301 refgen = (UNOP *)((BINOP *)o)->op_first;
1303 if (!refgen || refgen->op_type != OP_REFGEN)
1306 exlist = (LISTOP *)refgen->op_first;
1307 if (!exlist || exlist->op_type != OP_NULL
1308 || exlist->op_targ != OP_LIST)
1311 if (exlist->op_first->op_type != OP_PUSHMARK)
1314 rv2cv = (UNOP*)exlist->op_last;
1316 if (rv2cv->op_type != OP_RV2CV)
1319 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1320 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1321 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1323 o->op_private |= OPpASSIGN_CV_TO_GV;
1324 rv2gv->op_private |= OPpDONT_INIT_GV;
1325 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1337 kid = cLOGOPo->op_first;
1338 if (kid->op_type == OP_NOT
1339 && (kid->op_flags & OPf_KIDS)
1341 if (o->op_type == OP_AND) {
1343 o->op_ppaddr = PL_ppaddr[OP_OR];
1345 o->op_type = OP_AND;
1346 o->op_ppaddr = PL_ppaddr[OP_AND];
1355 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1360 if (o->op_flags & OPf_STACKED)
1367 if (!(o->op_flags & OPf_KIDS))
1378 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1388 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1389 newSVpvn_flags(useless, strlen(useless),
1390 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
1395 S_listkids(pTHX_ OP *o)
1397 if (o && o->op_flags & OPf_KIDS) {
1399 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1406 Perl_list(pTHX_ OP *o)
1411 /* assumes no premature commitment */
1412 if (!o || (o->op_flags & OPf_WANT)
1413 || (PL_parser && PL_parser->error_count)
1414 || o->op_type == OP_RETURN)
1419 if ((o->op_private & OPpTARGET_MY)
1420 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1422 return o; /* As if inside SASSIGN */
1425 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1427 switch (o->op_type) {
1430 list(cBINOPo->op_first);
1435 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1443 if (!(o->op_flags & OPf_KIDS))
1445 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1446 list(cBINOPo->op_first);
1447 return gen_constant_list(o);
1454 kid = cLISTOPo->op_first;
1456 kid = kid->op_sibling;
1459 OP *sib = kid->op_sibling;
1460 if (sib && kid->op_type != OP_LEAVEWHEN)
1466 PL_curcop = &PL_compiling;
1470 kid = cLISTOPo->op_first;
1477 S_scalarseq(pTHX_ OP *o)
1481 const OPCODE type = o->op_type;
1483 if (type == OP_LINESEQ || type == OP_SCOPE ||
1484 type == OP_LEAVE || type == OP_LEAVETRY)
1487 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1488 if (kid->op_sibling) {
1492 PL_curcop = &PL_compiling;
1494 o->op_flags &= ~OPf_PARENS;
1495 if (PL_hints & HINT_BLOCK_SCOPE)
1496 o->op_flags |= OPf_PARENS;
1499 o = newOP(OP_STUB, 0);
1504 S_modkids(pTHX_ OP *o, I32 type)
1506 if (o && o->op_flags & OPf_KIDS) {
1508 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1509 op_lvalue(kid, type);
1515 =for apidoc finalize_optree
1517 This function finalizes the optree. Should be called directly after
1518 the complete optree is built. It does some additional
1519 checking which can't be done in the normal ck_xxx functions and makes
1520 the tree thread-safe.
1525 Perl_finalize_optree(pTHX_ OP* o)
1527 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1530 SAVEVPTR(PL_curcop);
1538 S_finalize_op(pTHX_ OP* o)
1540 PERL_ARGS_ASSERT_FINALIZE_OP;
1542 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1544 /* Make sure mad ops are also thread-safe */
1545 MADPROP *mp = o->op_madprop;
1547 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1548 OP *prop_op = (OP *) mp->mad_val;
1549 /* We only need "Relocate sv to the pad for thread safety.", but this
1550 easiest way to make sure it traverses everything */
1551 if (prop_op->op_type == OP_CONST)
1552 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1553 finalize_op(prop_op);
1560 switch (o->op_type) {
1563 PL_curcop = ((COP*)o); /* for warnings */
1567 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1568 && ckWARN(WARN_SYNTAX))
1570 if (o->op_sibling->op_sibling) {
1571 const OPCODE type = o->op_sibling->op_sibling->op_type;
1572 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1573 const line_t oldline = CopLINE(PL_curcop);
1574 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1575 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1576 "Statement unlikely to be reached");
1577 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1578 "\t(Maybe you meant system() when you said exec()?)\n");
1579 CopLINE_set(PL_curcop, oldline);
1586 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1587 GV * const gv = cGVOPo_gv;
1588 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1589 /* XXX could check prototype here instead of just carping */
1590 SV * const sv = sv_newmortal();
1591 gv_efullname3(sv, gv, NULL);
1592 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1593 "%"SVf"() called too early to check prototype",
1600 if (cSVOPo->op_private & OPpCONST_STRICT)
1601 no_bareword_allowed(o);
1605 case OP_METHOD_NAMED:
1606 /* Relocate sv to the pad for thread safety.
1607 * Despite being a "constant", the SV is written to,
1608 * for reference counts, sv_upgrade() etc. */
1609 if (cSVOPo->op_sv) {
1610 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1611 if (o->op_type != OP_METHOD_NAMED &&
1612 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1614 /* If op_sv is already a PADTMP/MY then it is being used by
1615 * some pad, so make a copy. */
1616 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1617 SvREADONLY_on(PAD_SVl(ix));
1618 SvREFCNT_dec(cSVOPo->op_sv);
1620 else if (o->op_type != OP_METHOD_NAMED
1621 && cSVOPo->op_sv == &PL_sv_undef) {
1622 /* PL_sv_undef is hack - it's unsafe to store it in the
1623 AV that is the pad, because av_fetch treats values of
1624 PL_sv_undef as a "free" AV entry and will merrily
1625 replace them with a new SV, causing pad_alloc to think
1626 that this pad slot is free. (When, clearly, it is not)
1628 SvOK_off(PAD_SVl(ix));
1629 SvPADTMP_on(PAD_SVl(ix));
1630 SvREADONLY_on(PAD_SVl(ix));
1633 SvREFCNT_dec(PAD_SVl(ix));
1634 SvPADTMP_on(cSVOPo->op_sv);
1635 PAD_SETSV(ix, cSVOPo->op_sv);
1636 /* XXX I don't know how this isn't readonly already. */
1637 SvREADONLY_on(PAD_SVl(ix));
1639 cSVOPo->op_sv = NULL;
1650 const char *key = NULL;
1653 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1656 /* Make the CONST have a shared SV */
1657 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1658 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1659 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1660 key = SvPV_const(sv, keylen);
1661 lexname = newSVpvn_share(key,
1662 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1668 if ((o->op_private & (OPpLVAL_INTRO)))
1671 rop = (UNOP*)((BINOP*)o)->op_first;
1672 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1674 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1675 if (!SvPAD_TYPED(lexname))
1677 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1678 if (!fields || !GvHV(*fields))
1680 key = SvPV_const(*svp, keylen);
1681 if (!hv_fetch(GvHV(*fields), key,
1682 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1683 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1684 "in variable %"SVf" of type %"HEKf,
1685 SVfARG(*svp), SVfARG(lexname),
1686 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1698 SVOP *first_key_op, *key_op;
1700 if ((o->op_private & (OPpLVAL_INTRO))
1701 /* I bet there's always a pushmark... */
1702 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1703 /* hmmm, no optimization if list contains only one key. */
1705 rop = (UNOP*)((LISTOP*)o)->op_last;
1706 if (rop->op_type != OP_RV2HV)
1708 if (rop->op_first->op_type == OP_PADSV)
1709 /* @$hash{qw(keys here)} */
1710 rop = (UNOP*)rop->op_first;
1712 /* @{$hash}{qw(keys here)} */
1713 if (rop->op_first->op_type == OP_SCOPE
1714 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1716 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1722 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1723 if (!SvPAD_TYPED(lexname))
1725 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1726 if (!fields || !GvHV(*fields))
1728 /* Again guessing that the pushmark can be jumped over.... */
1729 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1730 ->op_first->op_sibling;
1731 for (key_op = first_key_op; key_op;
1732 key_op = (SVOP*)key_op->op_sibling) {
1733 if (key_op->op_type != OP_CONST)
1735 svp = cSVOPx_svp(key_op);
1736 key = SvPV_const(*svp, keylen);
1737 if (!hv_fetch(GvHV(*fields), key,
1738 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1739 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
1740 "in variable %"SVf" of type %"HEKf,
1741 SVfARG(*svp), SVfARG(lexname),
1742 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
1748 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1749 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1756 if (o->op_flags & OPf_KIDS) {
1758 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1764 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1766 Propagate lvalue ("modifiable") context to an op and its children.
1767 I<type> represents the context type, roughly based on the type of op that
1768 would do the modifying, although C<local()> is represented by OP_NULL,
1769 because it has no op type of its own (it is signalled by a flag on
1772 This function detects things that can't be modified, such as C<$x+1>, and
1773 generates errors for them. For example, C<$x+1 = 2> would cause it to be
1774 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1776 It also flags things that need to behave specially in an lvalue context,
1777 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
1783 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
1787 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1790 if (!o || (PL_parser && PL_parser->error_count))
1793 if ((o->op_private & OPpTARGET_MY)
1794 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1799 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1801 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1803 switch (o->op_type) {
1808 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1812 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
1813 !(o->op_flags & OPf_STACKED)) {
1814 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1815 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1816 poses, so we need it clear. */
1817 o->op_private &= ~1;
1818 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1819 assert(cUNOPo->op_first->op_type == OP_NULL);
1820 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1823 else { /* lvalue subroutine call */
1824 o->op_private |= OPpLVAL_INTRO
1825 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
1826 PL_modcount = RETURN_UNLIMITED_NUMBER;
1827 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1828 /* Potential lvalue context: */
1829 o->op_private |= OPpENTERSUB_INARGS;
1832 else { /* Compile-time error message: */
1833 OP *kid = cUNOPo->op_first;
1836 if (kid->op_type != OP_PUSHMARK) {
1837 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1839 "panic: unexpected lvalue entersub "
1840 "args: type/targ %ld:%"UVuf,
1841 (long)kid->op_type, (UV)kid->op_targ);
1842 kid = kLISTOP->op_first;
1844 while (kid->op_sibling)
1845 kid = kid->op_sibling;
1846 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1847 break; /* Postpone until runtime */
1850 kid = kUNOP->op_first;
1851 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1852 kid = kUNOP->op_first;
1853 if (kid->op_type == OP_NULL)
1855 "Unexpected constant lvalue entersub "
1856 "entry via type/targ %ld:%"UVuf,
1857 (long)kid->op_type, (UV)kid->op_targ);
1858 if (kid->op_type != OP_GV) {
1862 cv = GvCV(kGVOP_gv);
1872 if (flags & OP_LVALUE_NO_CROAK) return NULL;
1873 /* grep, foreach, subcalls, refgen */
1874 if (type == OP_GREPSTART || type == OP_ENTERSUB
1875 || type == OP_REFGEN || type == OP_LEAVESUBLV)
1877 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1878 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1880 : (o->op_type == OP_ENTERSUB
1881 ? "non-lvalue subroutine call"
1883 type ? PL_op_desc[type] : "local"));
1897 case OP_RIGHT_SHIFT:
1906 if (!(o->op_flags & OPf_STACKED))
1913 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1914 op_lvalue(kid, type);
1919 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1920 PL_modcount = RETURN_UNLIMITED_NUMBER;
1921 return o; /* Treat \(@foo) like ordinary list. */
1925 if (scalar_mod_type(o, type))
1927 ref(cUNOPo->op_first, o->op_type);
1931 if (type == OP_LEAVESUBLV)
1932 o->op_private |= OPpMAYBE_LVSUB;
1938 PL_modcount = RETURN_UNLIMITED_NUMBER;
1941 PL_hints |= HINT_BLOCK_SCOPE;
1942 if (type == OP_LEAVESUBLV)
1943 o->op_private |= OPpMAYBE_LVSUB;
1947 ref(cUNOPo->op_first, o->op_type);
1951 PL_hints |= HINT_BLOCK_SCOPE;
1960 case OP_AELEMFAST_LEX:
1967 PL_modcount = RETURN_UNLIMITED_NUMBER;
1968 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1969 return o; /* Treat \(@foo) like ordinary list. */
1970 if (scalar_mod_type(o, type))
1972 if (type == OP_LEAVESUBLV)
1973 o->op_private |= OPpMAYBE_LVSUB;
1977 if (!type) /* local() */
1978 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1979 PAD_COMPNAME_SV(o->op_targ));
1988 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
1992 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1998 if (type == OP_LEAVESUBLV)
1999 o->op_private |= OPpMAYBE_LVSUB;
2000 pad_free(o->op_targ);
2001 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
2002 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
2003 if (o->op_flags & OPf_KIDS)
2004 op_lvalue(cBINOPo->op_first->op_sibling, type);
2009 ref(cBINOPo->op_first, o->op_type);
2010 if (type == OP_ENTERSUB &&
2011 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2012 o->op_private |= OPpLVAL_DEFER;
2013 if (type == OP_LEAVESUBLV)
2014 o->op_private |= OPpMAYBE_LVSUB;
2024 if (o->op_flags & OPf_KIDS)
2025 op_lvalue(cLISTOPo->op_last, type);
2030 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2032 else if (!(o->op_flags & OPf_KIDS))
2034 if (o->op_targ != OP_LIST) {
2035 op_lvalue(cBINOPo->op_first, type);
2041 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2042 /* elements might be in void context because the list is
2043 in scalar context or because they are attribute sub calls */
2044 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2045 op_lvalue(kid, type);
2049 if (type != OP_LEAVESUBLV)
2051 break; /* op_lvalue()ing was handled by ck_return() */
2057 /* [20011101.069] File test operators interpret OPf_REF to mean that
2058 their argument is a filehandle; thus \stat(".") should not set
2060 if (type == OP_REFGEN &&
2061 PL_check[o->op_type] == Perl_ck_ftst)
2064 if (type != OP_LEAVESUBLV)
2065 o->op_flags |= OPf_MOD;
2067 if (type == OP_AASSIGN || type == OP_SASSIGN)
2068 o->op_flags |= OPf_SPECIAL|OPf_REF;
2069 else if (!type) { /* local() */
2072 o->op_private |= OPpLVAL_INTRO;
2073 o->op_flags &= ~OPf_SPECIAL;
2074 PL_hints |= HINT_BLOCK_SCOPE;
2079 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2080 "Useless localization of %s", OP_DESC(o));
2083 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2084 && type != OP_LEAVESUBLV)
2085 o->op_flags |= OPf_REF;
2090 S_scalar_mod_type(const OP *o, I32 type)
2095 if (o && o->op_type == OP_RV2GV)
2119 case OP_RIGHT_SHIFT:
2140 S_is_handle_constructor(const OP *o, I32 numargs)
2142 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2144 switch (o->op_type) {
2152 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
2165 S_refkids(pTHX_ OP *o, I32 type)
2167 if (o && o->op_flags & OPf_KIDS) {
2169 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2176 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2181 PERL_ARGS_ASSERT_DOREF;
2183 if (!o || (PL_parser && PL_parser->error_count))
2186 switch (o->op_type) {
2188 if ((type == OP_EXISTS || type == OP_DEFINED) &&
2189 !(o->op_flags & OPf_STACKED)) {
2190 o->op_type = OP_RV2CV; /* entersub => rv2cv */
2191 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2192 assert(cUNOPo->op_first->op_type == OP_NULL);
2193 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
2194 o->op_flags |= OPf_SPECIAL;
2195 o->op_private &= ~1;
2197 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2198 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2199 : type == OP_RV2HV ? OPpDEREF_HV
2201 o->op_flags |= OPf_MOD;
2207 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2208 doref(kid, type, set_op_ref);
2211 if (type == OP_DEFINED)
2212 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2213 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2216 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2217 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2218 : type == OP_RV2HV ? OPpDEREF_HV
2220 o->op_flags |= OPf_MOD;
2227 o->op_flags |= OPf_REF;
2230 if (type == OP_DEFINED)
2231 o->op_flags |= OPf_SPECIAL; /* don't create GV */
2232 doref(cUNOPo->op_first, o->op_type, set_op_ref);
2238 o->op_flags |= OPf_REF;
2243 if (!(o->op_flags & OPf_KIDS))
2245 doref(cBINOPo->op_first, type, set_op_ref);
2249 doref(cBINOPo->op_first, o->op_type, set_op_ref);
2250 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2251 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2252 : type == OP_RV2HV ? OPpDEREF_HV
2254 o->op_flags |= OPf_MOD;
2264 if (!(o->op_flags & OPf_KIDS))
2266 doref(cLISTOPo->op_last, type, set_op_ref);
2276 S_dup_attrlist(pTHX_ OP *o)
2281 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2283 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2284 * where the first kid is OP_PUSHMARK and the remaining ones
2285 * are OP_CONST. We need to push the OP_CONST values.
2287 if (o->op_type == OP_CONST)
2288 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2290 else if (o->op_type == OP_NULL)
2294 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2296 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2297 if (o->op_type == OP_CONST)
2298 rop = op_append_elem(OP_LIST, rop,
2299 newSVOP(OP_CONST, o->op_flags,
2300 SvREFCNT_inc_NN(cSVOPo->op_sv)));
2307 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
2312 PERL_ARGS_ASSERT_APPLY_ATTRS;
2314 /* fake up C<use attributes $pkg,$rv,@attrs> */
2315 ENTER; /* need to protect against side-effects of 'use' */
2316 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2318 #define ATTRSMODULE "attributes"
2319 #define ATTRSMODULE_PM "attributes.pm"
2322 /* Don't force the C<use> if we don't need it. */
2323 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2324 if (svp && *svp != &PL_sv_undef)
2325 NOOP; /* already in %INC */
2327 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2328 newSVpvs(ATTRSMODULE), NULL);
2331 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2332 newSVpvs(ATTRSMODULE),
2334 op_prepend_elem(OP_LIST,
2335 newSVOP(OP_CONST, 0, stashsv),
2336 op_prepend_elem(OP_LIST,
2337 newSVOP(OP_CONST, 0,
2339 dup_attrlist(attrs))));
2345 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2348 OP *pack, *imop, *arg;
2351 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2356 assert(target->op_type == OP_PADSV ||
2357 target->op_type == OP_PADHV ||
2358 target->op_type == OP_PADAV);
2360 /* Ensure that attributes.pm is loaded. */
2361 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
2363 /* Need package name for method call. */
2364 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2366 /* Build up the real arg-list. */
2367 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2369 arg = newOP(OP_PADSV, 0);
2370 arg->op_targ = target->op_targ;
2371 arg = op_prepend_elem(OP_LIST,
2372 newSVOP(OP_CONST, 0, stashsv),
2373 op_prepend_elem(OP_LIST,
2374 newUNOP(OP_REFGEN, 0,
2375 op_lvalue(arg, OP_REFGEN)),
2376 dup_attrlist(attrs)));
2378 /* Fake up a method call to import */
2379 meth = newSVpvs_share("import");
2380 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2381 op_append_elem(OP_LIST,
2382 op_prepend_elem(OP_LIST, pack, list(arg)),
2383 newSVOP(OP_METHOD_NAMED, 0, meth)));
2385 /* Combine the ops. */
2386 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2390 =notfor apidoc apply_attrs_string
2392 Attempts to apply a list of attributes specified by the C<attrstr> and
2393 C<len> arguments to the subroutine identified by the C<cv> argument which
2394 is expected to be associated with the package identified by the C<stashpv>
2395 argument (see L<attributes>). It gets this wrong, though, in that it
2396 does not correctly identify the boundaries of the individual attribute
2397 specifications within C<attrstr>. This is not really intended for the
2398 public API, but has to be listed here for systems such as AIX which
2399 need an explicit export list for symbols. (It's called from XS code
2400 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2401 to respect attribute syntax properly would be welcome.
2407 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2408 const char *attrstr, STRLEN len)
2412 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2415 len = strlen(attrstr);
2419 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2421 const char * const sstr = attrstr;
2422 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2423 attrs = op_append_elem(OP_LIST, attrs,
2424 newSVOP(OP_CONST, 0,
2425 newSVpvn(sstr, attrstr-sstr)));
2429 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2430 newSVpvs(ATTRSMODULE),
2431 NULL, op_prepend_elem(OP_LIST,
2432 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2433 op_prepend_elem(OP_LIST,
2434 newSVOP(OP_CONST, 0,
2435 newRV(MUTABLE_SV(cv))),
2440 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2444 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2446 PERL_ARGS_ASSERT_MY_KID;
2448 if (!o || (PL_parser && PL_parser->error_count))
2452 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2453 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2457 if (type == OP_LIST) {
2459 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2460 my_kid(kid, attrs, imopsp);
2462 } else if (type == OP_UNDEF
2468 } else if (type == OP_RV2SV || /* "our" declaration */
2470 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2471 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2472 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2474 PL_parser->in_my == KEY_our
2476 : PL_parser->in_my == KEY_state ? "state" : "my"));
2478 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2479 PL_parser->in_my = FALSE;
2480 PL_parser->in_my_stash = NULL;
2481 apply_attrs(GvSTASH(gv),
2482 (type == OP_RV2SV ? GvSV(gv) :
2483 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2484 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2487 o->op_private |= OPpOUR_INTRO;
2490 else if (type != OP_PADSV &&
2493 type != OP_PUSHMARK)
2495 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2497 PL_parser->in_my == KEY_our
2499 : PL_parser->in_my == KEY_state ? "state" : "my"));
2502 else if (attrs && type != OP_PUSHMARK) {
2505 PL_parser->in_my = FALSE;
2506 PL_parser->in_my_stash = NULL;
2508 /* check for C<my Dog $spot> when deciding package */
2509 stash = PAD_COMPNAME_TYPE(o->op_targ);
2511 stash = PL_curstash;
2512 apply_attrs_my(stash, o, attrs, imopsp);
2514 o->op_flags |= OPf_MOD;
2515 o->op_private |= OPpLVAL_INTRO;
2517 o->op_private |= OPpPAD_STATE;
2522 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2526 int maybe_scalar = 0;
2528 PERL_ARGS_ASSERT_MY_ATTRS;
2530 /* [perl #17376]: this appears to be premature, and results in code such as
2531 C< our(%x); > executing in list mode rather than void mode */
2533 if (o->op_flags & OPf_PARENS)
2543 o = my_kid(o, attrs, &rops);
2545 if (maybe_scalar && o->op_type == OP_PADSV) {
2546 o = scalar(op_append_list(OP_LIST, rops, o));
2547 o->op_private |= OPpLVAL_INTRO;
2550 /* The listop in rops might have a pushmark at the beginning,
2551 which will mess up list assignment. */
2552 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2553 if (rops->op_type == OP_LIST &&
2554 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2556 OP * const pushmark = lrops->op_first;
2557 lrops->op_first = pushmark->op_sibling;
2560 o = op_append_list(OP_LIST, o, rops);
2563 PL_parser->in_my = FALSE;
2564 PL_parser->in_my_stash = NULL;
2569 Perl_sawparens(pTHX_ OP *o)
2571 PERL_UNUSED_CONTEXT;
2573 o->op_flags |= OPf_PARENS;
2578 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2582 const OPCODE ltype = left->op_type;
2583 const OPCODE rtype = right->op_type;
2585 PERL_ARGS_ASSERT_BIND_MATCH;
2587 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2588 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2590 const char * const desc
2592 rtype == OP_SUBST || rtype == OP_TRANS
2593 || rtype == OP_TRANSR
2595 ? (int)rtype : OP_MATCH];
2596 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2599 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2600 ? cUNOPx(left)->op_first->op_type == OP_GV
2601 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2602 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2605 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2608 Perl_warner(aTHX_ packWARN(WARN_MISC),
2609 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2612 const char * const sample = (isary
2613 ? "@array" : "%hash");
2614 Perl_warner(aTHX_ packWARN(WARN_MISC),
2615 "Applying %s to %s will act on scalar(%s)",
2616 desc, sample, sample);
2620 if (rtype == OP_CONST &&
2621 cSVOPx(right)->op_private & OPpCONST_BARE &&
2622 cSVOPx(right)->op_private & OPpCONST_STRICT)
2624 no_bareword_allowed(right);
2627 /* !~ doesn't make sense with /r, so error on it for now */
2628 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2630 yyerror("Using !~ with s///r doesn't make sense");
2631 if (rtype == OP_TRANSR && type == OP_NOT)
2632 yyerror("Using !~ with tr///r doesn't make sense");
2634 ismatchop = (rtype == OP_MATCH ||
2635 rtype == OP_SUBST ||
2636 rtype == OP_TRANS || rtype == OP_TRANSR)
2637 && !(right->op_flags & OPf_SPECIAL);
2638 if (ismatchop && right->op_private & OPpTARGET_MY) {
2640 right->op_private &= ~OPpTARGET_MY;
2642 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2645 right->op_flags |= OPf_STACKED;
2646 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
2647 ! (rtype == OP_TRANS &&
2648 right->op_private & OPpTRANS_IDENTICAL) &&
2649 ! (rtype == OP_SUBST &&
2650 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
2651 newleft = op_lvalue(left, rtype);
2654 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
2655 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2657 o = op_prepend_elem(rtype, scalar(newleft), right);
2659 return newUNOP(OP_NOT, 0, scalar(o));
2663 return bind_match(type, left,
2664 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2668 Perl_invert(pTHX_ OP *o)
2672 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2676 =for apidoc Amx|OP *|op_scope|OP *o
2678 Wraps up an op tree with some additional ops so that at runtime a dynamic
2679 scope will be created. The original ops run in the new dynamic scope,
2680 and then, provided that they exit normally, the scope will be unwound.
2681 The additional ops used to create and unwind the dynamic scope will
2682 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2683 instead if the ops are simple enough to not need the full dynamic scope
2690 Perl_op_scope(pTHX_ OP *o)
2694 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2695 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2696 o->op_type = OP_LEAVE;
2697 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2699 else if (o->op_type == OP_LINESEQ) {
2701 o->op_type = OP_SCOPE;
2702 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2703 kid = ((LISTOP*)o)->op_first;
2704 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2707 /* The following deals with things like 'do {1 for 1}' */
2708 kid = kid->op_sibling;
2710 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2715 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2721 Perl_block_start(pTHX_ int full)
2724 const int retval = PL_savestack_ix;
2726 pad_block_start(full);
2728 PL_hints &= ~HINT_BLOCK_SCOPE;
2729 SAVECOMPILEWARNINGS();
2730 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2732 CALL_BLOCK_HOOKS(bhk_start, full);
2738 Perl_block_end(pTHX_ I32 floor, OP *seq)
2741 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2742 OP* retval = scalarseq(seq);
2744 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
2747 CopHINTS_set(&PL_compiling, PL_hints);
2749 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2752 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
2758 =head1 Compile-time scope hooks
2760 =for apidoc Aox||blockhook_register
2762 Register a set of hooks to be called when the Perl lexical scope changes
2763 at compile time. See L<perlguts/"Compile-time scope hooks">.
2769 Perl_blockhook_register(pTHX_ BHK *hk)
2771 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2773 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2780 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
2781 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2782 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2785 OP * const o = newOP(OP_PADSV, 0);
2786 o->op_targ = offset;
2792 Perl_newPROG(pTHX_ OP *o)
2796 PERL_ARGS_ASSERT_NEWPROG;
2803 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2804 ((PL_in_eval & EVAL_KEEPERR)
2805 ? OPf_SPECIAL : 0), o);
2807 cx = &cxstack[cxstack_ix];
2808 assert(CxTYPE(cx) == CXt_EVAL);
2810 if ((cx->blk_gimme & G_WANT) == G_VOID)
2811 scalarvoid(PL_eval_root);
2812 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2815 scalar(PL_eval_root);
2817 /* don't use LINKLIST, since PL_eval_root might indirect through
2818 * a rather expensive function call and LINKLIST evaluates its
2819 * argument more than once */
2820 PL_eval_start = op_linklist(PL_eval_root);
2821 PL_eval_root->op_private |= OPpREFCOUNTED;
2822 OpREFCNT_set(PL_eval_root, 1);
2823 PL_eval_root->op_next = 0;
2824 i = PL_savestack_ix;
2827 CALL_PEEP(PL_eval_start);
2828 finalize_optree(PL_eval_root);
2830 PL_savestack_ix = i;
2833 if (o->op_type == OP_STUB) {
2834 PL_comppad_name = 0;
2836 S_op_destroy(aTHX_ o);
2839 PL_main_root = op_scope(sawparens(scalarvoid(o)));
2840 PL_curcop = &PL_compiling;
2841 PL_main_start = LINKLIST(PL_main_root);
2842 PL_main_root->op_private |= OPpREFCOUNTED;
2843 OpREFCNT_set(PL_main_root, 1);
2844 PL_main_root->op_next = 0;
2845 CALL_PEEP(PL_main_start);
2846 finalize_optree(PL_main_root);
2849 /* Register with debugger */
2851 CV * const cv = get_cvs("DB::postponed", 0);
2855 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2857 call_sv(MUTABLE_SV(cv), G_DISCARD);
2864 Perl_localize(pTHX_ OP *o, I32 lex)
2868 PERL_ARGS_ASSERT_LOCALIZE;
2870 if (o->op_flags & OPf_PARENS)
2871 /* [perl #17376]: this appears to be premature, and results in code such as
2872 C< our(%x); > executing in list mode rather than void mode */
2879 if ( PL_parser->bufptr > PL_parser->oldbufptr
2880 && PL_parser->bufptr[-1] == ','
2881 && ckWARN(WARN_PARENTHESIS))
2883 char *s = PL_parser->bufptr;
2886 /* some heuristics to detect a potential error */
2887 while (*s && (strchr(", \t\n", *s)))
2891 if (*s && strchr("@$%*", *s) && *++s
2892 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2895 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2897 while (*s && (strchr(", \t\n", *s)))
2903 if (sigil && (*s == ';' || *s == '=')) {
2904 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2905 "Parentheses missing around \"%s\" list",
2907 ? (PL_parser->in_my == KEY_our
2909 : PL_parser->in_my == KEY_state
2919 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
2920 PL_parser->in_my = FALSE;
2921 PL_parser->in_my_stash = NULL;
2926 Perl_jmaybe(pTHX_ OP *o)
2928 PERL_ARGS_ASSERT_JMAYBE;
2930 if (o->op_type == OP_LIST) {
2932 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2933 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
2938 PERL_STATIC_INLINE OP *
2939 S_op_std_init(pTHX_ OP *o)
2941 I32 type = o->op_type;
2943 PERL_ARGS_ASSERT_OP_STD_INIT;
2945 if (PL_opargs[type] & OA_RETSCALAR)
2947 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2948 o->op_targ = pad_alloc(type, SVs_PADTMP);
2953 PERL_STATIC_INLINE OP *
2954 S_op_integerize(pTHX_ OP *o)
2956 I32 type = o->op_type;
2958 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2960 /* integerize op, unless it happens to be C<-foo>.
2961 * XXX should pp_i_negate() do magic string negation instead? */
2962 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2963 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2964 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2967 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2970 if (type == OP_NEGATE)
2971 /* XXX might want a ck_negate() for this */
2972 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2978 S_fold_constants(pTHX_ register OP *o)
2981 register OP * VOL curop;
2983 VOL I32 type = o->op_type;
2988 SV * const oldwarnhook = PL_warnhook;
2989 SV * const olddiehook = PL_diehook;
2993 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2995 if (!(PL_opargs[type] & OA_FOLDCONST))
3009 /* XXX what about the numeric ops? */
3010 if (IN_LOCALE_COMPILETIME)
3015 if (PL_parser && PL_parser->error_count)
3016 goto nope; /* Don't try to run w/ errors */
3018 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3019 const OPCODE type = curop->op_type;
3020 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3022 type != OP_SCALAR &&
3024 type != OP_PUSHMARK)
3030 curop = LINKLIST(o);
3031 old_next = o->op_next;
3035 oldscope = PL_scopestack_ix;
3036 create_eval_scope(G_FAKINGEVAL);
3038 /* Verify that we don't need to save it: */
3039 assert(PL_curcop == &PL_compiling);
3040 StructCopy(&PL_compiling, ¬_compiling, COP);
3041 PL_curcop = ¬_compiling;
3042 /* The above ensures that we run with all the correct hints of the
3043 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3044 assert(IN_PERL_RUNTIME);
3045 PL_warnhook = PERL_WARNHOOK_FATAL;
3052 sv = *(PL_stack_sp--);
3053 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3055 /* Can't simply swipe the SV from the pad, because that relies on
3056 the op being freed "real soon now". Under MAD, this doesn't
3057 happen (see the #ifdef below). */
3060 pad_swipe(o->op_targ, FALSE);
3063 else if (SvTEMP(sv)) { /* grab mortal temp? */
3064 SvREFCNT_inc_simple_void(sv);
3069 /* Something tried to die. Abandon constant folding. */
3070 /* Pretend the error never happened. */
3072 o->op_next = old_next;
3076 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3077 PL_warnhook = oldwarnhook;
3078 PL_diehook = olddiehook;
3079 /* XXX note that this croak may fail as we've already blown away
3080 * the stack - eg any nested evals */
3081 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3084 PL_warnhook = oldwarnhook;
3085 PL_diehook = olddiehook;
3086 PL_curcop = &PL_compiling;
3088 if (PL_scopestack_ix > oldscope)
3089 delete_eval_scope();
3098 if (type == OP_RV2GV)
3099 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3101 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3102 op_getmad(o,newop,'f');
3110 S_gen_constant_list(pTHX_ register OP *o)
3114 const I32 oldtmps_floor = PL_tmps_floor;
3117 if (PL_parser && PL_parser->error_count)
3118 return o; /* Don't attempt to run with errors */
3120 PL_op = curop = LINKLIST(o);
3123 Perl_pp_pushmark(aTHX);
3126 assert (!(curop->op_flags & OPf_SPECIAL));
3127 assert(curop->op_type == OP_RANGE);
3128 Perl_pp_anonlist(aTHX);
3129 PL_tmps_floor = oldtmps_floor;
3131 o->op_type = OP_RV2AV;
3132 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3133 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3134 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
3135 o->op_opt = 0; /* needs to be revisited in rpeep() */
3136 curop = ((UNOP*)o)->op_first;
3137 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
3139 op_getmad(curop,o,'O');
3148 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3151 if (type < 0) type = -type, flags |= OPf_SPECIAL;
3152 if (!o || o->op_type != OP_LIST)
3153 o = newLISTOP(OP_LIST, 0, o, NULL);
3155 o->op_flags &= ~OPf_WANT;
3157 if (!(PL_opargs[type] & OA_MARK))
3158 op_null(cLISTOPo->op_first);
3160 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3161 if (kid2 && kid2->op_type == OP_COREARGS) {
3162 op_null(cLISTOPo->op_first);
3163 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3167 o->op_type = (OPCODE)type;
3168 o->op_ppaddr = PL_ppaddr[type];
3169 o->op_flags |= flags;
3171 o = CHECKOP(type, o);
3172 if (o->op_type != (unsigned)type)
3175 return fold_constants(op_integerize(op_std_init(o)));
3179 =head1 Optree Manipulation Functions
3182 /* List constructors */
3185 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3187 Append an item to the list of ops contained directly within a list-type
3188 op, returning the lengthened list. I<first> is the list-type op,
3189 and I<last> is the op to append to the list. I<optype> specifies the
3190 intended opcode for the list. If I<first> is not already a list of the
3191 right type, it will be upgraded into one. If either I<first> or I<last>
3192 is null, the other is returned unchanged.
3198 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3206 if (first->op_type != (unsigned)type
3207 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3209 return newLISTOP(type, 0, first, last);
3212 if (first->op_flags & OPf_KIDS)
3213 ((LISTOP*)first)->op_last->op_sibling = last;
3215 first->op_flags |= OPf_KIDS;
3216 ((LISTOP*)first)->op_first = last;
3218 ((LISTOP*)first)->op_last = last;
3223 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3225 Concatenate the lists of ops contained directly within two list-type ops,
3226 returning the combined list. I<first> and I<last> are the list-type ops
3227 to concatenate. I<optype> specifies the intended opcode for the list.
3228 If either I<first> or I<last> is not already a list of the right type,
3229 it will be upgraded into one. If either I<first> or I<last> is null,
3230 the other is returned unchanged.
3236 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3244 if (first->op_type != (unsigned)type)
3245 return op_prepend_elem(type, first, last);
3247 if (last->op_type != (unsigned)type)
3248 return op_append_elem(type, first, last);
3250 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3251 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3252 first->op_flags |= (last->op_flags & OPf_KIDS);
3255 if (((LISTOP*)last)->op_first && first->op_madprop) {
3256 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3258 while (mp->mad_next)
3260 mp->mad_next = first->op_madprop;
3263 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3266 first->op_madprop = last->op_madprop;
3267 last->op_madprop = 0;
3270 S_op_destroy(aTHX_ last);
3276 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3278 Prepend an item to the list of ops contained directly within a list-type
3279 op, returning the lengthened list. I<first> is the op to prepend to the
3280 list, and I<last> is the list-type op. I<optype> specifies the intended
3281 opcode for the list. If I<last> is not already a list of the right type,
3282 it will be upgraded into one. If either I<first> or I<last> is null,
3283 the other is returned unchanged.
3289 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3297 if (last->op_type == (unsigned)type) {
3298 if (type == OP_LIST) { /* already a PUSHMARK there */
3299 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3300 ((LISTOP*)last)->op_first->op_sibling = first;
3301 if (!(first->op_flags & OPf_PARENS))
3302 last->op_flags &= ~OPf_PARENS;
3305 if (!(last->op_flags & OPf_KIDS)) {
3306 ((LISTOP*)last)->op_last = first;
3307 last->op_flags |= OPf_KIDS;
3309 first->op_sibling = ((LISTOP*)last)->op_first;
3310 ((LISTOP*)last)->op_first = first;
3312 last->op_flags |= OPf_KIDS;
3316 return newLISTOP(type, 0, first, last);
3324 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3327 Newxz(tk, 1, TOKEN);
3328 tk->tk_type = (OPCODE)optype;
3329 tk->tk_type = 12345;
3331 tk->tk_mad = madprop;
3336 Perl_token_free(pTHX_ TOKEN* tk)
3338 PERL_ARGS_ASSERT_TOKEN_FREE;
3340 if (tk->tk_type != 12345)
3342 mad_free(tk->tk_mad);
3347 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3352 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3354 if (tk->tk_type != 12345) {
3355 Perl_warner(aTHX_ packWARN(WARN_MISC),
3356 "Invalid TOKEN object ignored");
3363 /* faked up qw list? */
3365 tm->mad_type == MAD_SV &&
3366 SvPVX((SV *)tm->mad_val)[0] == 'q')
3373 /* pretend constant fold didn't happen? */
3374 if (mp->mad_key == 'f' &&
3375 (o->op_type == OP_CONST ||
3376 o->op_type == OP_GV) )
3378 token_getmad(tk,(OP*)mp->mad_val,slot);
3392 if (mp->mad_key == 'X')
3393 mp->mad_key = slot; /* just change the first one */
3403 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3412 /* pretend constant fold didn't happen? */
3413 if (mp->mad_key == 'f' &&
3414 (o->op_type == OP_CONST ||
3415 o->op_type == OP_GV) )
3417 op_getmad(from,(OP*)mp->mad_val,slot);
3424 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3427 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3433 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3442 /* pretend constant fold didn't happen? */
3443 if (mp->mad_key == 'f' &&
3444 (o->op_type == OP_CONST ||
3445 o->op_type == OP_GV) )
3447 op_getmad(from,(OP*)mp->mad_val,slot);
3454 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3457 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3461 PerlIO_printf(PerlIO_stderr(),
3462 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
3468 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3486 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3490 addmad(tm, &(o->op_madprop), slot);
3494 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3515 Perl_newMADsv(pTHX_ char key, SV* sv)
3517 PERL_ARGS_ASSERT_NEWMADSV;
3519 return newMADPROP(key, MAD_SV, sv, 0);
3523 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
3525 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
3528 mp->mad_vlen = vlen;
3529 mp->mad_type = type;
3531 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3536 Perl_mad_free(pTHX_ MADPROP* mp)
3538 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3542 mad_free(mp->mad_next);
3543 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
3544 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3545 switch (mp->mad_type) {
3549 Safefree((char*)mp->mad_val);
3552 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3553 op_free((OP*)mp->mad_val);
3556 sv_free(MUTABLE_SV(mp->mad_val));
3559 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3562 PerlMemShared_free(mp);
3568 =head1 Optree construction
3570 =for apidoc Am|OP *|newNULLLIST
3572 Constructs, checks, and returns a new C<stub> op, which represents an
3573 empty list expression.
3579 Perl_newNULLLIST(pTHX)
3581 return newOP(OP_STUB, 0);
3585 S_force_list(pTHX_ OP *o)
3587 if (!o || o->op_type != OP_LIST)
3588 o = newLISTOP(OP_LIST, 0, o, NULL);
3594 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3596 Constructs, checks, and returns an op of any list type. I<type> is
3597 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3598 C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3599 supply up to two ops to be direct children of the list op; they are
3600 consumed by this function and become part of the constructed op tree.
3606 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3611 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3613 NewOp(1101, listop, 1, LISTOP);
3615 listop->op_type = (OPCODE)type;
3616 listop->op_ppaddr = PL_ppaddr[type];
3619 listop->op_flags = (U8)flags;
3623 else if (!first && last)
3626 first->op_sibling = last;
3627 listop->op_first = first;
3628 listop->op_last = last;
3629 if (type == OP_LIST) {
3630 OP* const pushop = newOP(OP_PUSHMARK, 0);
3631 pushop->op_sibling = first;
3632 listop->op_first = pushop;
3633 listop->op_flags |= OPf_KIDS;
3635 listop->op_last = pushop;
3638 return CHECKOP(type, listop);
3642 =for apidoc Am|OP *|newOP|I32 type|I32 flags
3644 Constructs, checks, and returns an op of any base type (any type that
3645 has no extra fields). I<type> is the opcode. I<flags> gives the
3646 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3653 Perl_newOP(pTHX_ I32 type, I32 flags)
3658 if (type == -OP_ENTEREVAL) {
3659 type = OP_ENTEREVAL;
3660 flags |= OPpEVAL_BYTES<<8;
3663 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3664 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3665 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3666 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3668 NewOp(1101, o, 1, OP);
3669 o->op_type = (OPCODE)type;
3670 o->op_ppaddr = PL_ppaddr[type];
3671 o->op_flags = (U8)flags;
3673 o->op_latefreed = 0;
3677 o->op_private = (U8)(0 | (flags >> 8));
3678 if (PL_opargs[type] & OA_RETSCALAR)
3680 if (PL_opargs[type] & OA_TARGET)
3681 o->op_targ = pad_alloc(type, SVs_PADTMP);
3682 return CHECKOP(type, o);
3686 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3688 Constructs, checks, and returns an op of any unary type. I<type> is
3689 the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3690 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3691 bits, the eight bits of C<op_private>, except that the bit with value 1
3692 is automatically set. I<first> supplies an optional op to be the direct
3693 child of the unary op; it is consumed by this function and become part
3694 of the constructed op tree.
3700 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3705 if (type == -OP_ENTEREVAL) {
3706 type = OP_ENTEREVAL;
3707 flags |= OPpEVAL_BYTES<<8;
3710 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
3711 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3712 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3713 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
3714 || type == OP_SASSIGN
3715 || type == OP_ENTERTRY
3716 || type == OP_NULL );
3719 first = newOP(OP_STUB, 0);
3720 if (PL_opargs[type] & OA_MARK)
3721 first = force_list(first);
3723 NewOp(1101, unop, 1, UNOP);
3724 unop->op_type = (OPCODE)type;
3725 unop->op_ppaddr = PL_ppaddr[type];
3726 unop->op_first = first;
3727 unop->op_flags = (U8)(flags | OPf_KIDS);
3728 unop->op_private = (U8)(1 | (flags >> 8));
3729 unop = (UNOP*) CHECKOP(type, unop);
3733 return fold_constants(op_integerize(op_std_init((OP *) unop)));
3737 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
3739 Constructs, checks, and returns an op of any binary type. I<type>
3740 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
3741 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
3742 the eight bits of C<op_private>, except that the bit with value 1 or
3743 2 is automatically set as required. I<first> and I<last> supply up to
3744 two ops to be the direct children of the binary op; they are consumed
3745 by this function and become part of the constructed op tree.
3751 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3756 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
3757 || type == OP_SASSIGN || type == OP_NULL );
3759 NewOp(1101, binop, 1, BINOP);
3762 first = newOP(OP_NULL, 0);
3764 binop->op_type = (OPCODE)type;
3765 binop->op_ppaddr = PL_ppaddr[type];
3766 binop->op_first = first;
3767 binop->op_flags = (U8)(flags | OPf_KIDS);
3770 binop->op_private = (U8)(1 | (flags >> 8));
3773 binop->op_private = (U8)(2 | (flags >> 8));
3774 first->op_sibling = last;
3777 binop = (BINOP*)CHECKOP(type, binop);
3778 if (binop->op_next || binop->op_type != (OPCODE)type)
3781 binop->op_last = binop->op_first->op_sibling;
3783 return fold_constants(op_integerize(op_std_init((OP *)binop)));
3786 static int uvcompare(const void *a, const void *b)
3787 __attribute__nonnull__(1)
3788 __attribute__nonnull__(2)
3789 __attribute__pure__;
3790 static int uvcompare(const void *a, const void *b)
3792 if (*((const UV *)a) < (*(const UV *)b))
3794 if (*((const UV *)a) > (*(const UV *)b))
3796 if (*((const UV *)a+1) < (*(const UV *)b+1))
3798 if (*((const UV *)a+1) > (*(const UV *)b+1))
3804 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3807 SV * const tstr = ((SVOP*)expr)->op_sv;
3810 (repl->op_type == OP_NULL)
3811 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3813 ((SVOP*)repl)->op_sv;
3816 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3817 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3821 register short *tbl;
3823 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3824 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3825 I32 del = o->op_private & OPpTRANS_DELETE;
3828 PERL_ARGS_ASSERT_PMTRANS;
3830 PL_hints |= HINT_BLOCK_SCOPE;
3833 o->op_private |= OPpTRANS_FROM_UTF;
3836 o->op_private |= OPpTRANS_TO_UTF;
3838 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3839 SV* const listsv = newSVpvs("# comment\n");
3841 const U8* tend = t + tlen;
3842 const U8* rend = r + rlen;
3856 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3857 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3860 const U32 flags = UTF8_ALLOW_DEFAULT;
3864 t = tsave = bytes_to_utf8(t, &len);
3867 if (!to_utf && rlen) {
3869 r = rsave = bytes_to_utf8(r, &len);
3873 /* There are several snags with this code on EBCDIC:
3874 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3875 2. scan_const() in toke.c has encoded chars in native encoding which makes
3876 ranges at least in EBCDIC 0..255 range the bottom odd.
3880 U8 tmpbuf[UTF8_MAXBYTES+1];
3883 Newx(cp, 2*tlen, UV);
3885 transv = newSVpvs("");
3887 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3889 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3891 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3895 cp[2*i+1] = cp[2*i];
3899 qsort(cp, i, 2*sizeof(UV), uvcompare);
3900 for (j = 0; j < i; j++) {
3902 diff = val - nextmin;
3904 t = uvuni_to_utf8(tmpbuf,nextmin);
3905 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3907 U8 range_mark = UTF_TO_NATIVE(0xff);
3908 t = uvuni_to_utf8(tmpbuf, val - 1);
3909 sv_catpvn(transv, (char *)&range_mark, 1);
3910 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3917 t = uvuni_to_utf8(tmpbuf,nextmin);
3918 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3920 U8 range_mark = UTF_TO_NATIVE(0xff);
3921 sv_catpvn(transv, (char *)&range_mark, 1);
3923 t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
3924 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3925 t = (const U8*)SvPVX_const(transv);
3926 tlen = SvCUR(transv);
3930 else if (!rlen && !del) {
3931 r = t; rlen = tlen; rend = tend;
3934 if ((!rlen && !del) || t == r ||
3935 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3937 o->op_private |= OPpTRANS_IDENTICAL;
3941 while (t < tend || tfirst <= tlast) {
3942 /* see if we need more "t" chars */
3943 if (tfirst > tlast) {
3944 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3946 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3948 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3955 /* now see if we need more "r" chars */
3956 if (rfirst > rlast) {
3958 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3960 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3962 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3971 rfirst = rlast = 0xffffffff;
3975 /* now see which range will peter our first, if either. */
3976 tdiff = tlast - tfirst;
3977 rdiff = rlast - rfirst;
3984 if (rfirst == 0xffffffff) {
3985 diff = tdiff; /* oops, pretend rdiff is infinite */
3987 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3988 (long)tfirst, (long)tlast);
3990 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3994 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3995 (long)tfirst, (long)(tfirst + diff),
3998 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3999 (long)tfirst, (long)rfirst);
4001 if (rfirst + diff > max)
4002 max = rfirst + diff;
4004 grows = (tfirst < rfirst &&
4005 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4017 else if (max > 0xff)
4022 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4024 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
4025 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4026 PAD_SETSV(cPADOPo->op_padix, swash);
4028 SvREADONLY_on(swash);
4030 cSVOPo->op_sv = swash;
4032 SvREFCNT_dec(listsv);
4033 SvREFCNT_dec(transv);
4035 if (!del && havefinal && rlen)
4036 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4037 newSVuv((UV)final), 0);
4040 o->op_private |= OPpTRANS_GROWS;
4046 op_getmad(expr,o,'e');
4047 op_getmad(repl,o,'r');
4055 tbl = (short*)PerlMemShared_calloc(
4056 (o->op_private & OPpTRANS_COMPLEMENT) &&
4057 !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4059 cPVOPo->op_pv = (char*)tbl;
4061 for (i = 0; i < (I32)tlen; i++)
4063 for (i = 0, j = 0; i < 256; i++) {
4065 if (j >= (I32)rlen) {
4074 if (i < 128 && r[j] >= 128)
4084 o->op_private |= OPpTRANS_IDENTICAL;
4086 else if (j >= (I32)rlen)
4091 PerlMemShared_realloc(tbl,
4092 (0x101+rlen-j) * sizeof(short));
4093 cPVOPo->op_pv = (char*)tbl;
4095 tbl[0x100] = (short)(rlen - j);
4096 for (i=0; i < (I32)rlen - j; i++)
4097 tbl[0x101+i] = r[j+i];
4101 if (!rlen && !del) {
4104 o->op_private |= OPpTRANS_IDENTICAL;
4106 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4107 o->op_private |= OPpTRANS_IDENTICAL;
4109 for (i = 0; i < 256; i++)
4111 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4112 if (j >= (I32)rlen) {
4114 if (tbl[t[i]] == -1)
4120 if (tbl[t[i]] == -1) {
4121 if (t[i] < 128 && r[j] >= 128)
4128 if(del && rlen == tlen) {
4129 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4130 } else if(rlen > tlen) {
4131 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4135 o->op_private |= OPpTRANS_GROWS;
4137 op_getmad(expr,o,'e');
4138 op_getmad(repl,o,'r');
4148 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4150 Constructs, checks, and returns an op of any pattern matching type.
4151 I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
4152 and, shifted up eight bits, the eight bits of C<op_private>.
4158 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4163 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4165 NewOp(1101, pmop, 1, PMOP);
4166 pmop->op_type = (OPCODE)type;
4167 pmop->op_ppaddr = PL_ppaddr[type];
4168 pmop->op_flags = (U8)flags;
4169 pmop->op_private = (U8)(0 | (flags >> 8));
4171 if (PL_hints & HINT_RE_TAINT)
4172 pmop->op_pmflags |= PMf_RETAINT;
4173 if (IN_LOCALE_COMPILETIME) {
4174 set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4176 else if ((! (PL_hints & HINT_BYTES))
4177 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4178 && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4180 set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4182 if (PL_hints & HINT_RE_FLAGS) {
4183 SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4184 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4186 if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4187 reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4188 PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4190 if (reflags && SvOK(reflags)) {
4191 set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4197 assert(SvPOK(PL_regex_pad[0]));
4198 if (SvCUR(PL_regex_pad[0])) {
4199 /* Pop off the "packed" IV from the end. */
4200 SV *const repointer_list = PL_regex_pad[0];
4201 const char *p = SvEND(repointer_list) - sizeof(IV);
4202 const IV offset = *((IV*)p);
4204 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4206 SvEND_set(repointer_list, p);
4208 pmop->op_pmoffset = offset;
4209 /* This slot should be free, so assert this: */
4210 assert(PL_regex_pad[offset] == &PL_sv_undef);
4212 SV * const repointer = &PL_sv_undef;
4213 av_push(PL_regex_padav, repointer);
4214 pmop->op_pmoffset = av_len(PL_regex_padav);
4215 PL_regex_pad = AvARRAY(PL_regex_padav);
4219 return CHECKOP(type, pmop);
4222 /* Given some sort of match op o, and an expression expr containing a
4223 * pattern, either compile expr into a regex and attach it to o (if it's
4224 * constant), or convert expr into a runtime regcomp op sequence (if it's
4227 * isreg indicates that the pattern is part of a regex construct, eg
4228 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4229 * split "pattern", which aren't. In the former case, expr will be a list
4230 * if the pattern contains more than one term (eg /a$b/) or if it contains
4231 * a replacement, ie s/// or tr///.
4235 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
4240 I32 repl_has_vars = 0;
4244 PERL_ARGS_ASSERT_PMRUNTIME;
4247 o->op_type == OP_SUBST
4248 || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
4250 /* last element in list is the replacement; pop it */
4252 repl = cLISTOPx(expr)->op_last;
4253 kid = cLISTOPx(expr)->op_first;
4254 while (kid->op_sibling != repl)
4255 kid = kid->op_sibling;
4256 kid->op_sibling = NULL;
4257 cLISTOPx(expr)->op_last = kid;
4260 if (isreg && expr->op_type == OP_LIST &&
4261 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
4263 /* convert single element list to element */
4264 OP* const oe = expr;
4265 expr = cLISTOPx(oe)->op_first->op_sibling;
4266 cLISTOPx(oe)->op_first->op_sibling = NULL;
4267 cLISTOPx(oe)->op_last = NULL;
4271 if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
4272 return pmtrans(o, expr, repl);
4275 reglist = isreg && expr->op_type == OP_LIST;
4279 PL_hints |= HINT_BLOCK_SCOPE;
4282 if (expr->op_type == OP_CONST) {
4283 SV *pat = ((SVOP*)expr)->op_sv;
4284 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4286 if (o->op_flags & OPf_SPECIAL)
4287 pm_flags |= RXf_SPLIT;
4290 assert (SvUTF8(pat));
4291 } else if (SvUTF8(pat)) {
4292 /* Not doing UTF-8, despite what the SV says. Is this only if we're
4293 trapped in use 'bytes'? */
4294 /* Make a copy of the octet sequence, but without the flag on, as
4295 the compiler now honours the SvUTF8 flag on pat. */
4297 const char *const p = SvPV(pat, len);
4298 pat = newSVpvn_flags(p, len, SVs_TEMP);
4301 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
4304 op_getmad(expr,(OP*)pm,'e');
4310 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
4311 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
4313 : OP_REGCMAYBE),0,expr);
4315 NewOp(1101, rcop, 1, LOGOP);
4316 rcop->op_type = OP_REGCOMP;
4317 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
4318 rcop->op_first = scalar(expr);
4319 rcop->op_flags |= OPf_KIDS
4320 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
4321 | (reglist ? OPf_STACKED : 0);
4322 rcop->op_private = 1;
4325 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
4327 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
4328 if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
4330 /* establish postfix order */
4331 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
4333 rcop->op_next = expr;
4334 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
4337 rcop->op_next = LINKLIST(expr);
4338 expr->op_next = (OP*)rcop;
4341 op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
4346 if (pm->op_pmflags & PMf_EVAL) {
4348 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
4349 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
4351 else if (repl->op_type == OP_CONST)
4355 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
4356 if (curop->op_type == OP_SCOPE
4357 || curop->op_type == OP_LEAVE
4358 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
4359 if (curop->op_type == OP_GV) {
4360 GV * const gv = cGVOPx_gv(curop);
4362 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
4365 else if (curop->op_type == OP_RV2CV)
4367 else if (curop->op_type == OP_RV2SV ||
4368 curop->op_type == OP_RV2AV ||
4369 curop->op_type == OP_RV2HV ||
4370 curop->op_type == OP_RV2GV) {
4371 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
4374 else if (curop->op_type == OP_PADSV ||
4375 curop->op_type == OP_PADAV ||
4376 curop->op_type == OP_PADHV ||
4377 curop->op_type == OP_PADANY)
4381 else if (curop->op_type == OP_PUSHRE)
4382 NOOP; /* Okay here, dangerous in newASSIGNOP */
4392 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
4394 pm->op_pmflags |= PMf_CONST; /* const for long enough */
4395 op_prepend_elem(o->op_type, scalar(repl), o);
4398 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
4399 pm->op_pmflags |= PMf_MAYBE_CONST;
4401 NewOp(1101, rcop, 1, LOGOP);
4402 rcop->op_type = OP_SUBSTCONT;
4403 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
4404 rcop->op_first = scalar(repl);
4405 rcop->op_flags |= OPf_KIDS;
4406 rcop->op_private = 1;
4409 /* establish postfix order */
4410 rcop->op_next = LINKLIST(repl);
4411 repl->op_next = (OP*)rcop;
4413 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
4414 assert(!(pm->op_pmflags & PMf_ONCE));
4415 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
4424 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
4426 Constructs, checks, and returns an op of any type that involves an
4427 embedded SV. I<type> is the opcode. I<flags> gives the eight bits
4428 of C<op_flags>. I<sv> gives the SV to embed in the op; this function
4429 takes ownership of one reference to it.
4435 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
4440 PERL_ARGS_ASSERT_NEWSVOP;
4442 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4443 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4444 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4446 NewOp(1101, svop, 1, SVOP);
4447 svop->op_type = (OPCODE)type;
4448 svop->op_ppaddr = PL_ppaddr[type];
4450 svop->op_next = (OP*)svop;
4451 svop->op_flags = (U8)flags;
4452 if (PL_opargs[type] & OA_RETSCALAR)
4454 if (PL_opargs[type] & OA_TARGET)
4455 svop->op_targ = pad_alloc(type, SVs_PADTMP);
4456 return CHECKOP(type, svop);
4462 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
4464 Constructs, checks, and returns an op of any type that involves a
4465 reference to a pad element. I<type> is the opcode. I<flags> gives the
4466 eight bits of C<op_flags>. A pad slot is automatically allocated, and
4467 is populated with I<sv>; this function takes ownership of one reference
4470 This function only exists if Perl has been compiled to use ithreads.
4476 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
4481 PERL_ARGS_ASSERT_NEWPADOP;
4483 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
4484 || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4485 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
4487 NewOp(1101, padop, 1, PADOP);
4488 padop->op_type = (OPCODE)type;
4489 padop->op_ppaddr = PL_ppaddr[type];
4490 padop->op_padix = pad_alloc(type, SVs_PADTMP);
4491 SvREFCNT_dec(PAD_SVl(padop->op_padix));
4492 PAD_SETSV(padop->op_padix, sv);
4495 padop->op_next = (OP*)padop;
4496 padop->op_flags = (U8)flags;
4497 if (PL_opargs[type] & OA_RETSCALAR)
4499 if (PL_opargs[type] & OA_TARGET)
4500 padop->op_targ = pad_alloc(type, SVs_PADTMP);
4501 return CHECKOP(type, padop);
4504 #endif /* !USE_ITHREADS */
4507 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
4509 Constructs, checks, and returns an op of any type that involves an
4510 embedded reference to a GV. I<type> is the opcode. I<flags> gives the
4511 eight bits of C<op_flags>. I<gv> identifies the GV that the op should
4512 reference; calling this function does not transfer ownership of any
4519 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
4523 PERL_ARGS_ASSERT_NEWGVOP;
4527 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4529 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
4534 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
4536 Constructs, checks, and returns an op of any type that involves an
4537 embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
4538 the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
4539 must have been allocated using L</PerlMemShared_malloc>; the memory will
4540 be freed when the op is destroyed.
4546 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
4549 const bool utf8 = cBOOL(flags & SVf_UTF8);
4554 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
4556 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4558 NewOp(1101, pvop, 1, PVOP);
4559 pvop->op_type = (OPCODE)type;
4560 pvop->op_ppaddr = PL_ppaddr[type];
4562 pvop->op_next = (OP*)pvop;
4563 pvop->op_flags = (U8)flags;
4564 pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
4565 if (PL_opargs[type] & OA_RETSCALAR)
4567 if (PL_opargs[type] & OA_TARGET)
4568 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
4569 return CHECKOP(type, pvop);
4577 Perl_package(pTHX_ OP *o)
4580 SV *const sv = cSVOPo->op_sv;
4585 PERL_ARGS_ASSERT_PACKAGE;
4587 SAVEGENERICSV(PL_curstash);
4588 save_item(PL_curstname);
4590 PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
4592 sv_setsv(PL_curstname, sv);
4594 PL_hints |= HINT_BLOCK_SCOPE;
4595 PL_parser->copline = NOLINE;
4596 PL_parser->expect = XSTATE;
4601 if (!PL_madskills) {
4606 pegop = newOP(OP_NULL,0);
4607 op_getmad(o,pegop,'P');
4613 Perl_package_version( pTHX_ OP *v )
4616 U32 savehints = PL_hints;
4617 PERL_ARGS_ASSERT_PACKAGE_VERSION;
4618 PL_hints &= ~HINT_STRICT_VARS;
4619 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
4620 PL_hints = savehints;
4629 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
4636 OP *pegop = newOP(OP_NULL,0);
4638 SV *use_version = NULL;
4640 PERL_ARGS_ASSERT_UTILIZE;
4642 if (idop->op_type != OP_CONST)
4643 Perl_croak(aTHX_ "Module name must be constant");
4646 op_getmad(idop,pegop,'U');
4651 SV * const vesv = ((SVOP*)version)->op_sv;
4654 op_getmad(version,pegop,'V');
4655 if (!arg && !SvNIOKp(vesv)) {
4662 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
4663 Perl_croak(aTHX_ "Version number must be a constant number");
4665 /* Make copy of idop so we don't free it twice */
4666 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4668 /* Fake up a method call to VERSION */
4669 meth = newSVpvs_share("VERSION");
4670 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4671 op_append_elem(OP_LIST,
4672 op_prepend_elem(OP_LIST, pack, list(version)),
4673 newSVOP(OP_METHOD_NAMED, 0, meth)));
4677 /* Fake up an import/unimport */
4678 if (arg && arg->op_type == OP_STUB) {
4680 op_getmad(arg,pegop,'S');
4681 imop = arg; /* no import on explicit () */
4683 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
4684 imop = NULL; /* use 5.0; */
4686 use_version = ((SVOP*)idop)->op_sv;
4688 idop->op_private |= OPpCONST_NOVER;
4694 op_getmad(arg,pegop,'A');
4696 /* Make copy of idop so we don't free it twice */
4697 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
4699 /* Fake up a method call to import/unimport */
4701 ? newSVpvs_share("import") : newSVpvs_share("unimport");
4702 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
4703 op_append_elem(OP_LIST,
4704 op_prepend_elem(OP_LIST, pack, list(arg)),
4705 newSVOP(OP_METHOD_NAMED, 0, meth)));
4708 /* Fake up the BEGIN {}, which does its thing immediately. */
4710 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
4713 op_append_elem(OP_LINESEQ,
4714 op_append_elem(OP_LINESEQ,
4715 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
4716 newSTATEOP(0, NULL, veop)),
4717 newSTATEOP(0, NULL, imop) ));
4721 * feature bundle that corresponds to the required version. */
4722 use_version = sv_2mortal(new_version(use_version));
4723 S_enable_feature_bundle(aTHX_ use_version);
4725 /* If a version >= 5.11.0 is requested, strictures are on by default! */
4726 if (vcmp(use_version,
4727 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
4728 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4729 PL_hints |= HINT_STRICT_REFS;
4730 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4731 PL_hints |= HINT_STRICT_SUBS;
4732 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4733 PL_hints |= HINT_STRICT_VARS;
4735 /* otherwise they are off */
4737 if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
4738 PL_hints &= ~HINT_STRICT_REFS;
4739 if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
4740 PL_hints &= ~HINT_STRICT_SUBS;
4741 if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
4742 PL_hints &= ~HINT_STRICT_VARS;
4746 /* The "did you use incorrect case?" warning used to be here.
4747 * The problem is that on case-insensitive filesystems one
4748 * might get false positives for "use" (and "require"):
4749 * "use Strict" or "require CARP" will work. This causes
4750 * portability problems for the script: in case-strict
4751 * filesystems the script will stop working.
4753 * The "incorrect case" warning checked whether "use Foo"
4754 * imported "Foo" to your namespace, but that is wrong, too:
4755 * there is no requirement nor promise in the language that
4756 * a Foo.pm should or would contain anything in package "Foo".
4758 * There is very little Configure-wise that can be done, either:
4759 * the case-sensitivity of the build filesystem of Perl does not
4760 * help in guessing the case-sensitivity of the runtime environment.
4763 PL_hints |= HINT_BLOCK_SCOPE;
4764 PL_parser->copline = NOLINE;
4765 PL_parser->expect = XSTATE;
4766 PL_cop_seqmax++; /* Purely for B::*'s benefit */
4767 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
4771 if (!PL_madskills) {
4772 /* FIXME - don't allocate pegop if !PL_madskills */
4781 =head1 Embedding Functions
4783 =for apidoc load_module
4785 Loads the module whose name is pointed to by the string part of name.
4786 Note that the actual module name, not its filename, should be given.
4787 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
4788 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4789 (or 0 for no flags). ver, if specified and not NULL, provides version semantics
4790 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
4791 arguments can be used to specify arguments to the module's import()
4792 method, similar to C<use Foo::Bar VERSION LIST>. They must be
4793 terminated with a final NULL pointer. Note that this list can only
4794 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4795 Otherwise at least a single NULL pointer to designate the default
4796 import list is required.
4798 The reference count for each specified C<SV*> parameter is decremented.
4803 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4807 PERL_ARGS_ASSERT_LOAD_MODULE;
4809 va_start(args, ver);
4810 vload_module(flags, name, ver, &args);
4814 #ifdef PERL_IMPLICIT_CONTEXT
4816 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4820 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4821 va_start(args, ver);
4822 vload_module(flags, name, ver, &args);
4828 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4832 OP * const modname = newSVOP(OP_CONST, 0, name);
4834 PERL_ARGS_ASSERT_VLOAD_MODULE;
4836 modname->op_private |= OPpCONST_BARE;
4838 veop = newSVOP(OP_CONST, 0, ver);
4842 if (flags & PERL_LOADMOD_NOIMPORT) {
4843 imop = sawparens(newNULLLIST());
4845 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4846 imop = va_arg(*args, OP*);
4851 sv = va_arg(*args, SV*);
4853 imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4854 sv = va_arg(*args, SV*);
4858 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4859 * that it has a PL_parser to play with while doing that, and also
4860 * that it doesn't mess with any existing parser, by creating a tmp
4861 * new parser with lex_start(). This won't actually be used for much,
4862 * since pp_require() will create another parser for the real work. */
4865 SAVEVPTR(PL_curcop);
4866 lex_start(NULL, NULL, LEX_START_SAME_FILTER);
4867 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4868 veop, modname, imop);
4873 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4879 PERL_ARGS_ASSERT_DOFILE;
4881 if (!force_builtin) {
4882 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4883 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4884 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4885 gv = gvp ? *gvp : NULL;
4889 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4890 doop = newUNOP(OP_ENTERSUB, OPf_STACKED,
4891 op_append_elem(OP_LIST, term,
4892 scalar(newUNOP(OP_RV2CV, 0,
4893 newGVOP(OP_GV, 0, gv)))));
4896 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4902 =head1 Optree construction
4904 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
4906 Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
4907 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
4908 be set automatically, and, shifted up eight bits, the eight bits of
4909 C<op_private>, except that the bit with value 1 or 2 is automatically
4910 set as required. I<listval> and I<subscript> supply the parameters of
4911 the slice; they are consumed by this function and become part of the
4912 constructed op tree.
4918 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4920 return newBINOP(OP_LSLICE, flags,
4921 list(force_list(subscript)),
4922 list(force_list(listval)) );
4926 S_is_list_assignment(pTHX_ register const OP *o)
4934 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4935 o = cUNOPo->op_first;
4937 flags = o->op_flags;
4939 if (type == OP_COND_EXPR) {
4940 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4941 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4946 yyerror("Assignment to both a list and a scalar");
4950 if (type == OP_LIST &&
4951 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4952 o->op_private & OPpLVAL_INTRO)
4955 if (type == OP_LIST || flags & OPf_PARENS ||
4956 type == OP_RV2AV || type == OP_RV2HV ||
4957 type == OP_ASLICE || type == OP_HSLICE)
4960 if (type == OP_PADAV || type == OP_PADHV)
4963 if (type == OP_RV2SV)
4970 Helper function for newASSIGNOP to detection commonality between the
4971 lhs and the rhs. Marks all variables with PL_generation. If it
4972 returns TRUE the assignment must be able to handle common variables.
4974 PERL_STATIC_INLINE bool
4975 S_aassign_common_vars(pTHX_ OP* o)
4978 for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
4979 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4980 if (curop->op_type == OP_GV) {
4981 GV *gv = cGVOPx_gv(curop);
4983 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4985 GvASSIGN_GENERATION_set(gv, PL_generation);
4987 else if (curop->op_type == OP_PADSV ||
4988 curop->op_type == OP_PADAV ||
4989 curop->op_type == OP_PADHV ||
4990 curop->op_type == OP_PADANY)
4992 if (PAD_COMPNAME_GEN(curop->op_targ)
4993 == (STRLEN)PL_generation)
4995 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4998 else if (curop->op_type == OP_RV2CV)
5000 else if (curop->op_type == OP_RV2SV ||
5001 curop->op_type == OP_RV2AV ||
5002 curop->op_type == OP_RV2HV ||
5003 curop->op_type == OP_RV2GV) {
5004 if (cUNOPx(curop)->op_first->op_type != OP_GV) /* funny deref? */
5007 else if (curop->op_type == OP_PUSHRE) {
5009 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
5010 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
5012 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5014 GvASSIGN_GENERATION_set(gv, PL_generation);
5018 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5021 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5023 GvASSIGN_GENERATION_set(gv, PL_generation);
5031 if (curop->op_flags & OPf_KIDS) {
5032 if (aassign_common_vars(curop))
5040 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5042 Constructs, checks, and returns an assignment op. I<left> and I<right>
5043 supply the parameters of the assignment; they are consumed by this
5044 function and become part of the constructed op tree.
5046 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5047 a suitable conditional optree is constructed. If I<optype> is the opcode
5048 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5049 performs the binary operation and assigns the result to the left argument.
5050 Either way, if I<optype> is non-zero then I<flags> has no effect.
5052 If I<optype> is zero, then a plain scalar or list assignment is
5053 constructed. Which type of assignment it is is automatically determined.
5054 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5055 will be set automatically, and, shifted up eight bits, the eight bits
5056 of C<op_private>, except that the bit with value 1 or 2 is automatically
5063 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5069 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5070 return newLOGOP(optype, 0,
5071 op_lvalue(scalar(left), optype),
5072 newUNOP(OP_SASSIGN, 0, scalar(right)));
5075 return newBINOP(optype, OPf_STACKED,
5076 op_lvalue(scalar(left), optype), scalar(right));
5080 if (is_list_assignment(left)) {
5081 static const char no_list_state[] = "Initialization of state variables"
5082 " in list context currently forbidden";
5084 bool maybe_common_vars = TRUE;
5087 left = op_lvalue(left, OP_AASSIGN);
5088 curop = list(force_list(left));
5089 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5090 o->op_private = (U8)(0 | (flags >> 8));
5092 if ((left->op_type == OP_LIST
5093 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
5095 OP* lop = ((LISTOP*)left)->op_first;
5096 maybe_common_vars = FALSE;
5098 if (lop->op_type == OP_PADSV ||
5099 lop->op_type == OP_PADAV ||
5100 lop->op_type == OP_PADHV ||
5101 lop->op_type == OP_PADANY) {
5102 if (!(lop->op_private & OPpLVAL_INTRO))
5103 maybe_common_vars = TRUE;
5105 if (lop->op_private & OPpPAD_STATE) {
5106 if (left->op_private & OPpLVAL_INTRO) {
5107 /* Each variable in state($a, $b, $c) = ... */
5110 /* Each state variable in
5111 (state $a, my $b, our $c, $d, undef) = ... */
5113 yyerror(no_list_state);
5115 /* Each my variable in
5116 (state $a, my $b, our $c, $d, undef) = ... */
5118 } else if (lop->op_type == OP_UNDEF ||
5119 lop->op_type == OP_PUSHMARK) {
5120 /* undef may be interesting in
5121 (state $a, undef, state $c) */
5123 /* Other ops in the list. */
5124 maybe_common_vars = TRUE;
5126 lop = lop->op_sibling;
5129 else if ((left->op_private & OPpLVAL_INTRO)
5130 && ( left->op_type == OP_PADSV
5131 || left->op_type == OP_PADAV
5132 || left->op_type == OP_PADHV
5133 || left->op_type == OP_PADANY))
5135 if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5136 if (left->op_private & OPpPAD_STATE) {
5137 /* All single variable list context state assignments, hence
5147 yyerror(no_list_state);
5151 /* PL_generation sorcery:
5152 * an assignment like ($a,$b) = ($c,$d) is easier than
5153 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5154 * To detect whether there are common vars, the global var
5155 * PL_generation is incremented for each assign op we compile.
5156 * Then, while compiling the assign op, we run through all the
5157 * variables on both sides of the assignment, setting a spare slot
5158 * in each of them to PL_generation. If any of them already have
5159 * that value, we know we've got commonality. We could use a
5160 * single bit marker, but then we'd have to make 2 passes, first
5161 * to clear the flag, then to test and set it. To find somewhere
5162 * to store these values, evil chicanery is done with SvUVX().
5165 if (maybe_common_vars) {
5167 if (aassign_common_vars(o))
5168 o->op_private |= OPpASSIGN_COMMON;
5172 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5173 OP* tmpop = ((LISTOP*)right)->op_first;
5174 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5175 PMOP * const pm = (PMOP*)tmpop;
5176 if (left->op_type == OP_RV2AV &&
5177 !(left->op_private & OPpLVAL_INTRO) &&
5178 !(o->op_private & OPpASSIGN_COMMON) )
5180 tmpop = ((UNOP*)left)->op_first;
5181 if (tmpop->op_type == OP_GV
5183 && !pm->op_pmreplrootu.op_pmtargetoff
5185 && !pm->op_pmreplrootu.op_pmtargetgv
5189 pm->op_pmreplrootu.op_pmtargetoff
5190 = cPADOPx(tmpop)->op_padix;
5191 cPADOPx(tmpop)->op_padix = 0; /* steal it */
5193 pm->op_pmreplrootu.op_pmtargetgv
5194 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5195 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
5197 pm->op_pmflags |= PMf_ONCE;
5198 tmpop = cUNOPo->op_first; /* to list (nulled) */
5199 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5200 tmpop->op_sibling = NULL; /* don't free split */
5201 right->op_next = tmpop->op_next; /* fix starting loc */
5202 op_free(o); /* blow off assign */
5203 right->op_flags &= ~OPf_WANT;
5204 /* "I don't know and I don't care." */
5209 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5210 ((LISTOP*)right)->op_last->op_type == OP_CONST)
5212 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5213 if (SvIOK(sv) && SvIVX(sv) == 0)
5214 sv_setiv(sv, PL_modcount+1);
5222 right = newOP(OP_UNDEF, 0);
5223 if (right->op_type == OP_READLINE) {
5224 right->op_flags |= OPf_STACKED;
5225 return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5229 o = newBINOP(OP_SASSIGN, flags,
5230 scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5236 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5238 Constructs a state op (COP). The state op is normally a C<nextstate> op,
5239 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5240 code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
5241 If I<label> is non-null, it supplies the name of a label to attach to
5242 the state op; this function takes ownership of the memory pointed at by
5243 I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
5246 If I<o> is null, the state op is returned. Otherwise the state op is
5247 combined with I<o> into a C<lineseq> list op, which is returned. I<o>
5248 is consumed by this function and becomes part of the returned op tree.
5254 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5257 const U32 seq = intro_my();
5258 const U32 utf8 = flags & SVf_UTF8;
5263 NewOp(1101, cop, 1, COP);
5264 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
5265 cop->op_type = OP_DBSTATE;
5266 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
5269 cop->op_type = OP_NEXTSTATE;
5270 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
5272 cop->op_flags = (U8)flags;
5273 CopHINTS_set(cop, PL_hints);
5275 cop->op_private |= NATIVE_HINTS;
5277 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
5278 cop->op_next = (OP*)cop;
5281 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
5282 CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
5284 Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
5286 PL_hints |= HINT_BLOCK_SCOPE;
5287 /* It seems that we need to defer freeing this pointer, as other parts
5288 of the grammar end up wanting to copy it after this op has been
5293 if (PL_parser && PL_parser->copline == NOLINE)
5294 CopLINE_set(cop, CopLINE(PL_curcop));
5296 CopLINE_set(cop, PL_parser->copline);
5298 PL_parser->copline = NOLINE;
5301 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
5303 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
5305 CopSTASH_set(cop, PL_curstash);
5307 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
5308 /* this line can have a breakpoint - store the cop in IV */
5309 AV *av = CopFILEAVx(PL_curcop);
5311 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
5312 if (svp && *svp != &PL_sv_undef ) {
5313 (void)SvIOK_on(*svp);
5314 SvIV_set(*svp, PTR2IV(cop));
5319 if (flags & OPf_SPECIAL)
5321 return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
5325 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
5327 Constructs, checks, and returns a logical (flow control) op. I<type>
5328 is the opcode. I<flags> gives the eight bits of C<op_flags>, except
5329 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5330 the eight bits of C<op_private>, except that the bit with value 1 is
5331 automatically set. I<first> supplies the expression controlling the
5332 flow, and I<other> supplies the side (alternate) chain of ops; they are
5333 consumed by this function and become part of the constructed op tree.
5339 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
5343 PERL_ARGS_ASSERT_NEWLOGOP;
5345 return new_logop(type, flags, &first, &other);
5349 S_search_const(pTHX_ OP *o)
5351 PERL_ARGS_ASSERT_SEARCH_CONST;
5353 switch (o->op_type) {
5357 if (o->op_flags & OPf_KIDS)
5358 return search_const(cUNOPo->op_first);
5365 if (!(o->op_flags & OPf_KIDS))
5367 kid = cLISTOPo->op_first;
5369 switch (kid->op_type) {
5373 kid = kid->op_sibling;
5376 if (kid != cLISTOPo->op_last)
5382 kid = cLISTOPo->op_last;
5384 return search_const(kid);
5392 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
5400 int prepend_not = 0;
5402 PERL_ARGS_ASSERT_NEW_LOGOP;
5407 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
5408 return newBINOP(type, flags, scalar(first), scalar(other));
5410 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
5412 scalarboolean(first);
5413 /* optimize AND and OR ops that have NOTs as children */
5414 if (first->op_type == OP_NOT
5415 && (first->op_flags & OPf_KIDS)
5416 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
5417 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
5419 if (type == OP_AND || type == OP_OR) {
5425 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
5427 prepend_not = 1; /* prepend a NOT op later */
5431 /* search for a constant op that could let us fold the test */
5432 if ((cstop = search_const(first))) {
5433 if (cstop->op_private & OPpCONST_STRICT)
5434 no_bareword_allowed(cstop);
5435 else if ((cstop->op_private & OPpCONST_BARE))
5436 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
5437 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
5438 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
5439 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
5441 if (other->op_type == OP_CONST)
5442 other->op_private |= OPpCONST_SHORTCIRCUIT;
5444 OP *newop = newUNOP(OP_NULL, 0, other);
5445 op_getmad(first, newop, '1');
5446 newop->op_targ = type; /* set "was" field */
5450 if (other->op_type == OP_LEAVE)
5451 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
5452 else if (other->op_type == OP_MATCH
5453 || other->op_type == OP_SUBST
5454 || other->op_type == OP_TRANSR
5455 || other->op_type == OP_TRANS)
5456 /* Mark the op as being unbindable with =~ */
5457 other->op_flags |= OPf_SPECIAL;
5461 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
5462 const OP *o2 = other;
5463 if ( ! (o2->op_type == OP_LIST
5464 && (( o2 = cUNOPx(o2)->op_first))
5465 && o2->op_type == OP_PUSHMARK
5466 && (( o2 = o2->op_sibling)) )
5469 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
5470 || o2->op_type == OP_PADHV)
5471 && o2->op_private & OPpLVAL_INTRO
5472 && !(o2->op_private & OPpPAD_STATE))
5474 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
5475 "Deprecated use of my() in false conditional");
5479 if (first->op_type == OP_CONST)
5480 first->op_private |= OPpCONST_SHORTCIRCUIT;
5482 first = newUNOP(OP_NULL, 0, first);
5483 op_getmad(other, first, '2');
5484 first->op_targ = type; /* set "was" field */
5491 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
5492 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
5494 const OP * const k1 = ((UNOP*)first)->op_first;
5495 const OP * const k2 = k1->op_sibling;
5497 switch (first->op_type)
5500 if (k2 && k2->op_type == OP_READLINE
5501 && (k2->op_flags & OPf_STACKED)
5502 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5504 warnop = k2->op_type;
5509 if (k1->op_type == OP_READDIR
5510 || k1->op_type == OP_GLOB
5511 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5512 || k1->op_type == OP_EACH
5513 || k1->op_type == OP_AEACH)
5515 warnop = ((k1->op_type == OP_NULL)
5516 ? (OPCODE)k1->op_targ : k1->op_type);
5521 const line_t oldline = CopLINE(PL_curcop);
5522 CopLINE_set(PL_curcop, PL_parser->copline);
5523 Perl_warner(aTHX_ packWARN(WARN_MISC),
5524 "Value of %s%s can be \"0\"; test with defined()",
5526 ((warnop == OP_READLINE || warnop == OP_GLOB)
5527 ? " construct" : "() operator"));
5528 CopLINE_set(PL_curcop, oldline);
5535 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
5536 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
5538 NewOp(1101, logop, 1, LOGOP);
5540 logop->op_type = (OPCODE)type;
5541 logop->op_ppaddr = PL_ppaddr[type];
5542 logop->op_first = first;
5543 logop->op_flags = (U8)(flags | OPf_KIDS);
5544 logop->op_other = LINKLIST(other);
5545 logop->op_private = (U8)(1 | (flags >> 8));
5547 /* establish postfix order */
5548 logop->op_next = LINKLIST(first);
5549 first->op_next = (OP*)logop;
5550 first->op_sibling = other;
5552 CHECKOP(type,logop);
5554 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
5561 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
5563 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
5564 op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5565 will be set automatically, and, shifted up eight bits, the eight bits of
5566 C<op_private>, except that the bit with value 1 is automatically set.
5567 I<first> supplies the expression selecting between the two branches,
5568 and I<trueop> and I<falseop> supply the branches; they are consumed by
5569 this function and become part of the constructed op tree.
5575 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
5583 PERL_ARGS_ASSERT_NEWCONDOP;
5586 return newLOGOP(OP_AND, 0, first, trueop);
5588 return newLOGOP(OP_OR, 0, first, falseop);
5590 scalarboolean(first);
5591 if ((cstop = search_const(first))) {
5592 /* Left or right arm of the conditional? */
5593 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
5594 OP *live = left ? trueop : falseop;
5595 OP *const dead = left ? falseop : trueop;
5596 if (cstop->op_private & OPpCONST_BARE &&
5597 cstop->op_private & OPpCONST_STRICT) {
5598 no_bareword_allowed(cstop);
5601 /* This is all dead code when PERL_MAD is not defined. */
5602 live = newUNOP(OP_NULL, 0, live);
5603 op_getmad(first, live, 'C');
5604 op_getmad(dead, live, left ? 'e' : 't');
5609 if (live->op_type == OP_LEAVE)
5610 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
5611 else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
5612 || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
5613 /* Mark the op as being unbindable with =~ */
5614 live->op_flags |= OPf_SPECIAL;
5617 NewOp(1101, logop, 1, LOGOP);
5618 logop->op_type = OP_COND_EXPR;
5619 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
5620 logop->op_first = first;
5621 logop->op_flags = (U8)(flags | OPf_KIDS);
5622 logop->op_private = (U8)(1 | (flags >> 8));
5623 logop->op_other = LINKLIST(trueop);
5624 logop->op_next = LINKLIST(falseop);
5626 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
5629 /* establish postfix order */
5630 start = LINKLIST(first);
5631 first->op_next = (OP*)logop;
5633 first->op_sibling = trueop;
5634 trueop->op_sibling = falseop;
5635 o = newUNOP(OP_NULL, 0, (OP*)logop);
5637 trueop->op_next = falseop->op_next = o;
5644 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
5646 Constructs and returns a C<range> op, with subordinate C<flip> and
5647 C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
5648 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
5649 for both the C<flip> and C<range> ops, except that the bit with value
5650 1 is automatically set. I<left> and I<right> supply the expressions
5651 controlling the endpoints of the range; they are consumed by this function
5652 and become part of the constructed op tree.
5658 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
5667 PERL_ARGS_ASSERT_NEWRANGE;
5669 NewOp(1101, range, 1, LOGOP);
5671 range->op_type = OP_RANGE;
5672 range->op_ppaddr = PL_ppaddr[OP_RANGE];
5673 range->op_first = left;
5674 range->op_flags = OPf_KIDS;
5675 leftstart = LINKLIST(left);
5676 range->op_other = LINKLIST(right);
5677 range->op_private = (U8)(1 | (flags >> 8));
5679 left->op_sibling = right;
5681 range->op_next = (OP*)range;
5682 flip = newUNOP(OP_FLIP, flags, (OP*)range);
5683 flop = newUNOP(OP_FLOP, 0, flip);
5684 o = newUNOP(OP_NULL, 0, flop);
5686 range->op_next = leftstart;
5688 left->op_next = flip;
5689 right->op_next = flop;
5691 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5692 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
5693 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
5694 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
5696 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5697 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
5699 /* check barewords before they might be optimized aways */
5700 if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
5701 no_bareword_allowed(left);
5702 if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
5703 no_bareword_allowed(right);
5706 if (!flip->op_private || !flop->op_private)
5707 LINKLIST(o); /* blow off optimizer unless constant */
5713 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
5715 Constructs, checks, and returns an op tree expressing a loop. This is
5716 only a loop in the control flow through the op tree; it does not have
5717 the heavyweight loop structure that allows exiting the loop by C<last>
5718 and suchlike. I<flags> gives the eight bits of C<op_flags> for the
5719 top-level op, except that some bits will be set automatically as required.
5720 I<expr> supplies the expression controlling loop iteration, and I<block>
5721 supplies the body of the loop; they are consumed by this function and
5722 become part of the constructed op tree. I<debuggable> is currently
5723 unused and should always be 1.
5729 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
5734 const bool once = block && block->op_flags & OPf_SPECIAL &&
5735 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
5737 PERL_UNUSED_ARG(debuggable);
5740 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
5741 return block; /* do {} while 0 does once */
5742 if (expr->op_type == OP_READLINE
5743 || expr->op_type == OP_READDIR
5744 || expr->op_type == OP_GLOB
5745 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
5746 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5747 expr = newUNOP(OP_DEFINED, 0,
5748 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5749 } else if (expr->op_flags & OPf_KIDS) {
5750 const OP * const k1 = ((UNOP*)expr)->op_first;
5751 const OP * const k2 = k1 ? k1->op_sibling : NULL;
5752 switch (expr->op_type) {
5754 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5755 && (k2->op_flags & OPf_STACKED)
5756 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5757 expr = newUNOP(OP_DEFINED, 0, expr);
5761 if (k1 && (k1->op_type == OP_READDIR
5762 || k1->op_type == OP_GLOB
5763 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5764 || k1->op_type == OP_EACH
5765 || k1->op_type == OP_AEACH))
5766 expr = newUNOP(OP_DEFINED, 0, expr);
5772 /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
5773 * op, in listop. This is wrong. [perl #27024] */
5775 block = newOP(OP_NULL, 0);
5776 listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
5777 o = new_logop(OP_AND, 0, &expr, &listop);
5780 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
5782 if (once && o != listop)
5783 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
5786 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
5788 o->op_flags |= flags;
5790 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
5795 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
5797 Constructs, checks, and returns an op tree expressing a C<while> loop.
5798 This is a heavyweight loop, with structure that allows exiting the loop
5799 by C<last> and suchlike.
5801 I<loop> is an optional preconstructed C<enterloop> op to use in the
5802 loop; if it is null then a suitable op will be constructed automatically.
5803 I<expr> supplies the loop's controlling expression. I<block> supplies the
5804 main body of the loop, and I<cont> optionally supplies a C<continue> block
5805 that operates as a second half of the body. All of these optree inputs
5806 are consumed by this function and become part of the constructed op tree.
5808 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5809 op and, shifted up eight bits, the eight bits of C<op_private> for
5810 the C<leaveloop> op, except that (in both cases) some bits will be set
5811 automatically. I<debuggable> is currently unused and should always be 1.
5812 I<has_my> can be supplied as true to force the
5813 loop body to be enclosed in its own scope.
5819 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
5820 OP *expr, OP *block, OP *cont, I32 has_my)
5829 PERL_UNUSED_ARG(debuggable);
5832 if (expr->op_type == OP_READLINE
5833 || expr->op_type == OP_READDIR
5834 || expr->op_type == OP_GLOB
5835 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
5836 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
5837 expr = newUNOP(OP_DEFINED, 0,
5838 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
5839 } else if (expr->op_flags & OPf_KIDS) {
5840 const OP * const k1 = ((UNOP*)expr)->op_first;
5841 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
5842 switch (expr->op_type) {
5844 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
5845 && (k2->op_flags & OPf_STACKED)
5846 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
5847 expr = newUNOP(OP_DEFINED, 0, expr);
5851 if (k1 && (k1->op_type == OP_READDIR
5852 || k1->op_type == OP_GLOB
5853 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
5854 || k1->op_type == OP_EACH
5855 || k1->op_type == OP_AEACH))
5856 expr = newUNOP(OP_DEFINED, 0, expr);
5863 block = newOP(OP_NULL, 0);
5864 else if (cont || has_my) {
5865 block = op_scope(block);
5869 next = LINKLIST(cont);
5872 OP * const unstack = newOP(OP_UNSTACK, 0);
5875 cont = op_append_elem(OP_LINESEQ, cont, unstack);
5879 listop = op_append_list(OP_LINESEQ, block, cont);
5881 redo = LINKLIST(listop);
5885 o = new_logop(OP_AND, 0, &expr, &listop);
5886 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
5887 op_free(expr); /* oops, it's a while (0) */
5889 return NULL; /* listop already freed by new_logop */
5892 ((LISTOP*)listop)->op_last->op_next =
5893 (o == listop ? redo : LINKLIST(o));
5899 NewOp(1101,loop,1,LOOP);
5900 loop->op_type = OP_ENTERLOOP;
5901 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
5902 loop->op_private = 0;
5903 loop->op_next = (OP*)loop;
5906 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
5908 loop->op_redoop = redo;
5909 loop->op_lastop = o;
5910 o->op_private |= loopflags;
5913 loop->op_nextop = next;
5915 loop->op_nextop = o;
5917 o->op_flags |= flags;
5918 o->op_private |= (flags >> 8);
5923 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
5925 Constructs, checks, and returns an op tree expressing a C<foreach>
5926 loop (iteration through a list of values). This is a heavyweight loop,
5927 with structure that allows exiting the loop by C<last> and suchlike.
5929 I<sv> optionally supplies the variable that will be aliased to each
5930 item in turn; if null, it defaults to C<$_> (either lexical or global).
5931 I<expr> supplies the list of values to iterate over. I<block> supplies
5932 the main body of the loop, and I<cont> optionally supplies a C<continue>
5933 block that operates as a second half of the body. All of these optree
5934 inputs are consumed by this function and become part of the constructed
5937 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
5938 op and, shifted up eight bits, the eight bits of C<op_private> for
5939 the C<leaveloop> op, except that (in both cases) some bits will be set
5946 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
5951 PADOFFSET padoff = 0;
5956 PERL_ARGS_ASSERT_NEWFOROP;
5959 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
5960 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
5961 sv->op_type = OP_RV2GV;
5962 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
5964 /* The op_type check is needed to prevent a possible segfault
5965 * if the loop variable is undeclared and 'strict vars' is in
5966 * effect. This is illegal but is nonetheless parsed, so we
5967 * may reach this point with an OP_CONST where we're expecting
5970 if (cUNOPx(sv)->op_first->op_type == OP_GV
5971 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5972 iterpflags |= OPpITER_DEF;
5974 else if (sv->op_type == OP_PADSV) { /* private variable */
5975 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5976 padoff = sv->op_targ;
5986 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5988 SV *const namesv = PAD_COMPNAME_SV(padoff);
5990 const char *const name = SvPV_const(namesv, len);
5992 if (len == 2 && name[0] == '$' && name[1] == '_')
5993 iterpflags |= OPpITER_DEF;
5997 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
5998 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5999 sv = newGVOP(OP_GV, 0, PL_defgv);
6004 iterpflags |= OPpITER_DEF;
6006 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6007 expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6008 iterflags |= OPf_STACKED;
6010 else if (expr->op_type == OP_NULL &&
6011 (expr->op_flags & OPf_KIDS) &&
6012 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6014 /* Basically turn for($x..$y) into the same as for($x,$y), but we
6015 * set the STACKED flag to indicate that these values are to be
6016 * treated as min/max values by 'pp_iterinit'.
6018 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6019 LOGOP* const range = (LOGOP*) flip->op_first;
6020 OP* const left = range->op_first;
6021 OP* const right = left->op_sibling;
6024 range->op_flags &= ~OPf_KIDS;
6025 range->op_first = NULL;
6027 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6028 listop->op_first->op_next = range->op_next;
6029 left->op_next = range->op_other;
6030 right->op_next = (OP*)listop;
6031 listop->op_next = listop->op_first;
6034 op_getmad(expr,(OP*)listop,'O');
6038 expr = (OP*)(listop);
6040 iterflags |= OPf_STACKED;
6043 expr = op_lvalue(force_list(expr), OP_GREPSTART);
6046 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6047 op_append_elem(OP_LIST, expr, scalar(sv))));
6048 assert(!loop->op_next);
6049 /* for my $x () sets OPpLVAL_INTRO;
6050 * for our $x () sets OPpOUR_INTRO */
6051 loop->op_private = (U8)iterpflags;
6052 #ifdef PL_OP_SLAB_ALLOC
6055 NewOp(1234,tmp,1,LOOP);
6056 Copy(loop,tmp,1,LISTOP);
6057 S_op_destroy(aTHX_ (OP*)loop);
6061 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6063 loop->op_targ = padoff;
6064 wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6066 op_getmad(madsv, (OP*)loop, 'v');
6071 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6073 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6074 or C<last>). I<type> is the opcode. I<label> supplies the parameter
6075 determining the target of the op; it is consumed by this function and
6076 become part of the constructed op tree.
6082 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6087 PERL_ARGS_ASSERT_NEWLOOPEX;
6089 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6091 if (type != OP_GOTO) {
6092 /* "last()" means "last" */
6093 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
6094 o = newOP(type, OPf_SPECIAL);
6098 label->op_type == OP_CONST
6099 ? SvUTF8(((SVOP*)label)->op_sv)
6101 savesharedpv(label->op_type == OP_CONST
6102 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
6106 op_getmad(label,o,'L');
6112 /* Check whether it's going to be a goto &function */
6113 if (label->op_type == OP_ENTERSUB
6114 && !(label->op_flags & OPf_STACKED))
6115 label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6116 else if (label->op_type == OP_CONST) {
6117 SV * const sv = ((SVOP *)label)->op_sv;
6119 const char *s = SvPV_const(sv,l);
6120 if (l == strlen(s)) goto const_label;
6122 o = newUNOP(type, OPf_STACKED, label);
6124 PL_hints |= HINT_BLOCK_SCOPE;
6128 /* if the condition is a literal array or hash
6129 (or @{ ... } etc), make a reference to it.
6132 S_ref_array_or_hash(pTHX_ OP *cond)
6135 && (cond->op_type == OP_RV2AV
6136 || cond->op_type == OP_PADAV
6137 || cond->op_type == OP_RV2HV
6138 || cond->op_type == OP_PADHV))
6140 return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6143 && (cond->op_type == OP_ASLICE
6144 || cond->op_type == OP_HSLICE)) {
6146 /* anonlist now needs a list from this op, was previously used in
6148 cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6149 cond->op_flags |= OPf_WANT_LIST;
6151 return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6158 /* These construct the optree fragments representing given()
6161 entergiven and enterwhen are LOGOPs; the op_other pointer
6162 points up to the associated leave op. We need this so we
6163 can put it in the context and make break/continue work.
6164 (Also, of course, pp_enterwhen will jump straight to
6165 op_other if the match fails.)
6169 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6170 I32 enter_opcode, I32 leave_opcode,
6171 PADOFFSET entertarg)
6177 PERL_ARGS_ASSERT_NEWGIVWHENOP;
6179 NewOp(1101, enterop, 1, LOGOP);
6180 enterop->op_type = (Optype)enter_opcode;
6181 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6182 enterop->op_flags = (U8) OPf_KIDS;
6183 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6184 enterop->op_private = 0;
6186 o = newUNOP(leave_opcode, 0, (OP *) enterop);
6189 enterop->op_first = scalar(cond);
6190 cond->op_sibling = block;
6192 o->op_next = LINKLIST(cond);
6193 cond->op_next = (OP *) enterop;
6196 /* This is a default {} block */
6197 enterop->op_first = block;
6198 enterop->op_flags |= OPf_SPECIAL;
6199 o ->op_flags |= OPf_SPECIAL;
6201 o->op_next = (OP *) enterop;
6204 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
6205 entergiven and enterwhen both
6208 enterop->op_next = LINKLIST(block);
6209 block->op_next = enterop->op_other = o;
6214 /* Does this look like a boolean operation? For these purposes
6215 a boolean operation is:
6216 - a subroutine call [*]
6217 - a logical connective
6218 - a comparison operator
6219 - a filetest operator, with the exception of -s -M -A -C
6220 - defined(), exists() or eof()
6221 - /$re/ or $foo =~ /$re/
6223 [*] possibly surprising
6226 S_looks_like_bool(pTHX_ const OP *o)
6230 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
6232 switch(o->op_type) {
6235 return looks_like_bool(cLOGOPo->op_first);
6239 looks_like_bool(cLOGOPo->op_first)
6240 && looks_like_bool(cLOGOPo->op_first->op_sibling));
6245 o->op_flags & OPf_KIDS
6246 && looks_like_bool(cUNOPo->op_first));
6250 case OP_NOT: case OP_XOR:
6252 case OP_EQ: case OP_NE: case OP_LT:
6253 case OP_GT: case OP_LE: case OP_GE:
6255 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
6256 case OP_I_GT: case OP_I_LE: case OP_I_GE:
6258 case OP_SEQ: case OP_SNE: case OP_SLT:
6259 case OP_SGT: case OP_SLE: case OP_SGE:
6263 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
6264 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
6265 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
6266 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
6267 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
6268 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
6269 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
6270 case OP_FTTEXT: case OP_FTBINARY:
6272 case OP_DEFINED: case OP_EXISTS:
6273 case OP_MATCH: case OP_EOF:
6280 /* Detect comparisons that have been optimized away */
6281 if (cSVOPo->op_sv == &PL_sv_yes
6282 || cSVOPo->op_sv == &PL_sv_no)
6295 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
6297 Constructs, checks, and returns an op tree expressing a C<given> block.
6298 I<cond> supplies the expression that will be locally assigned to a lexical
6299 variable, and I<block> supplies the body of the C<given> construct; they
6300 are consumed by this function and become part of the constructed op tree.
6301 I<defsv_off> is the pad offset of the scalar lexical variable that will
6308 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
6311 PERL_ARGS_ASSERT_NEWGIVENOP;
6312 return newGIVWHENOP(
6313 ref_array_or_hash(cond),
6315 OP_ENTERGIVEN, OP_LEAVEGIVEN,
6320 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
6322 Constructs, checks, and returns an op tree expressing a C<when> block.
6323 I<cond> supplies the test expression, and I<block> supplies the block
6324 that will be executed if the test evaluates to true; they are consumed
6325 by this function and become part of the constructed op tree. I<cond>
6326 will be interpreted DWIMically, often as a comparison against C<$_>,
6327 and may be null to generate a C<default> block.
6333 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
6335 const bool cond_llb = (!cond || looks_like_bool(cond));
6338 PERL_ARGS_ASSERT_NEWWHENOP;
6343 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
6345 scalar(ref_array_or_hash(cond)));
6348 return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
6352 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
6353 const STRLEN len, const U32 flags)
6355 const char * const cvp = CvPROTO(cv);
6356 const STRLEN clen = CvPROTOLEN(cv);
6358 PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
6360 if (((!p != !cvp) /* One has prototype, one has not. */
6362 (flags & SVf_UTF8) == SvUTF8(cv)
6363 ? len != clen || memNE(cvp, p, len)
6365 ? bytes_cmp_utf8((const U8 *)cvp, clen,
6367 : bytes_cmp_utf8((const U8 *)p, len,
6368 (const U8 *)cvp, clen)
6372 && ckWARN_d(WARN_PROTOTYPE)) {
6373 SV* const msg = sv_newmortal();
6377 gv_efullname3(name = sv_newmortal(), gv, NULL);
6378 sv_setpvs(msg, "Prototype mismatch:");
6380 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
6382 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
6383 SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
6386 sv_catpvs(msg, ": none");
6387 sv_catpvs(msg, " vs ");
6389 Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
6391 sv_catpvs(msg, "none");
6392 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
6396 static void const_sv_xsub(pTHX_ CV* cv);
6400 =head1 Optree Manipulation Functions
6402 =for apidoc cv_const_sv
6404 If C<cv> is a constant sub eligible for inlining. returns the constant
6405 value returned by the sub. Otherwise, returns NULL.
6407 Constant subs can be created with C<newCONSTSUB> or as described in
6408 L<perlsub/"Constant Functions">.
6413 Perl_cv_const_sv(pTHX_ const CV *const cv)
6415 PERL_UNUSED_CONTEXT;
6418 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
6420 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
6423 /* op_const_sv: examine an optree to determine whether it's in-lineable.
6424 * Can be called in 3 ways:
6427 * look for a single OP_CONST with attached value: return the value
6429 * cv && CvCLONE(cv) && !CvCONST(cv)
6431 * examine the clone prototype, and if contains only a single
6432 * OP_CONST referencing a pad const, or a single PADSV referencing
6433 * an outer lexical, return a non-zero value to indicate the CV is
6434 * a candidate for "constizing" at clone time
6438 * We have just cloned an anon prototype that was marked as a const
6439 * candidate. Try to grab the current value, and in the case of
6440 * PADSV, ignore it if it has multiple references. Return the value.
6444 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
6455 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
6456 o = cLISTOPo->op_first->op_sibling;
6458 for (; o; o = o->op_next) {
6459 const OPCODE type = o->op_type;
6461 if (sv && o->op_next == o)
6463 if (o->op_next != o) {
6464 if (type == OP_NEXTSTATE
6465 || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
6466 || type == OP_PUSHMARK)
6468 if (type == OP_DBSTATE)
6471 if (type == OP_LEAVESUB || type == OP_RETURN)
6475 if (type == OP_CONST && cSVOPo->op_sv)
6477 else if (cv && type == OP_CONST) {
6478 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6482 else if (cv && type == OP_PADSV) {
6483 if (CvCONST(cv)) { /* newly cloned anon */
6484 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
6485 /* the candidate should have 1 ref from this pad and 1 ref
6486 * from the parent */
6487 if (!sv || SvREFCNT(sv) != 2)
6494 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
6495 sv = &PL_sv_undef; /* an arbitrary non-null value */
6510 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6513 /* This would be the return value, but the return cannot be reached. */
6514 OP* pegop = newOP(OP_NULL, 0);
6517 PERL_UNUSED_ARG(floor);
6527 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
6529 NORETURN_FUNCTION_END;
6534 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
6536 return newATTRSUB_flags(floor, o, proto, attrs, block, 0);
6540 Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
6541 OP *block, U32 flags)
6546 STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
6548 register CV *cv = NULL;
6550 /* If the subroutine has no body, no attributes, and no builtin attributes
6551 then it's just a sub declaration, and we may be able to get away with
6552 storing with a placeholder scalar in the symbol table, rather than a
6553 full GV and CV. If anything is present then it will take a full CV to
6555 const I32 gv_fetch_flags
6556 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6558 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
6560 const bool o_is_gv = flags & 1;
6561 const char * const name =
6562 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
6564 bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
6567 assert(proto->op_type == OP_CONST);
6568 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
6569 ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
6579 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
6581 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
6582 SV * const sv = sv_newmortal();
6583 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
6584 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
6585 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
6586 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
6588 } else if (PL_curstash) {
6589 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
6592 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
6596 if (!PL_madskills) {
6605 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
6606 maximum a prototype before. */
6607 if (SvTYPE(gv) > SVt_NULL) {
6608 cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
6611 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
6612 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
6615 sv_setiv(MUTABLE_SV(gv), -1);
6617 SvREFCNT_dec(PL_compcv);
6618 cv = PL_compcv = NULL;
6622 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
6624 if (!block || !ps || *ps || attrs
6625 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
6627 || block->op_type == OP_NULL
6632 const_sv = op_const_sv(block, NULL);
6635 const bool exists = CvROOT(cv) || CvXSUB(cv);
6637 /* if the subroutine doesn't exist and wasn't pre-declared
6638 * with a prototype, assume it will be AUTOLOADed,
6639 * skipping the prototype check
6641 if (exists || SvPOK(cv))
6642 cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
6643 /* already defined (or promised)? */
6644 if (exists || GvASSUMECV(gv)) {
6647 || block->op_type == OP_NULL
6650 if (CvFLAGS(PL_compcv)) {
6651 /* might have had built-in attrs applied */
6652 const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
6653 if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
6654 && ckWARN(WARN_MISC))
6655 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
6657 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
6658 & ~(CVf_LVALUE * pureperl));
6660 if (attrs) goto attrs;
6661 /* just a "sub foo;" when &foo is already defined */
6662 SAVEFREESV(PL_compcv);
6667 && block->op_type != OP_NULL
6670 const line_t oldline = CopLINE(PL_curcop);
6671 if (PL_parser && PL_parser->copline != NOLINE)
6672 CopLINE_set(PL_curcop, PL_parser->copline);
6673 report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
6674 CopLINE_set(PL_curcop, oldline);
6676 if (!PL_minus_c) /* keep old one around for madskills */
6679 /* (PL_madskills unset in used file.) */
6688 SvREFCNT_inc_simple_void_NN(const_sv);
6690 assert(!CvROOT(cv) && !CvCONST(cv));
6691 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
6692 CvXSUBANY(cv).any_ptr = const_sv;
6693 CvXSUB(cv) = const_sv_xsub;
6699 cv = newCONSTSUB_flags(
6700 NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
6705 (CvGV(cv) && GvSTASH(CvGV(cv)))
6710 if (HvENAME_HEK(stash))
6711 mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */
6715 SvREFCNT_dec(PL_compcv);
6719 if (cv) { /* must reuse cv if autoloaded */
6720 /* transfer PL_compcv to cv */
6723 && block->op_type != OP_NULL
6726 cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
6727 AV *const temp_av = CvPADLIST(cv);
6728 CV *const temp_cv = CvOUTSIDE(cv);
6730 assert(!CvWEAKOUTSIDE(cv));
6731 assert(!CvCVGV_RC(cv));
6732 assert(CvGV(cv) == gv);
6735 CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
6736 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
6737 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
6738 CvPADLIST(cv) = CvPADLIST(PL_compcv);
6739 CvOUTSIDE(PL_compcv) = temp_cv;
6740 CvPADLIST(PL_compcv) = temp_av;
6742 if (CvFILE(cv) && CvDYNFILE(cv)) {
6743 Safefree(CvFILE(cv));
6745 CvFILE_set_from_cop(cv, PL_curcop);
6746 CvSTASH_set(cv, PL_curstash);
6748 /* inner references to PL_compcv must be fixed up ... */
6749 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
6750 if (PERLDB_INTER)/* Advice debugger on the new sub. */
6751 ++PL_sub_generation;
6754 /* Might have had built-in attributes applied -- propagate them. */
6755 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
6757 /* ... before we throw it away */
6758 SvREFCNT_dec(PL_compcv);
6766 if (strEQ(name, "import")) {
6767 PL_formfeed = MUTABLE_SV(cv);
6768 /* diag_listed_as: SKIPME */
6769 Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
6773 if (HvENAME_HEK(GvSTASH(gv)))
6774 /* sub Foo::bar { (shift)+1 } */
6775 mro_method_changed_in(GvSTASH(gv));
6780 CvFILE_set_from_cop(cv, PL_curcop);
6781 CvSTASH_set(cv, PL_curstash);
6785 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
6786 if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
6789 if (PL_parser && PL_parser->error_count) {
6793 const char *s = strrchr(name, ':');
6795 if (strEQ(s, "BEGIN")) {
6796 const char not_safe[] =
6797 "BEGIN not safe after errors--compilation aborted";
6798 if (PL_in_eval & EVAL_KEEPERR)
6799 Perl_croak(aTHX_ not_safe);
6801 /* force display of errors found but not reported */
6802 sv_catpv(ERRSV, not_safe);
6803 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
6812 /* If we assign an optree to a PVCV, then we've defined a subroutine that
6813 the debugger could be able to set a breakpoint in, so signal to
6814 pp_entereval that it should not throw away any saved lines at scope
6817 PL_breakable_sub_gen++;
6818 /* This makes sub {}; work as expected. */
6819 if (block->op_type == OP_STUB) {
6820 OP* const newblock = newSTATEOP(0, NULL, 0);
6822 op_getmad(block,newblock,'B');
6828 else block->op_attached = 1;
6829 CvROOT(cv) = CvLVALUE(cv)
6830 ? newUNOP(OP_LEAVESUBLV, 0,
6831 op_lvalue(scalarseq(block), OP_LEAVESUBLV))
6832 : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
6833 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6834 OpREFCNT_set(CvROOT(cv), 1);
6835 CvSTART(cv) = LINKLIST(CvROOT(cv));
6836 CvROOT(cv)->op_next = 0;
6837 CALL_PEEP(CvSTART(cv));
6838 finalize_optree(CvROOT(cv));
6840 /* now that optimizer has done its work, adjust pad values */
6842 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
6845 assert(!CvCONST(cv));
6846 if (ps && !*ps && op_const_sv(block, cv))
6852 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
6853 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
6854 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
6857 if (block && has_name) {
6858 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
6859 SV * const tmpstr = sv_newmortal();
6860 GV * const db_postponed = gv_fetchpvs("DB::postponed",
6861 GV_ADDMULTI, SVt_PVHV);
6863 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
6866 (long)CopLINE(PL_curcop));
6867 gv_efullname3(tmpstr, gv, NULL);
6868 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
6869 SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
6870 hv = GvHVn(db_postponed);
6871 if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
6872 CV * const pcv = GvCV(db_postponed);
6878 call_sv(MUTABLE_SV(pcv), G_DISCARD);
6883 if (name && ! (PL_parser && PL_parser->error_count))
6884 process_special_blocks(name, gv, cv);
6889 PL_parser->copline = NOLINE;
6895 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
6898 const char *const colon = strrchr(fullname,':');
6899 const char *const name = colon ? colon + 1 : fullname;
6901 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
6904 if (strEQ(name, "BEGIN")) {
6905 const I32 oldscope = PL_scopestack_ix;
6907 SAVECOPFILE(&PL_compiling);
6908 SAVECOPLINE(&PL_compiling);
6909 SAVEVPTR(PL_curcop);
6911 DEBUG_x( dump_sub(gv) );
6912 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
6913 GvCV_set(gv,0); /* cv has been hijacked */
6914 call_list(oldscope, PL_beginav);
6916 CopHINTS_set(&PL_compiling, PL_hints);
6923 if strEQ(name, "END") {
6924 DEBUG_x( dump_sub(gv) );
6925 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
6928 } else if (*name == 'U') {
6929 if (strEQ(name, "UNITCHECK")) {
6930 /* It's never too late to run a unitcheck block */
6931 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
6935 } else if (*name == 'C') {
6936 if (strEQ(name, "CHECK")) {
6938 /* diag_listed_as: Too late to run %s block */
6939 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6940 "Too late to run CHECK block");
6941 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
6945 } else if (*name == 'I') {
6946 if (strEQ(name, "INIT")) {
6948 /* diag_listed_as: Too late to run %s block */
6949 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
6950 "Too late to run INIT block");
6951 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
6957 DEBUG_x( dump_sub(gv) );
6958 GvCV_set(gv,0); /* cv has been hijacked */
6963 =for apidoc newCONSTSUB
6965 See L</newCONSTSUB_flags>.
6971 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
6973 return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
6977 =for apidoc newCONSTSUB_flags
6979 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
6980 eligible for inlining at compile-time.
6982 Currently, the only useful value for C<flags> is SVf_UTF8.
6984 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
6985 which won't be called if used as a destructor, but will suppress the overhead
6986 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
6993 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
6999 const char *const file = CopFILE(PL_curcop);
7001 SV *const temp_sv = CopFILESV(PL_curcop);
7002 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
7007 if (IN_PERL_RUNTIME) {
7008 /* at runtime, it's not safe to manipulate PL_curcop: it may be
7009 * an op shared between threads. Use a non-shared COP for our
7011 SAVEVPTR(PL_curcop);
7012 SAVECOMPILEWARNINGS();
7013 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
7014 PL_curcop = &PL_compiling;
7016 SAVECOPLINE(PL_curcop);
7017 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
7020 PL_hints &= ~HINT_BLOCK_SCOPE;
7023 SAVEGENERICSV(PL_curstash);
7024 PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
7027 /* file becomes the CvFILE. For an XS, it's usually static storage,
7028 and so doesn't get free()d. (It's expected to be from the C pre-
7029 processor __FILE__ directive). But we need a dynamically allocated one,
7030 and we need it to get freed. */
7031 cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
7032 &sv, XS_DYNAMIC_FILENAME | flags);
7033 CvXSUBANY(cv).any_ptr = sv;
7042 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
7043 const char *const filename, const char *const proto,
7046 PERL_ARGS_ASSERT_NEWXS_FLAGS;
7047 return newXS_len_flags(
7048 name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
7053 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
7054 XSUBADDR_t subaddr, const char *const filename,
7055 const char *const proto, SV **const_svp,
7060 PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
7063 GV * const gv = name
7065 name,len,GV_ADDMULTI|flags,SVt_PVCV
7068 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
7069 GV_ADDMULTI | flags, SVt_PVCV);
7072 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
7074 if ((cv = (name ? GvCV(gv) : NULL))) {
7076 /* just a cached method */
7080 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
7081 /* already defined (or promised) */
7082 /* Redundant check that allows us to avoid creating an SV
7083 most of the time: */
7084 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7085 const line_t oldline = CopLINE(PL_curcop);
7086 if (PL_parser && PL_parser->copline != NOLINE)
7087 CopLINE_set(PL_curcop, PL_parser->copline);
7088 report_redefined_cv(newSVpvn_flags(
7089 name,len,(flags&SVf_UTF8)|SVs_TEMP
7092 CopLINE_set(PL_curcop, oldline);
7099 if (cv) /* must reuse cv if autoloaded */
7102 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7106 if (HvENAME_HEK(GvSTASH(gv)))
7107 mro_method_changed_in(GvSTASH(gv)); /* newXS */
7113 (void)gv_fetchfile(filename);
7114 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
7115 an external constant string */
7116 assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
7118 CvXSUB(cv) = subaddr;
7121 process_special_blocks(name, gv, cv);
7124 if (flags & XS_DYNAMIC_FILENAME) {
7125 CvFILE(cv) = savepv(filename);
7128 sv_setpv(MUTABLE_SV(cv), proto);
7133 =for apidoc U||newXS
7135 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
7136 static storage, as it is used directly as CvFILE(), without a copy being made.
7142 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
7144 PERL_ARGS_ASSERT_NEWXS;
7145 return newXS_len_flags(
7146 name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
7155 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
7160 OP* pegop = newOP(OP_NULL, 0);
7164 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
7165 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
7168 if ((cv = GvFORM(gv))) {
7169 if (ckWARN(WARN_REDEFINE)) {
7170 const line_t oldline = CopLINE(PL_curcop);
7171 if (PL_parser && PL_parser->copline != NOLINE)
7172 CopLINE_set(PL_curcop, PL_parser->copline);
7174 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7175 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
7177 /* diag_listed_as: Format %s redefined */
7178 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
7179 "Format STDOUT redefined");
7181 CopLINE_set(PL_curcop, oldline);
7188 CvFILE_set_from_cop(cv, PL_curcop);
7191 pad_tidy(padtidy_FORMAT);
7192 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
7193 CvROOT(cv)->op_private |= OPpREFCOUNTED;
7194 OpREFCNT_set(CvROOT(cv), 1);
7195 CvSTART(cv) = LINKLIST(CvROOT(cv));
7196 CvROOT(cv)->op_next = 0;
7197 CALL_PEEP(CvSTART(cv));
7198 finalize_optree(CvROOT(cv));
7200 op_getmad(o,pegop,'n');
7201 op_getmad_weak(block, pegop, 'b');
7206 PL_parser->copline = NOLINE;
7214 Perl_newANONLIST(pTHX_ OP *o)
7216 return convert(OP_ANONLIST, OPf_SPECIAL, o);
7220 Perl_newANONHASH(pTHX_ OP *o)
7222 return convert(OP_ANONHASH, OPf_SPECIAL, o);
7226 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
7228 return newANONATTRSUB(floor, proto, NULL, block);
7232 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
7234 return newUNOP(OP_REFGEN, 0,
7235 newSVOP(OP_ANONCODE, 0,
7236 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
7240 Perl_oopsAV(pTHX_ OP *o)
7244 PERL_ARGS_ASSERT_OOPSAV;
7246 switch (o->op_type) {
7248 o->op_type = OP_PADAV;
7249 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7250 return ref(o, OP_RV2AV);
7253 o->op_type = OP_RV2AV;
7254 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
7259 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
7266 Perl_oopsHV(pTHX_ OP *o)
7270 PERL_ARGS_ASSERT_OOPSHV;
7272 switch (o->op_type) {
7275 o->op_type = OP_PADHV;
7276 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7277 return ref(o, OP_RV2HV);
7281 o->op_type = OP_RV2HV;
7282 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
7287 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
7294 Perl_newAVREF(pTHX_ OP *o)
7298 PERL_ARGS_ASSERT_NEWAVREF;
7300 if (o->op_type == OP_PADANY) {
7301 o->op_type = OP_PADAV;
7302 o->op_ppaddr = PL_ppaddr[OP_PADAV];
7305 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
7306 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7307 "Using an array as a reference is deprecated");
7309 return newUNOP(OP_RV2AV, 0, scalar(o));
7313 Perl_newGVREF(pTHX_ I32 type, OP *o)
7315 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
7316 return newUNOP(OP_NULL, 0, o);
7317 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
7321 Perl_newHVREF(pTHX_ OP *o)
7325 PERL_ARGS_ASSERT_NEWHVREF;
7327 if (o->op_type == OP_PADANY) {
7328 o->op_type = OP_PADHV;
7329 o->op_ppaddr = PL_ppaddr[OP_PADHV];
7332 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
7333 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7334 "Using a hash as a reference is deprecated");
7336 return newUNOP(OP_RV2HV, 0, scalar(o));
7340 Perl_newCVREF(pTHX_ I32 flags, OP *o)
7342 return newUNOP(OP_RV2CV, flags, scalar(o));
7346 Perl_newSVREF(pTHX_ OP *o)
7350 PERL_ARGS_ASSERT_NEWSVREF;
7352 if (o->op_type == OP_PADANY) {
7353 o->op_type = OP_PADSV;
7354 o->op_ppaddr = PL_ppaddr[OP_PADSV];
7357 return newUNOP(OP_RV2SV, 0, scalar(o));
7360 /* Check routines. See the comments at the top of this file for details
7361 * on when these are called */
7364 Perl_ck_anoncode(pTHX_ OP *o)
7366 PERL_ARGS_ASSERT_CK_ANONCODE;
7368 cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
7370 cSVOPo->op_sv = NULL;
7375 Perl_ck_bitop(pTHX_ OP *o)
7379 PERL_ARGS_ASSERT_CK_BITOP;
7381 o->op_private = (U8)(PL_hints & HINT_INTEGER);
7382 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
7383 && (o->op_type == OP_BIT_OR
7384 || o->op_type == OP_BIT_AND
7385 || o->op_type == OP_BIT_XOR))
7387 const OP * const left = cBINOPo->op_first;
7388 const OP * const right = left->op_sibling;
7389 if ((OP_IS_NUMCOMPARE(left->op_type) &&
7390 (left->op_flags & OPf_PARENS) == 0) ||
7391 (OP_IS_NUMCOMPARE(right->op_type) &&
7392 (right->op_flags & OPf_PARENS) == 0))
7393 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7394 "Possible precedence problem on bitwise %c operator",
7395 o->op_type == OP_BIT_OR ? '|'
7396 : o->op_type == OP_BIT_AND ? '&' : '^'
7402 PERL_STATIC_INLINE bool
7403 is_dollar_bracket(pTHX_ const OP * const o)
7406 return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
7407 && (kid = cUNOPx(o)->op_first)
7408 && kid->op_type == OP_GV
7409 && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
7413 Perl_ck_cmp(pTHX_ OP *o)
7415 PERL_ARGS_ASSERT_CK_CMP;
7416 if (ckWARN(WARN_SYNTAX)) {
7417 const OP *kid = cUNOPo->op_first;
7420 is_dollar_bracket(aTHX_ kid)
7421 && kid->op_sibling && kid->op_sibling->op_type == OP_CONST
7423 || ( kid->op_type == OP_CONST
7424 && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
7426 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7427 "$[ used in %s (did you mean $] ?)", OP_DESC(o));
7433 Perl_ck_concat(pTHX_ OP *o)
7435 const OP * const kid = cUNOPo->op_first;
7437 PERL_ARGS_ASSERT_CK_CONCAT;
7438 PERL_UNUSED_CONTEXT;
7440 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
7441 !(kUNOP->op_first->op_flags & OPf_MOD))
7442 o->op_flags |= OPf_STACKED;
7447 Perl_ck_spair(pTHX_ OP *o)
7451 PERL_ARGS_ASSERT_CK_SPAIR;
7453 if (o->op_flags & OPf_KIDS) {
7456 const OPCODE type = o->op_type;
7457 o = modkids(ck_fun(o), type);
7458 kid = cUNOPo->op_first;
7459 newop = kUNOP->op_first->op_sibling;
7461 const OPCODE type = newop->op_type;
7462 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
7463 type == OP_PADAV || type == OP_PADHV ||
7464 type == OP_RV2AV || type == OP_RV2HV)
7468 op_getmad(kUNOP->op_first,newop,'K');
7470 op_free(kUNOP->op_first);
7472 kUNOP->op_first = newop;
7474 o->op_ppaddr = PL_ppaddr[++o->op_type];
7479 Perl_ck_delete(pTHX_ OP *o)
7481 PERL_ARGS_ASSERT_CK_DELETE;
7485 if (o->op_flags & OPf_KIDS) {
7486 OP * const kid = cUNOPo->op_first;
7487 switch (kid->op_type) {
7489 o->op_flags |= OPf_SPECIAL;
7492 o->op_private |= OPpSLICE;
7495 o->op_flags |= OPf_SPECIAL;
7500 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
7503 if (kid->op_private & OPpLVAL_INTRO)
7504 o->op_private |= OPpLVAL_INTRO;
7511 Perl_ck_die(pTHX_ OP *o)
7513 PERL_ARGS_ASSERT_CK_DIE;
7516 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7522 Perl_ck_eof(pTHX_ OP *o)
7526 PERL_ARGS_ASSERT_CK_EOF;
7528 if (o->op_flags & OPf_KIDS) {
7530 if (cLISTOPo->op_first->op_type == OP_STUB) {
7532 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
7534 op_getmad(o,newop,'O');
7541 kid = cLISTOPo->op_first;
7542 if (kid->op_type == OP_RV2GV)
7543 kid->op_private |= OPpALLOW_FAKE;
7549 Perl_ck_eval(pTHX_ OP *o)
7553 PERL_ARGS_ASSERT_CK_EVAL;
7555 PL_hints |= HINT_BLOCK_SCOPE;
7556 if (o->op_flags & OPf_KIDS) {
7557 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7560 o->op_flags &= ~OPf_KIDS;
7563 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
7569 cUNOPo->op_first = 0;
7574 NewOp(1101, enter, 1, LOGOP);
7575 enter->op_type = OP_ENTERTRY;
7576 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
7577 enter->op_private = 0;
7579 /* establish postfix order */
7580 enter->op_next = (OP*)enter;
7582 o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
7583 o->op_type = OP_LEAVETRY;
7584 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
7585 enter->op_other = o;
7586 op_getmad(oldo,o,'O');
7595 const U8 priv = o->op_private;
7601 o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
7602 op_getmad(oldo,o,'O');
7604 o->op_targ = (PADOFFSET)PL_hints;
7605 if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
7606 if ((PL_hints & HINT_LOCALIZE_HH) != 0
7607 && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
7608 /* Store a copy of %^H that pp_entereval can pick up. */
7609 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
7610 MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
7611 cUNOPo->op_first->op_sibling = hhop;
7612 o->op_private |= OPpEVAL_HAS_HH;
7614 if (!(o->op_private & OPpEVAL_BYTES)
7615 && FEATURE_UNIEVAL_IS_ENABLED)
7616 o->op_private |= OPpEVAL_UNICODE;
7621 Perl_ck_exit(pTHX_ OP *o)
7623 PERL_ARGS_ASSERT_CK_EXIT;
7626 HV * const table = GvHV(PL_hintgv);
7628 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
7629 if (svp && *svp && SvTRUE(*svp))
7630 o->op_private |= OPpEXIT_VMSISH;
7632 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
7638 Perl_ck_exec(pTHX_ OP *o)
7640 PERL_ARGS_ASSERT_CK_EXEC;
7642 if (o->op_flags & OPf_STACKED) {
7645 kid = cUNOPo->op_first->op_sibling;
7646 if (kid->op_type == OP_RV2GV)
7655 Perl_ck_exists(pTHX_ OP *o)
7659 PERL_ARGS_ASSERT_CK_EXISTS;
7662 if (o->op_flags & OPf_KIDS) {
7663 OP * const kid = cUNOPo->op_first;
7664 if (kid->op_type == OP_ENTERSUB) {
7665 (void) ref(kid, o->op_type);
7666 if (kid->op_type != OP_RV2CV
7667 && !(PL_parser && PL_parser->error_count))
7668 Perl_croak(aTHX_ "%s argument is not a subroutine name",
7670 o->op_private |= OPpEXISTS_SUB;
7672 else if (kid->op_type == OP_AELEM)
7673 o->op_flags |= OPf_SPECIAL;
7674 else if (kid->op_type != OP_HELEM)
7675 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
7683 Perl_ck_rvconst(pTHX_ register OP *o)
7686 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7688 PERL_ARGS_ASSERT_CK_RVCONST;
7690 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7691 if (o->op_type == OP_RV2CV)
7692 o->op_private &= ~1;
7694 if (kid->op_type == OP_CONST) {
7697 SV * const kidsv = kid->op_sv;
7699 /* Is it a constant from cv_const_sv()? */
7700 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
7701 SV * const rsv = SvRV(kidsv);
7702 const svtype type = SvTYPE(rsv);
7703 const char *badtype = NULL;
7705 switch (o->op_type) {
7707 if (type > SVt_PVMG)
7708 badtype = "a SCALAR";
7711 if (type != SVt_PVAV)
7712 badtype = "an ARRAY";
7715 if (type != SVt_PVHV)
7719 if (type != SVt_PVCV)
7724 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
7727 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
7728 const char *badthing;
7729 switch (o->op_type) {
7731 badthing = "a SCALAR";
7734 badthing = "an ARRAY";
7737 badthing = "a HASH";
7745 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
7746 SVfARG(kidsv), badthing);
7749 * This is a little tricky. We only want to add the symbol if we
7750 * didn't add it in the lexer. Otherwise we get duplicate strict
7751 * warnings. But if we didn't add it in the lexer, we must at
7752 * least pretend like we wanted to add it even if it existed before,
7753 * or we get possible typo warnings. OPpCONST_ENTERED says
7754 * whether the lexer already added THIS instance of this symbol.
7756 iscv = (o->op_type == OP_RV2CV) * 2;
7758 gv = gv_fetchsv(kidsv,
7759 iscv | !(kid->op_private & OPpCONST_ENTERED),
7762 : o->op_type == OP_RV2SV
7764 : o->op_type == OP_RV2AV
7766 : o->op_type == OP_RV2HV
7769 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
7771 kid->op_type = OP_GV;
7772 SvREFCNT_dec(kid->op_sv);
7774 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
7775 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
7776 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
7778 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
7780 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
7782 kid->op_private = 0;
7783 kid->op_ppaddr = PL_ppaddr[OP_GV];
7784 /* FAKE globs in the symbol table cause weird bugs (#77810) */
7792 Perl_ck_ftst(pTHX_ OP *o)
7795 const I32 type = o->op_type;
7797 PERL_ARGS_ASSERT_CK_FTST;
7799 if (o->op_flags & OPf_REF) {
7802 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
7803 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7804 const OPCODE kidtype = kid->op_type;
7806 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7807 OP * const newop = newGVOP(type, OPf_REF,
7808 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
7810 op_getmad(o,newop,'O');
7816 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
7817 o->op_private |= OPpFT_ACCESS;
7818 if (PL_check[kidtype] == Perl_ck_ftst
7819 && kidtype != OP_STAT && kidtype != OP_LSTAT) {
7820 o->op_private |= OPpFT_STACKED;
7821 kid->op_private |= OPpFT_STACKING;
7822 if (kidtype == OP_FTTTY && (
7823 !(kid->op_private & OPpFT_STACKED)
7824 || kid->op_private & OPpFT_AFTER_t
7826 o->op_private |= OPpFT_AFTER_t;
7835 if (type == OP_FTTTY)
7836 o = newGVOP(type, OPf_REF, PL_stdingv);
7838 o = newUNOP(type, 0, newDEFSVOP());
7839 op_getmad(oldo,o,'O');
7845 Perl_ck_fun(pTHX_ OP *o)
7848 const int type = o->op_type;
7849 register I32 oa = PL_opargs[type] >> OASHIFT;
7851 PERL_ARGS_ASSERT_CK_FUN;
7853 if (o->op_flags & OPf_STACKED) {
7854 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
7857 return no_fh_allowed(o);
7860 if (o->op_flags & OPf_KIDS) {
7861 OP **tokid = &cLISTOPo->op_first;
7862 register OP *kid = cLISTOPo->op_first;
7865 bool seen_optional = FALSE;
7867 if (kid->op_type == OP_PUSHMARK ||
7868 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
7870 tokid = &kid->op_sibling;
7871 kid = kid->op_sibling;
7873 if (kid && kid->op_type == OP_COREARGS) {
7874 bool optional = FALSE;
7877 if (oa & OA_OPTIONAL) optional = TRUE;
7880 if (optional) o->op_private |= numargs;
7885 if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
7886 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
7887 *tokid = kid = newDEFSVOP();
7888 seen_optional = TRUE;
7893 sibl = kid->op_sibling;
7895 if (!sibl && kid->op_type == OP_STUB) {
7902 /* list seen where single (scalar) arg expected? */
7903 if (numargs == 1 && !(oa >> 4)
7904 && kid->op_type == OP_LIST && type != OP_SCALAR)
7906 return too_many_arguments_pv(o,PL_op_desc[type], 0);
7919 if ((type == OP_PUSH || type == OP_UNSHIFT)
7920 && !kid->op_sibling)
7921 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
7922 "Useless use of %s with no values",
7925 if (kid->op_type == OP_CONST &&
7926 (kid->op_private & OPpCONST_BARE))
7928 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
7929 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
7930 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7931 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
7932 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7934 op_getmad(kid,newop,'K');
7939 kid->op_sibling = sibl;
7942 else if (kid->op_type == OP_CONST
7943 && ( !SvROK(cSVOPx_sv(kid))
7944 || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
7946 bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
7947 /* Defer checks to run-time if we have a scalar arg */
7948 if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
7949 op_lvalue(kid, type);
7953 if (kid->op_type == OP_CONST &&
7954 (kid->op_private & OPpCONST_BARE))
7956 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
7957 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
7958 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7959 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
7960 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
7962 op_getmad(kid,newop,'K');
7967 kid->op_sibling = sibl;
7970 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
7971 bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
7972 op_lvalue(kid, type);
7976 OP * const newop = newUNOP(OP_NULL, 0, kid);
7977 kid->op_sibling = 0;
7979 newop->op_next = newop;
7981 kid->op_sibling = sibl;
7986 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
7987 if (kid->op_type == OP_CONST &&
7988 (kid->op_private & OPpCONST_BARE))
7990 OP * const newop = newGVOP(OP_GV, 0,
7991 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
7992 if (!(o->op_private & 1) && /* if not unop */
7993 kid == cLISTOPo->op_last)
7994 cLISTOPo->op_last = newop;
7996 op_getmad(kid,newop,'K');
8002 else if (kid->op_type == OP_READLINE) {
8003 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
8004 bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
8007 I32 flags = OPf_SPECIAL;
8011 /* is this op a FH constructor? */
8012 if (is_handle_constructor(o,numargs)) {
8013 const char *name = NULL;
8016 bool want_dollar = TRUE;
8019 /* Set a flag to tell rv2gv to vivify
8020 * need to "prove" flag does not mean something
8021 * else already - NI-S 1999/05/07
8024 if (kid->op_type == OP_PADSV) {
8026 = PAD_COMPNAME_SV(kid->op_targ);
8027 name = SvPV_const(namesv, len);
8028 name_utf8 = SvUTF8(namesv);
8030 else if (kid->op_type == OP_RV2SV
8031 && kUNOP->op_first->op_type == OP_GV)
8033 GV * const gv = cGVOPx_gv(kUNOP->op_first);
8035 len = GvNAMELEN(gv);
8036 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
8038 else if (kid->op_type == OP_AELEM
8039 || kid->op_type == OP_HELEM)
8042 OP *op = ((BINOP*)kid)->op_first;
8046 const char * const a =
8047 kid->op_type == OP_AELEM ?
8049 if (((op->op_type == OP_RV2AV) ||
8050 (op->op_type == OP_RV2HV)) &&
8051 (firstop = ((UNOP*)op)->op_first) &&
8052 (firstop->op_type == OP_GV)) {
8053 /* packagevar $a[] or $h{} */
8054 GV * const gv = cGVOPx_gv(firstop);
8062 else if (op->op_type == OP_PADAV
8063 || op->op_type == OP_PADHV) {
8064 /* lexicalvar $a[] or $h{} */
8065 const char * const padname =
8066 PAD_COMPNAME_PV(op->op_targ);
8075 name = SvPV_const(tmpstr, len);
8076 name_utf8 = SvUTF8(tmpstr);
8081 name = "__ANONIO__";
8083 want_dollar = FALSE;
8085 op_lvalue(kid, type);
8089 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
8090 namesv = PAD_SVl(targ);
8091 SvUPGRADE(namesv, SVt_PV);
8092 if (want_dollar && *name != '$')
8093 sv_setpvs(namesv, "$");
8094 sv_catpvn(namesv, name, len);
8095 if ( name_utf8 ) SvUTF8_on(namesv);
8098 kid->op_sibling = 0;
8099 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
8100 kid->op_targ = targ;
8101 kid->op_private |= priv;
8103 kid->op_sibling = sibl;
8109 if ((type == OP_UNDEF || type == OP_POS)
8110 && numargs == 1 && !(oa >> 4)
8111 && kid->op_type == OP_LIST)
8112 return too_many_arguments_pv(o,PL_op_desc[type], 0);
8113 op_lvalue(scalar(kid), type);
8117 tokid = &kid->op_sibling;
8118 kid = kid->op_sibling;
8121 if (kid && kid->op_type != OP_STUB)
8122 return too_many_arguments_pv(o,OP_DESC(o), 0);
8123 o->op_private |= numargs;
8125 /* FIXME - should the numargs move as for the PERL_MAD case? */
8126 o->op_private |= numargs;
8128 return too_many_arguments_pv(o,OP_DESC(o), 0);
8132 else if (PL_opargs[type] & OA_DEFGV) {
8134 OP *newop = newUNOP(type, 0, newDEFSVOP());
8135 op_getmad(o,newop,'O');
8138 /* Ordering of these two is important to keep f_map.t passing. */
8140 return newUNOP(type, 0, newDEFSVOP());
8145 while (oa & OA_OPTIONAL)
8147 if (oa && oa != OA_LIST)
8148 return too_few_arguments_pv(o,OP_DESC(o), 0);
8154 Perl_ck_glob(pTHX_ OP *o)
8158 const bool core = o->op_flags & OPf_SPECIAL;
8160 PERL_ARGS_ASSERT_CK_GLOB;
8163 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
8164 op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
8166 if (core) gv = NULL;
8167 else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
8168 && GvCVu(gv) && GvIMPORTED_CV(gv)))
8170 GV * const * const gvp =
8171 (GV **)hv_fetchs(PL_globalstash, "glob", FALSE);
8172 gv = gvp ? *gvp : NULL;
8175 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8178 * \ null - const(wildcard)
8183 * \ mark - glob - rv2cv
8184 * | \ gv(CORE::GLOBAL::glob)
8186 * \ null - const(wildcard) - const(ix)
8188 o->op_flags |= OPf_SPECIAL;
8189 o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
8190 op_append_elem(OP_GLOB, o,
8191 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
8192 o = newLISTOP(OP_LIST, 0, o, NULL);
8193 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
8194 op_append_elem(OP_LIST, o,
8195 scalar(newUNOP(OP_RV2CV, 0,
8196 newGVOP(OP_GV, 0, gv)))));
8197 o = newUNOP(OP_NULL, 0, o);
8198 o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
8201 else o->op_flags &= ~OPf_SPECIAL;
8202 #if !defined(PERL_EXTERNAL_GLOB)
8205 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
8206 newSVpvs("File::Glob"), NULL, NULL, NULL);
8209 #endif /* !PERL_EXTERNAL_GLOB */
8210 gv = newGVgen("main");
8212 #ifndef PERL_EXTERNAL_GLOB
8213 sv_setiv(GvSVn(gv),PL_glob_index++);
8215 op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
8221 Perl_ck_grep(pTHX_ OP *o)
8226 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
8229 PERL_ARGS_ASSERT_CK_GREP;
8231 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
8232 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
8234 if (o->op_flags & OPf_STACKED) {
8237 kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
8238 if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
8239 return no_fh_allowed(o);
8240 for (k = kid; k; k = k->op_next) {
8243 NewOp(1101, gwop, 1, LOGOP);
8244 kid->op_next = (OP*)gwop;
8245 o->op_flags &= ~OPf_STACKED;
8247 kid = cLISTOPo->op_first->op_sibling;
8248 if (type == OP_MAPWHILE)
8253 if (PL_parser && PL_parser->error_count)
8255 kid = cLISTOPo->op_first->op_sibling;
8256 if (kid->op_type != OP_NULL)
8257 Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
8258 kid = kUNOP->op_first;
8261 NewOp(1101, gwop, 1, LOGOP);
8262 gwop->op_type = type;
8263 gwop->op_ppaddr = PL_ppaddr[type];
8264 gwop->op_first = listkids(o);
8265 gwop->op_flags |= OPf_KIDS;
8266 gwop->op_other = LINKLIST(kid);
8267 kid->op_next = (OP*)gwop;
8268 offset = pad_findmy_pvs("$_", 0);
8269 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
8270 o->op_private = gwop->op_private = 0;
8271 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
8274 o->op_private = gwop->op_private = OPpGREP_LEX;
8275 gwop->op_targ = o->op_targ = offset;
8278 kid = cLISTOPo->op_first->op_sibling;
8279 if (!kid || !kid->op_sibling)
8280 return too_few_arguments_pv(o,OP_DESC(o), 0);
8281 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
8282 op_lvalue(kid, OP_GREPSTART);
8288 Perl_ck_index(pTHX_ OP *o)
8290 PERL_ARGS_ASSERT_CK_INDEX;
8292 if (o->op_flags & OPf_KIDS) {
8293 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8295 kid = kid->op_sibling; /* get past "big" */
8296 if (kid && kid->op_type == OP_CONST) {
8297 const bool save_taint = PL_tainted;
8298 fbm_compile(((SVOP*)kid)->op_sv, 0);
8299 PL_tainted = save_taint;
8306 Perl_ck_lfun(pTHX_ OP *o)
8308 const OPCODE type = o->op_type;
8310 PERL_ARGS_ASSERT_CK_LFUN;
8312 return modkids(ck_fun(o), type);
8316 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
8318 PERL_ARGS_ASSERT_CK_DEFINED;
8320 if ((o->op_flags & OPf_KIDS)) {
8321 switch (cUNOPo->op_first->op_type) {
8324 case OP_AASSIGN: /* Is this a good idea? */
8325 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8326 "defined(@array) is deprecated");
8327 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8328 "\t(Maybe you should just omit the defined()?)\n");
8332 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8333 "defined(%%hash) is deprecated");
8334 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8335 "\t(Maybe you should just omit the defined()?)\n");
8346 Perl_ck_readline(pTHX_ OP *o)
8348 PERL_ARGS_ASSERT_CK_READLINE;
8350 if (o->op_flags & OPf_KIDS) {
8351 OP *kid = cLISTOPo->op_first;
8352 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
8356 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
8358 op_getmad(o,newop,'O');
8368 Perl_ck_rfun(pTHX_ OP *o)
8370 const OPCODE type = o->op_type;
8372 PERL_ARGS_ASSERT_CK_RFUN;
8374 return refkids(ck_fun(o), type);
8378 Perl_ck_listiob(pTHX_ OP *o)
8382 PERL_ARGS_ASSERT_CK_LISTIOB;
8384 kid = cLISTOPo->op_first;
8387 kid = cLISTOPo->op_first;
8389 if (kid->op_type == OP_PUSHMARK)
8390 kid = kid->op_sibling;
8391 if (kid && o->op_flags & OPf_STACKED)
8392 kid = kid->op_sibling;
8393 else if (kid && !kid->op_sibling) { /* print HANDLE; */
8394 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
8395 o->op_flags |= OPf_STACKED; /* make it a filehandle */
8396 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
8397 cLISTOPo->op_first->op_sibling = kid;
8398 cLISTOPo->op_last = kid;
8399 kid = kid->op_sibling;
8404 op_append_elem(o->op_type, o, newDEFSVOP());
8406 if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
8411 Perl_ck_smartmatch(pTHX_ OP *o)
8414 PERL_ARGS_ASSERT_CK_SMARTMATCH;
8415 if (0 == (o->op_flags & OPf_SPECIAL)) {
8416 OP *first = cBINOPo->op_first;
8417 OP *second = first->op_sibling;
8419 /* Implicitly take a reference to an array or hash */
8420 first->op_sibling = NULL;
8421 first = cBINOPo->op_first = ref_array_or_hash(first);
8422 second = first->op_sibling = ref_array_or_hash(second);
8424 /* Implicitly take a reference to a regular expression */
8425 if (first->op_type == OP_MATCH) {
8426 first->op_type = OP_QR;
8427 first->op_ppaddr = PL_ppaddr[OP_QR];
8429 if (second->op_type == OP_MATCH) {
8430 second->op_type = OP_QR;
8431 second->op_ppaddr = PL_ppaddr[OP_QR];
8440 Perl_ck_sassign(pTHX_ OP *o)
8443 OP * const kid = cLISTOPo->op_first;
8445 PERL_ARGS_ASSERT_CK_SASSIGN;
8447 /* has a disposable target? */
8448 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
8449 && !(kid->op_flags & OPf_STACKED)
8450 /* Cannot steal the second time! */
8451 && !(kid->op_private & OPpTARGET_MY)
8452 /* Keep the full thing for madskills */
8456 OP * const kkid = kid->op_sibling;
8458 /* Can just relocate the target. */
8459 if (kkid && kkid->op_type == OP_PADSV
8460 && !(kkid->op_private & OPpLVAL_INTRO))
8462 kid->op_targ = kkid->op_targ;
8464 /* Now we do not need PADSV and SASSIGN. */
8465 kid->op_sibling = o->op_sibling; /* NULL */
8466 cLISTOPo->op_first = NULL;
8469 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
8473 if (kid->op_sibling) {
8474 OP *kkid = kid->op_sibling;
8475 /* For state variable assignment, kkid is a list op whose op_last
8477 if ((kkid->op_type == OP_PADSV ||
8478 (kkid->op_type == OP_LIST &&
8479 (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
8482 && (kkid->op_private & OPpLVAL_INTRO)
8483 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
8484 const PADOFFSET target = kkid->op_targ;
8485 OP *const other = newOP(OP_PADSV,
8487 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
8488 OP *const first = newOP(OP_NULL, 0);
8489 OP *const nullop = newCONDOP(0, first, o, other);
8490 OP *const condop = first->op_next;
8491 /* hijacking PADSTALE for uninitialized state variables */
8492 SvPADSTALE_on(PAD_SVl(target));
8494 condop->op_type = OP_ONCE;
8495 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
8496 condop->op_targ = target;
8497 other->op_targ = target;
8499 /* Because we change the type of the op here, we will skip the
8500 assignment binop->op_last = binop->op_first->op_sibling; at the
8501 end of Perl_newBINOP(). So need to do it here. */
8502 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
8511 Perl_ck_match(pTHX_ OP *o)
8515 PERL_ARGS_ASSERT_CK_MATCH;
8517 if (o->op_type != OP_QR && PL_compcv) {
8518 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
8519 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
8520 o->op_targ = offset;
8521 o->op_private |= OPpTARGET_MY;
8524 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
8525 o->op_private |= OPpRUNTIME;
8530 Perl_ck_method(pTHX_ OP *o)
8532 OP * const kid = cUNOPo->op_first;
8534 PERL_ARGS_ASSERT_CK_METHOD;
8536 if (kid->op_type == OP_CONST) {
8537 SV* sv = kSVOP->op_sv;
8538 const char * const method = SvPVX_const(sv);
8539 if (!(strchr(method, ':') || strchr(method, '\''))) {
8541 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
8542 sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
8545 kSVOP->op_sv = NULL;
8547 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
8549 op_getmad(o,cmop,'O');
8560 Perl_ck_null(pTHX_ OP *o)
8562 PERL_ARGS_ASSERT_CK_NULL;
8563 PERL_UNUSED_CONTEXT;
8568 Perl_ck_open(pTHX_ OP *o)
8571 HV * const table = GvHV(PL_hintgv);
8573 PERL_ARGS_ASSERT_CK_OPEN;
8576 SV **svp = hv_fetchs(table, "open_IN", FALSE);
8579 const char *d = SvPV_const(*svp, len);
8580 const I32 mode = mode_from_discipline(d, len);
8581 if (mode & O_BINARY)
8582 o->op_private |= OPpOPEN_IN_RAW;
8583 else if (mode & O_TEXT)
8584 o->op_private |= OPpOPEN_IN_CRLF;
8587 svp = hv_fetchs(table, "open_OUT", FALSE);
8590 const char *d = SvPV_const(*svp, len);
8591 const I32 mode = mode_from_discipline(d, len);
8592 if (mode & O_BINARY)
8593 o->op_private |= OPpOPEN_OUT_RAW;
8594 else if (mode & O_TEXT)
8595 o->op_private |= OPpOPEN_OUT_CRLF;
8598 if (o->op_type == OP_BACKTICK) {
8599 if (!(o->op_flags & OPf_KIDS)) {
8600 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
8602 op_getmad(o,newop,'O');
8611 /* In case of three-arg dup open remove strictness
8612 * from the last arg if it is a bareword. */
8613 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
8614 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
8618 if ((last->op_type == OP_CONST) && /* The bareword. */
8619 (last->op_private & OPpCONST_BARE) &&
8620 (last->op_private & OPpCONST_STRICT) &&
8621 (oa = first->op_sibling) && /* The fh. */
8622 (oa = oa->op_sibling) && /* The mode. */
8623 (oa->op_type == OP_CONST) &&
8624 SvPOK(((SVOP*)oa)->op_sv) &&
8625 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
8626 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
8627 (last == oa->op_sibling)) /* The bareword. */
8628 last->op_private &= ~OPpCONST_STRICT;
8634 Perl_ck_repeat(pTHX_ OP *o)
8636 PERL_ARGS_ASSERT_CK_REPEAT;
8638 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
8639 o->op_private |= OPpREPEAT_DOLIST;
8640 cBINOPo->op_first = force_list(cBINOPo->op_first);
8648 Perl_ck_require(pTHX_ OP *o)
8653 PERL_ARGS_ASSERT_CK_REQUIRE;
8655 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
8656 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8658 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
8659 SV * const sv = kid->op_sv;
8660 U32 was_readonly = SvREADONLY(sv);
8667 sv_force_normal_flags(sv, 0);
8668 assert(!SvREADONLY(sv));
8678 for (; s < end; s++) {
8679 if (*s == ':' && s[1] == ':') {
8681 Move(s+2, s+1, end - s - 1, char);
8686 sv_catpvs(sv, ".pm");
8687 SvFLAGS(sv) |= was_readonly;
8691 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
8692 /* handle override, if any */
8693 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
8694 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
8695 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
8696 gv = gvp ? *gvp : NULL;
8700 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
8702 if (o->op_flags & OPf_KIDS) {
8703 kid = cUNOPo->op_first;
8704 cUNOPo->op_first = NULL;
8712 newop = newUNOP(OP_ENTERSUB, OPf_STACKED,
8713 op_append_elem(OP_LIST, kid,
8714 scalar(newUNOP(OP_RV2CV, 0,
8717 op_getmad(o,newop,'O');
8721 return scalar(ck_fun(o));
8725 Perl_ck_return(pTHX_ OP *o)
8730 PERL_ARGS_ASSERT_CK_RETURN;
8732 kid = cLISTOPo->op_first->op_sibling;
8733 if (CvLVALUE(PL_compcv)) {
8734 for (; kid; kid = kid->op_sibling)
8735 op_lvalue(kid, OP_LEAVESUBLV);
8742 Perl_ck_select(pTHX_ OP *o)
8747 PERL_ARGS_ASSERT_CK_SELECT;
8749 if (o->op_flags & OPf_KIDS) {
8750 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8751 if (kid && kid->op_sibling) {
8752 o->op_type = OP_SSELECT;
8753 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
8755 return fold_constants(op_integerize(op_std_init(o)));
8759 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8760 if (kid && kid->op_type == OP_RV2GV)
8761 kid->op_private &= ~HINT_STRICT_REFS;
8766 Perl_ck_shift(pTHX_ OP *o)
8769 const I32 type = o->op_type;
8771 PERL_ARGS_ASSERT_CK_SHIFT;
8773 if (!(o->op_flags & OPf_KIDS)) {
8776 if (!CvUNIQUE(PL_compcv)) {
8777 o->op_flags |= OPf_SPECIAL;
8781 argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
8784 OP * const oldo = o;
8785 o = newUNOP(type, 0, scalar(argop));
8786 op_getmad(oldo,o,'O');
8791 return newUNOP(type, 0, scalar(argop));
8794 return scalar(ck_fun(o));
8798 Perl_ck_sort(pTHX_ OP *o)
8803 PERL_ARGS_ASSERT_CK_SORT;
8805 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
8806 HV * const hinthv = GvHV(PL_hintgv);
8808 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
8810 const I32 sorthints = (I32)SvIV(*svp);
8811 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
8812 o->op_private |= OPpSORT_QSORT;
8813 if ((sorthints & HINT_SORT_STABLE) != 0)
8814 o->op_private |= OPpSORT_STABLE;
8819 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
8821 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8822 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
8824 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
8826 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
8828 if (kid->op_type == OP_SCOPE) {
8832 else if (kid->op_type == OP_LEAVE) {
8833 if (o->op_type == OP_SORT) {
8834 op_null(kid); /* wipe out leave */
8837 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
8838 if (k->op_next == kid)
8840 /* don't descend into loops */
8841 else if (k->op_type == OP_ENTERLOOP
8842 || k->op_type == OP_ENTERITER)
8844 k = cLOOPx(k)->op_lastop;
8849 kid->op_next = 0; /* just disconnect the leave */
8850 k = kLISTOP->op_first;
8855 if (o->op_type == OP_SORT) {
8856 /* provide scalar context for comparison function/block */
8862 o->op_flags |= OPf_SPECIAL;
8865 firstkid = firstkid->op_sibling;
8868 /* provide list context for arguments */
8869 if (o->op_type == OP_SORT)
8876 S_simplify_sort(pTHX_ OP *o)
8879 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
8885 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
8887 if (!(o->op_flags & OPf_STACKED))
8889 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
8890 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
8891 kid = kUNOP->op_first; /* get past null */
8892 if (kid->op_type != OP_SCOPE)
8894 kid = kLISTOP->op_last; /* get past scope */
8895 switch(kid->op_type) {
8903 k = kid; /* remember this node*/
8904 if (kBINOP->op_first->op_type != OP_RV2SV)
8906 kid = kBINOP->op_first; /* get past cmp */
8907 if (kUNOP->op_first->op_type != OP_GV)
8909 kid = kUNOP->op_first; /* get past rv2sv */
8911 if (GvSTASH(gv) != PL_curstash)
8913 gvname = GvNAME(gv);
8914 if (*gvname == 'a' && gvname[1] == '\0')
8916 else if (*gvname == 'b' && gvname[1] == '\0')
8921 kid = k; /* back to cmp */
8922 if (kBINOP->op_last->op_type != OP_RV2SV)
8924 kid = kBINOP->op_last; /* down to 2nd arg */
8925 if (kUNOP->op_first->op_type != OP_GV)
8927 kid = kUNOP->op_first; /* get past rv2sv */
8929 if (GvSTASH(gv) != PL_curstash)
8931 gvname = GvNAME(gv);
8933 ? !(*gvname == 'a' && gvname[1] == '\0')
8934 : !(*gvname == 'b' && gvname[1] == '\0'))
8936 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
8938 o->op_private |= OPpSORT_DESCEND;
8939 if (k->op_type == OP_NCMP)
8940 o->op_private |= OPpSORT_NUMERIC;
8941 if (k->op_type == OP_I_NCMP)
8942 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
8943 kid = cLISTOPo->op_first->op_sibling;
8944 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
8946 op_getmad(kid,o,'S'); /* then delete it */
8948 op_free(kid); /* then delete it */
8953 Perl_ck_split(pTHX_ OP *o)
8958 PERL_ARGS_ASSERT_CK_SPLIT;
8960 if (o->op_flags & OPf_STACKED)
8961 return no_fh_allowed(o);
8963 kid = cLISTOPo->op_first;
8964 if (kid->op_type != OP_NULL)
8965 Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
8966 kid = kid->op_sibling;
8967 op_free(cLISTOPo->op_first);
8969 cLISTOPo->op_first = kid;
8971 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
8972 cLISTOPo->op_last = kid; /* There was only one element previously */
8975 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
8976 OP * const sibl = kid->op_sibling;
8977 kid->op_sibling = 0;
8978 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
8979 if (cLISTOPo->op_first == cLISTOPo->op_last)
8980 cLISTOPo->op_last = kid;
8981 cLISTOPo->op_first = kid;
8982 kid->op_sibling = sibl;
8985 kid->op_type = OP_PUSHRE;
8986 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
8988 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
8989 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8990 "Use of /g modifier is meaningless in split");
8993 if (!kid->op_sibling)
8994 op_append_elem(OP_SPLIT, o, newDEFSVOP());
8996 kid = kid->op_sibling;
8999 if (!kid->op_sibling)
9000 op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
9001 assert(kid->op_sibling);
9003 kid = kid->op_sibling;
9006 if (kid->op_sibling)
9007 return too_many_arguments_pv(o,OP_DESC(o), 0);
9013 Perl_ck_join(pTHX_ OP *o)
9015 const OP * const kid = cLISTOPo->op_first->op_sibling;
9017 PERL_ARGS_ASSERT_CK_JOIN;
9019 if (kid && kid->op_type == OP_MATCH) {
9020 if (ckWARN(WARN_SYNTAX)) {
9021 const REGEXP *re = PM_GETRE(kPMOP);
9023 ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
9024 SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
9025 : newSVpvs_flags( "STRING", SVs_TEMP );
9026 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9027 "/%"SVf"/ should probably be written as \"%"SVf"\"",
9028 SVfARG(msg), SVfARG(msg));
9035 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
9037 Examines an op, which is expected to identify a subroutine at runtime,
9038 and attempts to determine at compile time which subroutine it identifies.
9039 This is normally used during Perl compilation to determine whether
9040 a prototype can be applied to a function call. I<cvop> is the op
9041 being considered, normally an C<rv2cv> op. A pointer to the identified
9042 subroutine is returned, if it could be determined statically, and a null
9043 pointer is returned if it was not possible to determine statically.
9045 Currently, the subroutine can be identified statically if the RV that the
9046 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
9047 A C<gv> op is suitable if the GV's CV slot is populated. A C<const> op is
9048 suitable if the constant value must be an RV pointing to a CV. Details of
9049 this process may change in future versions of Perl. If the C<rv2cv> op
9050 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
9051 the subroutine statically: this flag is used to suppress compile-time
9052 magic on a subroutine call, forcing it to use default runtime behaviour.
9054 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
9055 of a GV reference is modified. If a GV was examined and its CV slot was
9056 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
9057 If the op is not optimised away, and the CV slot is later populated with
9058 a subroutine having a prototype, that flag eventually triggers the warning
9059 "called too early to check prototype".
9061 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
9062 of returning a pointer to the subroutine it returns a pointer to the
9063 GV giving the most appropriate name for the subroutine in this context.
9064 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
9065 (C<CvANON>) subroutine that is referenced through a GV it will be the
9066 referencing GV. The resulting C<GV*> is cast to C<CV*> to be returned.
9067 A null pointer is returned as usual if there is no statically-determinable
9074 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
9079 PERL_ARGS_ASSERT_RV2CV_OP_CV;
9080 if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
9081 Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
9082 if (cvop->op_type != OP_RV2CV)
9084 if (cvop->op_private & OPpENTERSUB_AMPER)
9086 if (!(cvop->op_flags & OPf_KIDS))
9088 rvop = cUNOPx(cvop)->op_first;
9089 switch (rvop->op_type) {
9091 gv = cGVOPx_gv(rvop);
9094 if (flags & RV2CVOPCV_MARK_EARLY)
9095 rvop->op_private |= OPpEARLY_CV;
9100 SV *rv = cSVOPx_sv(rvop);
9110 if (SvTYPE((SV*)cv) != SVt_PVCV)
9112 if (flags & RV2CVOPCV_RETURN_NAME_GV) {
9113 if (!CvANON(cv) || !gv)
9122 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
9124 Performs the default fixup of the arguments part of an C<entersub>
9125 op tree. This consists of applying list context to each of the
9126 argument ops. This is the standard treatment used on a call marked
9127 with C<&>, or a method call, or a call through a subroutine reference,
9128 or any other call where the callee can't be identified at compile time,
9129 or a call where the callee has no prototype.
9135 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
9138 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
9139 aop = cUNOPx(entersubop)->op_first;
9140 if (!aop->op_sibling)
9141 aop = cUNOPx(aop)->op_first;
9142 for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
9143 if (!(PL_madskills && aop->op_type == OP_STUB)) {
9145 op_lvalue(aop, OP_ENTERSUB);
9152 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
9154 Performs the fixup of the arguments part of an C<entersub> op tree
9155 based on a subroutine prototype. This makes various modifications to
9156 the argument ops, from applying context up to inserting C<refgen> ops,
9157 and checking the number and syntactic types of arguments, as directed by
9158 the prototype. This is the standard treatment used on a subroutine call,
9159 not marked with C<&>, where the callee can be identified at compile time
9160 and has a prototype.
9162 I<protosv> supplies the subroutine prototype to be applied to the call.
9163 It may be a normal defined scalar, of which the string value will be used.
9164 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9165 that has been cast to C<SV*>) which has a prototype. The prototype
9166 supplied, in whichever form, does not need to match the actual callee
9167 referenced by the op tree.
9169 If the argument ops disagree with the prototype, for example by having
9170 an unacceptable number of arguments, a valid op tree is returned anyway.
9171 The error is reflected in the parser state, normally resulting in a single
9172 exception at the top level of parsing which covers all the compilation
9173 errors that occurred. In the error message, the callee is referred to
9174 by the name defined by the I<namegv> parameter.
9180 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9183 const char *proto, *proto_end;
9184 OP *aop, *prev, *cvop;
9187 I32 contextclass = 0;
9188 const char *e = NULL;
9189 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
9190 if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
9191 Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
9192 "flags=%lx", (unsigned long) SvFLAGS(protosv));
9193 if (SvTYPE(protosv) == SVt_PVCV)
9194 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
9195 else proto = SvPV(protosv, proto_len);
9196 proto_end = proto + proto_len;
9197 aop = cUNOPx(entersubop)->op_first;
9198 if (!aop->op_sibling)
9199 aop = cUNOPx(aop)->op_first;
9201 aop = aop->op_sibling;
9202 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9203 while (aop != cvop) {
9205 if (PL_madskills && aop->op_type == OP_STUB) {
9206 aop = aop->op_sibling;
9209 if (PL_madskills && aop->op_type == OP_NULL)
9210 o3 = ((UNOP*)aop)->op_first;
9214 if (proto >= proto_end)
9215 return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
9223 /* _ must be at the end */
9224 if (proto[1] && !strchr(";@%", proto[1]))
9239 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
9241 arg == 1 ? "block or sub {}" : "sub {}",
9242 gv_ename(namegv), 0, o3);
9245 /* '*' allows any scalar type, including bareword */
9248 if (o3->op_type == OP_RV2GV)
9249 goto wrapref; /* autoconvert GLOB -> GLOBref */
9250 else if (o3->op_type == OP_CONST)
9251 o3->op_private &= ~OPpCONST_STRICT;
9252 else if (o3->op_type == OP_ENTERSUB) {
9253 /* accidental subroutine, revert to bareword */
9254 OP *gvop = ((UNOP*)o3)->op_first;
9255 if (gvop && gvop->op_type == OP_NULL) {
9256 gvop = ((UNOP*)gvop)->op_first;
9258 for (; gvop->op_sibling; gvop = gvop->op_sibling)
9261 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
9262 (gvop = ((UNOP*)gvop)->op_first) &&
9263 gvop->op_type == OP_GV)
9265 GV * const gv = cGVOPx_gv(gvop);
9266 OP * const sibling = aop->op_sibling;
9267 SV * const n = newSVpvs("");
9269 OP * const oldaop = aop;
9273 gv_fullname4(n, gv, "", FALSE);
9274 aop = newSVOP(OP_CONST, 0, n);
9275 op_getmad(oldaop,aop,'O');
9276 prev->op_sibling = aop;
9277 aop->op_sibling = sibling;
9287 if (o3->op_type == OP_RV2AV ||
9288 o3->op_type == OP_PADAV ||
9289 o3->op_type == OP_RV2HV ||
9290 o3->op_type == OP_PADHV
9305 if (contextclass++ == 0) {
9306 e = strchr(proto, ']');
9307 if (!e || e == proto)
9316 const char *p = proto;
9317 const char *const end = proto;
9320 /* \[$] accepts any scalar lvalue */
9322 && Perl_op_lvalue_flags(aTHX_
9324 OP_READ, /* not entersub */
9327 bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
9329 gv_ename(namegv), 0, o3);
9334 if (o3->op_type == OP_RV2GV)
9337 bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
9340 if (o3->op_type == OP_ENTERSUB)
9343 bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
9347 if (o3->op_type == OP_RV2SV ||
9348 o3->op_type == OP_PADSV ||
9349 o3->op_type == OP_HELEM ||
9350 o3->op_type == OP_AELEM)
9352 if (!contextclass) {
9353 /* \$ accepts any scalar lvalue */
9354 if (Perl_op_lvalue_flags(aTHX_
9356 OP_READ, /* not entersub */
9359 bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
9363 if (o3->op_type == OP_RV2AV ||
9364 o3->op_type == OP_PADAV)
9367 bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
9370 if (o3->op_type == OP_RV2HV ||
9371 o3->op_type == OP_PADHV)
9374 bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
9378 OP* const kid = aop;
9379 OP* const sib = kid->op_sibling;
9380 kid->op_sibling = 0;
9381 aop = newUNOP(OP_REFGEN, 0, kid);
9382 aop->op_sibling = sib;
9383 prev->op_sibling = aop;
9385 if (contextclass && e) {
9400 SV* const tmpsv = sv_newmortal();
9401 gv_efullname3(tmpsv, namegv, NULL);
9402 Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
9403 SVfARG(tmpsv), SVfARG(protosv));
9407 op_lvalue(aop, OP_ENTERSUB);
9409 aop = aop->op_sibling;
9411 if (aop == cvop && *proto == '_') {
9412 /* generate an access to $_ */
9414 aop->op_sibling = prev->op_sibling;
9415 prev->op_sibling = aop; /* instead of cvop */
9417 if (!optional && proto_end > proto &&
9418 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
9419 return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
9424 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
9426 Performs the fixup of the arguments part of an C<entersub> op tree either
9427 based on a subroutine prototype or using default list-context processing.
9428 This is the standard treatment used on a subroutine call, not marked
9429 with C<&>, where the callee can be identified at compile time.
9431 I<protosv> supplies the subroutine prototype to be applied to the call,
9432 or indicates that there is no prototype. It may be a normal scalar,
9433 in which case if it is defined then the string value will be used
9434 as a prototype, and if it is undefined then there is no prototype.
9435 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
9436 that has been cast to C<SV*>), of which the prototype will be used if it
9437 has one. The prototype (or lack thereof) supplied, in whichever form,
9438 does not need to match the actual callee referenced by the op tree.
9440 If the argument ops disagree with the prototype, for example by having
9441 an unacceptable number of arguments, a valid op tree is returned anyway.
9442 The error is reflected in the parser state, normally resulting in a single
9443 exception at the top level of parsing which covers all the compilation
9444 errors that occurred. In the error message, the callee is referred to
9445 by the name defined by the I<namegv> parameter.
9451 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
9452 GV *namegv, SV *protosv)
9454 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
9455 if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
9456 return ck_entersub_args_proto(entersubop, namegv, protosv);
9458 return ck_entersub_args_list(entersubop);
9462 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
9464 int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
9465 OP *aop = cUNOPx(entersubop)->op_first;
9467 PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
9471 if (!aop->op_sibling)
9472 aop = cUNOPx(aop)->op_first;
9473 aop = aop->op_sibling;
9474 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9475 if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
9476 aop = aop->op_sibling;
9479 (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
9481 op_free(entersubop);
9482 switch(GvNAME(namegv)[2]) {
9483 case 'F': return newSVOP(OP_CONST, 0,
9484 newSVpv(CopFILE(PL_curcop),0));
9485 case 'L': return newSVOP(
9488 "%"IVdf, (IV)CopLINE(PL_curcop)
9491 case 'P': return newSVOP(OP_CONST, 0,
9493 ? newSVhek(HvNAME_HEK(PL_curstash))
9504 bool seenarg = FALSE;
9506 if (!aop->op_sibling)
9507 aop = cUNOPx(aop)->op_first;
9510 aop = aop->op_sibling;
9511 prev->op_sibling = NULL;
9514 prev=cvop, cvop = cvop->op_sibling)
9516 if (PL_madskills && cvop->op_sibling
9517 && cvop->op_type != OP_STUB) seenarg = TRUE
9520 prev->op_sibling = NULL;
9521 flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
9523 if (aop == cvop) aop = NULL;
9524 op_free(entersubop);
9526 if (opnum == OP_ENTEREVAL
9527 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
9528 flags |= OPpEVAL_BYTES <<8;
9530 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
9532 case OA_BASEOP_OR_UNOP:
9534 return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
9538 if (!PL_madskills || seenarg)
9540 (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
9543 return opnum == OP_RUNCV
9544 ? newPVOP(OP_RUNCV,0,NULL)
9547 return convert(opnum,0,aop);
9555 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
9557 Retrieves the function that will be used to fix up a call to I<cv>.
9558 Specifically, the function is applied to an C<entersub> op tree for a
9559 subroutine call, not marked with C<&>, where the callee can be identified
9560 at compile time as I<cv>.
9562 The C-level function pointer is returned in I<*ckfun_p>, and an SV
9563 argument for it is returned in I<*ckobj_p>. The function is intended
9564 to be called in this manner:
9566 entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
9568 In this call, I<entersubop> is a pointer to the C<entersub> op,
9569 which may be replaced by the check function, and I<namegv> is a GV
9570 supplying the name that should be used by the check function to refer
9571 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9572 It is permitted to apply the check function in non-standard situations,
9573 such as to a call to a different subroutine or to a method call.
9575 By default, the function is
9576 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
9577 and the SV parameter is I<cv> itself. This implements standard
9578 prototype processing. It can be changed, for a particular subroutine,
9579 by L</cv_set_call_checker>.
9585 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
9588 PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
9589 callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
9591 *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
9592 *ckobj_p = callmg->mg_obj;
9594 *ckfun_p = Perl_ck_entersub_args_proto_or_list;
9600 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
9602 Sets the function that will be used to fix up a call to I<cv>.
9603 Specifically, the function is applied to an C<entersub> op tree for a
9604 subroutine call, not marked with C<&>, where the callee can be identified
9605 at compile time as I<cv>.
9607 The C-level function pointer is supplied in I<ckfun>, and an SV argument
9608 for it is supplied in I<ckobj>. The function is intended to be called
9611 entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
9613 In this call, I<entersubop> is a pointer to the C<entersub> op,
9614 which may be replaced by the check function, and I<namegv> is a GV
9615 supplying the name that should be used by the check function to refer
9616 to the callee of the C<entersub> op if it needs to emit any diagnostics.
9617 It is permitted to apply the check function in non-standard situations,
9618 such as to a call to a different subroutine or to a method call.
9620 The current setting for a particular CV can be retrieved by
9621 L</cv_get_call_checker>.
9627 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
9629 PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
9630 if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
9631 if (SvMAGICAL((SV*)cv))
9632 mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
9635 sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
9636 callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
9637 if (callmg->mg_flags & MGf_REFCOUNTED) {
9638 SvREFCNT_dec(callmg->mg_obj);
9639 callmg->mg_flags &= ~MGf_REFCOUNTED;
9641 callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
9642 callmg->mg_obj = ckobj;
9643 if (ckobj != (SV*)cv) {
9644 SvREFCNT_inc_simple_void_NN(ckobj);
9645 callmg->mg_flags |= MGf_REFCOUNTED;
9647 callmg->mg_flags |= MGf_COPY;
9652 Perl_ck_subr(pTHX_ OP *o)
9658 PERL_ARGS_ASSERT_CK_SUBR;
9660 aop = cUNOPx(o)->op_first;
9661 if (!aop->op_sibling)
9662 aop = cUNOPx(aop)->op_first;
9663 aop = aop->op_sibling;
9664 for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
9665 cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
9666 namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
9668 o->op_private &= ~1;
9669 o->op_private |= OPpENTERSUB_HASTARG;
9670 o->op_private |= (PL_hints & HINT_STRICT_REFS);
9671 if (PERLDB_SUB && PL_curstash != PL_debstash)
9672 o->op_private |= OPpENTERSUB_DB;
9673 if (cvop->op_type == OP_RV2CV) {
9674 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
9676 } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
9677 if (aop->op_type == OP_CONST)
9678 aop->op_private &= ~OPpCONST_STRICT;
9679 else if (aop->op_type == OP_LIST) {
9680 OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
9681 if (sib && sib->op_type == OP_CONST)
9682 sib->op_private &= ~OPpCONST_STRICT;
9687 return ck_entersub_args_list(o);
9689 Perl_call_checker ckfun;
9691 cv_get_call_checker(cv, &ckfun, &ckobj);
9692 return ckfun(aTHX_ o, namegv, ckobj);
9697 Perl_ck_svconst(pTHX_ OP *o)
9699 PERL_ARGS_ASSERT_CK_SVCONST;
9700 PERL_UNUSED_CONTEXT;
9701 SvREADONLY_on(cSVOPo->op_sv);
9706 Perl_ck_chdir(pTHX_ OP *o)
9708 PERL_ARGS_ASSERT_CK_CHDIR;
9709 if (o->op_flags & OPf_KIDS) {
9710 SVOP * const kid = (SVOP*)cUNOPo->op_first;
9712 if (kid && kid->op_type == OP_CONST &&
9713 (kid->op_private & OPpCONST_BARE))
9715 o->op_flags |= OPf_SPECIAL;
9716 kid->op_private &= ~OPpCONST_STRICT;
9723 Perl_ck_trunc(pTHX_ OP *o)
9725 PERL_ARGS_ASSERT_CK_TRUNC;
9727 if (o->op_flags & OPf_KIDS) {
9728 SVOP *kid = (SVOP*)cUNOPo->op_first;
9730 if (kid->op_type == OP_NULL)
9731 kid = (SVOP*)kid->op_sibling;
9732 if (kid && kid->op_type == OP_CONST &&
9733 (kid->op_private & OPpCONST_BARE))
9735 o->op_flags |= OPf_SPECIAL;
9736 kid->op_private &= ~OPpCONST_STRICT;
9743 Perl_ck_substr(pTHX_ OP *o)
9745 PERL_ARGS_ASSERT_CK_SUBSTR;
9748 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
9749 OP *kid = cLISTOPo->op_first;
9751 if (kid->op_type == OP_NULL)
9752 kid = kid->op_sibling;
9754 kid->op_flags |= OPf_MOD;
9761 Perl_ck_tell(pTHX_ OP *o)
9763 PERL_ARGS_ASSERT_CK_TELL;
9765 if (o->op_flags & OPf_KIDS) {
9766 OP *kid = cLISTOPo->op_first;
9767 if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
9768 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9774 Perl_ck_each(pTHX_ OP *o)
9777 OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
9778 const unsigned orig_type = o->op_type;
9779 const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
9780 : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
9781 const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
9782 : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
9784 PERL_ARGS_ASSERT_CK_EACH;
9787 switch (kid->op_type) {
9793 CHANGE_TYPE(o, array_type);
9796 if (kid->op_private == OPpCONST_BARE
9797 || !SvROK(cSVOPx_sv(kid))
9798 || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
9799 && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
9801 /* we let ck_fun handle it */
9804 CHANGE_TYPE(o, ref_type);
9808 /* if treating as a reference, defer additional checks to runtime */
9809 return o->op_type == ref_type ? o : ck_fun(o);
9813 Perl_ck_length(pTHX_ OP *o)
9815 PERL_ARGS_ASSERT_CK_LENGTH;
9819 if (ckWARN(WARN_SYNTAX)) {
9820 const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
9824 const bool hash = kid->op_type == OP_PADHV
9825 || kid->op_type == OP_RV2HV;
9826 switch (kid->op_type) {
9830 (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
9836 if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
9838 GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
9840 name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
9847 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9848 "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
9850 name, hash ? "keys " : "", name
9853 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9854 "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
9856 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9857 "length() used on @array (did you mean \"scalar(@array)\"?)");
9864 /* caller is supposed to assign the return to the
9865 container of the rep_op var */
9867 S_opt_scalarhv(pTHX_ OP *rep_op) {
9871 PERL_ARGS_ASSERT_OPT_SCALARHV;
9873 NewOp(1101, unop, 1, UNOP);
9874 unop->op_type = (OPCODE)OP_BOOLKEYS;
9875 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
9876 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
9877 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
9878 unop->op_first = rep_op;
9879 unop->op_next = rep_op->op_next;
9880 rep_op->op_next = (OP*)unop;
9881 rep_op->op_flags|=(OPf_REF | OPf_MOD);
9882 unop->op_sibling = rep_op->op_sibling;
9883 rep_op->op_sibling = NULL;
9884 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
9885 if (rep_op->op_type == OP_PADHV) {
9886 rep_op->op_flags &= ~OPf_WANT_SCALAR;
9887 rep_op->op_flags |= OPf_WANT_LIST;
9892 /* Check for in place reverse and sort assignments like "@a = reverse @a"
9893 and modify the optree to make them work inplace */
9896 S_inplace_aassign(pTHX_ OP *o) {
9898 OP *modop, *modop_pushmark;
9900 OP *oleft, *oleft_pushmark;
9902 PERL_ARGS_ASSERT_INPLACE_AASSIGN;
9904 assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
9906 assert(cUNOPo->op_first->op_type == OP_NULL);
9907 modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
9908 assert(modop_pushmark->op_type == OP_PUSHMARK);
9909 modop = modop_pushmark->op_sibling;
9911 if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
9914 /* no other operation except sort/reverse */
9915 if (modop->op_sibling)
9918 assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
9919 if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
9921 if (modop->op_flags & OPf_STACKED) {
9922 /* skip sort subroutine/block */
9923 assert(oright->op_type == OP_NULL);
9924 oright = oright->op_sibling;
9927 assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
9928 oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
9929 assert(oleft_pushmark->op_type == OP_PUSHMARK);
9930 oleft = oleft_pushmark->op_sibling;
9932 /* Check the lhs is an array */
9934 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
9935 || oleft->op_sibling
9936 || (oleft->op_private & OPpLVAL_INTRO)
9940 /* Only one thing on the rhs */
9941 if (oright->op_sibling)
9944 /* check the array is the same on both sides */
9945 if (oleft->op_type == OP_RV2AV) {
9946 if (oright->op_type != OP_RV2AV
9947 || !cUNOPx(oright)->op_first
9948 || cUNOPx(oright)->op_first->op_type != OP_GV
9949 || cUNOPx(oleft )->op_first->op_type != OP_GV
9950 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
9951 cGVOPx_gv(cUNOPx(oright)->op_first)
9955 else if (oright->op_type != OP_PADAV
9956 || oright->op_targ != oleft->op_targ
9960 /* This actually is an inplace assignment */
9962 modop->op_private |= OPpSORT_INPLACE;
9964 /* transfer MODishness etc from LHS arg to RHS arg */
9965 oright->op_flags = oleft->op_flags;
9967 /* remove the aassign op and the lhs */
9969 op_null(oleft_pushmark);
9970 if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
9971 op_null(cUNOPx(oleft)->op_first);
9975 #define MAX_DEFERRED 4
9978 if (defer_ix == (MAX_DEFERRED-1)) { \
9979 CALL_RPEEP(defer_queue[defer_base]); \
9980 defer_base = (defer_base + 1) % MAX_DEFERRED; \
9983 defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o;
9985 /* A peephole optimizer. We visit the ops in the order they're to execute.
9986 * See the comments at the top of this file for more details about when
9987 * peep() is called */
9990 Perl_rpeep(pTHX_ register OP *o)
9993 register OP* oldop = NULL;
9994 OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
9998 if (!o || o->op_opt)
10002 SAVEVPTR(PL_curcop);
10003 for (;; o = o->op_next) {
10004 if (o && o->op_opt)
10007 while (defer_ix >= 0)
10008 CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]);
10012 /* By default, this op has now been optimised. A couple of cases below
10013 clear this again. */
10016 switch (o->op_type) {
10018 PL_curcop = ((COP*)o); /* for warnings */
10021 PL_curcop = ((COP*)o); /* for warnings */
10023 /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
10024 to carry two labels. For now, take the easier option, and skip
10025 this optimisation if the first NEXTSTATE has a label. */
10026 if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
10027 OP *nextop = o->op_next;
10028 while (nextop && nextop->op_type == OP_NULL)
10029 nextop = nextop->op_next;
10031 if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
10032 COP *firstcop = (COP *)o;
10033 COP *secondcop = (COP *)nextop;
10034 /* We want the COP pointed to by o (and anything else) to
10035 become the next COP down the line. */
10036 cop_free(firstcop);
10038 firstcop->op_next = secondcop->op_next;
10040 /* Now steal all its pointers, and duplicate the other
10042 firstcop->cop_line = secondcop->cop_line;
10043 #ifdef USE_ITHREADS
10044 firstcop->cop_stashoff = secondcop->cop_stashoff;
10045 firstcop->cop_file = secondcop->cop_file;
10047 firstcop->cop_stash = secondcop->cop_stash;
10048 firstcop->cop_filegv = secondcop->cop_filegv;
10050 firstcop->cop_hints = secondcop->cop_hints;
10051 firstcop->cop_seq = secondcop->cop_seq;
10052 firstcop->cop_warnings = secondcop->cop_warnings;
10053 firstcop->cop_hints_hash = secondcop->cop_hints_hash;
10055 #ifdef USE_ITHREADS
10056 secondcop->cop_stashoff = NULL;
10057 secondcop->cop_file = NULL;
10059 secondcop->cop_stash = NULL;
10060 secondcop->cop_filegv = NULL;
10062 secondcop->cop_warnings = NULL;
10063 secondcop->cop_hints_hash = NULL;
10065 /* If we use op_null(), and hence leave an ex-COP, some
10066 warnings are misreported. For example, the compile-time
10067 error in 'use strict; no strict refs;' */
10068 secondcop->op_type = OP_NULL;
10069 secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
10075 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
10076 if (o->op_next->op_private & OPpTARGET_MY) {
10077 if (o->op_flags & OPf_STACKED) /* chained concats */
10078 break; /* ignore_optimization */
10080 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
10081 o->op_targ = o->op_next->op_targ;
10082 o->op_next->op_targ = 0;
10083 o->op_private |= OPpTARGET_MY;
10086 op_null(o->op_next);
10090 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
10091 break; /* Scalar stub must produce undef. List stub is noop */
10095 if (o->op_targ == OP_NEXTSTATE
10096 || o->op_targ == OP_DBSTATE)
10098 PL_curcop = ((COP*)o);
10100 /* XXX: We avoid setting op_seq here to prevent later calls
10101 to rpeep() from mistakenly concluding that optimisation
10102 has already occurred. This doesn't fix the real problem,
10103 though (See 20010220.007). AMS 20010719 */
10104 /* op_seq functionality is now replaced by op_opt */
10111 if (oldop && o->op_next) {
10112 oldop->op_next = o->op_next;
10120 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
10121 OP* const pop = (o->op_type == OP_PADAV) ?
10122 o->op_next : o->op_next->op_next;
10124 if (pop && pop->op_type == OP_CONST &&
10125 ((PL_op = pop->op_next)) &&
10126 pop->op_next->op_type == OP_AELEM &&
10127 !(pop->op_next->op_private &
10128 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
10129 (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0)
10132 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
10133 no_bareword_allowed(pop);
10134 if (o->op_type == OP_GV)
10135 op_null(o->op_next);
10136 op_null(pop->op_next);
10138 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
10139 o->op_next = pop->op_next->op_next;
10140 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
10141 o->op_private = (U8)i;
10142 if (o->op_type == OP_GV) {
10145 o->op_type = OP_AELEMFAST;
10148 o->op_type = OP_AELEMFAST_LEX;
10153 if (o->op_next->op_type == OP_RV2SV) {
10154 if (!(o->op_next->op_private & OPpDEREF)) {
10155 op_null(o->op_next);
10156 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
10158 o->op_next = o->op_next->op_next;
10159 o->op_type = OP_GVSV;
10160 o->op_ppaddr = PL_ppaddr[OP_GVSV];
10163 else if (o->op_next->op_type == OP_READLINE
10164 && o->op_next->op_next->op_type == OP_CONCAT
10165 && (o->op_next->op_next->op_flags & OPf_STACKED))
10167 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
10168 o->op_type = OP_RCATLINE;
10169 o->op_flags |= OPf_STACKED;
10170 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
10171 op_null(o->op_next->op_next);
10172 op_null(o->op_next);
10182 fop = cUNOP->op_first;
10190 fop = cLOGOP->op_first;
10191 sop = fop->op_sibling;
10192 while (cLOGOP->op_other->op_type == OP_NULL)
10193 cLOGOP->op_other = cLOGOP->op_other->op_next;
10194 while (o->op_next && ( o->op_type == o->op_next->op_type
10195 || o->op_next->op_type == OP_NULL))
10196 o->op_next = o->op_next->op_next;
10197 DEFER(cLOGOP->op_other);
10201 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10203 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
10208 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
10209 while (nop && nop->op_next) {
10210 switch (nop->op_next->op_type) {
10215 lop = nop = nop->op_next;
10218 nop = nop->op_next;
10226 if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
10227 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
10228 cLOGOP->op_first = opt_scalarhv(fop);
10229 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
10230 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
10246 while (cLOGOP->op_other->op_type == OP_NULL)
10247 cLOGOP->op_other = cLOGOP->op_other->op_next;
10248 DEFER(cLOGOP->op_other);
10253 while (cLOOP->op_redoop->op_type == OP_NULL)
10254 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
10255 while (cLOOP->op_nextop->op_type == OP_NULL)
10256 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
10257 while (cLOOP->op_lastop->op_type == OP_NULL)
10258 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
10259 /* a while(1) loop doesn't have an op_next that escapes the
10260 * loop, so we have to explicitly follow the op_lastop to
10261 * process the rest of the code */
10262 DEFER(cLOOP->op_lastop);
10266 assert(!(cPMOP->op_pmflags & PMf_ONCE));
10267 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
10268 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
10269 cPMOP->op_pmstashstartu.op_pmreplstart
10270 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
10271 DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
10275 /* check that RHS of sort is a single plain array */
10276 OP *oright = cUNOPo->op_first;
10277 if (!oright || oright->op_type != OP_PUSHMARK)
10280 if (o->op_private & OPpSORT_INPLACE)
10283 /* reverse sort ... can be optimised. */
10284 if (!cUNOPo->op_sibling) {
10285 /* Nothing follows us on the list. */
10286 OP * const reverse = o->op_next;
10288 if (reverse->op_type == OP_REVERSE &&
10289 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
10290 OP * const pushmark = cUNOPx(reverse)->op_first;
10291 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
10292 && (cUNOPx(pushmark)->op_sibling == o)) {
10293 /* reverse -> pushmark -> sort */
10294 o->op_private |= OPpSORT_REVERSE;
10296 pushmark->op_next = oright->op_next;
10306 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
10308 LISTOP *enter, *exlist;
10310 if (o->op_private & OPpSORT_INPLACE)
10313 enter = (LISTOP *) o->op_next;
10316 if (enter->op_type == OP_NULL) {
10317 enter = (LISTOP *) enter->op_next;
10321 /* for $a (...) will have OP_GV then OP_RV2GV here.
10322 for (...) just has an OP_GV. */
10323 if (enter->op_type == OP_GV) {
10324 gvop = (OP *) enter;
10325 enter = (LISTOP *) enter->op_next;
10328 if (enter->op_type == OP_RV2GV) {
10329 enter = (LISTOP *) enter->op_next;
10335 if (enter->op_type != OP_ENTERITER)
10338 iter = enter->op_next;
10339 if (!iter || iter->op_type != OP_ITER)
10342 expushmark = enter->op_first;
10343 if (!expushmark || expushmark->op_type != OP_NULL
10344 || expushmark->op_targ != OP_PUSHMARK)
10347 exlist = (LISTOP *) expushmark->op_sibling;
10348 if (!exlist || exlist->op_type != OP_NULL
10349 || exlist->op_targ != OP_LIST)
10352 if (exlist->op_last != o) {
10353 /* Mmm. Was expecting to point back to this op. */
10356 theirmark = exlist->op_first;
10357 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
10360 if (theirmark->op_sibling != o) {
10361 /* There's something between the mark and the reverse, eg
10362 for (1, reverse (...))
10367 ourmark = ((LISTOP *)o)->op_first;
10368 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
10371 ourlast = ((LISTOP *)o)->op_last;
10372 if (!ourlast || ourlast->op_next != o)
10375 rv2av = ourmark->op_sibling;
10376 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
10377 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
10378 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
10379 /* We're just reversing a single array. */
10380 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
10381 enter->op_flags |= OPf_STACKED;
10384 /* We don't have control over who points to theirmark, so sacrifice
10386 theirmark->op_next = ourmark->op_next;
10387 theirmark->op_flags = ourmark->op_flags;
10388 ourlast->op_next = gvop ? gvop : (OP *) enter;
10391 enter->op_private |= OPpITER_REVERSED;
10392 iter->op_private |= OPpITER_REVERSED;
10399 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
10400 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
10405 if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
10407 if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef;
10409 sv = newRV((SV *)PL_compcv);
10413 o->op_type = OP_CONST;
10414 o->op_ppaddr = PL_ppaddr[OP_CONST];
10415 o->op_flags |= OPf_SPECIAL;
10416 cSVOPo->op_sv = sv;
10421 if (OP_GIMME(o,0) == G_VOID) {
10422 OP *right = cBINOP->op_first;
10424 OP *left = right->op_sibling;
10425 if (left->op_type == OP_SUBSTR
10426 && (left->op_private & 7) < 4) {
10428 cBINOP->op_first = left;
10429 right->op_sibling =
10430 cBINOPx(left)->op_first->op_sibling;
10431 cBINOPx(left)->op_first->op_sibling = right;
10432 left->op_private |= OPpSUBSTR_REPL_FIRST;
10434 (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
10441 Perl_cpeep_t cpeep =
10442 XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
10444 cpeep(aTHX_ o, oldop);
10455 Perl_peep(pTHX_ register OP *o)
10461 =head1 Custom Operators
10463 =for apidoc Ao||custom_op_xop
10464 Return the XOP structure for a given custom op. This function should be
10465 considered internal to OP_NAME and the other access macros: use them instead.
10471 Perl_custom_op_xop(pTHX_ const OP *o)
10477 static const XOP xop_null = { 0, 0, 0, 0, 0 };
10479 PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
10480 assert(o->op_type == OP_CUSTOM);
10482 /* This is wrong. It assumes a function pointer can be cast to IV,
10483 * which isn't guaranteed, but this is what the old custom OP code
10484 * did. In principle it should be safer to Copy the bytes of the
10485 * pointer into a PV: since the new interface is hidden behind
10486 * functions, this can be changed later if necessary. */
10487 /* Change custom_op_xop if this ever happens */
10488 keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
10491 he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
10493 /* assume noone will have just registered a desc */
10494 if (!he && PL_custom_op_names &&
10495 (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
10500 /* XXX does all this need to be shared mem? */
10501 Newxz(xop, 1, XOP);
10502 pv = SvPV(HeVAL(he), l);
10503 XopENTRY_set(xop, xop_name, savepvn(pv, l));
10504 if (PL_custom_op_descs &&
10505 (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
10507 pv = SvPV(HeVAL(he), l);
10508 XopENTRY_set(xop, xop_desc, savepvn(pv, l));
10510 Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
10514 if (!he) return &xop_null;
10516 xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
10521 =for apidoc Ao||custom_op_register
10522 Register a custom op. See L<perlguts/"Custom Operators">.
10528 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
10532 PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
10534 /* see the comment in custom_op_xop */
10535 keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
10537 if (!PL_custom_ops)
10538 PL_custom_ops = newHV();
10540 if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
10541 Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
10545 =head1 Functions in file op.c
10547 =for apidoc core_prototype
10548 This function assigns the prototype of the named core function to C<sv>, or
10549 to a new mortal SV if C<sv> is NULL. It returns the modified C<sv>, or
10550 NULL if the core function has no prototype. C<code> is a code as returned
10551 by C<keyword()>. It must not be equal to 0 or -KEY_CORE.
10557 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
10560 int i = 0, n = 0, seen_question = 0, defgv = 0;
10562 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
10563 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
10564 bool nullret = FALSE;
10566 PERL_ARGS_ASSERT_CORE_PROTOTYPE;
10568 assert (code && code != -KEY_CORE);
10570 if (!sv) sv = sv_newmortal();
10572 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
10574 switch (code < 0 ? -code : code) {
10575 case KEY_and : case KEY_chop: case KEY_chomp:
10576 case KEY_cmp : case KEY_defined: case KEY_delete: case KEY_exec :
10577 case KEY_exists: case KEY_eq : case KEY_ge : case KEY_goto :
10578 case KEY_grep : case KEY_gt : case KEY_last : case KEY_le :
10579 case KEY_lt : case KEY_map : case KEY_ne : case KEY_next :
10580 case KEY_or : case KEY_print : case KEY_printf: case KEY_qr :
10581 case KEY_redo : case KEY_require: case KEY_return: case KEY_say :
10582 case KEY_select: case KEY_sort : case KEY_split : case KEY_system:
10583 case KEY_x : case KEY_xor :
10584 if (!opnum) return NULL; nullret = TRUE; goto findopnum;
10585 case KEY_glob: retsetpvs("_;", OP_GLOB);
10586 case KEY_keys: retsetpvs("+", OP_KEYS);
10587 case KEY_values: retsetpvs("+", OP_VALUES);
10588 case KEY_each: retsetpvs("+", OP_EACH);
10589 case KEY_push: retsetpvs("+@", OP_PUSH);
10590 case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
10591 case KEY_pop: retsetpvs(";+", OP_POP);
10592 case KEY_shift: retsetpvs(";+", OP_SHIFT);
10593 case KEY_pos: retsetpvs(";\\[$*]", OP_POS);
10595 retsetpvs("+;$$@", OP_SPLICE);
10596 case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
10598 case KEY_evalbytes:
10599 name = "entereval"; break;
10607 while (i < MAXO) { /* The slow way. */
10608 if (strEQ(name, PL_op_name[i])
10609 || strEQ(name, PL_op_desc[i]))
10611 if (nullret) { assert(opnum); *opnum = i; return NULL; }
10618 defgv = PL_opargs[i] & OA_DEFGV;
10619 oa = PL_opargs[i] >> OASHIFT;
10621 if (oa & OA_OPTIONAL && !seen_question && (
10622 !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
10627 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
10628 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
10629 /* But globs are already references (kinda) */
10630 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
10634 if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
10635 && !scalar_mod_type(NULL, i)) {
10640 if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
10644 else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
10645 if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
10646 str[n-1] = '_'; defgv = 0;
10650 if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
10652 sv_setpvn(sv, str, n - 1);
10653 if (opnum) *opnum = i;
10658 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
10661 OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
10664 PERL_ARGS_ASSERT_CORESUB_OP;
10668 return op_append_elem(OP_LINESEQ,
10671 newSVOP(OP_CONST, 0, newSViv(-code % 3)),
10675 case OP_SELECT: /* which represents OP_SSELECT as well */
10680 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
10681 newSVOP(OP_CONST, 0, newSVuv(1))
10683 coresub_op(newSVuv((UV)OP_SSELECT), 0,
10685 coresub_op(coreargssv, 0, OP_SELECT)
10689 switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10691 return op_append_elem(
10694 opnum == OP_WANTARRAY || opnum == OP_RUNCV
10695 ? OPpOFFBYONE << 8 : 0)
10697 case OA_BASEOP_OR_UNOP:
10698 if (opnum == OP_ENTEREVAL) {
10699 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
10700 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
10702 else o = newUNOP(opnum,0,argop);
10703 if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
10706 if (is_handle_constructor(o, 1))
10707 argop->op_private |= OPpCOREARGS_DEREF1;
10708 if (scalar_mod_type(NULL, opnum))
10709 argop->op_private |= OPpCOREARGS_SCALARMOD;
10713 o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
10714 if (is_handle_constructor(o, 2))
10715 argop->op_private |= OPpCOREARGS_DEREF2;
10716 if (opnum == OP_SUBSTR) {
10717 o->op_private |= OPpMAYBE_LVSUB;
10726 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
10727 SV * const *new_const_svp)
10729 const char *hvname;
10730 bool is_const = !!CvCONST(old_cv);
10731 SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
10733 PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
10735 if (is_const && new_const_svp && old_const_sv == *new_const_svp)
10737 /* They are 2 constant subroutines generated from
10738 the same constant. This probably means that
10739 they are really the "same" proxy subroutine
10740 instantiated in 2 places. Most likely this is
10741 when a constant is exported twice. Don't warn.
10744 (ckWARN(WARN_REDEFINE)
10746 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
10747 && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
10748 && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
10749 strEQ(hvname, "autouse"))
10753 && ckWARN_d(WARN_REDEFINE)
10754 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
10757 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10759 ? "Constant subroutine %"SVf" redefined"
10760 : "Subroutine %"SVf" redefined",
10765 =head1 Hook manipulation
10767 These functions provide convenient and thread-safe means of manipulating
10774 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
10776 Puts a C function into the chain of check functions for a specified op
10777 type. This is the preferred way to manipulate the L</PL_check> array.
10778 I<opcode> specifies which type of op is to be affected. I<new_checker>
10779 is a pointer to the C function that is to be added to that opcode's
10780 check chain, and I<old_checker_p> points to the storage location where a
10781 pointer to the next function in the chain will be stored. The value of
10782 I<new_pointer> is written into the L</PL_check> array, while the value
10783 previously stored there is written to I<*old_checker_p>.
10785 L</PL_check> is global to an entire process, and a module wishing to
10786 hook op checking may find itself invoked more than once per process,
10787 typically in different threads. To handle that situation, this function
10788 is idempotent. The location I<*old_checker_p> must initially (once
10789 per process) contain a null pointer. A C variable of static duration
10790 (declared at file scope, typically also marked C<static> to give
10791 it internal linkage) will be implicitly initialised appropriately,
10792 if it does not have an explicit initialiser. This function will only
10793 actually modify the check chain if it finds I<*old_checker_p> to be null.
10794 This function is also thread safe on the small scale. It uses appropriate
10795 locking to avoid race conditions in accessing L</PL_check>.
10797 When this function is called, the function referenced by I<new_checker>
10798 must be ready to be called, except for I<*old_checker_p> being unfilled.
10799 In a threading situation, I<new_checker> may be called immediately,
10800 even before this function has returned. I<*old_checker_p> will always
10801 be appropriately set before I<new_checker> is called. If I<new_checker>
10802 decides not to do anything special with an op that it is given (which
10803 is the usual case for most uses of op check hooking), it must chain the
10804 check function referenced by I<*old_checker_p>.
10806 If you want to influence compilation of calls to a specific subroutine,
10807 then use L</cv_set_call_checker> rather than hooking checking of all
10814 Perl_wrap_op_checker(pTHX_ Optype opcode,
10815 Perl_check_t new_checker, Perl_check_t *old_checker_p)
10819 PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
10820 if (*old_checker_p) return;
10821 OP_CHECK_MUTEX_LOCK;
10822 if (!*old_checker_p) {
10823 *old_checker_p = PL_check[opcode];
10824 PL_check[opcode] = new_checker;
10826 OP_CHECK_MUTEX_UNLOCK;
10831 /* Efficient sub that returns a constant scalar value. */
10833 const_sv_xsub(pTHX_ CV* cv)
10837 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
10841 /* diag_listed_as: SKIPME */
10842 Perl_croak(aTHX_ "usage: %s::%s()",
10843 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
10856 * c-indentation-style: bsd
10857 * c-basic-offset: 4
10858 * indent-tabs-mode: nil
10861 * ex: set ts=8 sts=4 sw=4 et: