185009909Smillert /* pad.c
285009909Smillert *
343003dfeSmillert * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
443003dfeSmillert * by Larry Wall and others
585009909Smillert *
685009909Smillert * You may distribute under the terms of either the GNU General Public
785009909Smillert * License or the Artistic License, as specified in the README file.
843003dfeSmillert */
943003dfeSmillert
1043003dfeSmillert /*
1143003dfeSmillert * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
1285009909Smillert * might say, among those queer Bucklanders, being brought up anyhow in
1385009909Smillert * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
1443003dfeSmillert * never had fewer than a couple of hundred relations in the place.
1543003dfeSmillert * Mr. Bilbo never did a kinder deed than when he brought the lad back
1643003dfeSmillert * to live among decent folk.' --the Gaffer
1743003dfeSmillert *
1843003dfeSmillert * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
1985009909Smillert */
2085009909Smillert
2185009909Smillert /*
22eac174f2Safresh1 =for apidoc_section $pad
2385009909Smillert
24898184e3Ssthen =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
255b2d2359Smillert
2691f110e0Safresh1 CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
27898184e3Ssthen scratchpad, which stores lexical variables and opcode temporary and
28898184e3Ssthen per-thread values.
2985009909Smillert
3091f110e0Safresh1 For these purposes "formats" are a kind-of CV; eval""s are too (except they're
3185009909Smillert not callable at will and are always thrown away after the eval"" is done
32850e2753Smillert executing). Require'd files are simply evals without any outer lexical
33850e2753Smillert scope.
3485009909Smillert
35b8851fccSafresh1 XSUBs do not have a C<CvPADLIST>. C<dXSTARG> fetches values from C<PL_curpad>,
3685009909Smillert but that is really the callers pad (a slot of which is allocated by
37b8851fccSafresh1 every entersub). Do not get or set C<CvPADLIST> if a CV is an XSUB (as
38b8851fccSafresh1 determined by C<CvISXSUB()>), C<CvPADLIST> slot is reused for a different
39b8851fccSafresh1 internal purpose in XSUBs.
4085009909Smillert
4191f110e0Safresh1 The PADLIST has a C array where pads are stored.
4285009909Smillert
43b8851fccSafresh1 The 0th entry of the PADLIST is a PADNAMELIST
44b8851fccSafresh1 which represents the "names" or rather
4591f110e0Safresh1 the "static type information" for lexicals. The individual elements of a
46b8851fccSafresh1 PADNAMELIST are PADNAMEs. Future
4791f110e0Safresh1 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
4891f110e0Safresh1 array, so don't rely on it. See L</PadlistNAMES>.
4985009909Smillert
5091f110e0Safresh1 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
5191f110e0Safresh1 at that depth of recursion into the CV. The 0th slot of a frame AV is an
52b8851fccSafresh1 AV which is C<@_>. Other entries are storage for variables and op targets.
5385009909Smillert
5491f110e0Safresh1 Iterating over the PADNAMELIST iterates over all possible pad
55b8851fccSafresh1 items. Pad slots for targets (C<SVs_PADTMP>)
56b8851fccSafresh1 and GVs end up having &PL_padname_undef "names", while slots for constants
57b8851fccSafresh1 have C<&PL_padname_const> "names" (see C<L</pad_alloc>>). That
58b8851fccSafresh1 C<&PL_padname_undef>
59b8851fccSafresh1 and C<&PL_padname_const> are used is an implementation detail subject to
60b8851fccSafresh1 change. To test for them, use C<!PadnamePV(name)> and
61b8851fccSafresh1 S<C<PadnamePV(name) && !PadnameLEN(name)>>, respectively.
6285009909Smillert
63b8851fccSafresh1 Only C<my>/C<our> variable slots get valid names.
6485009909Smillert The rest are op targets/GVs/constants which are statically allocated
6585009909Smillert or resolved at compile time. These don't have names by which they
6691f110e0Safresh1 can be looked up from Perl code at run time through eval"" the way
67b8851fccSafresh1 C<my>/C<our> variables can be. Since they can't be looked up by "name"
6885009909Smillert but only by their index allocated at compile time (which is usually
699f11ffb7Safresh1 in C<< PL_op->op_targ >>), wasting a name SV for them doesn't make sense.
7085009909Smillert
71b8851fccSafresh1 The pad names in the PADNAMELIST have their PV holding the name of
72b8851fccSafresh1 the variable. The C<COP_SEQ_RANGE_LOW> and C<_HIGH> fields form a range
73b8851fccSafresh1 (low+1..high inclusive) of cop_seq numbers for which the name is
74b8851fccSafresh1 valid. During compilation, these fields may hold the special value
75898184e3Ssthen PERL_PADSEQ_INTRO to indicate various stages:
76898184e3Ssthen
77898184e3Ssthen COP_SEQ_RANGE_LOW _HIGH
78898184e3Ssthen ----------------- -----
79b8851fccSafresh1 PERL_PADSEQ_INTRO 0 variable not yet introduced:
80b8851fccSafresh1 { my ($x
81b8851fccSafresh1 valid-seq# PERL_PADSEQ_INTRO variable in scope:
829f11ffb7Safresh1 { my ($x);
83b8851fccSafresh1 valid-seq# valid-seq# compilation of scope complete:
849f11ffb7Safresh1 { my ($x); .... }
859f11ffb7Safresh1
869f11ffb7Safresh1 When a lexical var hasn't yet been introduced, it already exists from the
879f11ffb7Safresh1 perspective of duplicate declarations, but not for variable lookups, e.g.
889f11ffb7Safresh1
899f11ffb7Safresh1 my ($x, $x); # '"my" variable $x masks earlier declaration'
909f11ffb7Safresh1 my $x = $x; # equal to my $x = $::x;
91898184e3Ssthen
92b8851fccSafresh1 For typed lexicals C<PadnameTYPE> points at the type stash. For C<our>
93b8851fccSafresh1 lexicals, C<PadnameOURSTASH> points at the stash of the associated global (so
94b8851fccSafresh1 that duplicate C<our> declarations in the same package can be detected).
95b8851fccSafresh1 C<PadnameGEN> is sometimes used to store the generation number during
96b8851fccSafresh1 compilation.
9785009909Smillert
98b8851fccSafresh1 If C<PadnameOUTER> is set on the pad name, then that slot in the frame AV
99b8851fccSafresh1 is a REFCNT'ed reference to a lexical from "outside". Such entries
100b8851fccSafresh1 are sometimes referred to as 'fake'. In this case, the name does not
101b8851fccSafresh1 use 'low' and 'high' to store a cop_seq range, since it is in scope
102b8851fccSafresh1 throughout. Instead 'high' stores some flags containing info about
103850e2753Smillert the real lexical (is it declared in an anon, and is it capable of being
104b8851fccSafresh1 instantiated multiple times?), and for fake ANONs, 'low' contains the index
105850e2753Smillert within the parent's pad where the lexical's value is stored, to make
106850e2753Smillert cloning quicker.
10785009909Smillert
108b8851fccSafresh1 If the 'name' is C<&> the corresponding entry in the PAD
10985009909Smillert is a CV representing a possible closure.
11085009909Smillert
111850e2753Smillert Note that formats are treated as anon subs, and are cloned each time
112850e2753Smillert write is called (if necessary).
113850e2753Smillert
114b8851fccSafresh1 The flag C<SVs_PADSTALE> is cleared on lexicals each time the C<my()> is executed,
11591f110e0Safresh1 and set on scope exit. This allows the
116b8851fccSafresh1 C<"Variable $x is not available"> warning
11743890927Smillert to be generated in evals, such as
11843890927Smillert
11943890927Smillert { my $x = 1; sub f { eval '$x'} } f();
12043890927Smillert
121b8851fccSafresh1 For state vars, C<SVs_PADSTALE> is overloaded to mean 'not yet initialised',
122b8851fccSafresh1 but this internal state is stored in a separate pad entry.
12343003dfeSmillert
12456d68f1eSafresh1 =for apidoc Amnh||SVs_PADSTALE
12556d68f1eSafresh1
12656d68f1eSafresh1 =for apidoc AmnxU|PADNAMELIST *|PL_comppad_name
127898184e3Ssthen
128898184e3Ssthen During compilation, this points to the array containing the names part
129898184e3Ssthen of the pad for the currently-compiling code.
130898184e3Ssthen
13156d68f1eSafresh1 =for apidoc AmnxU|PAD *|PL_comppad
132898184e3Ssthen
133898184e3Ssthen During compilation, this points to the array containing the values
134898184e3Ssthen part of the pad for the currently-compiling code. (At runtime a CV may
135898184e3Ssthen have many such value arrays; at compile time just one is constructed.)
136898184e3Ssthen At runtime, this points to the array containing the currently-relevant
137898184e3Ssthen values for the pad for the currently-executing code.
138898184e3Ssthen
13956d68f1eSafresh1 =for apidoc AmnxU|SV **|PL_curpad
140898184e3Ssthen
141898184e3Ssthen Points directly to the body of the L</PL_comppad> array.
1429f11ffb7Safresh1 (I.e., this is C<PadARRAY(PL_comppad)>.)
143898184e3Ssthen
14485009909Smillert =cut
14585009909Smillert */
14685009909Smillert
14785009909Smillert
14885009909Smillert #include "EXTERN.h"
14985009909Smillert #define PERL_IN_PAD_C
15085009909Smillert #include "perl.h"
151850e2753Smillert #include "keywords.h"
15285009909Smillert
153850e2753Smillert #define COP_SEQ_RANGE_LOW_set(sv,val) \
154b8851fccSafresh1 STMT_START { (sv)->xpadn_low = (val); } STMT_END
155850e2753Smillert #define COP_SEQ_RANGE_HIGH_set(sv,val) \
156b8851fccSafresh1 STMT_START { (sv)->xpadn_high = (val); } STMT_END
15785009909Smillert
158b8851fccSafresh1 #define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set
159b8851fccSafresh1 #define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set
16085009909Smillert
161b8851fccSafresh1 #ifdef DEBUGGING
162b8851fccSafresh1 void
Perl_set_padlist(CV * cv,PADLIST * padlist)163b8851fccSafresh1 Perl_set_padlist(CV * cv, PADLIST *padlist){
164b8851fccSafresh1 PERL_ARGS_ASSERT_SET_PADLIST;
165b8851fccSafresh1 # if PTRSIZE == 8
166b8851fccSafresh1 assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
167b8851fccSafresh1 # elif PTRSIZE == 4
168b8851fccSafresh1 assert((Size_t)padlist != 0xEFEFEFEF);
169b8851fccSafresh1 # else
170b8851fccSafresh1 # error unknown pointer size
171b8851fccSafresh1 # endif
172b8851fccSafresh1 assert(!CvISXSUB(cv));
173b8851fccSafresh1 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
174850e2753Smillert }
175850e2753Smillert #endif
17685009909Smillert
17785009909Smillert /*
17856d68f1eSafresh1 =for apidoc pad_new
179898184e3Ssthen
180898184e3Ssthen Create a new padlist, updating the global variables for the
181898184e3Ssthen currently-compiling padlist to point to the new padlist. The following
182898184e3Ssthen flags can be OR'ed together:
18385009909Smillert
18485009909Smillert padnew_CLONE this pad is for a cloned CV
185898184e3Ssthen padnew_SAVE save old globals on the save stack
18685009909Smillert padnew_SAVESUB also save extra stuff for start of sub
18785009909Smillert
18885009909Smillert =cut
18985009909Smillert */
19085009909Smillert
19185009909Smillert PADLIST *
Perl_pad_new(pTHX_ int flags)19285009909Smillert Perl_pad_new(pTHX_ int flags)
19385009909Smillert {
19491f110e0Safresh1 PADLIST *padlist;
195b8851fccSafresh1 PADNAMELIST *padname;
196b8851fccSafresh1 PAD *pad;
19791f110e0Safresh1 PAD **ary;
19885009909Smillert
19985009909Smillert ASSERT_CURPAD_LEGAL("pad_new");
20085009909Smillert
20185009909Smillert /* save existing state, ... */
20285009909Smillert
20385009909Smillert if (flags & padnew_SAVE) {
20485009909Smillert SAVECOMPPAD();
20585009909Smillert if (! (flags & padnew_CLONE)) {
20691f110e0Safresh1 SAVESPTR(PL_comppad_name);
207eac174f2Safresh1 SAVESTRLEN(PL_padix);
208eac174f2Safresh1 SAVESTRLEN(PL_constpadix);
209eac174f2Safresh1 SAVESTRLEN(PL_comppad_name_fill);
210eac174f2Safresh1 SAVESTRLEN(PL_min_intro_pending);
211eac174f2Safresh1 SAVESTRLEN(PL_max_intro_pending);
212850e2753Smillert SAVEBOOL(PL_cv_has_eval);
21385009909Smillert if (flags & padnew_SAVESUB) {
214b39c5158Smillert SAVEBOOL(PL_pad_reset_pending);
21585009909Smillert }
21685009909Smillert }
21785009909Smillert }
21885009909Smillert
21985009909Smillert /* ... create new pad ... */
22085009909Smillert
22191f110e0Safresh1 Newxz(padlist, 1, PADLIST);
22285009909Smillert pad = newAV();
223eac174f2Safresh1 Newxz(AvALLOC(pad), 4, SV *); /* Originally sized to
224eac174f2Safresh1 match av_extend default */
225eac174f2Safresh1 AvARRAY(pad) = AvALLOC(pad);
226eac174f2Safresh1 AvMAX(pad) = 3;
227eac174f2Safresh1 AvFILLp(pad) = 0; /* @_ or NULL, set below. */
22885009909Smillert
22985009909Smillert if (flags & padnew_CLONE) {
23052bd00bfSmillert AV * const a0 = newAV(); /* will be @_ */
231eac174f2Safresh1 AvARRAY(pad)[0] = MUTABLE_SV(a0);
232850e2753Smillert AvREIFY_only(a0);
23391f110e0Safresh1
234b8851fccSafresh1 PadnamelistREFCNT(padname = PL_comppad_name)++;
23585009909Smillert }
23685009909Smillert else {
237b8851fccSafresh1 padlist->xpadl_id = PL_padlist_generation++;
238eac174f2Safresh1 /* Set implicitly through use of Newxz above
239eac174f2Safresh1 AvARRAY(pad)[0] = NULL;
240eac174f2Safresh1 */
241b8851fccSafresh1 padname = newPADNAMELIST(0);
242b8851fccSafresh1 padnamelist_store(padname, 0, &PL_padname_undef);
24385009909Smillert }
24485009909Smillert
245898184e3Ssthen /* Most subroutines never recurse, hence only need 2 entries in the padlist
246898184e3Ssthen array - names, and depth=1. The default for av_store() is to allocate
247898184e3Ssthen 0..3, and even an explicit call to av_extend() with <3 will be rounded
248898184e3Ssthen up, so we inline the allocation of the array here. */
24991f110e0Safresh1 Newx(ary, 2, PAD *);
25091f110e0Safresh1 PadlistMAX(padlist) = 1;
25191f110e0Safresh1 PadlistARRAY(padlist) = ary;
252b8851fccSafresh1 ary[0] = (PAD *)padname;
25391f110e0Safresh1 ary[1] = pad;
25485009909Smillert
25585009909Smillert /* ... then update state variables */
25685009909Smillert
257898184e3Ssthen PL_comppad = pad;
258898184e3Ssthen PL_curpad = AvARRAY(pad);
25985009909Smillert
26085009909Smillert if (! (flags & padnew_CLONE)) {
26191f110e0Safresh1 PL_comppad_name = padname;
26285009909Smillert PL_comppad_name_fill = 0;
26385009909Smillert PL_min_intro_pending = 0;
26485009909Smillert PL_padix = 0;
265b8851fccSafresh1 PL_constpadix = 0;
266850e2753Smillert PL_cv_has_eval = 0;
26785009909Smillert }
26885009909Smillert
26985009909Smillert DEBUG_X(PerlIO_printf(Perl_debug_log,
270850e2753Smillert "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf
27185009909Smillert " name=0x%" UVxf " flags=0x%" UVxf "\n",
272850e2753Smillert PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
27385009909Smillert PTR2UV(padname), (UV)flags
27485009909Smillert )
27585009909Smillert );
27685009909Smillert
27785009909Smillert return (PADLIST*)padlist;
27885009909Smillert }
27985009909Smillert
280898184e3Ssthen
28185009909Smillert /*
282eac174f2Safresh1 =for apidoc_section $embedding
28385009909Smillert
284898184e3Ssthen =for apidoc cv_undef
28585009909Smillert
286898184e3Ssthen Clear out all the active components of a CV. This can happen either
287898184e3Ssthen by an explicit C<undef &foo>, or by the reference count going to zero.
288b8851fccSafresh1 In the former case, we keep the C<CvOUTSIDE> pointer, so that any anonymous
289898184e3Ssthen children can still follow the full lexical scope chain.
29085009909Smillert
29185009909Smillert =cut
29285009909Smillert */
29385009909Smillert
29485009909Smillert void
Perl_cv_undef(pTHX_ CV * cv)295898184e3Ssthen Perl_cv_undef(pTHX_ CV *cv)
29685009909Smillert {
297898184e3Ssthen PERL_ARGS_ASSERT_CV_UNDEF;
298b8851fccSafresh1 cv_undef_flags(cv, 0);
299b8851fccSafresh1 }
300b8851fccSafresh1
301b8851fccSafresh1 void
Perl_cv_undef_flags(pTHX_ CV * cv,U32 flags)302b8851fccSafresh1 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
303b8851fccSafresh1 {
304b8851fccSafresh1 CV cvbody;/*CV body will never be realloced inside this func,
305*e0680481Safresh1 so don't read it more than once, use fake CV so existing macros
306b8851fccSafresh1 will work, the indirection and CV head struct optimized away*/
307b8851fccSafresh1 SvANY(&cvbody) = SvANY(cv);
308b8851fccSafresh1
309b8851fccSafresh1 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
31043003dfeSmillert
311898184e3Ssthen DEBUG_X(PerlIO_printf(Perl_debug_log,
312898184e3Ssthen "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n",
313898184e3Ssthen PTR2UV(cv), PTR2UV(PL_comppad))
314898184e3Ssthen );
315898184e3Ssthen
316b8851fccSafresh1 if (CvFILE(&cvbody)) {
317b8851fccSafresh1 char * file = CvFILE(&cvbody);
318b8851fccSafresh1 CvFILE(&cvbody) = NULL;
319b8851fccSafresh1 if(CvDYNFILE(&cvbody))
320b8851fccSafresh1 Safefree(file);
321898184e3Ssthen }
322898184e3Ssthen
323b8851fccSafresh1 /* CvSLABBED_off(&cvbody); *//* turned off below */
324b8851fccSafresh1 /* release the sub's body */
325b8851fccSafresh1 if (!CvISXSUB(&cvbody)) {
326b8851fccSafresh1 if(CvROOT(&cvbody)) {
327b8851fccSafresh1 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
328b8851fccSafresh1 if (CvDEPTHunsafe(&cvbody)) {
329b8851fccSafresh1 assert(SvTYPE(cv) == SVt_PVCV);
330b8851fccSafresh1 Perl_croak_nocontext("Can't undef active subroutine");
331b8851fccSafresh1 }
332898184e3Ssthen ENTER;
333898184e3Ssthen
334898184e3Ssthen PAD_SAVE_SETNULLPAD();
335898184e3Ssthen
336b8851fccSafresh1 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
337b8851fccSafresh1 op_free(CvROOT(&cvbody));
338b8851fccSafresh1 CvROOT(&cvbody) = NULL;
339b8851fccSafresh1 CvSTART(&cvbody) = NULL;
340898184e3Ssthen LEAVE;
341898184e3Ssthen }
342b8851fccSafresh1 else if (CvSLABBED(&cvbody)) {
343b8851fccSafresh1 if( CvSTART(&cvbody)) {
34491f110e0Safresh1 ENTER;
34591f110e0Safresh1 PAD_SAVE_SETNULLPAD();
34691f110e0Safresh1
34791f110e0Safresh1 /* discard any leaked ops */
34891f110e0Safresh1 if (PL_parser)
349b8851fccSafresh1 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
350b8851fccSafresh1 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
351b8851fccSafresh1 CvSTART(&cvbody) = NULL;
35291f110e0Safresh1
35391f110e0Safresh1 LEAVE;
35491f110e0Safresh1 }
35591f110e0Safresh1 #ifdef DEBUGGING
356b8851fccSafresh1 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
35791f110e0Safresh1 #endif
358b8851fccSafresh1 }
359b8851fccSafresh1 }
360*e0680481Safresh1 else { /* don't bother checking if CvXSUB(cv) is true, less branching */
361b8851fccSafresh1 CvXSUB(&cvbody) = NULL;
362b8851fccSafresh1 }
363898184e3Ssthen SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
36491f110e0Safresh1 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
365b8851fccSafresh1 if (!(flags & CV_UNDEF_KEEP_NAME)) {
366b8851fccSafresh1 if (CvNAMED(&cvbody)) {
367b8851fccSafresh1 CvNAME_HEK_set(&cvbody, NULL);
368b8851fccSafresh1 CvNAMED_off(&cvbody);
369b8851fccSafresh1 }
37091f110e0Safresh1 else CvGV_set(cv, NULL);
371b8851fccSafresh1 }
372898184e3Ssthen
373898184e3Ssthen /* This statement and the subsequence if block was pad_undef(). */
374850e2753Smillert pad_peg("pad_undef");
375898184e3Ssthen
376b8851fccSafresh1 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
3779f11ffb7Safresh1 PADOFFSET ix;
378b8851fccSafresh1 const PADLIST *padlist = CvPADLIST(&cvbody);
379898184e3Ssthen
380898184e3Ssthen /* Free the padlist associated with a CV.
381898184e3Ssthen If parts of it happen to be current, we null the relevant PL_*pad*
382898184e3Ssthen global vars so that we don't have any dangling references left.
383898184e3Ssthen We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
384898184e3Ssthen subs to the outer of this cv. */
38585009909Smillert
38685009909Smillert DEBUG_X(PerlIO_printf(Perl_debug_log,
387850e2753Smillert "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n",
388850e2753Smillert PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
38985009909Smillert );
39085009909Smillert
39185009909Smillert /* detach any '&' anon children in the pad; if afterwards they
39285009909Smillert * are still live, fix up their CvOUTSIDEs to point to our outside,
39385009909Smillert * bypassing us. */
39485009909Smillert
395898184e3Ssthen if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
396b8851fccSafresh1 CV * const outercv = CvOUTSIDE(&cvbody);
397b8851fccSafresh1 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
398b8851fccSafresh1 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
399b8851fccSafresh1 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
40091f110e0Safresh1 PAD * const comppad = PadlistARRAY(padlist)[1];
40152bd00bfSmillert SV ** const curpad = AvARRAY(comppad);
402b8851fccSafresh1 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
403b8851fccSafresh1 PADNAME * const name = namepad[ix];
404b8851fccSafresh1 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
40585009909Smillert {
40643003dfeSmillert CV * const innercv = MUTABLE_CV(curpad[ix]);
4079f11ffb7Safresh1 U32 inner_rc;
4089f11ffb7Safresh1 assert(innercv);
409898184e3Ssthen assert(SvTYPE(innercv) != SVt_PVFM);
4109f11ffb7Safresh1 inner_rc = SvREFCNT(innercv);
4119f11ffb7Safresh1 assert(inner_rc);
41243890927Smillert
41343890927Smillert if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
414850e2753Smillert curpad[ix] = NULL;
41591f110e0Safresh1 SvREFCNT_dec_NN(innercv);
41652bd00bfSmillert inner_rc--;
41743890927Smillert }
418850e2753Smillert
419850e2753Smillert /* in use, not just a prototype */
420b8851fccSafresh1 if (inner_rc && SvTYPE(innercv) == SVt_PVCV
421b8851fccSafresh1 && (CvOUTSIDE(innercv) == cv))
422b8851fccSafresh1 {
42385009909Smillert assert(CvWEAKOUTSIDE(innercv));
42485009909Smillert /* don't relink to grandfather if he's being freed */
42585009909Smillert if (outercv && SvREFCNT(outercv)) {
42685009909Smillert CvWEAKOUTSIDE_off(innercv);
42785009909Smillert CvOUTSIDE(innercv) = outercv;
42885009909Smillert CvOUTSIDE_SEQ(innercv) = seq;
429850e2753Smillert SvREFCNT_inc_simple_void_NN(outercv);
43085009909Smillert }
43185009909Smillert else {
432850e2753Smillert CvOUTSIDE(innercv) = NULL;
43385009909Smillert }
43485009909Smillert }
43585009909Smillert }
43685009909Smillert }
43785009909Smillert }
43885009909Smillert
43991f110e0Safresh1 ix = PadlistMAX(padlist);
440898184e3Ssthen while (ix > 0) {
44191f110e0Safresh1 PAD * const sv = PadlistARRAY(padlist)[ix--];
442850e2753Smillert if (sv) {
44391f110e0Safresh1 if (sv == PL_comppad) {
444850e2753Smillert PL_comppad = NULL;
445850e2753Smillert PL_curpad = NULL;
446850e2753Smillert }
44791f110e0Safresh1 SvREFCNT_dec_NN(sv);
44885009909Smillert }
449898184e3Ssthen }
450898184e3Ssthen {
451b8851fccSafresh1 PADNAMELIST * const names = PadlistNAMES(padlist);
452b8851fccSafresh1 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
453898184e3Ssthen PL_comppad_name = NULL;
454b8851fccSafresh1 PadnamelistREFCNT_dec(names);
455898184e3Ssthen }
45691f110e0Safresh1 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
45791f110e0Safresh1 Safefree(padlist);
458b8851fccSafresh1 CvPADLIST_set(&cvbody, NULL);
45985009909Smillert }
460*e0680481Safresh1 else if (CvISXSUB(&cvbody)) {
461*e0680481Safresh1 if (CvREFCOUNTED_ANYSV(&cvbody))
462*e0680481Safresh1 SvREFCNT_dec(CvXSUBANY(&cvbody).any_sv);
463b8851fccSafresh1 CvHSCXT(&cvbody) = NULL;
464*e0680481Safresh1 }
465b8851fccSafresh1 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
46685009909Smillert
46785009909Smillert
468898184e3Ssthen /* remove CvOUTSIDE unless this is an undef rather than a free */
469b8851fccSafresh1 if (!SvREFCNT(cv)) {
470b8851fccSafresh1 CV * outside = CvOUTSIDE(&cvbody);
471b8851fccSafresh1 if(outside) {
472b8851fccSafresh1 CvOUTSIDE(&cvbody) = NULL;
473b8851fccSafresh1 if (!CvWEAKOUTSIDE(&cvbody))
474b8851fccSafresh1 SvREFCNT_dec_NN(outside);
475898184e3Ssthen }
476898184e3Ssthen }
477b8851fccSafresh1 if (CvCONST(&cvbody)) {
478b8851fccSafresh1 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
479b8851fccSafresh1 /* CvCONST_off(cv); *//* turned off below */
480898184e3Ssthen }
481898184e3Ssthen /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
482b8851fccSafresh1 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
483b8851fccSafresh1 * LEXICAL, which are used to determine the sub's name. */
484b8851fccSafresh1 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
485b8851fccSafresh1 |CVf_NAMED);
486898184e3Ssthen }
48785009909Smillert
488898184e3Ssthen /*
48991f110e0Safresh1 =for apidoc cv_forget_slab
49091f110e0Safresh1
491b8851fccSafresh1 When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
49291f110e0Safresh1 for making sure it is freed. (Hence, no two CVs should ever have a
49391f110e0Safresh1 reference count on the same slab.) The CV only needs to reference the slab
494b8851fccSafresh1 during compilation. Once it is compiled and C<CvROOT> attached, it has
49591f110e0Safresh1 finished its job, so it can forget the slab.
49691f110e0Safresh1
49791f110e0Safresh1 =cut
49891f110e0Safresh1 */
49991f110e0Safresh1
50091f110e0Safresh1 void
Perl_cv_forget_slab(pTHX_ CV * cv)50191f110e0Safresh1 Perl_cv_forget_slab(pTHX_ CV *cv)
50291f110e0Safresh1 {
503b8851fccSafresh1 bool slabbed;
50491f110e0Safresh1 OPSLAB *slab = NULL;
50591f110e0Safresh1
506b8851fccSafresh1 if (!cv)
507b8851fccSafresh1 return;
508b8851fccSafresh1 slabbed = cBOOL(CvSLABBED(cv));
50991f110e0Safresh1 if (!slabbed) return;
51091f110e0Safresh1
51191f110e0Safresh1 CvSLABBED_off(cv);
51291f110e0Safresh1
51391f110e0Safresh1 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
51491f110e0Safresh1 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
51591f110e0Safresh1 #ifdef DEBUGGING
516b8851fccSafresh1 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
51791f110e0Safresh1 #endif
51891f110e0Safresh1
51991f110e0Safresh1 if (slab) {
52091f110e0Safresh1 #ifdef PERL_DEBUG_READONLY_OPS
52191f110e0Safresh1 const size_t refcnt = slab->opslab_refcnt;
52291f110e0Safresh1 #endif
52391f110e0Safresh1 OpslabREFCNT_dec(slab);
52491f110e0Safresh1 #ifdef PERL_DEBUG_READONLY_OPS
52591f110e0Safresh1 if (refcnt > 1) Slab_to_ro(slab);
52691f110e0Safresh1 #endif
52791f110e0Safresh1 }
52891f110e0Safresh1 }
52991f110e0Safresh1
53091f110e0Safresh1 /*
53156d68f1eSafresh1 =for apidoc pad_alloc_name
532898184e3Ssthen
533898184e3Ssthen Allocates a place in the currently-compiling
534898184e3Ssthen pad (via L<perlapi/pad_alloc>) and
535b8851fccSafresh1 then stores a name for that entry. C<name> is adopted and
536b8851fccSafresh1 becomes the name entry; it must already contain the name
537b8851fccSafresh1 string. C<typestash> and C<ourstash> and the C<padadd_STATE>
538b8851fccSafresh1 flag get added to C<name>. None of the other
539898184e3Ssthen processing of L<perlapi/pad_add_name_pvn>
540898184e3Ssthen is done. Returns the offset of the allocated pad slot.
541898184e3Ssthen
542898184e3Ssthen =cut
543898184e3Ssthen */
54485009909Smillert
545b39c5158Smillert static PADOFFSET
S_pad_alloc_name(pTHX_ PADNAME * name,U32 flags,HV * typestash,HV * ourstash)546b8851fccSafresh1 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
547b8851fccSafresh1 HV *ourstash)
548b39c5158Smillert {
549b39c5158Smillert const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
550b39c5158Smillert
551898184e3Ssthen PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
552b39c5158Smillert
553898184e3Ssthen ASSERT_CURPAD_ACTIVE("pad_alloc_name");
554b39c5158Smillert
555b39c5158Smillert if (typestash) {
556*e0680481Safresh1 PadnameFLAGS(name) |= PADNAMEf_TYPED;
557b8851fccSafresh1 PadnameTYPE(name) =
558b8851fccSafresh1 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
559b39c5158Smillert }
560b39c5158Smillert if (ourstash) {
561*e0680481Safresh1 PadnameFLAGS(name) |= PADNAMEf_OUR;
562*e0680481Safresh1 PadnameOURSTASH_set(name, ourstash);
563b39c5158Smillert SvREFCNT_inc_simple_void_NN(ourstash);
564b39c5158Smillert }
565b39c5158Smillert else if (flags & padadd_STATE) {
566*e0680481Safresh1 PadnameFLAGS(name) |= PADNAMEf_STATE;
567*e0680481Safresh1 }
568*e0680481Safresh1 if (flags & padadd_FIELD) {
569*e0680481Safresh1 assert(HvSTASH_IS_CLASS(PL_curstash));
570*e0680481Safresh1 class_add_field(PL_curstash, name);
571b39c5158Smillert }
572b39c5158Smillert
573b8851fccSafresh1 padnamelist_store(PL_comppad_name, offset, name);
574b8851fccSafresh1 if (PadnameLEN(name) > 1)
5756fb12b70Safresh1 PadnamelistMAXNAMED(PL_comppad_name) = offset;
576b39c5158Smillert return offset;
577b39c5158Smillert }
578b39c5158Smillert
57985009909Smillert /*
58056d68f1eSafresh1 =for apidoc pad_add_name_pvn
58185009909Smillert
582898184e3Ssthen Allocates a place in the currently-compiling pad for a named lexical
583898184e3Ssthen variable. Stores the name and other metadata in the name part of the
584898184e3Ssthen pad, and makes preparations to manage the variable's lexical scoping.
585898184e3Ssthen Returns the offset of the allocated pad slot.
58685009909Smillert
587b8851fccSafresh1 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
588b8851fccSafresh1 If C<typestash> is non-null, the name is for a typed lexical, and this
589b8851fccSafresh1 identifies the type. If C<ourstash> is non-null, it's a lexical reference
590898184e3Ssthen to a package variable, and this identifies the package. The following
591898184e3Ssthen flags can be OR'ed together:
592898184e3Ssthen
593898184e3Ssthen padadd_OUR redundantly specifies if it's a package var
594898184e3Ssthen padadd_STATE variable will retain value persistently
595898184e3Ssthen padadd_NO_DUP_CHECK skip check for lexical shadowing
596*e0680481Safresh1 padadd_FIELD specifies that the lexical is a field for a class
59785009909Smillert
59885009909Smillert =cut
59985009909Smillert */
60085009909Smillert
60185009909Smillert PADOFFSET
Perl_pad_add_name_pvn(pTHX_ const char * namepv,STRLEN namelen,U32 flags,HV * typestash,HV * ourstash)602898184e3Ssthen Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
603898184e3Ssthen U32 flags, HV *typestash, HV *ourstash)
60485009909Smillert {
605b39c5158Smillert PADOFFSET offset;
606b8851fccSafresh1 PADNAME *name;
60785009909Smillert
608898184e3Ssthen PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
60943003dfeSmillert
610*e0680481Safresh1 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_FIELD))
611898184e3Ssthen Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
612b39c5158Smillert (UV)flags);
613b39c5158Smillert
614b8851fccSafresh1 name = newPADNAMEpvn(namepv, namelen);
61585009909Smillert
616b39c5158Smillert if ((flags & padadd_NO_DUP_CHECK) == 0) {
61791f110e0Safresh1 ENTER;
618b8851fccSafresh1 SAVEFREEPADNAME(name); /* in case of fatal warnings */
619b39c5158Smillert /* check for duplicate declaration */
620*e0680481Safresh1 pad_check_dup(name, flags & (padadd_OUR|padadd_FIELD), ourstash);
621*e0680481Safresh1 PadnameREFCNT_inc(name);
62291f110e0Safresh1 LEAVE;
62385009909Smillert }
62485009909Smillert
625b8851fccSafresh1 offset = pad_alloc_name(name, flags, typestash, ourstash);
626b39c5158Smillert
62785009909Smillert /* not yet introduced */
628b8851fccSafresh1 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
629b8851fccSafresh1 COP_SEQ_RANGE_HIGH_set(name, 0);
63085009909Smillert
63185009909Smillert if (!PL_min_intro_pending)
63285009909Smillert PL_min_intro_pending = offset;
63385009909Smillert PL_max_intro_pending = offset;
634850e2753Smillert /* if it's not a simple scalar, replace with an AV or HV */
635898184e3Ssthen assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
636898184e3Ssthen assert(SvREFCNT(PL_curpad[offset]) == 1);
637898184e3Ssthen if (namelen != 0 && *namepv == '@')
638898184e3Ssthen sv_upgrade(PL_curpad[offset], SVt_PVAV);
639898184e3Ssthen else if (namelen != 0 && *namepv == '%')
640898184e3Ssthen sv_upgrade(PL_curpad[offset], SVt_PVHV);
64191f110e0Safresh1 else if (namelen != 0 && *namepv == '&')
64291f110e0Safresh1 sv_upgrade(PL_curpad[offset], SVt_PVCV);
643898184e3Ssthen assert(SvPADMY(PL_curpad[offset]));
644850e2753Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
645850e2753Smillert "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n",
646b8851fccSafresh1 (long)offset, PadnamePV(name),
647898184e3Ssthen PTR2UV(PL_curpad[offset])));
64885009909Smillert
64985009909Smillert return offset;
65085009909Smillert }
65185009909Smillert
652898184e3Ssthen /*
65356d68f1eSafresh1 =for apidoc pad_add_name_pv
65485009909Smillert
655898184e3Ssthen Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
656898184e3Ssthen instead of a string/length pair.
65785009909Smillert
658898184e3Ssthen =cut
659898184e3Ssthen */
660898184e3Ssthen
661898184e3Ssthen PADOFFSET
Perl_pad_add_name_pv(pTHX_ const char * name,const U32 flags,HV * typestash,HV * ourstash)662898184e3Ssthen Perl_pad_add_name_pv(pTHX_ const char *name,
663898184e3Ssthen const U32 flags, HV *typestash, HV *ourstash)
664898184e3Ssthen {
665898184e3Ssthen PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
666898184e3Ssthen return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
667898184e3Ssthen }
66885009909Smillert
66985009909Smillert /*
67056d68f1eSafresh1 =for apidoc pad_add_name_sv
67185009909Smillert
672898184e3Ssthen Exactly like L</pad_add_name_pvn>, but takes the name string in the form
673898184e3Ssthen of an SV instead of a string/length pair.
674898184e3Ssthen
675898184e3Ssthen =cut
676898184e3Ssthen */
677898184e3Ssthen
678898184e3Ssthen PADOFFSET
Perl_pad_add_name_sv(pTHX_ SV * name,U32 flags,HV * typestash,HV * ourstash)679898184e3Ssthen Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
680898184e3Ssthen {
681898184e3Ssthen char *namepv;
682898184e3Ssthen STRLEN namelen;
683898184e3Ssthen PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
684b8851fccSafresh1 namepv = SvPVutf8(name, namelen);
685898184e3Ssthen return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
686898184e3Ssthen }
687898184e3Ssthen
688898184e3Ssthen /*
68956d68f1eSafresh1 =for apidoc pad_alloc
690898184e3Ssthen
691898184e3Ssthen Allocates a place in the currently-compiling pad,
692898184e3Ssthen returning the offset of the allocated pad slot.
693898184e3Ssthen No name is initially attached to the pad slot.
694b8851fccSafresh1 C<tmptype> is a set of flags indicating the kind of pad entry required,
695898184e3Ssthen which will be set in the value SV for the allocated pad entry:
696898184e3Ssthen
697898184e3Ssthen SVs_PADMY named lexical variable ("my", "our", "state")
698898184e3Ssthen SVs_PADTMP unnamed temporary store
6996fb12b70Safresh1 SVf_READONLY constant shared between recursion levels
7006fb12b70Safresh1
7016fb12b70Safresh1 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
7026fb12b70Safresh1 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
7036fb12b70Safresh1 does not cause the SV in the pad slot to be marked read-only, but simply
7046fb12b70Safresh1 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
7056fb12b70Safresh1 least should be treated as such.
706898184e3Ssthen
707b8851fccSafresh1 C<optype> should be an opcode indicating the type of operation that the
708898184e3Ssthen pad entry is to support. This doesn't affect operational semantics,
709898184e3Ssthen but is used for debugging.
71085009909Smillert
71185009909Smillert =cut
71285009909Smillert */
71385009909Smillert
71485009909Smillert PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype,U32 tmptype)71585009909Smillert Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
71685009909Smillert {
71785009909Smillert SV *sv;
7189f11ffb7Safresh1 PADOFFSET retval;
71985009909Smillert
720850e2753Smillert PERL_UNUSED_ARG(optype);
72185009909Smillert ASSERT_CURPAD_ACTIVE("pad_alloc");
72285009909Smillert
72385009909Smillert if (AvARRAY(PL_comppad) != PL_curpad)
724898184e3Ssthen Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
725898184e3Ssthen AvARRAY(PL_comppad), PL_curpad);
72685009909Smillert if (PL_pad_reset_pending)
72785009909Smillert pad_reset();
728b8851fccSafresh1 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
729898184e3Ssthen /* For a my, simply push a null SV onto the end of PL_comppad. */
730eac174f2Safresh1 sv = *av_store_simple(PL_comppad, AvFILLp(PL_comppad) + 1, newSV_type(SVt_NULL));
7319f11ffb7Safresh1 retval = (PADOFFSET)AvFILLp(PL_comppad);
73285009909Smillert }
73385009909Smillert else {
734898184e3Ssthen /* For a tmp, scan the pad from PL_padix upwards
735898184e3Ssthen * for a slot which has no name and no active value.
736b8851fccSafresh1 * For a constant, likewise, but use PL_constpadix.
737898184e3Ssthen */
738b8851fccSafresh1 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
739b8851fccSafresh1 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
740b8851fccSafresh1 const bool konst = cBOOL(tmptype & SVf_READONLY);
741b8851fccSafresh1 retval = konst ? PL_constpadix : PL_padix;
74285009909Smillert for (;;) {
74385009909Smillert /*
7446fb12b70Safresh1 * Entries that close over unavailable variables
7456fb12b70Safresh1 * in outer subs contain values not marked PADMY.
7466fb12b70Safresh1 * Thus we must skip, not just pad values that are
74785009909Smillert * marked as current pad values, but also those with names.
748b8851fccSafresh1 * If pad_reset is enabled, ‘current’ means different
749b8851fccSafresh1 * things depending on whether we are allocating a con-
750b8851fccSafresh1 * stant or a target. For a target, things marked PADTMP
751b8851fccSafresh1 * can be reused; not so for constants.
75285009909Smillert */
753b8851fccSafresh1 PADNAME *pn;
754b8851fccSafresh1 if (++retval <= names_fill &&
755b8851fccSafresh1 (pn = names[retval]) && PadnamePV(pn))
75685009909Smillert continue;
757eac174f2Safresh1 sv = *av_fetch_simple(PL_comppad, retval, TRUE);
758b8851fccSafresh1 if (!(SvFLAGS(sv) &
759b8851fccSafresh1 #ifdef USE_PAD_RESET
7609f11ffb7Safresh1 (konst ? SVs_PADTMP : 0)
761b8851fccSafresh1 #else
762b8851fccSafresh1 SVs_PADTMP
763b8851fccSafresh1 #endif
764b8851fccSafresh1 ))
76585009909Smillert break;
76685009909Smillert }
767b8851fccSafresh1 if (konst) {
768b8851fccSafresh1 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
7696fb12b70Safresh1 tmptype &= ~SVf_READONLY;
7706fb12b70Safresh1 tmptype |= SVs_PADTMP;
7716fb12b70Safresh1 }
772b8851fccSafresh1 *(konst ? &PL_constpadix : &PL_padix) = retval;
77385009909Smillert }
77485009909Smillert SvFLAGS(sv) |= tmptype;
77585009909Smillert PL_curpad = AvARRAY(PL_comppad);
77685009909Smillert
77785009909Smillert DEBUG_X(PerlIO_printf(Perl_debug_log,
77885009909Smillert "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n",
77985009909Smillert PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
78085009909Smillert PL_op_name[optype]));
781850e2753Smillert #ifdef DEBUG_LEAKING_SCALARS
782850e2753Smillert sv->sv_debug_optype = optype;
783850e2753Smillert sv->sv_debug_inpad = 1;
784850e2753Smillert #endif
7859f11ffb7Safresh1 return retval;
78685009909Smillert }
78785009909Smillert
78885009909Smillert /*
78956d68f1eSafresh1 =for apidoc pad_add_anon
79085009909Smillert
791898184e3Ssthen Allocates a place in the currently-compiling pad (via L</pad_alloc>)
792898184e3Ssthen for an anonymous function that is lexically scoped inside the
793898184e3Ssthen currently-compiling function.
794b8851fccSafresh1 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
795898184e3Ssthen to the outer scope is weakened to avoid a reference loop.
796898184e3Ssthen
79791f110e0Safresh1 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
79891f110e0Safresh1
799b8851fccSafresh1 C<optype> should be an opcode indicating the type of operation that the
800898184e3Ssthen pad entry is to support. This doesn't affect operational semantics,
801898184e3Ssthen but is used for debugging.
80285009909Smillert
80385009909Smillert =cut
80485009909Smillert */
80585009909Smillert
80685009909Smillert PADOFFSET
Perl_pad_add_anon(pTHX_ CV * func,I32 optype)807898184e3Ssthen Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
80885009909Smillert {
80985009909Smillert PADOFFSET ix;
810b8851fccSafresh1 PADNAME * const name = newPADNAMEpvn("&", 1);
81143003dfeSmillert
81243003dfeSmillert PERL_ARGS_ASSERT_PAD_ADD_ANON;
813b8851fccSafresh1 assert (SvTYPE(func) == SVt_PVCV);
81443003dfeSmillert
815850e2753Smillert pad_peg("add_anon");
816898184e3Ssthen /* These two aren't used; just make sure they're not equal to
817b8851fccSafresh1 * PERL_PADSEQ_INTRO. They should be 0 by default. */
818b8851fccSafresh1 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
819b8851fccSafresh1 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
820898184e3Ssthen ix = pad_alloc(optype, SVs_PADMY);
821b8851fccSafresh1 padnamelist_store(PL_comppad_name, ix, name);
822898184e3Ssthen av_store(PL_comppad, ix, (SV*)func);
82385009909Smillert
82485009909Smillert /* to avoid ref loops, we never have parent + child referencing each
82585009909Smillert * other simultaneously */
826b8851fccSafresh1 if (CvOUTSIDE(func)) {
827898184e3Ssthen assert(!CvWEAKOUTSIDE(func));
828898184e3Ssthen CvWEAKOUTSIDE_on(func);
82991f110e0Safresh1 SvREFCNT_dec_NN(CvOUTSIDE(func));
83085009909Smillert }
83185009909Smillert return ix;
83285009909Smillert }
83385009909Smillert
834b8851fccSafresh1 void
Perl_pad_add_weakref(pTHX_ CV * func)835b8851fccSafresh1 Perl_pad_add_weakref(pTHX_ CV* func)
836b8851fccSafresh1 {
837b8851fccSafresh1 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
838b8851fccSafresh1 PADNAME * const name = newPADNAMEpvn("&", 1);
839b8851fccSafresh1 SV * const rv = newRV_inc((SV *)func);
840b8851fccSafresh1
841b8851fccSafresh1 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
842b8851fccSafresh1
843b8851fccSafresh1 /* These two aren't used; just make sure they're not equal to
844b8851fccSafresh1 * PERL_PADSEQ_INTRO. They should be 0 by default. */
845b8851fccSafresh1 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
846b8851fccSafresh1 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
847b8851fccSafresh1 padnamelist_store(PL_comppad_name, ix, name);
848b8851fccSafresh1 sv_rvweaken(rv);
849b8851fccSafresh1 av_store(PL_comppad, ix, rv);
850b8851fccSafresh1 }
851b8851fccSafresh1
85285009909Smillert /*
85385009909Smillert =for apidoc pad_check_dup
85485009909Smillert
85585009909Smillert Check for duplicate declarations: report any of:
856898184e3Ssthen
857b8851fccSafresh1 * a 'my' in the current scope with the same name;
858b8851fccSafresh1 * an 'our' (anywhere in the pad) with the same name and the
859b8851fccSafresh1 same stash as 'ourstash'
860898184e3Ssthen
861b8851fccSafresh1 C<is_our> indicates that the name to check is an C<"our"> declaration.
86285009909Smillert
86385009909Smillert =cut
86485009909Smillert */
86585009909Smillert
866b39c5158Smillert STATIC void
S_pad_check_dup(pTHX_ PADNAME * name,U32 flags,const HV * ourstash)867b8851fccSafresh1 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
86885009909Smillert {
869b8851fccSafresh1 PADNAME **svp;
87085009909Smillert PADOFFSET top, off;
871b39c5158Smillert const U32 is_our = flags & padadd_OUR;
872*e0680481Safresh1 bool is_field = flags & padadd_FIELD;
87385009909Smillert
87443003dfeSmillert PERL_ARGS_ASSERT_PAD_CHECK_DUP;
87543003dfeSmillert
87685009909Smillert ASSERT_CURPAD_ACTIVE("pad_check_dup");
877b39c5158Smillert
878*e0680481Safresh1 assert((flags & ~(padadd_OUR|padadd_FIELD)) == 0);
879b39c5158Smillert
8809f11ffb7Safresh1 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW))
88185009909Smillert return; /* nothing to check */
88285009909Smillert
883b8851fccSafresh1 svp = PadnamelistARRAY(PL_comppad_name);
884b8851fccSafresh1 top = PadnamelistMAX(PL_comppad_name);
88585009909Smillert /* check the current scope */
8869f11ffb7Safresh1 for (off = top; off > PL_comppad_name_floor; off--) {
887*e0680481Safresh1 PADNAME * const pn = svp[off];
888*e0680481Safresh1 if (pn
889*e0680481Safresh1 && PadnameLEN(pn) == PadnameLEN(name)
890*e0680481Safresh1 && !PadnameOUTER(pn)
891*e0680481Safresh1 && ( COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO
892*e0680481Safresh1 || COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO)
893*e0680481Safresh1 && memEQ(PadnamePV(pn), PadnamePV(name), PadnameLEN(name)))
89485009909Smillert {
895*e0680481Safresh1 if (is_our && (PadnameIsOUR(pn)))
896850e2753Smillert break; /* "our" masking "our" */
897*e0680481Safresh1 if (is_field && PadnameIsFIELD(pn) &&
898*e0680481Safresh1 PadnameFIELDINFO(pn)->fieldstash != PL_curstash)
899*e0680481Safresh1 break; /* field of a different class */
90091f110e0Safresh1 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
9019f11ffb7Safresh1 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
902b8851fccSafresh1 "\"%s\" %s %" PNf " masks earlier declaration in same %s",
9039f11ffb7Safresh1 ( is_our ? "our" :
9049f11ffb7Safresh1 PL_parser->in_my == KEY_my ? "my" :
9059f11ffb7Safresh1 PL_parser->in_my == KEY_sigvar ? "my" :
906*e0680481Safresh1 PL_parser->in_my == KEY_field ? "field" :
9079f11ffb7Safresh1 "state" ),
908*e0680481Safresh1 *PadnamePV(pn) == '&' ? "subroutine" : "variable",
909*e0680481Safresh1 PNfARG(pn),
910*e0680481Safresh1 (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO
911898184e3Ssthen ? "scope" : "statement"));
91285009909Smillert --off;
91385009909Smillert break;
91485009909Smillert }
91585009909Smillert }
91685009909Smillert /* check the rest of the pad */
91785009909Smillert if (is_our) {
918898184e3Ssthen while (off > 0) {
919*e0680481Safresh1 PADNAME * const pn = svp[off];
920*e0680481Safresh1 if (pn
921*e0680481Safresh1 && PadnameLEN(pn) == PadnameLEN(name)
922*e0680481Safresh1 && !PadnameOUTER(pn)
923*e0680481Safresh1 && ( COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO
924*e0680481Safresh1 || COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO)
925*e0680481Safresh1 && PadnameOURSTASH(pn) == ourstash
926*e0680481Safresh1 && memEQ(PadnamePV(pn), PadnamePV(name), PadnameLEN(name)))
92785009909Smillert {
9289f11ffb7Safresh1 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
929*e0680481Safresh1 "\"our\" variable %" PNf " redeclared", PNfARG(pn));
9309f11ffb7Safresh1 if (off <= PL_comppad_name_floor)
9319f11ffb7Safresh1 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
93285009909Smillert "\t(Did you mean \"local\" instead of \"our\"?)\n");
93385009909Smillert break;
93485009909Smillert }
935898184e3Ssthen --off;
936898184e3Ssthen }
93785009909Smillert }
93885009909Smillert }
93985009909Smillert
94085009909Smillert
94185009909Smillert /*
94256d68f1eSafresh1 =for apidoc pad_findmy_pvn
94385009909Smillert
944898184e3Ssthen Given the name of a lexical variable, find its position in the
945898184e3Ssthen currently-compiling pad.
946b8851fccSafresh1 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
947b8851fccSafresh1 C<flags> is reserved and must be zero.
948898184e3Ssthen If it is not in the current pad but appears in the pad of any lexically
949898184e3Ssthen enclosing scope, then a pseudo-entry for it is added in the current pad.
950898184e3Ssthen Returns the offset in the current pad,
951898184e3Ssthen or C<NOT_IN_PAD> if no such lexical is in scope.
95285009909Smillert
95385009909Smillert =cut
95485009909Smillert */
95585009909Smillert
95685009909Smillert PADOFFSET
Perl_pad_findmy_pvn(pTHX_ const char * namepv,STRLEN namelen,U32 flags)957898184e3Ssthen Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
95885009909Smillert {
959b8851fccSafresh1 PADNAME *out_pn;
960850e2753Smillert int out_flags;
9619f11ffb7Safresh1 PADOFFSET offset;
962b8851fccSafresh1 const PADNAMELIST *namelist;
963b8851fccSafresh1 PADNAME **name_p;
96485009909Smillert
965898184e3Ssthen PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
96643003dfeSmillert
967898184e3Ssthen pad_peg("pad_findmy_pvn");
968b39c5158Smillert
969b8851fccSafresh1 if (flags)
970898184e3Ssthen Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
971b39c5158Smillert (UV)flags);
972b39c5158Smillert
973b8851fccSafresh1 /* compilation errors can zero PL_compcv */
974b8851fccSafresh1 if (!PL_compcv)
975b8851fccSafresh1 return NOT_IN_PAD;
976b39c5158Smillert
977898184e3Ssthen offset = pad_findlex(namepv, namelen, flags,
978b8851fccSafresh1 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
9799f11ffb7Safresh1 if (offset != NOT_IN_PAD)
980850e2753Smillert return offset;
98185009909Smillert
982b8851fccSafresh1 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
983b8851fccSafresh1 */
984b8851fccSafresh1 if (*namepv == '&') return NOT_IN_PAD;
985b8851fccSafresh1
98685009909Smillert /* look for an our that's being introduced; this allows
98785009909Smillert * our $foo = 0 unless defined $foo;
98885009909Smillert * to not give a warning. (Yes, this is a hack) */
98985009909Smillert
990b8851fccSafresh1 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
991b8851fccSafresh1 name_p = PadnamelistARRAY(namelist);
992b8851fccSafresh1 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
993b8851fccSafresh1 const PADNAME * const name = name_p[offset];
994b8851fccSafresh1 if (name && PadnameLEN(name) == namelen
995b8851fccSafresh1 && !PadnameOUTER(name)
996b8851fccSafresh1 && (PadnameIsOUR(name))
997b8851fccSafresh1 && ( PadnamePV(name) == namepv
998b8851fccSafresh1 || memEQ(PadnamePV(name), namepv, namelen) )
999b8851fccSafresh1 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
1000850e2753Smillert )
1001850e2753Smillert return offset;
1002850e2753Smillert }
1003850e2753Smillert return NOT_IN_PAD;
100485009909Smillert }
100585009909Smillert
1006850e2753Smillert /*
100756d68f1eSafresh1 =for apidoc pad_findmy_pv
1008898184e3Ssthen
1009898184e3Ssthen Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1010898184e3Ssthen instead of a string/length pair.
1011898184e3Ssthen
1012898184e3Ssthen =cut
1013898184e3Ssthen */
1014898184e3Ssthen
1015898184e3Ssthen PADOFFSET
Perl_pad_findmy_pv(pTHX_ const char * name,U32 flags)1016898184e3Ssthen Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1017898184e3Ssthen {
1018898184e3Ssthen PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1019898184e3Ssthen return pad_findmy_pvn(name, strlen(name), flags);
1020898184e3Ssthen }
1021898184e3Ssthen
1022898184e3Ssthen /*
102356d68f1eSafresh1 =for apidoc pad_findmy_sv
1024898184e3Ssthen
1025898184e3Ssthen Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1026898184e3Ssthen of an SV instead of a string/length pair.
1027898184e3Ssthen
1028898184e3Ssthen =cut
1029898184e3Ssthen */
1030898184e3Ssthen
1031898184e3Ssthen PADOFFSET
Perl_pad_findmy_sv(pTHX_ SV * name,U32 flags)1032898184e3Ssthen Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1033898184e3Ssthen {
1034898184e3Ssthen char *namepv;
1035898184e3Ssthen STRLEN namelen;
1036898184e3Ssthen PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1037b8851fccSafresh1 namepv = SvPVutf8(name, namelen);
1038898184e3Ssthen return pad_findmy_pvn(namepv, namelen, flags);
1039898184e3Ssthen }
1040898184e3Ssthen
1041898184e3Ssthen /*
104256d68f1eSafresh1 =for apidoc find_rundefsv
1043898184e3Ssthen
1044b8851fccSafresh1 Returns the global variable C<$_>.
1045898184e3Ssthen
1046898184e3Ssthen =cut
1047898184e3Ssthen */
1048898184e3Ssthen
1049898184e3Ssthen SV *
Perl_find_rundefsv(pTHX)1050898184e3Ssthen Perl_find_rundefsv(pTHX)
1051898184e3Ssthen {
1052898184e3Ssthen return DEFSV;
1053898184e3Ssthen }
1054898184e3Ssthen
1055898184e3Ssthen /*
105656d68f1eSafresh1 =for apidoc pad_findlex
105785009909Smillert
105885009909Smillert Find a named lexical anywhere in a chain of nested pads. Add fake entries
1059850e2753Smillert in the inner pads if it's found in an outer one.
1060850e2753Smillert
1061850e2753Smillert Returns the offset in the bottom pad of the lex or the fake lex.
1062b8851fccSafresh1 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1063b8851fccSafresh1 to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
1064850e2753Smillert vars return values, and so are pointers to where the returned values
1065b8851fccSafresh1 should be stored. C<out_capture>, if non-null, requests that the innermost
1066b8851fccSafresh1 instance of the lexical is captured; C<out_name> is set to the innermost
1067b8851fccSafresh1 matched pad name or fake pad name; C<out_flags> returns the flags normally
1068b8851fccSafresh1 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1069850e2753Smillert
1070b8851fccSafresh1 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
10716fb12b70Safresh1 then comes back down, adding fake entries
10726fb12b70Safresh1 as it goes. It has to be this way
1073eac174f2Safresh1 because fake names in anon prototypes have to store in C<xpadn_low> the
10749f11ffb7Safresh1 index into the parent pad.
107585009909Smillert
107685009909Smillert =cut
107785009909Smillert */
107885009909Smillert
1079850e2753Smillert /* the CV has finished being compiled. This is not a sufficient test for
1080850e2753Smillert * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1081850e2753Smillert #define CvCOMPILED(cv) CvROOT(cv)
1082850e2753Smillert
1083850e2753Smillert /* the CV does late binding of its lexicals */
108491f110e0Safresh1 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1085850e2753Smillert
108691f110e0Safresh1 static void
S_unavailable(pTHX_ PADNAME * name)1087b8851fccSafresh1 S_unavailable(pTHX_ PADNAME *name)
108891f110e0Safresh1 {
108991f110e0Safresh1 /* diag_listed_as: Variable "%s" is not available */
109091f110e0Safresh1 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
109156d68f1eSafresh1 "%s \"%" PNf "\" is not available",
1092b8851fccSafresh1 *PadnamePV(name) == '&'
109356d68f1eSafresh1 ? "Subroutine"
109456d68f1eSafresh1 : "Variable",
1095b8851fccSafresh1 PNfARG(name));
109691f110e0Safresh1 }
1097850e2753Smillert
109885009909Smillert STATIC PADOFFSET
S_pad_findlex(pTHX_ const char * namepv,STRLEN namelen,U32 flags,const CV * cv,U32 seq,int warn,SV ** out_capture,PADNAME ** out_name,int * out_flags)1099898184e3Ssthen S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1100b8851fccSafresh1 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
110185009909Smillert {
11029f11ffb7Safresh1 PADOFFSET offset, new_offset;
1103850e2753Smillert SV *new_capture;
1104850e2753Smillert SV **new_capturep;
110591f110e0Safresh1 const PADLIST * const padlist = CvPADLIST(cv);
1106*e0680481Safresh1 const bool staleok = cBOOL(flags & padadd_STALEOK);
1107*e0680481Safresh1 const bool fieldok = cBOOL(flags & padfind_FIELD_OK);
110885009909Smillert
110943003dfeSmillert PERL_ARGS_ASSERT_PAD_FINDLEX;
111043003dfeSmillert
1111*e0680481Safresh1 flags &= ~(padadd_STALEOK|padfind_FIELD_OK); /* one-shot flags */
1112b8851fccSafresh1 if (flags)
1113898184e3Ssthen Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1114898184e3Ssthen (UV)flags);
1115898184e3Ssthen
1116850e2753Smillert *out_flags = 0;
111785009909Smillert
111885009909Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1119898184e3Ssthen "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n",
1120898184e3Ssthen PTR2UV(cv), (int)namelen, namepv, (int)seq,
1121898184e3Ssthen out_capture ? " capturing" : "" ));
112285009909Smillert
1123850e2753Smillert /* first, search this pad */
112485009909Smillert
1125850e2753Smillert if (padlist) { /* not an undef CV */
11269f11ffb7Safresh1 PADOFFSET fake_offset = 0;
1127b8851fccSafresh1 const PADNAMELIST * const names = PadlistNAMES(padlist);
1128b8851fccSafresh1 PADNAME * const * const name_p = PadnamelistARRAY(names);
112985009909Smillert
1130b8851fccSafresh1 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1131b8851fccSafresh1 const PADNAME * const name = name_p[offset];
1132b8851fccSafresh1 if (name && PadnameLEN(name) == namelen
1133b8851fccSafresh1 && ( PadnamePV(name) == namepv
1134b8851fccSafresh1 || memEQ(PadnamePV(name), namepv, namelen) ))
113585009909Smillert {
1136b8851fccSafresh1 if (PadnameOUTER(name)) {
1137850e2753Smillert fake_offset = offset; /* in case we don't find a real one */
1138898184e3Ssthen continue;
1139898184e3Ssthen }
1140b8851fccSafresh1 if (PadnameIN_SCOPE(name, seq))
114185009909Smillert break;
114285009909Smillert }
114385009909Smillert }
1144850e2753Smillert
1145850e2753Smillert if (offset > 0 || fake_offset > 0 ) { /* a match! */
1146850e2753Smillert if (offset > 0) { /* not fake */
1147850e2753Smillert fake_offset = 0;
1148b8851fccSafresh1 *out_name = name_p[offset]; /* return the name */
1149850e2753Smillert
1150*e0680481Safresh1 if (PadnameIsFIELD(*out_name) && !fieldok)
1151*e0680481Safresh1 croak("Field %" SVf " is not accessible outside a method",
1152*e0680481Safresh1 SVfARG(PadnameSV(*out_name)));
1153*e0680481Safresh1
1154850e2753Smillert /* set PAD_FAKELEX_MULTI if this lex can have multiple
1155850e2753Smillert * instances. For now, we just test !CvUNIQUE(cv), but
1156850e2753Smillert * ideally, we should detect my's declared within loops
1157850e2753Smillert * etc - this would allow a wider range of 'not stayed
1158898184e3Ssthen * shared' warnings. We also treated already-compiled
1159850e2753Smillert * lexes as not multi as viewed from evals. */
1160850e2753Smillert
1161850e2753Smillert *out_flags = CvANON(cv) ?
1162850e2753Smillert PAD_FAKELEX_ANON :
1163850e2753Smillert (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1164850e2753Smillert ? PAD_FAKELEX_MULTI : 0;
1165850e2753Smillert
1166850e2753Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1167850e2753Smillert "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n",
1168850e2753Smillert PTR2UV(cv), (long)offset,
1169b8851fccSafresh1 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1170b8851fccSafresh1 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
117185009909Smillert }
1172850e2753Smillert else { /* fake match */
1173850e2753Smillert offset = fake_offset;
1174b8851fccSafresh1 *out_name = name_p[offset]; /* return the name */
1175b8851fccSafresh1 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1176850e2753Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1177850e2753Smillert "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n",
1178850e2753Smillert PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1179b8851fccSafresh1 (unsigned long) PARENT_PAD_INDEX(*out_name)
1180850e2753Smillert ));
118185009909Smillert }
1182850e2753Smillert
1183850e2753Smillert /* return the lex? */
1184850e2753Smillert
1185850e2753Smillert if (out_capture) {
1186850e2753Smillert
1187850e2753Smillert /* our ? */
1188b8851fccSafresh1 if (PadnameIsOUR(*out_name)) {
1189850e2753Smillert *out_capture = NULL;
1190850e2753Smillert return offset;
1191850e2753Smillert }
1192850e2753Smillert
1193850e2753Smillert /* trying to capture from an anon prototype? */
1194850e2753Smillert if (CvCOMPILED(cv)
1195850e2753Smillert ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1196850e2753Smillert : *out_flags & PAD_FAKELEX_ANON)
119785009909Smillert {
1198b39c5158Smillert if (warn)
119991f110e0Safresh1 S_unavailable(aTHX_
1200b8851fccSafresh1 *out_name);
1201898184e3Ssthen
1202850e2753Smillert *out_capture = NULL;
1203850e2753Smillert }
1204850e2753Smillert
1205850e2753Smillert /* real value */
1206850e2753Smillert else {
1207850e2753Smillert int newwarn = warn;
1208850e2753Smillert if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1209b8851fccSafresh1 && !PadnameIsSTATE(name_p[offset])
1210850e2753Smillert && warn && ckWARN(WARN_CLOSURE)) {
1211850e2753Smillert newwarn = 0;
1212b8851fccSafresh1 /* diag_listed_as: Variable "%s" will not stay
1213b8851fccSafresh1 shared */
121485009909Smillert Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
121556d68f1eSafresh1 "%s \"%" UTF8f "\" will not stay shared",
121656d68f1eSafresh1 *namepv == '&' ? "Subroutine" : "Variable",
1217b8851fccSafresh1 UTF8fARG(1, namelen, namepv));
121885009909Smillert }
1219850e2753Smillert
1220850e2753Smillert if (fake_offset && CvANON(cv)
1221850e2753Smillert && CvCLONE(cv) &&!CvCLONED(cv))
1222850e2753Smillert {
1223b8851fccSafresh1 PADNAME *n;
1224850e2753Smillert /* not yet caught - look further up */
122585009909Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1226850e2753Smillert "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n",
1227850e2753Smillert PTR2UV(cv)));
1228b8851fccSafresh1 n = *out_name;
1229898184e3Ssthen (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1230850e2753Smillert CvOUTSIDE_SEQ(cv),
1231b8851fccSafresh1 newwarn, out_capture, out_name, out_flags);
1232b8851fccSafresh1 *out_name = n;
1233850e2753Smillert return offset;
1234850e2753Smillert }
1235850e2753Smillert
123691f110e0Safresh1 *out_capture = AvARRAY(PadlistARRAY(padlist)[
123791f110e0Safresh1 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1238850e2753Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1239850e2753Smillert "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n",
1240850e2753Smillert PTR2UV(cv), PTR2UV(*out_capture)));
1241850e2753Smillert
124243003dfeSmillert if (SvPADSTALE(*out_capture)
124391f110e0Safresh1 && (!CvDEPTH(cv) || !staleok)
1244b8851fccSafresh1 && !PadnameIsSTATE(name_p[offset]))
124543003dfeSmillert {
124691f110e0Safresh1 S_unavailable(aTHX_
1247b8851fccSafresh1 name_p[offset]);
1248850e2753Smillert *out_capture = NULL;
1249850e2753Smillert }
1250850e2753Smillert }
1251850e2753Smillert if (!*out_capture) {
1252898184e3Ssthen if (namelen != 0 && *namepv == '@')
1253eac174f2Safresh1 *out_capture = newSV_type_mortal(SVt_PVAV);
1254898184e3Ssthen else if (namelen != 0 && *namepv == '%')
1255eac174f2Safresh1 *out_capture = newSV_type_mortal(SVt_PVHV);
125691f110e0Safresh1 else if (namelen != 0 && *namepv == '&')
1257eac174f2Safresh1 *out_capture = newSV_type_mortal(SVt_PVCV);
1258850e2753Smillert else
1259eac174f2Safresh1 *out_capture = newSV_type_mortal(SVt_NULL);
1260850e2753Smillert }
1261850e2753Smillert }
1262850e2753Smillert
1263850e2753Smillert return offset;
1264850e2753Smillert }
1265850e2753Smillert }
1266850e2753Smillert
1267850e2753Smillert /* it's not in this pad - try above */
1268850e2753Smillert
1269850e2753Smillert if (!CvOUTSIDE(cv))
1270850e2753Smillert return NOT_IN_PAD;
1271850e2753Smillert
1272850e2753Smillert /* out_capture non-null means caller wants us to capture lex; in
1273850e2753Smillert * addition we capture ourselves unless it's an ANON/format */
1274850e2753Smillert new_capturep = out_capture ? out_capture :
1275850e2753Smillert CvLATE(cv) ? NULL : &new_capture;
1276850e2753Smillert
1277*e0680481Safresh1 U32 recurse_flags = flags;
1278*e0680481Safresh1 if(new_capturep == &new_capture)
1279*e0680481Safresh1 recurse_flags |= padadd_STALEOK;
1280*e0680481Safresh1 if(CvIsMETHOD(cv))
1281*e0680481Safresh1 recurse_flags |= padfind_FIELD_OK;
1282*e0680481Safresh1
1283*e0680481Safresh1 offset = pad_findlex(namepv, namelen, recurse_flags,
128491f110e0Safresh1 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1285b8851fccSafresh1 new_capturep, out_name, out_flags);
12869f11ffb7Safresh1 if (offset == NOT_IN_PAD)
1287850e2753Smillert return NOT_IN_PAD;
1288850e2753Smillert
1289*e0680481Safresh1 if (PadnameIsFIELD(*out_name)) {
1290*e0680481Safresh1 HV *fieldstash = PadnameFIELDINFO(*out_name)->fieldstash;
1291*e0680481Safresh1
1292*e0680481Safresh1 /* fields are only visible to the class that declared them */
1293*e0680481Safresh1 if(fieldstash != PL_curstash)
1294*e0680481Safresh1 croak("Field %" SVf " of %" HvNAMEf_QUOTEDPREFIX " is not accessible in a method of %" HvNAMEf_QUOTEDPREFIX,
1295*e0680481Safresh1 SVfARG(PadnameSV(*out_name)), HvNAMEfARG(fieldstash), HvNAMEfARG(PL_curstash));
1296*e0680481Safresh1 }
1297*e0680481Safresh1
1298850e2753Smillert /* found in an outer CV. Add appropriate fake entry to this pad */
1299850e2753Smillert
1300850e2753Smillert /* don't add new fake entries (via eval) to CVs that we have already
1301850e2753Smillert * finished compiling, or to undef CVs */
1302850e2753Smillert if (CvCOMPILED(cv) || !padlist)
1303850e2753Smillert return 0; /* this dummy (and invalid) value isnt used by the caller */
1304850e2753Smillert
1305850e2753Smillert {
1306b8851fccSafresh1 PADNAME *new_name = newPADNAMEouter(*out_name);
1307b8851fccSafresh1 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1308850e2753Smillert PAD * const ocomppad = PL_comppad;
1309b8851fccSafresh1 PL_comppad_name = PadlistNAMES(padlist);
131091f110e0Safresh1 PL_comppad = PadlistARRAY(padlist)[1];
1311850e2753Smillert PL_curpad = AvARRAY(PL_comppad);
1312850e2753Smillert
1313b39c5158Smillert new_offset
1314b8851fccSafresh1 = pad_alloc_name(new_name,
1315b8851fccSafresh1 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1316b8851fccSafresh1 PadnameTYPE(*out_name),
1317b8851fccSafresh1 PadnameOURSTASH(*out_name)
131885009909Smillert );
1319850e2753Smillert
1320b39c5158Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1321b39c5158Smillert "Pad addname: %ld \"%.*s\" FAKE\n",
1322b39c5158Smillert (long)new_offset,
1323b8851fccSafresh1 (int) PadnameLEN(new_name),
1324b8851fccSafresh1 PadnamePV(new_name)));
1325b8851fccSafresh1 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1326850e2753Smillert
1327b8851fccSafresh1 PARENT_PAD_INDEX_set(new_name, 0);
1328b8851fccSafresh1 if (PadnameIsOUR(new_name)) {
1329850e2753Smillert NOOP; /* do nothing */
1330850e2753Smillert }
1331850e2753Smillert else if (CvLATE(cv)) {
1332850e2753Smillert /* delayed creation - just note the offset within parent pad */
1333b8851fccSafresh1 PARENT_PAD_INDEX_set(new_name, offset);
1334850e2753Smillert CvCLONE_on(cv);
1335850e2753Smillert }
1336850e2753Smillert else {
1337850e2753Smillert /* immediate creation - capture outer value right now */
1338850e2753Smillert av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
133991f110e0Safresh1 /* But also note the offset, as newMYSUB needs it */
1340b8851fccSafresh1 PARENT_PAD_INDEX_set(new_name, offset);
1341850e2753Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1342850e2753Smillert "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n",
1343850e2753Smillert PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1344850e2753Smillert }
1345b8851fccSafresh1 *out_name = new_name;
1346b8851fccSafresh1 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1347850e2753Smillert
1348850e2753Smillert PL_comppad_name = ocomppad_name;
1349850e2753Smillert PL_comppad = ocomppad;
1350850e2753Smillert PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1351850e2753Smillert }
1352850e2753Smillert return new_offset;
135385009909Smillert }
135485009909Smillert
1355850e2753Smillert #ifdef DEBUGGING
135685009909Smillert
1357898184e3Ssthen /*
135856d68f1eSafresh1 =for apidoc pad_sv
1359898184e3Ssthen
1360b8851fccSafresh1 Get the value at offset C<po> in the current (compiling or executing) pad.
1361b8851fccSafresh1 Use macro C<PAD_SV> instead of calling this function directly.
136285009909Smillert
136385009909Smillert =cut
136485009909Smillert */
136585009909Smillert
136685009909Smillert SV *
Perl_pad_sv(pTHX_ PADOFFSET po)136785009909Smillert Perl_pad_sv(pTHX_ PADOFFSET po)
136885009909Smillert {
136985009909Smillert ASSERT_CURPAD_ACTIVE("pad_sv");
137085009909Smillert
137185009909Smillert if (!po)
137285009909Smillert Perl_croak(aTHX_ "panic: pad_sv po");
137385009909Smillert DEBUG_X(PerlIO_printf(Perl_debug_log,
137485009909Smillert "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n",
137585009909Smillert PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
137685009909Smillert );
137785009909Smillert return PL_curpad[po];
137885009909Smillert }
137985009909Smillert
138085009909Smillert /*
138156d68f1eSafresh1 =for apidoc pad_setsv
138285009909Smillert
1383b8851fccSafresh1 Set the value at offset C<po> in the current (compiling or executing) pad.
1384b8851fccSafresh1 Use the macro C<PAD_SETSV()> rather than calling this function directly.
138585009909Smillert
138685009909Smillert =cut
138785009909Smillert */
138885009909Smillert
138985009909Smillert void
Perl_pad_setsv(pTHX_ PADOFFSET po,SV * sv)139085009909Smillert Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
139185009909Smillert {
139243003dfeSmillert PERL_ARGS_ASSERT_PAD_SETSV;
139343003dfeSmillert
139485009909Smillert ASSERT_CURPAD_ACTIVE("pad_setsv");
139585009909Smillert
139685009909Smillert DEBUG_X(PerlIO_printf(Perl_debug_log,
139785009909Smillert "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n",
139885009909Smillert PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
139985009909Smillert );
140085009909Smillert PL_curpad[po] = sv;
140185009909Smillert }
140285009909Smillert
1403898184e3Ssthen #endif /* DEBUGGING */
140485009909Smillert
140585009909Smillert /*
140656d68f1eSafresh1 =for apidoc pad_block_start
140785009909Smillert
140891f110e0Safresh1 Update the pad compilation state variables on entry to a new block.
140985009909Smillert
141085009909Smillert =cut
141185009909Smillert */
141285009909Smillert
141385009909Smillert void
Perl_pad_block_start(pTHX_ int full)141485009909Smillert Perl_pad_block_start(pTHX_ int full)
141585009909Smillert {
141685009909Smillert ASSERT_CURPAD_ACTIVE("pad_block_start");
1417eac174f2Safresh1 SAVESTRLEN(PL_comppad_name_floor);
1418b8851fccSafresh1 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
141985009909Smillert if (full)
142085009909Smillert PL_comppad_name_fill = PL_comppad_name_floor;
142185009909Smillert if (PL_comppad_name_floor < 0)
142285009909Smillert PL_comppad_name_floor = 0;
1423eac174f2Safresh1 SAVESTRLEN(PL_min_intro_pending);
1424eac174f2Safresh1 SAVESTRLEN(PL_max_intro_pending);
142585009909Smillert PL_min_intro_pending = 0;
1426eac174f2Safresh1 SAVESTRLEN(PL_comppad_name_fill);
1427eac174f2Safresh1 SAVESTRLEN(PL_padix_floor);
1428b8851fccSafresh1 /* PL_padix_floor is what PL_padix is reset to at the start of each
1429b8851fccSafresh1 statement, by pad_reset(). We set it when entering a new scope
1430b8851fccSafresh1 to keep things like this working:
1431b8851fccSafresh1 print "$foo$bar", do { this(); that() . "foo" };
1432b8851fccSafresh1 We must not let "$foo$bar" and the later concatenation share the
1433b8851fccSafresh1 same target. */
143485009909Smillert PL_padix_floor = PL_padix;
143585009909Smillert PL_pad_reset_pending = FALSE;
143685009909Smillert }
143785009909Smillert
143885009909Smillert /*
143956d68f1eSafresh1 =for apidoc intro_my
144085009909Smillert
1441b8851fccSafresh1 "Introduce" C<my> variables to visible status. This is called during parsing
1442b8851fccSafresh1 at the end of each statement to make lexical variables visible to subsequent
1443b8851fccSafresh1 statements.
144485009909Smillert
144585009909Smillert =cut
144685009909Smillert */
144785009909Smillert
144885009909Smillert U32
Perl_intro_my(pTHX)144985009909Smillert Perl_intro_my(pTHX)
145085009909Smillert {
1451b8851fccSafresh1 PADNAME **svp;
14529f11ffb7Safresh1 PADOFFSET i;
1453898184e3Ssthen U32 seq;
145485009909Smillert
145585009909Smillert ASSERT_CURPAD_ACTIVE("intro_my");
1456b8851fccSafresh1 if (PL_compiling.cop_seq) {
1457b8851fccSafresh1 seq = PL_compiling.cop_seq;
1458b8851fccSafresh1 PL_compiling.cop_seq = 0;
1459b8851fccSafresh1 }
1460b8851fccSafresh1 else
1461b8851fccSafresh1 seq = PL_cop_seqmax;
146285009909Smillert if (! PL_min_intro_pending)
1463b8851fccSafresh1 return seq;
146485009909Smillert
1465b8851fccSafresh1 svp = PadnamelistARRAY(PL_comppad_name);
146685009909Smillert for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1467b8851fccSafresh1 PADNAME * const sv = svp[i];
146852bd00bfSmillert
1469b8851fccSafresh1 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1470898184e3Ssthen && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1471898184e3Ssthen {
1472898184e3Ssthen COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1473850e2753Smillert COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
147485009909Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147585009909Smillert "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1476b8851fccSafresh1 (long)i, PadnamePV(sv),
1477850e2753Smillert (unsigned long)COP_SEQ_RANGE_LOW(sv),
1478850e2753Smillert (unsigned long)COP_SEQ_RANGE_HIGH(sv))
147985009909Smillert );
148085009909Smillert }
148185009909Smillert }
1482b8851fccSafresh1 COP_SEQMAX_INC;
148385009909Smillert PL_min_intro_pending = 0;
148485009909Smillert PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
148585009909Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1486898184e3Ssthen "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
148785009909Smillert
1488898184e3Ssthen return seq;
148985009909Smillert }
149085009909Smillert
149185009909Smillert /*
149256d68f1eSafresh1 =for apidoc pad_leavemy
149385009909Smillert
149485009909Smillert Cleanup at end of scope during compilation: set the max seq number for
149585009909Smillert lexicals in this scope and warn of any lexicals that never got introduced.
149685009909Smillert
149785009909Smillert =cut
149885009909Smillert */
149985009909Smillert
150091f110e0Safresh1 OP *
Perl_pad_leavemy(pTHX)150185009909Smillert Perl_pad_leavemy(pTHX)
150285009909Smillert {
15039f11ffb7Safresh1 PADOFFSET off;
150491f110e0Safresh1 OP *o = NULL;
1505b8851fccSafresh1 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
150685009909Smillert
150785009909Smillert PL_pad_reset_pending = FALSE;
150885009909Smillert
150985009909Smillert ASSERT_CURPAD_ACTIVE("pad_leavemy");
151085009909Smillert if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
151185009909Smillert for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1512b8851fccSafresh1 const PADNAME * const name = svp[off];
1513b8851fccSafresh1 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1514b39c5158Smillert Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1515b8851fccSafresh1 "%" PNf " never introduced",
1516b8851fccSafresh1 PNfARG(name));
151785009909Smillert }
151885009909Smillert }
151985009909Smillert /* "Deintroduce" my variables that are leaving with this scope. */
1520b8851fccSafresh1 for (off = PadnamelistMAX(PL_comppad_name);
1521b8851fccSafresh1 off > PL_comppad_name_fill; off--) {
1522b8851fccSafresh1 PADNAME * const sv = svp[off];
1523b8851fccSafresh1 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1524898184e3Ssthen && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1525898184e3Ssthen {
1526850e2753Smillert COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
152785009909Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
152885009909Smillert "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1529b8851fccSafresh1 (long)off, PadnamePV(sv),
1530850e2753Smillert (unsigned long)COP_SEQ_RANGE_LOW(sv),
1531850e2753Smillert (unsigned long)COP_SEQ_RANGE_HIGH(sv))
153285009909Smillert );
153391f110e0Safresh1 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
153491f110e0Safresh1 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
153591f110e0Safresh1 OP *kid = newOP(OP_INTROCV, 0);
153691f110e0Safresh1 kid->op_targ = off;
153791f110e0Safresh1 o = op_prepend_elem(OP_LINESEQ, kid, o);
153891f110e0Safresh1 }
153985009909Smillert }
154085009909Smillert }
1541b8851fccSafresh1 COP_SEQMAX_INC;
154285009909Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
154385009909Smillert "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
154491f110e0Safresh1 return o;
154585009909Smillert }
154685009909Smillert
154785009909Smillert /*
154856d68f1eSafresh1 =for apidoc pad_swipe
154985009909Smillert
1550b8851fccSafresh1 Abandon the tmp in the current pad at offset C<po> and replace with a
155185009909Smillert new one.
155285009909Smillert
155385009909Smillert =cut
155485009909Smillert */
155585009909Smillert
155685009909Smillert void
Perl_pad_swipe(pTHX_ PADOFFSET po,bool refadjust)155785009909Smillert Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
155885009909Smillert {
155985009909Smillert ASSERT_CURPAD_LEGAL("pad_swipe");
156085009909Smillert if (!PL_curpad)
156185009909Smillert return;
156285009909Smillert if (AvARRAY(PL_comppad) != PL_curpad)
1563898184e3Ssthen Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1564898184e3Ssthen AvARRAY(PL_comppad), PL_curpad);
1565898184e3Ssthen if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1566898184e3Ssthen Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1567898184e3Ssthen (long)po, (long)AvFILLp(PL_comppad));
156885009909Smillert
156985009909Smillert DEBUG_X(PerlIO_printf(Perl_debug_log,
157085009909Smillert "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n",
157185009909Smillert PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
157285009909Smillert
157385009909Smillert if (refadjust)
157485009909Smillert SvREFCNT_dec(PL_curpad[po]);
157585009909Smillert
157652bd00bfSmillert
157752bd00bfSmillert /* if pad tmps aren't shared between ops, then there's no need to
157852bd00bfSmillert * create a new tmp when an existing op is freed */
1579b8851fccSafresh1 #ifdef USE_PAD_RESET
1580eac174f2Safresh1 PL_curpad[po] = newSV_type(SVt_NULL);
158185009909Smillert SvPADTMP_on(PL_curpad[po]);
158252bd00bfSmillert #else
15836fb12b70Safresh1 PL_curpad[po] = NULL;
158452bd00bfSmillert #endif
15856fb12b70Safresh1 if (PadnamelistMAX(PL_comppad_name) != -1
15866fb12b70Safresh1 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
15876fb12b70Safresh1 if (PadnamelistARRAY(PL_comppad_name)[po]) {
15886fb12b70Safresh1 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
15896fb12b70Safresh1 }
1590b8851fccSafresh1 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
15916fb12b70Safresh1 }
1592b8851fccSafresh1 /* Use PL_constpadix here, not PL_padix. The latter may have been
1593b8851fccSafresh1 reset by pad_reset. We don’t want pad_alloc to have to scan the
1594b8851fccSafresh1 whole pad when allocating a constant. */
15959f11ffb7Safresh1 if (po < PL_constpadix)
1596b8851fccSafresh1 PL_constpadix = po - 1;
159785009909Smillert }
159885009909Smillert
159985009909Smillert /*
160056d68f1eSafresh1 =for apidoc pad_reset
160185009909Smillert
160285009909Smillert Mark all the current temporaries for reuse
160385009909Smillert
160485009909Smillert =cut
160585009909Smillert */
160685009909Smillert
1607b8851fccSafresh1 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1608b8851fccSafresh1 * between OPs from different statements. During compilation, at the start
1609b8851fccSafresh1 * of each statement pad_reset resets PL_padix back to its previous value.
1610b8851fccSafresh1 * When allocating a target, pad_alloc begins its scan through the pad at
1611b8851fccSafresh1 * PL_padix+1. */
1612b39c5158Smillert static void
S_pad_reset(pTHX)1613b39c5158Smillert S_pad_reset(pTHX)
161485009909Smillert {
1615b8851fccSafresh1 #ifdef USE_PAD_RESET
161685009909Smillert if (AvARRAY(PL_comppad) != PL_curpad)
1617898184e3Ssthen Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1618898184e3Ssthen AvARRAY(PL_comppad), PL_curpad);
161985009909Smillert
162085009909Smillert DEBUG_X(PerlIO_printf(Perl_debug_log,
162185009909Smillert "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld",
162285009909Smillert PTR2UV(PL_comppad), PTR2UV(PL_curpad),
162385009909Smillert (long)PL_padix, (long)PL_padix_floor
162485009909Smillert )
162585009909Smillert );
162685009909Smillert
162791f110e0Safresh1 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
162885009909Smillert PL_padix = PL_padix_floor;
162985009909Smillert }
163085009909Smillert #endif
163185009909Smillert PL_pad_reset_pending = FALSE;
163285009909Smillert }
163385009909Smillert
163485009909Smillert /*
163556d68f1eSafresh1 =for apidoc pad_tidy
163685009909Smillert
1637898184e3Ssthen Tidy up a pad at the end of compilation of the code to which it belongs.
1638898184e3Ssthen Jobs performed here are: remove most stuff from the pads of anonsub
1639b8851fccSafresh1 prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
1640898184e3Ssthen the kind of subroutine:
1641898184e3Ssthen
1642898184e3Ssthen padtidy_SUB ordinary subroutine
1643898184e3Ssthen padtidy_SUBCLONE prototype for lexical closure
1644898184e3Ssthen padtidy_FORMAT format
164585009909Smillert
164685009909Smillert =cut
164785009909Smillert */
164885009909Smillert
164985009909Smillert void
Perl_pad_tidy(pTHX_ padtidy_type type)165085009909Smillert Perl_pad_tidy(pTHX_ padtidy_type type)
165185009909Smillert {
165285009909Smillert
165385009909Smillert ASSERT_CURPAD_ACTIVE("pad_tidy");
1654850e2753Smillert
165591f110e0Safresh1 /* If this CV has had any 'eval-capable' ops planted in it:
165691f110e0Safresh1 * i.e. it contains any of:
165791f110e0Safresh1 *
165891f110e0Safresh1 * * eval '...',
165991f110e0Safresh1 * * //ee,
166091f110e0Safresh1 * * use re 'eval'; /$var/
166191f110e0Safresh1 * * /(?{..})/),
166291f110e0Safresh1 *
166391f110e0Safresh1 * Then any anon prototypes in the chain of CVs should be marked as
166491f110e0Safresh1 * cloneable, so that for example the eval's CV in
166591f110e0Safresh1 *
166691f110e0Safresh1 * sub { eval '$x' }
166791f110e0Safresh1 *
166891f110e0Safresh1 * gets the right CvOUTSIDE. If running with -d, *any* sub may
166991f110e0Safresh1 * potentially have an eval executed within it.
1670850e2753Smillert */
1671850e2753Smillert
1672850e2753Smillert if (PL_cv_has_eval || PL_perldb) {
1673850e2753Smillert const CV *cv;
1674850e2753Smillert for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1675850e2753Smillert if (cv != PL_compcv && CvCOMPILED(cv))
1676850e2753Smillert break; /* no need to mark already-compiled code */
1677850e2753Smillert if (CvANON(cv)) {
1678850e2753Smillert DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1679850e2753Smillert "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
1680850e2753Smillert CvCLONE_on(cv);
1681850e2753Smillert }
168291f110e0Safresh1 CvHASEVAL_on(cv);
1683850e2753Smillert }
1684850e2753Smillert }
1685850e2753Smillert
16866fb12b70Safresh1 /* extend namepad to match curpad */
1687b8851fccSafresh1 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1688b8851fccSafresh1 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
168985009909Smillert
169085009909Smillert if (type == padtidy_SUBCLONE) {
1691b8851fccSafresh1 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
169252bd00bfSmillert PADOFFSET ix;
1693850e2753Smillert
169485009909Smillert for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1695b8851fccSafresh1 PADNAME *namesv;
1696b8851fccSafresh1 if (!namep[ix]) namep[ix] = &PL_padname_undef;
169785009909Smillert
169885009909Smillert /*
169985009909Smillert * The only things that a clonable function needs in its
17006fb12b70Safresh1 * pad are anonymous subs, constants and GVs.
170185009909Smillert * The rest are created anew during cloning.
170285009909Smillert */
1703b8851fccSafresh1 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
17046fb12b70Safresh1 continue;
17056fb12b70Safresh1 namesv = namep[ix];
17066fb12b70Safresh1 if (!(PadnamePV(namesv) &&
1707b8851fccSafresh1 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
170885009909Smillert {
170985009909Smillert SvREFCNT_dec(PL_curpad[ix]);
1710850e2753Smillert PL_curpad[ix] = NULL;
171185009909Smillert }
171285009909Smillert }
171385009909Smillert }
171485009909Smillert else if (type == padtidy_SUB) {
171552bd00bfSmillert AV * const av = newAV(); /* Will be @_ */
171643003dfeSmillert av_store(PL_comppad, 0, MUTABLE_SV(av));
1717850e2753Smillert AvREIFY_only(av);
171885009909Smillert }
171985009909Smillert
1720898184e3Ssthen if (type == padtidy_SUB || type == padtidy_FORMAT) {
1721b8851fccSafresh1 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
172252bd00bfSmillert PADOFFSET ix;
172385009909Smillert for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1724b8851fccSafresh1 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1725b8851fccSafresh1 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
172685009909Smillert continue;
1727b8851fccSafresh1 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1728898184e3Ssthen /* This is a work around for how the current implementation of
1729898184e3Ssthen ?{ } blocks in regexps interacts with lexicals.
1730898184e3Ssthen
1731898184e3Ssthen One of our lexicals.
1732898184e3Ssthen Can't do this on all lexicals, otherwise sub baz() won't
1733898184e3Ssthen compile in
1734898184e3Ssthen
1735898184e3Ssthen my $foo;
1736898184e3Ssthen
1737898184e3Ssthen sub bar { ++$foo; }
1738898184e3Ssthen
1739898184e3Ssthen sub baz { ++$foo; }
1740898184e3Ssthen
1741898184e3Ssthen because completion of compiling &bar calling pad_tidy()
1742898184e3Ssthen would cause (top level) $foo to be marked as stale, and
1743898184e3Ssthen "no longer available". */
1744898184e3Ssthen SvPADSTALE_on(PL_curpad[ix]);
174585009909Smillert }
174685009909Smillert }
174785009909Smillert }
174885009909Smillert PL_curpad = AvARRAY(PL_comppad);
174985009909Smillert }
175085009909Smillert
175185009909Smillert /*
175256d68f1eSafresh1 =for apidoc pad_free
175385009909Smillert
175452bd00bfSmillert Free the SV at offset po in the current pad.
175585009909Smillert
175685009909Smillert =cut
175785009909Smillert */
175885009909Smillert
175985009909Smillert void
Perl_pad_free(pTHX_ PADOFFSET po)176085009909Smillert Perl_pad_free(pTHX_ PADOFFSET po)
176185009909Smillert {
1762b8851fccSafresh1 #ifndef USE_PAD_RESET
176391f110e0Safresh1 SV *sv;
1764b8851fccSafresh1 #endif
176585009909Smillert ASSERT_CURPAD_LEGAL("pad_free");
176685009909Smillert if (!PL_curpad)
176785009909Smillert return;
176885009909Smillert if (AvARRAY(PL_comppad) != PL_curpad)
1769898184e3Ssthen Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1770898184e3Ssthen AvARRAY(PL_comppad), PL_curpad);
177185009909Smillert if (!po)
177285009909Smillert Perl_croak(aTHX_ "panic: pad_free po");
177385009909Smillert
177485009909Smillert DEBUG_X(PerlIO_printf(Perl_debug_log,
177585009909Smillert "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
177685009909Smillert PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
177785009909Smillert );
177885009909Smillert
1779b8851fccSafresh1 #ifndef USE_PAD_RESET
178091f110e0Safresh1 sv = PL_curpad[po];
178191f110e0Safresh1 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
178291f110e0Safresh1 SvFLAGS(sv) &= ~SVs_PADTMP;
178391f110e0Safresh1
17849f11ffb7Safresh1 if (po < PL_padix)
178585009909Smillert PL_padix = po - 1;
1786b8851fccSafresh1 #endif
178785009909Smillert }
178885009909Smillert
178985009909Smillert /*
179056d68f1eSafresh1 =for apidoc do_dump_pad
179185009909Smillert
179285009909Smillert Dump the contents of a padlist
179385009909Smillert
179485009909Smillert =cut
179585009909Smillert */
179685009909Smillert
179785009909Smillert void
Perl_do_dump_pad(pTHX_ I32 level,PerlIO * file,PADLIST * padlist,int full)179885009909Smillert Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
179985009909Smillert {
1800b8851fccSafresh1 const PADNAMELIST *pad_name;
180152bd00bfSmillert const AV *pad;
1802b8851fccSafresh1 PADNAME **pname;
180385009909Smillert SV **ppad;
18049f11ffb7Safresh1 PADOFFSET ix;
180585009909Smillert
180643003dfeSmillert PERL_ARGS_ASSERT_DO_DUMP_PAD;
180743003dfeSmillert
180885009909Smillert if (!padlist) {
180985009909Smillert return;
181085009909Smillert }
1811b8851fccSafresh1 pad_name = PadlistNAMES(padlist);
181291f110e0Safresh1 pad = PadlistARRAY(padlist)[1];
1813b8851fccSafresh1 pname = PadnamelistARRAY(pad_name);
181485009909Smillert ppad = AvARRAY(pad);
181585009909Smillert Perl_dump_indent(aTHX_ level, file,
181685009909Smillert "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
181785009909Smillert PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
181885009909Smillert );
181985009909Smillert
1820b8851fccSafresh1 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1821b8851fccSafresh1 const PADNAME *namesv = pname[ix];
18226fb12b70Safresh1 if (namesv && !PadnameLEN(namesv)) {
1823850e2753Smillert namesv = NULL;
182485009909Smillert }
182585009909Smillert if (namesv) {
1826b8851fccSafresh1 if (PadnameOUTER(namesv))
182785009909Smillert Perl_dump_indent(aTHX_ level+1, file,
1828850e2753Smillert "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
182985009909Smillert (int) ix,
183085009909Smillert PTR2UV(ppad[ix]),
183185009909Smillert (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1832b8851fccSafresh1 PadnamePV(namesv),
1833850e2753Smillert (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1834850e2753Smillert (unsigned long)PARENT_PAD_INDEX(namesv)
1835850e2753Smillert
183685009909Smillert );
183785009909Smillert else
183885009909Smillert Perl_dump_indent(aTHX_ level+1, file,
183985009909Smillert "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
184085009909Smillert (int) ix,
184185009909Smillert PTR2UV(ppad[ix]),
184285009909Smillert (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1843850e2753Smillert (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1844850e2753Smillert (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1845b8851fccSafresh1 PadnamePV(namesv)
184685009909Smillert );
184785009909Smillert }
184885009909Smillert else if (full) {
184985009909Smillert Perl_dump_indent(aTHX_ level+1, file,
185085009909Smillert "%2d. 0x%" UVxf "<%lu>\n",
185185009909Smillert (int) ix,
185285009909Smillert PTR2UV(ppad[ix]),
185385009909Smillert (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
185485009909Smillert );
185585009909Smillert }
185685009909Smillert }
185785009909Smillert }
185885009909Smillert
1859898184e3Ssthen #ifdef DEBUGGING
186085009909Smillert
186185009909Smillert /*
186256d68f1eSafresh1 =for apidoc cv_dump
186385009909Smillert
186485009909Smillert dump the contents of a CV
186585009909Smillert
186685009909Smillert =cut
186785009909Smillert */
186885009909Smillert
186985009909Smillert STATIC void
S_cv_dump(pTHX_ const CV * cv,const char * title)187052bd00bfSmillert S_cv_dump(pTHX_ const CV *cv, const char *title)
187185009909Smillert {
187252bd00bfSmillert const CV * const outside = CvOUTSIDE(cv);
187385009909Smillert
187443003dfeSmillert PERL_ARGS_ASSERT_CV_DUMP;
187543003dfeSmillert
187685009909Smillert PerlIO_printf(Perl_debug_log,
187785009909Smillert " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
187885009909Smillert title,
187985009909Smillert PTR2UV(cv),
188085009909Smillert (CvANON(cv) ? "ANON"
1881850e2753Smillert : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
188285009909Smillert : (cv == PL_main_cv) ? "MAIN"
188385009909Smillert : CvUNIQUE(cv) ? "UNIQUE"
188485009909Smillert : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
188585009909Smillert PTR2UV(outside),
188685009909Smillert (!outside ? "null"
188785009909Smillert : CvANON(outside) ? "ANON"
188885009909Smillert : (outside == PL_main_cv) ? "MAIN"
188985009909Smillert : CvUNIQUE(outside) ? "UNIQUE"
189085009909Smillert : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
189185009909Smillert
1892eac174f2Safresh1 if (!CvISXSUB(cv)) {
1893eac174f2Safresh1 /* SVPADLIST(cv) will fail an assert if CvISXSUB(cv) is true,
1894eac174f2Safresh1 * and if the assert is removed this code will SEGV. XSUBs don't
1895eac174f2Safresh1 * have padlists I believe - Yves */
1896eac174f2Safresh1 PADLIST* const padlist = CvPADLIST(cv);
189785009909Smillert PerlIO_printf(Perl_debug_log,
189885009909Smillert " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
189985009909Smillert do_dump_pad(1, Perl_debug_log, padlist, 1);
190085009909Smillert }
1901eac174f2Safresh1 }
1902898184e3Ssthen
190385009909Smillert #endif /* DEBUGGING */
190485009909Smillert
190585009909Smillert /*
190656d68f1eSafresh1 =for apidoc cv_clone
190785009909Smillert
1908b8851fccSafresh1 Clone a CV, making a lexical closure. C<proto> supplies the prototype
1909898184e3Ssthen of the function: its code, pad structure, and other attributes.
1910898184e3Ssthen The prototype is combined with a capture of outer lexicals to which the
1911898184e3Ssthen code refers, which are taken from the currently-executing instance of
1912898184e3Ssthen the immediately surrounding code.
191385009909Smillert
191485009909Smillert =cut
191585009909Smillert */
191685009909Smillert
1917b8851fccSafresh1 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
191891f110e0Safresh1
1919b8851fccSafresh1 static CV *
S_cv_clone_pad(pTHX_ CV * proto,CV * cv,CV * outside,HV * cloned,bool newcv)1920b8851fccSafresh1 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1921b8851fccSafresh1 bool newcv)
192285009909Smillert {
19239f11ffb7Safresh1 PADOFFSET ix;
192491f110e0Safresh1 PADLIST* const protopadlist = CvPADLIST(proto);
1925b8851fccSafresh1 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
192691f110e0Safresh1 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1927b8851fccSafresh1 PADNAME** const pname = PadnamelistARRAY(protopad_name);
192852bd00bfSmillert SV** const ppad = AvARRAY(protopad);
19299f11ffb7Safresh1 const PADOFFSET fname = PadnamelistMAX(protopad_name);
19309f11ffb7Safresh1 const PADOFFSET fpad = AvFILLp(protopad);
1931850e2753Smillert SV** outpad;
1932850e2753Smillert long depth;
1933b8851fccSafresh1 U32 subclones = 0;
1934b8851fccSafresh1 bool trouble = FALSE;
193543003dfeSmillert
193685009909Smillert assert(!CvUNIQUE(proto));
193785009909Smillert
193891f110e0Safresh1 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
193991f110e0Safresh1 * reliable. The currently-running sub is always the one we need to
194091f110e0Safresh1 * close over.
194191f110e0Safresh1 * For my subs, the currently-running sub may not be the one we want.
194291f110e0Safresh1 * We have to check whether it is a clone of CvOUTSIDE.
194391f110e0Safresh1 * Note that in general for formats, CvOUTSIDE != find_runcv.
194491f110e0Safresh1 * Since formats may be nested inside closures, CvOUTSIDE may point
1945850e2753Smillert * to a prototype; we instead want the cloned parent who called us.
1946898184e3Ssthen */
1947850e2753Smillert
194891f110e0Safresh1 if (!outside) {
194991f110e0Safresh1 if (CvWEAKOUTSIDE(proto))
1950850e2753Smillert outside = find_runcv(NULL);
195191f110e0Safresh1 else {
1952898184e3Ssthen outside = CvOUTSIDE(proto);
195391f110e0Safresh1 if ((CvCLONE(outside) && ! CvCLONED(outside))
195491f110e0Safresh1 || !CvPADLIST(outside)
1955b8851fccSafresh1 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
195691f110e0Safresh1 outside = find_runcv_where(
195791f110e0Safresh1 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
195891f110e0Safresh1 );
195991f110e0Safresh1 /* outside could be null */
196091f110e0Safresh1 }
196191f110e0Safresh1 }
196291f110e0Safresh1 }
196391f110e0Safresh1 depth = outside ? CvDEPTH(outside) : 0;
1964850e2753Smillert if (!depth)
1965850e2753Smillert depth = 1;
1966850e2753Smillert
196785009909Smillert ENTER;
196885009909Smillert SAVESPTR(PL_compcv);
196991f110e0Safresh1 PL_compcv = cv;
197091f110e0Safresh1 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
197185009909Smillert
197291f110e0Safresh1 if (CvHASEVAL(cv))
197343003dfeSmillert CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
197485009909Smillert
197591f110e0Safresh1 SAVESPTR(PL_comppad_name);
197691f110e0Safresh1 PL_comppad_name = protopad_name;
1977b8851fccSafresh1 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1978b8851fccSafresh1 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
197985009909Smillert
1980850e2753Smillert av_fill(PL_comppad, fpad);
198185009909Smillert
198285009909Smillert PL_curpad = AvARRAY(PL_comppad);
198385009909Smillert
198491f110e0Safresh1 outpad = outside && CvPADLIST(outside)
198591f110e0Safresh1 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
1986898184e3Ssthen : NULL;
1987b8851fccSafresh1 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
1988850e2753Smillert
198985009909Smillert for (ix = fpad; ix > 0; ix--) {
1990b8851fccSafresh1 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
1991850e2753Smillert SV *sv = NULL;
19926fb12b70Safresh1 if (namesv && PadnameLEN(namesv)) { /* lexical */
19936fb12b70Safresh1 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
19946fb12b70Safresh1 NOOP;
19956fb12b70Safresh1 }
19966fb12b70Safresh1 else {
1997b8851fccSafresh1 if (PadnameOUTER(namesv)) { /* lexical from outside? */
199891f110e0Safresh1 /* formats may have an inactive, or even undefined, parent;
199991f110e0Safresh1 but state vars are always available. */
2000898184e3Ssthen if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2001*e0680481Safresh1 || ( SvPADSTALE(sv) && !PadnameIsSTATE(namesv)
200291f110e0Safresh1 && (!outside || !CvDEPTH(outside))) ) {
200391f110e0Safresh1 S_unavailable(aTHX_ namesv);
2004850e2753Smillert sv = NULL;
200585009909Smillert }
200643003dfeSmillert else
2007850e2753Smillert SvREFCNT_inc_simple_void_NN(sv);
2008850e2753Smillert }
2009850e2753Smillert if (!sv) {
2010b8851fccSafresh1 const char sigil = PadnamePV(namesv)[0];
2011850e2753Smillert if (sigil == '&')
201291f110e0Safresh1 /* If there are state subs, we need to clone them, too.
201391f110e0Safresh1 But they may need to close over variables we have
201491f110e0Safresh1 not cloned yet. So we will have to do a second
201591f110e0Safresh1 pass. Furthermore, there may be state subs clos-
201691f110e0Safresh1 ing over other state subs’ entries, so we have
201791f110e0Safresh1 to put a stub here and then clone into it on the
201891f110e0Safresh1 second pass. */
2019*e0680481Safresh1 if (PadnameIsSTATE(namesv) && !CvCLONED(ppad[ix])) {
202091f110e0Safresh1 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2021b8851fccSafresh1 subclones ++;
2022b8851fccSafresh1 if (CvOUTSIDE(ppad[ix]) != proto)
2023b8851fccSafresh1 trouble = TRUE;
202491f110e0Safresh1 sv = newSV_type(SVt_PVCV);
2025b8851fccSafresh1 CvLEXICAL_on(sv);
202691f110e0Safresh1 }
202791f110e0Safresh1 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
202891f110e0Safresh1 {
202991f110e0Safresh1 /* my sub */
203091f110e0Safresh1 /* Just provide a stub, but name it. It will be
20319f11ffb7Safresh1 upgraded to the real thing on scope entry. */
2032b8851fccSafresh1 U32 hash;
2033b8851fccSafresh1 PERL_HASH(hash, PadnamePV(namesv)+1,
2034b8851fccSafresh1 PadnameLEN(namesv) - 1);
203591f110e0Safresh1 sv = newSV_type(SVt_PVCV);
203691f110e0Safresh1 CvNAME_HEK_set(
203791f110e0Safresh1 sv,
2038b8851fccSafresh1 share_hek(PadnamePV(namesv)+1,
2039b8851fccSafresh1 1 - PadnameLEN(namesv),
2040b8851fccSafresh1 hash)
204191f110e0Safresh1 );
2042b8851fccSafresh1 CvLEXICAL_on(sv);
204391f110e0Safresh1 }
204491f110e0Safresh1 else sv = SvREFCNT_inc(ppad[ix]);
2045850e2753Smillert else if (sigil == '@')
204643003dfeSmillert sv = MUTABLE_SV(newAV());
2047850e2753Smillert else if (sigil == '%')
204843003dfeSmillert sv = MUTABLE_SV(newHV());
204985009909Smillert else
2050eac174f2Safresh1 sv = newSV_type(SVt_NULL);
2051850e2753Smillert /* reset the 'assign only once' flag on each state var */
2052*e0680481Safresh1 if (sigil != '&' && PadnameIsSTATE(namesv))
2053850e2753Smillert SvPADSTALE_on(sv);
205485009909Smillert }
205585009909Smillert }
20566fb12b70Safresh1 }
2057b8851fccSafresh1 else if (namesv && PadnamePV(namesv)) {
2058850e2753Smillert sv = SvREFCNT_inc_NN(ppad[ix]);
205985009909Smillert }
206085009909Smillert else {
2061eac174f2Safresh1 sv = newSV_type(SVt_NULL);
206285009909Smillert SvPADTMP_on(sv);
2063850e2753Smillert }
206485009909Smillert PL_curpad[ix] = sv;
206585009909Smillert }
206685009909Smillert
206791f110e0Safresh1 if (subclones)
2068b8851fccSafresh1 {
2069b8851fccSafresh1 if (trouble || cloned) {
2070b8851fccSafresh1 /* Uh-oh, we have trouble! At least one of the state subs here
2071b8851fccSafresh1 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2072b8851fccSafresh1 could be pointing to another state protosub that we are
2073b8851fccSafresh1 about to clone. So we have to track which sub clones come
2074b8851fccSafresh1 from which protosubs. If the CvOUTSIDE pointer for a parti-
2075b8851fccSafresh1 cular sub points to something we have not cloned yet, we
2076b8851fccSafresh1 delay cloning it. We must loop through the pad entries,
2077b8851fccSafresh1 until we get a full pass with no cloning. If any uncloned
2078b8851fccSafresh1 subs remain (probably nested inside anonymous or ‘my’ subs),
2079b8851fccSafresh1 then they get cloned in a final pass.
2080b8851fccSafresh1 */
2081b8851fccSafresh1 bool cloned_in_this_pass;
2082b8851fccSafresh1 if (!cloned)
2083eac174f2Safresh1 cloned = (HV *)newSV_type_mortal(SVt_PVHV);
2084b8851fccSafresh1 do {
2085b8851fccSafresh1 cloned_in_this_pass = FALSE;
208691f110e0Safresh1 for (ix = fpad; ix > 0; ix--) {
2087b8851fccSafresh1 PADNAME * const name =
2088b8851fccSafresh1 (ix <= fname) ? pname[ix] : NULL;
2089b8851fccSafresh1 if (name && name != &PL_padname_undef
2090b8851fccSafresh1 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2091b8851fccSafresh1 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2092b8851fccSafresh1 {
2093b8851fccSafresh1 CV * const protokey = CvOUTSIDE(ppad[ix]);
2094b8851fccSafresh1 CV ** const cvp = protokey == proto
2095b8851fccSafresh1 ? &cv
2096b8851fccSafresh1 : (CV **)hv_fetch(cloned, (char *)&protokey,
2097b8851fccSafresh1 sizeof(CV *), 0);
2098b8851fccSafresh1 if (cvp && *cvp) {
2099b8851fccSafresh1 S_cv_clone(aTHX_ (CV *)ppad[ix],
2100b8851fccSafresh1 (CV *)PL_curpad[ix],
2101b8851fccSafresh1 *cvp, cloned);
2102b8851fccSafresh1 (void)hv_store(cloned, (char *)&ppad[ix],
2103b8851fccSafresh1 sizeof(CV *),
2104b8851fccSafresh1 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2105b8851fccSafresh1 0);
2106b8851fccSafresh1 subclones--;
2107b8851fccSafresh1 cloned_in_this_pass = TRUE;
2108b8851fccSafresh1 }
2109b8851fccSafresh1 }
2110b8851fccSafresh1 }
2111b8851fccSafresh1 } while (cloned_in_this_pass);
2112b8851fccSafresh1 if (subclones)
2113b8851fccSafresh1 for (ix = fpad; ix > 0; ix--) {
2114b8851fccSafresh1 PADNAME * const name =
2115b8851fccSafresh1 (ix <= fname) ? pname[ix] : NULL;
2116b8851fccSafresh1 if (name && name != &PL_padname_undef
2117b8851fccSafresh1 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2118b8851fccSafresh1 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2119b8851fccSafresh1 S_cv_clone(aTHX_ (CV *)ppad[ix],
2120b8851fccSafresh1 (CV *)PL_curpad[ix],
2121b8851fccSafresh1 CvOUTSIDE(ppad[ix]), cloned);
2122b8851fccSafresh1 }
2123b8851fccSafresh1 }
2124b8851fccSafresh1 else for (ix = fpad; ix > 0; ix--) {
2125b8851fccSafresh1 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2126b8851fccSafresh1 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2127b8851fccSafresh1 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2128b8851fccSafresh1 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2129b8851fccSafresh1 NULL);
2130b8851fccSafresh1 }
213191f110e0Safresh1 }
213291f110e0Safresh1
213391f110e0Safresh1 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
213491f110e0Safresh1 LEAVE;
2135b8851fccSafresh1
2136b8851fccSafresh1 if (CvCONST(cv)) {
2137b8851fccSafresh1 /* Constant sub () { $x } closing over $x:
2138*e0680481Safresh1 * The prototype was marked as a candidate for const-ization,
2139b8851fccSafresh1 * so try to grab the current const value, and if successful,
2140b8851fccSafresh1 * turn into a const sub:
2141b8851fccSafresh1 */
2142b8851fccSafresh1 SV* const_sv;
2143b8851fccSafresh1 OP *o = CvSTART(cv);
2144b8851fccSafresh1 assert(newcv);
2145b8851fccSafresh1 for (; o; o = o->op_next)
2146b8851fccSafresh1 if (o->op_type == OP_PADSV)
2147b8851fccSafresh1 break;
2148b8851fccSafresh1 ASSUME(o->op_type == OP_PADSV);
2149b8851fccSafresh1 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2150b8851fccSafresh1 /* the candidate should have 1 ref from this pad and 1 ref
2151b8851fccSafresh1 * from the parent */
2152b8851fccSafresh1 if (const_sv && SvREFCNT(const_sv) == 2) {
2153*e0680481Safresh1 const bool was_method = cBOOL(CvNOWARN_AMBIGUOUS(cv));
2154b8851fccSafresh1 if (outside) {
2155b8851fccSafresh1 PADNAME * const pn =
2156b8851fccSafresh1 PadlistNAMESARRAY(CvPADLIST(outside))
2157b8851fccSafresh1 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2158b8851fccSafresh1 CvPADLIST(cv))[o->op_targ])];
2159b8851fccSafresh1 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2160b8851fccSafresh1 [o->op_targ]));
2161b8851fccSafresh1 if (PadnameLVALUE(pn)) {
2162b8851fccSafresh1 /* We have a lexical that is potentially modifiable
2163b8851fccSafresh1 elsewhere, so making a constant will break clo-
2164b8851fccSafresh1 sure behaviour. If this is a ‘simple lexical
2165b8851fccSafresh1 op tree’, i.e., sub(){$x}, emit a deprecation
2166b8851fccSafresh1 warning, but continue to exhibit the old behav-
2167b8851fccSafresh1 iour of making it a constant based on the ref-
2168b8851fccSafresh1 count of the candidate variable.
2169b8851fccSafresh1
2170b8851fccSafresh1 A simple lexical op tree looks like this:
2171b8851fccSafresh1
2172b8851fccSafresh1 leavesub
2173b8851fccSafresh1 lineseq
2174b8851fccSafresh1 nextstate
2175b8851fccSafresh1 padsv
2176b8851fccSafresh1 */
2177b8851fccSafresh1 if (OpSIBLING(
2178b8851fccSafresh1 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2179b8851fccSafresh1 ) == o
2180b8851fccSafresh1 && !OpSIBLING(o))
2181b8851fccSafresh1 {
218256d68f1eSafresh1 Perl_croak(aTHX_
218356d68f1eSafresh1 "Constants from lexical variables potentially modified "
218456d68f1eSafresh1 "elsewhere are no longer permitted");
2185b8851fccSafresh1 }
2186b8851fccSafresh1 else
2187b8851fccSafresh1 goto constoff;
2188b8851fccSafresh1 }
2189b8851fccSafresh1 }
2190b8851fccSafresh1 SvREFCNT_inc_simple_void_NN(const_sv);
2191b8851fccSafresh1 /* If the lexical is not used elsewhere, it is safe to turn on
2192b8851fccSafresh1 SvPADTMP, since it is only when it is used in lvalue con-
2193b8851fccSafresh1 text that the difference is observable. */
2194b8851fccSafresh1 SvREADONLY_on(const_sv);
2195b8851fccSafresh1 SvPADTMP_on(const_sv);
2196b8851fccSafresh1 SvREFCNT_dec_NN(cv);
2197b8851fccSafresh1 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2198b8851fccSafresh1 if (was_method)
2199*e0680481Safresh1 CvNOWARN_AMBIGUOUS_on(cv);
2200b8851fccSafresh1 }
2201b8851fccSafresh1 else {
2202b8851fccSafresh1 constoff:
2203b8851fccSafresh1 CvCONST_off(cv);
2204b8851fccSafresh1 }
2205b8851fccSafresh1 }
2206b8851fccSafresh1
2207b8851fccSafresh1 return cv;
220891f110e0Safresh1 }
220991f110e0Safresh1
221091f110e0Safresh1 static CV *
S_cv_clone(pTHX_ CV * proto,CV * cv,CV * outside,HV * cloned)2211b8851fccSafresh1 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
221291f110e0Safresh1 {
221391f110e0Safresh1 const bool newcv = !cv;
221491f110e0Safresh1
221591f110e0Safresh1 assert(!CvUNIQUE(proto));
221691f110e0Safresh1
221791f110e0Safresh1 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
221891f110e0Safresh1 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
221991f110e0Safresh1 |CVf_SLABBED);
222091f110e0Safresh1 CvCLONED_on(cv);
222191f110e0Safresh1
222291f110e0Safresh1 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
222391f110e0Safresh1 : CvFILE(proto);
222491f110e0Safresh1 if (CvNAMED(proto))
222591f110e0Safresh1 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
222691f110e0Safresh1 else CvGV_set(cv,CvGV(proto));
222791f110e0Safresh1 CvSTASH_set(cv, CvSTASH(proto));
2228eac174f2Safresh1
2229eac174f2Safresh1 /* It is unlikely that proto is an xsub, but it could happen; e.g. if a
2230eac174f2Safresh1 * module has performed a lexical sub import trick on an xsub. This
2231eac174f2Safresh1 * happens with builtin::import, for example
2232eac174f2Safresh1 */
2233eac174f2Safresh1 if (UNLIKELY(CvISXSUB(proto))) {
2234eac174f2Safresh1 CvXSUB(cv) = CvXSUB(proto);
2235eac174f2Safresh1 CvXSUBANY(cv) = CvXSUBANY(proto);
2236*e0680481Safresh1 if (CvREFCOUNTED_ANYSV(cv))
2237*e0680481Safresh1 SvREFCNT_inc(CvXSUBANY(cv).any_sv);
2238eac174f2Safresh1 }
2239eac174f2Safresh1 else {
224091f110e0Safresh1 OP_REFCNT_LOCK;
224191f110e0Safresh1 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
224291f110e0Safresh1 OP_REFCNT_UNLOCK;
224391f110e0Safresh1 CvSTART(cv) = CvSTART(proto);
224491f110e0Safresh1 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2245eac174f2Safresh1 }
224691f110e0Safresh1
22476fb12b70Safresh1 if (SvPOK(proto)) {
224891f110e0Safresh1 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
22496fb12b70Safresh1 if (SvUTF8(proto))
22506fb12b70Safresh1 SvUTF8_on(MUTABLE_SV(cv));
22516fb12b70Safresh1 }
225291f110e0Safresh1 if (SvMAGIC(proto))
225391f110e0Safresh1 mg_copy((SV *)proto, (SV *)cv, 0, 0);
225491f110e0Safresh1
2255eac174f2Safresh1 if (!CvISXSUB(proto) && CvPADLIST(proto))
2256b8851fccSafresh1 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
225791f110e0Safresh1
225885009909Smillert DEBUG_Xv(
225985009909Smillert PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
226091f110e0Safresh1 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
226185009909Smillert cv_dump(proto, "Proto");
226285009909Smillert cv_dump(cv, "To");
226385009909Smillert );
226485009909Smillert
226585009909Smillert return cv;
226685009909Smillert }
226785009909Smillert
226891f110e0Safresh1 CV *
Perl_cv_clone(pTHX_ CV * proto)226991f110e0Safresh1 Perl_cv_clone(pTHX_ CV *proto)
227091f110e0Safresh1 {
227191f110e0Safresh1 PERL_ARGS_ASSERT_CV_CLONE;
227291f110e0Safresh1
227391f110e0Safresh1 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2274b8851fccSafresh1 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
227591f110e0Safresh1 }
227691f110e0Safresh1
227791f110e0Safresh1 /* Called only by pp_clonecv */
227891f110e0Safresh1 CV *
Perl_cv_clone_into(pTHX_ CV * proto,CV * target)227991f110e0Safresh1 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
228091f110e0Safresh1 {
228191f110e0Safresh1 PERL_ARGS_ASSERT_CV_CLONE_INTO;
228291f110e0Safresh1 cv_undef(target);
2283b8851fccSafresh1 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2284b8851fccSafresh1 }
2285b8851fccSafresh1
2286b8851fccSafresh1 /*
2287b8851fccSafresh1 =for apidoc cv_name
2288b8851fccSafresh1
2289b8851fccSafresh1 Returns an SV containing the name of the CV, mainly for use in error
2290b8851fccSafresh1 reporting. The CV may actually be a GV instead, in which case the returned
2291b8851fccSafresh1 SV holds the GV's name. Anything other than a GV or CV is treated as a
2292b8851fccSafresh1 string already holding the sub name, but this could change in the future.
2293b8851fccSafresh1
2294b8851fccSafresh1 An SV may be passed as a second argument. If so, the name will be assigned
2295b8851fccSafresh1 to it and it will be returned. Otherwise the returned SV will be a new
2296b8851fccSafresh1 mortal.
2297b8851fccSafresh1
2298b8851fccSafresh1 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2299b8851fccSafresh1 included. If the first argument is neither a CV nor a GV, this flag is
2300b8851fccSafresh1 ignored (subject to change).
2301b8851fccSafresh1
230256d68f1eSafresh1 =for apidoc Amnh||CV_NAME_NOTQUAL
230356d68f1eSafresh1
2304b8851fccSafresh1 =cut
2305b8851fccSafresh1 */
2306b8851fccSafresh1
2307b8851fccSafresh1 SV *
Perl_cv_name(pTHX_ CV * cv,SV * sv,U32 flags)2308b8851fccSafresh1 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2309b8851fccSafresh1 {
2310b8851fccSafresh1 PERL_ARGS_ASSERT_CV_NAME;
2311b8851fccSafresh1 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2312b8851fccSafresh1 if (sv) sv_setsv(sv,(SV *)cv);
2313b8851fccSafresh1 return sv ? (sv) : (SV *)cv;
2314b8851fccSafresh1 }
2315b8851fccSafresh1 {
2316b8851fccSafresh1 SV * const retsv = sv ? (sv) : sv_newmortal();
2317b8851fccSafresh1 if (SvTYPE(cv) == SVt_PVCV) {
2318b8851fccSafresh1 if (CvNAMED(cv)) {
2319b8851fccSafresh1 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2320b8851fccSafresh1 sv_sethek(retsv, CvNAME_HEK(cv));
2321b8851fccSafresh1 else {
23229f11ffb7Safresh1 if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
2323b8851fccSafresh1 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
23249f11ffb7Safresh1 else
23259f11ffb7Safresh1 sv_setpvs(retsv, "__ANON__");
2326b8851fccSafresh1 sv_catpvs(retsv, "::");
2327b8851fccSafresh1 sv_cathek(retsv, CvNAME_HEK(cv));
2328b8851fccSafresh1 }
2329b8851fccSafresh1 }
2330b8851fccSafresh1 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2331b8851fccSafresh1 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2332b8851fccSafresh1 else gv_efullname3(retsv, CvGV(cv), NULL);
2333b8851fccSafresh1 }
2334b8851fccSafresh1 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2335b8851fccSafresh1 else gv_efullname3(retsv,(GV *)cv,NULL);
2336b8851fccSafresh1 return retsv;
2337b8851fccSafresh1 }
233891f110e0Safresh1 }
233991f110e0Safresh1
234085009909Smillert /*
234156d68f1eSafresh1 =for apidoc pad_fixup_inner_anons
234285009909Smillert
2343b8851fccSafresh1 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2344b8851fccSafresh1 C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
234585009909Smillert moved to a pre-existing CV struct.
234685009909Smillert
234785009909Smillert =cut
234885009909Smillert */
234985009909Smillert
235085009909Smillert void
Perl_pad_fixup_inner_anons(pTHX_ PADLIST * padlist,CV * old_cv,CV * new_cv)235185009909Smillert Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
235285009909Smillert {
23539f11ffb7Safresh1 PADOFFSET ix;
2354b8851fccSafresh1 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
235591f110e0Safresh1 AV * const comppad = PadlistARRAY(padlist)[1];
2356b8851fccSafresh1 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
235752bd00bfSmillert SV ** const curpad = AvARRAY(comppad);
235843003dfeSmillert
235943003dfeSmillert PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2360850e2753Smillert PERL_UNUSED_ARG(old_cv);
2361850e2753Smillert
2362b8851fccSafresh1 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2363b8851fccSafresh1 const PADNAME *name = namepad[ix];
2364b8851fccSafresh1 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2365b8851fccSafresh1 && *PadnamePV(name) == '&')
236685009909Smillert {
2367b8851fccSafresh1 CV *innercv = MUTABLE_CV(curpad[ix]);
2368b8851fccSafresh1 if (UNLIKELY(PadnameOUTER(name))) {
2369b8851fccSafresh1 CV *cv = new_cv;
2370b8851fccSafresh1 PADNAME **names = namepad;
2371b8851fccSafresh1 PADOFFSET i = ix;
2372b8851fccSafresh1 while (PadnameOUTER(name)) {
23739f11ffb7Safresh1 assert(SvTYPE(cv) == SVt_PVCV);
2374b8851fccSafresh1 cv = CvOUTSIDE(cv);
2375b8851fccSafresh1 names = PadlistNAMESARRAY(CvPADLIST(cv));
2376b8851fccSafresh1 i = PARENT_PAD_INDEX(name);
2377b8851fccSafresh1 name = names[i];
2378b8851fccSafresh1 }
2379b8851fccSafresh1 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2380b8851fccSafresh1 }
2381b8851fccSafresh1 if (SvTYPE(innercv) == SVt_PVCV) {
2382b8851fccSafresh1 /* XXX 0afba48f added code here to check for a proto CV
2383b8851fccSafresh1 attached to the pad entry by magic. But shortly there-
2384b8851fccSafresh1 after 81df9f6f95 moved the magic to the pad name. The
2385b8851fccSafresh1 code here was never updated, so it wasn’t doing anything
2386b8851fccSafresh1 and got deleted when PADNAME became a distinct type. Is
2387b8851fccSafresh1 there any bug as a result? */
238891f110e0Safresh1 if (CvOUTSIDE(innercv) == old_cv) {
238991f110e0Safresh1 if (!CvWEAKOUTSIDE(innercv)) {
239091f110e0Safresh1 SvREFCNT_dec(old_cv);
239191f110e0Safresh1 SvREFCNT_inc_simple_void_NN(new_cv);
239291f110e0Safresh1 }
239385009909Smillert CvOUTSIDE(innercv) = new_cv;
239485009909Smillert }
239591f110e0Safresh1 }
2396898184e3Ssthen else { /* format reference */
2397898184e3Ssthen SV * const rv = curpad[ix];
2398898184e3Ssthen CV *innercv;
2399898184e3Ssthen if (!SvOK(rv)) continue;
2400898184e3Ssthen assert(SvROK(rv));
2401898184e3Ssthen assert(SvWEAKREF(rv));
2402898184e3Ssthen innercv = (CV *)SvRV(rv);
2403898184e3Ssthen assert(!CvWEAKOUTSIDE(innercv));
24049f11ffb7Safresh1 assert(CvOUTSIDE(innercv) == old_cv);
2405898184e3Ssthen SvREFCNT_dec(CvOUTSIDE(innercv));
2406898184e3Ssthen CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
240785009909Smillert }
240885009909Smillert }
2409898184e3Ssthen }
2410898184e3Ssthen }
241185009909Smillert
241285009909Smillert /*
241356d68f1eSafresh1 =for apidoc pad_push
241485009909Smillert
241585009909Smillert Push a new pad frame onto the padlist, unless there's already a pad at
2416850e2753Smillert this depth, in which case don't bother creating a new one. Then give
2417b8851fccSafresh1 the new pad an C<@_> in slot zero.
241885009909Smillert
241985009909Smillert =cut
242085009909Smillert */
242185009909Smillert
242285009909Smillert void
Perl_pad_push(pTHX_ PADLIST * padlist,int depth)2423850e2753Smillert Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
242485009909Smillert {
242543003dfeSmillert PERL_ARGS_ASSERT_PAD_PUSH;
242643003dfeSmillert
242791f110e0Safresh1 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
242891f110e0Safresh1 PAD** const svp = PadlistARRAY(padlist);
242952bd00bfSmillert AV* const newpad = newAV();
243052bd00bfSmillert SV** const oldpad = AvARRAY(svp[depth-1]);
24319f11ffb7Safresh1 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
24329f11ffb7Safresh1 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2433b8851fccSafresh1 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2434850e2753Smillert AV *av;
2435850e2753Smillert
2436eac174f2Safresh1 Newxz( AvALLOC(newpad), ix + 1, SV *);
2437eac174f2Safresh1 AvARRAY(newpad) = AvALLOC(newpad);
2438eac174f2Safresh1 AvMAX(newpad) = AvFILLp(newpad) = ix;
2439eac174f2Safresh1
244085009909Smillert for ( ;ix > 0; ix--) {
2441eac174f2Safresh1 SV *sv;
24426fb12b70Safresh1 if (names_fill >= ix && PadnameLEN(names[ix])) {
2443b8851fccSafresh1 const char sigil = PadnamePV(names[ix])[0];
2444b8851fccSafresh1 if (PadnameOUTER(names[ix])
2445b8851fccSafresh1 || PadnameIsSTATE(names[ix])
2446850e2753Smillert || sigil == '&')
2447850e2753Smillert {
244885009909Smillert /* outer lexical or anon code */
2449eac174f2Safresh1 sv = SvREFCNT_inc(oldpad[ix]);
245085009909Smillert }
245185009909Smillert else { /* our own lexical */
2452850e2753Smillert if (sigil == '@')
245343003dfeSmillert sv = MUTABLE_SV(newAV());
2454850e2753Smillert else if (sigil == '%')
245543003dfeSmillert sv = MUTABLE_SV(newHV());
245685009909Smillert else
2457eac174f2Safresh1 sv = newSV_type(SVt_NULL);
245885009909Smillert }
245985009909Smillert }
2460b8851fccSafresh1 else if (PadnamePV(names[ix])) {
2461eac174f2Safresh1 sv = SvREFCNT_inc_NN(oldpad[ix]);
246285009909Smillert }
246385009909Smillert else {
246485009909Smillert /* save temporaries on recursion? */
2465eac174f2Safresh1 sv = newSV_type(SVt_NULL);
246685009909Smillert SvPADTMP_on(sv);
246785009909Smillert }
2468eac174f2Safresh1 AvARRAY(newpad)[ix] = sv;
246985009909Smillert }
2470850e2753Smillert av = newAV();
2471eac174f2Safresh1 AvARRAY(newpad)[0] = MUTABLE_SV(av);
2472850e2753Smillert AvREIFY_only(av);
2473850e2753Smillert
247491f110e0Safresh1 padlist_store(padlist, depth, newpad);
247585009909Smillert }
247685009909Smillert }
247752bd00bfSmillert
2478898184e3Ssthen #if defined(USE_ITHREADS)
2479898184e3Ssthen
2480898184e3Ssthen /*
248191f110e0Safresh1 =for apidoc padlist_dup
2482898184e3Ssthen
2483898184e3Ssthen Duplicates a pad.
2484898184e3Ssthen
2485898184e3Ssthen =cut
2486898184e3Ssthen */
2487898184e3Ssthen
248891f110e0Safresh1 PADLIST *
Perl_padlist_dup(pTHX_ PADLIST * srcpad,CLONE_PARAMS * param)248991f110e0Safresh1 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2490898184e3Ssthen {
249191f110e0Safresh1 PADLIST *dstpad;
249291f110e0Safresh1 bool cloneall;
249391f110e0Safresh1 PADOFFSET max;
249491f110e0Safresh1
2495898184e3Ssthen PERL_ARGS_ASSERT_PADLIST_DUP;
2496898184e3Ssthen
2497b8851fccSafresh1 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
249891f110e0Safresh1 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
249991f110e0Safresh1
250091f110e0Safresh1 max = cloneall ? PadlistMAX(srcpad) : 1;
250191f110e0Safresh1
250291f110e0Safresh1 Newx(dstpad, 1, PADLIST);
250391f110e0Safresh1 ptr_table_store(PL_ptr_table, srcpad, dstpad);
250491f110e0Safresh1 PadlistMAX(dstpad) = max;
250591f110e0Safresh1 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
250691f110e0Safresh1
2507*e0680481Safresh1 PadlistARRAY(dstpad)[0] = (PAD *)padnamelist_dup_inc(PadlistNAMES(srcpad), param);
250891f110e0Safresh1 if (cloneall) {
250991f110e0Safresh1 PADOFFSET depth;
2510b8851fccSafresh1 for (depth = 1; depth <= max; ++depth)
251191f110e0Safresh1 PadlistARRAY(dstpad)[depth] =
251291f110e0Safresh1 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2513898184e3Ssthen } else {
2514898184e3Ssthen /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2515898184e3Ssthen to build anything other than the first level of pads. */
25169f11ffb7Safresh1 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2517898184e3Ssthen AV *pad1;
25189f11ffb7Safresh1 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
251991f110e0Safresh1 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2520898184e3Ssthen SV **oldpad = AvARRAY(srcpad1);
2521b8851fccSafresh1 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2522898184e3Ssthen SV **pad1a;
2523898184e3Ssthen AV *args;
2524898184e3Ssthen
2525898184e3Ssthen pad1 = newAV();
2526898184e3Ssthen
2527898184e3Ssthen av_extend(pad1, ix);
252891f110e0Safresh1 PadlistARRAY(dstpad)[1] = pad1;
2529898184e3Ssthen pad1a = AvARRAY(pad1);
2530898184e3Ssthen
2531898184e3Ssthen if (ix > -1) {
2532898184e3Ssthen AvFILLp(pad1) = ix;
2533898184e3Ssthen
2534898184e3Ssthen for ( ;ix > 0; ix--) {
2535898184e3Ssthen if (!oldpad[ix]) {
2536898184e3Ssthen pad1a[ix] = NULL;
25376fb12b70Safresh1 } else if (names_fill >= ix && names[ix] &&
25386fb12b70Safresh1 PadnameLEN(names[ix])) {
2539b8851fccSafresh1 const char sigil = PadnamePV(names[ix])[0];
2540b8851fccSafresh1 if (PadnameOUTER(names[ix])
2541b8851fccSafresh1 || PadnameIsSTATE(names[ix])
2542898184e3Ssthen || sigil == '&')
2543898184e3Ssthen {
2544898184e3Ssthen /* outer lexical or anon code */
2545898184e3Ssthen pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2546898184e3Ssthen }
2547898184e3Ssthen else { /* our own lexical */
2548898184e3Ssthen if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2549898184e3Ssthen /* This is a work around for how the current
2550898184e3Ssthen implementation of ?{ } blocks in regexps
2551898184e3Ssthen interacts with lexicals. */
2552898184e3Ssthen pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2553898184e3Ssthen } else {
2554898184e3Ssthen SV *sv;
2555898184e3Ssthen
2556898184e3Ssthen if (sigil == '@')
2557898184e3Ssthen sv = MUTABLE_SV(newAV());
2558898184e3Ssthen else if (sigil == '%')
2559898184e3Ssthen sv = MUTABLE_SV(newHV());
2560898184e3Ssthen else
2561eac174f2Safresh1 sv = newSV_type(SVt_NULL);
2562898184e3Ssthen pad1a[ix] = sv;
2563898184e3Ssthen }
2564898184e3Ssthen }
2565898184e3Ssthen }
2566b8851fccSafresh1 else if (( names_fill >= ix && names[ix]
25676fb12b70Safresh1 && PadnamePV(names[ix]) )) {
2568898184e3Ssthen pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2569898184e3Ssthen }
2570898184e3Ssthen else {
2571898184e3Ssthen /* save temporaries on recursion? */
2572eac174f2Safresh1 SV * const sv = newSV_type(SVt_NULL);
2573898184e3Ssthen pad1a[ix] = sv;
2574898184e3Ssthen
2575898184e3Ssthen /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2576898184e3Ssthen FIXTHAT before merging this branch.
2577898184e3Ssthen (And I know how to) */
2578b8851fccSafresh1 if (SvPADTMP(oldpad[ix]))
2579898184e3Ssthen SvPADTMP_on(sv);
2580898184e3Ssthen }
2581898184e3Ssthen }
2582898184e3Ssthen
2583898184e3Ssthen if (oldpad[0]) {
2584898184e3Ssthen args = newAV(); /* Will be @_ */
2585898184e3Ssthen AvREIFY_only(args);
2586898184e3Ssthen pad1a[0] = (SV *)args;
2587898184e3Ssthen }
2588898184e3Ssthen }
2589898184e3Ssthen }
2590898184e3Ssthen
2591898184e3Ssthen return dstpad;
2592898184e3Ssthen }
2593898184e3Ssthen
2594898184e3Ssthen #endif /* USE_ITHREADS */
2595898184e3Ssthen
259691f110e0Safresh1 PAD **
Perl_padlist_store(pTHX_ PADLIST * padlist,I32 key,PAD * val)259791f110e0Safresh1 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
259891f110e0Safresh1 {
259991f110e0Safresh1 PAD **ary;
260091f110e0Safresh1 SSize_t const oldmax = PadlistMAX(padlist);
260191f110e0Safresh1
260291f110e0Safresh1 PERL_ARGS_ASSERT_PADLIST_STORE;
260391f110e0Safresh1
260491f110e0Safresh1 assert(key >= 0);
260591f110e0Safresh1
260691f110e0Safresh1 if (key > PadlistMAX(padlist)) {
260791f110e0Safresh1 av_extend_guts(NULL,key,&PadlistMAX(padlist),
260891f110e0Safresh1 (SV ***)&PadlistARRAY(padlist),
260991f110e0Safresh1 (SV ***)&PadlistARRAY(padlist));
261091f110e0Safresh1 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
261191f110e0Safresh1 PAD *);
261291f110e0Safresh1 }
261391f110e0Safresh1 ary = PadlistARRAY(padlist);
261491f110e0Safresh1 SvREFCNT_dec(ary[key]);
261591f110e0Safresh1 ary[key] = val;
261691f110e0Safresh1 return &ary[key];
261791f110e0Safresh1 }
261891f110e0Safresh1
261952bd00bfSmillert /*
2620b8851fccSafresh1 =for apidoc newPADNAMELIST
2621b8851fccSafresh1
2622b8851fccSafresh1 Creates a new pad name list. C<max> is the highest index for which space
2623b8851fccSafresh1 is allocated.
2624b8851fccSafresh1
2625b8851fccSafresh1 =cut
2626b8851fccSafresh1 */
2627b8851fccSafresh1
2628b8851fccSafresh1 PADNAMELIST *
Perl_newPADNAMELIST(size_t max)2629b8851fccSafresh1 Perl_newPADNAMELIST(size_t max)
2630b8851fccSafresh1 {
2631b8851fccSafresh1 PADNAMELIST *pnl;
2632b8851fccSafresh1 Newx(pnl, 1, PADNAMELIST);
2633b8851fccSafresh1 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2634b8851fccSafresh1 PadnamelistMAX(pnl) = -1;
2635b8851fccSafresh1 PadnamelistREFCNT(pnl) = 1;
2636b8851fccSafresh1 PadnamelistMAXNAMED(pnl) = 0;
2637b8851fccSafresh1 pnl->xpadnl_max = max;
2638b8851fccSafresh1 return pnl;
2639b8851fccSafresh1 }
2640b8851fccSafresh1
2641b8851fccSafresh1 /*
2642b8851fccSafresh1 =for apidoc padnamelist_store
2643b8851fccSafresh1
2644b8851fccSafresh1 Stores the pad name (which may be null) at the given index, freeing any
2645b8851fccSafresh1 existing pad name in that slot.
2646b8851fccSafresh1
2647b8851fccSafresh1 =cut
2648b8851fccSafresh1 */
2649b8851fccSafresh1
2650b8851fccSafresh1 PADNAME **
Perl_padnamelist_store(pTHX_ PADNAMELIST * pnl,SSize_t key,PADNAME * val)2651b8851fccSafresh1 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2652b8851fccSafresh1 {
2653b8851fccSafresh1 PADNAME **ary;
2654b8851fccSafresh1
2655b8851fccSafresh1 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2656b8851fccSafresh1
2657b8851fccSafresh1 assert(key >= 0);
2658b8851fccSafresh1
2659b8851fccSafresh1 if (key > pnl->xpadnl_max)
2660b8851fccSafresh1 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2661b8851fccSafresh1 (SV ***)&PadnamelistARRAY(pnl),
2662b8851fccSafresh1 (SV ***)&PadnamelistARRAY(pnl));
2663b8851fccSafresh1 if (PadnamelistMAX(pnl) < key) {
2664b8851fccSafresh1 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2665b8851fccSafresh1 key-PadnamelistMAX(pnl), PADNAME *);
2666b8851fccSafresh1 PadnamelistMAX(pnl) = key;
2667b8851fccSafresh1 }
2668b8851fccSafresh1 ary = PadnamelistARRAY(pnl);
2669b8851fccSafresh1 if (ary[key])
2670b8851fccSafresh1 PadnameREFCNT_dec(ary[key]);
2671b8851fccSafresh1 ary[key] = val;
2672b8851fccSafresh1 return &ary[key];
2673b8851fccSafresh1 }
2674b8851fccSafresh1
2675b8851fccSafresh1 /*
2676b8851fccSafresh1 =for apidoc padnamelist_fetch
2677b8851fccSafresh1
2678b8851fccSafresh1 Fetches the pad name from the given index.
2679b8851fccSafresh1
2680b8851fccSafresh1 =cut
2681b8851fccSafresh1 */
2682b8851fccSafresh1
2683b8851fccSafresh1 PADNAME *
Perl_padnamelist_fetch(PADNAMELIST * pnl,SSize_t key)2684b8851fccSafresh1 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2685b8851fccSafresh1 {
2686b8851fccSafresh1 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2687b8851fccSafresh1 ASSUME(key >= 0);
2688b8851fccSafresh1
2689b8851fccSafresh1 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2690b8851fccSafresh1 }
2691b8851fccSafresh1
2692b8851fccSafresh1 void
Perl_padnamelist_free(pTHX_ PADNAMELIST * pnl)2693b8851fccSafresh1 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2694b8851fccSafresh1 {
2695b8851fccSafresh1 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2696b8851fccSafresh1 if (!--PadnamelistREFCNT(pnl)) {
2697b8851fccSafresh1 while(PadnamelistMAX(pnl) >= 0)
2698b8851fccSafresh1 {
2699b8851fccSafresh1 PADNAME * const pn =
2700b8851fccSafresh1 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2701b8851fccSafresh1 if (pn)
2702b8851fccSafresh1 PadnameREFCNT_dec(pn);
2703b8851fccSafresh1 }
2704b8851fccSafresh1 Safefree(PadnamelistARRAY(pnl));
2705b8851fccSafresh1 Safefree(pnl);
2706b8851fccSafresh1 }
2707b8851fccSafresh1 }
2708b8851fccSafresh1
2709b8851fccSafresh1 #if defined(USE_ITHREADS)
2710b8851fccSafresh1
2711b8851fccSafresh1 /*
2712b8851fccSafresh1 =for apidoc padnamelist_dup
2713b8851fccSafresh1
2714b8851fccSafresh1 Duplicates a pad name list.
2715b8851fccSafresh1
2716b8851fccSafresh1 =cut
2717b8851fccSafresh1 */
2718b8851fccSafresh1
2719b8851fccSafresh1 PADNAMELIST *
Perl_padnamelist_dup(pTHX_ PADNAMELIST * srcpad,CLONE_PARAMS * param)2720b8851fccSafresh1 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2721b8851fccSafresh1 {
2722b8851fccSafresh1 PADNAMELIST *dstpad;
2723b8851fccSafresh1 SSize_t max = PadnamelistMAX(srcpad);
2724b8851fccSafresh1
2725b8851fccSafresh1 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2726b8851fccSafresh1
2727b8851fccSafresh1 /* look for it in the table first */
2728b8851fccSafresh1 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2729b8851fccSafresh1 if (dstpad)
2730b8851fccSafresh1 return dstpad;
2731b8851fccSafresh1
2732b8851fccSafresh1 dstpad = newPADNAMELIST(max);
2733b8851fccSafresh1 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2734b8851fccSafresh1 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2735b8851fccSafresh1 PadnamelistMAX(dstpad) = max;
2736b8851fccSafresh1
2737b8851fccSafresh1 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2738b8851fccSafresh1 for (; max >= 0; max--)
2739b8851fccSafresh1 if (PadnamelistARRAY(srcpad)[max]) {
2740b8851fccSafresh1 PadnamelistARRAY(dstpad)[max] =
2741*e0680481Safresh1 padname_dup_inc(PadnamelistARRAY(srcpad)[max], param);
2742b8851fccSafresh1 }
2743b8851fccSafresh1
2744b8851fccSafresh1 return dstpad;
2745b8851fccSafresh1 }
2746b8851fccSafresh1
2747b8851fccSafresh1 #endif /* USE_ITHREADS */
2748b8851fccSafresh1
2749b8851fccSafresh1 /*
2750b8851fccSafresh1 =for apidoc newPADNAMEpvn
2751b8851fccSafresh1
2752b8851fccSafresh1 Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
2753b8851fccSafresh1 use this for pad names that point to outer lexicals. See
2754b8851fccSafresh1 C<L</newPADNAMEouter>>.
2755b8851fccSafresh1
2756b8851fccSafresh1 =cut
2757b8851fccSafresh1 */
2758b8851fccSafresh1
2759b8851fccSafresh1 PADNAME *
Perl_newPADNAMEpvn(const char * s,STRLEN len)2760b8851fccSafresh1 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2761b8851fccSafresh1 {
2762b8851fccSafresh1 struct padname_with_str *alloc;
2763b8851fccSafresh1 char *alloc2; /* for Newxz */
2764b8851fccSafresh1 PADNAME *pn;
2765b8851fccSafresh1 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2766b8851fccSafresh1 Newxz(alloc2,
2767b8851fccSafresh1 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2768b8851fccSafresh1 char);
2769b8851fccSafresh1 alloc = (struct padname_with_str *)alloc2;
2770b8851fccSafresh1 pn = (PADNAME *)alloc;
2771b8851fccSafresh1 PadnameREFCNT(pn) = 1;
2772b8851fccSafresh1 PadnamePV(pn) = alloc->xpadn_str;
2773b8851fccSafresh1 Copy(s, PadnamePV(pn), len, char);
2774b8851fccSafresh1 *(PadnamePV(pn) + len) = '\0';
2775b8851fccSafresh1 PadnameLEN(pn) = len;
2776b8851fccSafresh1 return pn;
2777b8851fccSafresh1 }
2778b8851fccSafresh1
2779b8851fccSafresh1 /*
2780b8851fccSafresh1 =for apidoc newPADNAMEouter
2781b8851fccSafresh1
2782b8851fccSafresh1 Constructs and returns a new pad name. Only use this function for names
2783b8851fccSafresh1 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
2784b8851fccSafresh1 the outer pad name that this one mirrors. The returned pad name has the
2785*e0680481Safresh1 C<PADNAMEf_OUTER> flag already set.
2786b8851fccSafresh1
2787*e0680481Safresh1 =for apidoc Amnh||PADNAMEf_OUTER
278856d68f1eSafresh1
2789b8851fccSafresh1 =cut
2790b8851fccSafresh1 */
2791b8851fccSafresh1
2792b8851fccSafresh1 PADNAME *
Perl_newPADNAMEouter(PADNAME * outer)2793b8851fccSafresh1 Perl_newPADNAMEouter(PADNAME *outer)
2794b8851fccSafresh1 {
2795b8851fccSafresh1 PADNAME *pn;
2796b8851fccSafresh1 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2797b8851fccSafresh1 Newxz(pn, 1, PADNAME);
2798b8851fccSafresh1 PadnameREFCNT(pn) = 1;
2799b8851fccSafresh1 PadnamePV(pn) = PadnamePV(outer);
2800b8851fccSafresh1 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2801b8851fccSafresh1 another entry. The original pad name owns the buffer. */
2802*e0680481Safresh1 PadnameREFCNT_inc(PADNAME_FROM_PV(PadnamePV(outer)));
2803*e0680481Safresh1 PadnameFLAGS(pn) = PADNAMEf_OUTER;
2804*e0680481Safresh1 if(PadnameIsFIELD(outer)) {
2805*e0680481Safresh1 PadnameFIELDINFO(pn) = PadnameFIELDINFO(outer);
2806*e0680481Safresh1 PadnameFIELDINFO(pn)->refcount++;
2807*e0680481Safresh1 PadnameFLAGS(pn) |= PADNAMEf_FIELD;
2808*e0680481Safresh1 }
2809b8851fccSafresh1 PadnameLEN(pn) = PadnameLEN(outer);
2810b8851fccSafresh1 return pn;
2811b8851fccSafresh1 }
2812b8851fccSafresh1
2813b8851fccSafresh1 void
Perl_padname_free(pTHX_ PADNAME * pn)2814b8851fccSafresh1 Perl_padname_free(pTHX_ PADNAME *pn)
2815b8851fccSafresh1 {
2816b8851fccSafresh1 PERL_ARGS_ASSERT_PADNAME_FREE;
2817b8851fccSafresh1 if (!--PadnameREFCNT(pn)) {
2818b8851fccSafresh1 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2819b8851fccSafresh1 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2820b8851fccSafresh1 return;
2821b8851fccSafresh1 }
2822b8851fccSafresh1 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2823b8851fccSafresh1 SvREFCNT_dec(PadnameOURSTASH(pn));
2824b8851fccSafresh1 if (PadnameOUTER(pn))
2825b8851fccSafresh1 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2826*e0680481Safresh1 if (PadnameIsFIELD(pn)) {
2827*e0680481Safresh1 struct padname_fieldinfo *info = PadnameFIELDINFO(pn);
2828*e0680481Safresh1 if(!--info->refcount) {
2829*e0680481Safresh1 SvREFCNT_dec(info->fieldstash);
2830*e0680481Safresh1 /* todo: something about defop */
2831*e0680481Safresh1 SvREFCNT_dec(info->paramname);
2832*e0680481Safresh1
2833*e0680481Safresh1 Safefree(info);
2834*e0680481Safresh1 }
2835*e0680481Safresh1 }
2836b8851fccSafresh1 Safefree(pn);
2837b8851fccSafresh1 }
2838b8851fccSafresh1 }
2839b8851fccSafresh1
2840b8851fccSafresh1 #if defined(USE_ITHREADS)
2841b8851fccSafresh1
2842b8851fccSafresh1 /*
2843b8851fccSafresh1 =for apidoc padname_dup
2844b8851fccSafresh1
2845b8851fccSafresh1 Duplicates a pad name.
2846b8851fccSafresh1
2847b8851fccSafresh1 =cut
2848b8851fccSafresh1 */
2849b8851fccSafresh1
2850b8851fccSafresh1 PADNAME *
Perl_padname_dup(pTHX_ PADNAME * src,CLONE_PARAMS * param)2851b8851fccSafresh1 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2852b8851fccSafresh1 {
2853b8851fccSafresh1 PADNAME *dst;
2854b8851fccSafresh1
2855b8851fccSafresh1 PERL_ARGS_ASSERT_PADNAME_DUP;
2856b8851fccSafresh1
2857b8851fccSafresh1 /* look for it in the table first */
2858b8851fccSafresh1 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2859b8851fccSafresh1 if (dst)
2860b8851fccSafresh1 return dst;
2861b8851fccSafresh1
2862b8851fccSafresh1 if (!PadnamePV(src)) {
2863b8851fccSafresh1 dst = &PL_padname_undef;
2864b8851fccSafresh1 ptr_table_store(PL_ptr_table, src, dst);
2865b8851fccSafresh1 return dst;
2866b8851fccSafresh1 }
2867b8851fccSafresh1
2868b8851fccSafresh1 dst = PadnameOUTER(src)
2869b8851fccSafresh1 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2870b8851fccSafresh1 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2871b8851fccSafresh1 ptr_table_store(PL_ptr_table, src, dst);
2872b8851fccSafresh1 PadnameLEN(dst) = PadnameLEN(src);
2873b8851fccSafresh1 PadnameFLAGS(dst) = PadnameFLAGS(src);
2874b8851fccSafresh1 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2875b8851fccSafresh1 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2876b8851fccSafresh1 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2877b8851fccSafresh1 param);
2878*e0680481Safresh1 if(PadnameIsFIELD(src) && !PadnameOUTER(src)) {
2879*e0680481Safresh1 struct padname_fieldinfo *sinfo = PadnameFIELDINFO(src);
2880*e0680481Safresh1 struct padname_fieldinfo *dinfo;
2881*e0680481Safresh1 Newxz(dinfo, 1, struct padname_fieldinfo);
2882*e0680481Safresh1
2883*e0680481Safresh1 dinfo->refcount = 1;
2884*e0680481Safresh1 dinfo->fieldix = sinfo->fieldix;
2885*e0680481Safresh1 dinfo->fieldstash = hv_dup_inc(sinfo->fieldstash, param);
2886*e0680481Safresh1 dinfo->paramname = sv_dup_inc(sinfo->paramname, param);
2887*e0680481Safresh1
2888*e0680481Safresh1 PadnameFIELDINFO(dst) = dinfo;
2889*e0680481Safresh1 }
2890b8851fccSafresh1 dst->xpadn_low = src->xpadn_low;
2891b8851fccSafresh1 dst->xpadn_high = src->xpadn_high;
2892b8851fccSafresh1 dst->xpadn_gen = src->xpadn_gen;
2893b8851fccSafresh1 return dst;
2894b8851fccSafresh1 }
2895b8851fccSafresh1
2896b8851fccSafresh1 #endif /* USE_ITHREADS */
2897b8851fccSafresh1
2898b8851fccSafresh1 /*
2899*e0680481Safresh1 =for apidoc_section $lexer
2900*e0680481Safresh1 =for apidoc suspend_compcv
2901*e0680481Safresh1
2902*e0680481Safresh1 Implements part of the concept of a "suspended compilation CV", which can be
2903*e0680481Safresh1 used to pause the parser and compiler during parsing a CV in order to come
2904*e0680481Safresh1 back to it later on.
2905*e0680481Safresh1
2906*e0680481Safresh1 This function saves the current state of the subroutine under compilation
2907*e0680481Safresh1 (C<PL_compcv>) into the supplied buffer. This should be used initially to
2908*e0680481Safresh1 create the state in the buffer, as the final thing before a C<LEAVE> within a
2909*e0680481Safresh1 block.
2910*e0680481Safresh1
2911*e0680481Safresh1 ENTER;
2912*e0680481Safresh1 start_subparse(0);
2913*e0680481Safresh1 ...
2914*e0680481Safresh1
2915*e0680481Safresh1 suspend_compcv(&buffer);
2916*e0680481Safresh1 LEAVE;
2917*e0680481Safresh1
2918*e0680481Safresh1 Once suspended, the C<resume_compcv> or C<resume_compcv_and_save> function can
2919*e0680481Safresh1 later be used to continue the parsing from the point this stopped.
2920*e0680481Safresh1
2921*e0680481Safresh1 =cut
2922*e0680481Safresh1 */
2923*e0680481Safresh1
2924*e0680481Safresh1 void
Perl_suspend_compcv(pTHX_ struct suspended_compcv * buffer)2925*e0680481Safresh1 Perl_suspend_compcv(pTHX_ struct suspended_compcv *buffer)
2926*e0680481Safresh1 {
2927*e0680481Safresh1 PERL_ARGS_ASSERT_SUSPEND_COMPCV;
2928*e0680481Safresh1
2929*e0680481Safresh1 buffer->compcv = PL_compcv;
2930*e0680481Safresh1
2931*e0680481Safresh1 buffer->padix = PL_padix;
2932*e0680481Safresh1 buffer->constpadix = PL_constpadix;
2933*e0680481Safresh1
2934*e0680481Safresh1 buffer->comppad_name_fill = PL_comppad_name_fill;
2935*e0680481Safresh1 buffer->min_intro_pending = PL_min_intro_pending;
2936*e0680481Safresh1 buffer->max_intro_pending = PL_max_intro_pending;
2937*e0680481Safresh1
2938*e0680481Safresh1 buffer->cv_has_eval = PL_cv_has_eval;
2939*e0680481Safresh1 buffer->pad_reset_pending = PL_pad_reset_pending;
2940*e0680481Safresh1 }
2941*e0680481Safresh1
2942*e0680481Safresh1 /*
2943*e0680481Safresh1 =for apidoc resume_compcv_final
2944*e0680481Safresh1
2945*e0680481Safresh1 Resumes the parser state previously saved using the C<suspend_compcv> function
2946*e0680481Safresh1 for a final time before being compiled into a full CV. This should be used
2947*e0680481Safresh1 within an C<ENTER>/C<LEAVE> scoped pair.
2948*e0680481Safresh1
2949*e0680481Safresh1 =for apidoc resume_compcv_and_save
2950*e0680481Safresh1
2951*e0680481Safresh1 Resumes a buffer previously suspended by the C<suspend_compcv> function, in a
2952*e0680481Safresh1 way that will be re-suspended at the end of the scope so it can be used again
2953*e0680481Safresh1 later. This should be used within an C<ENTER>/C<LEAVE> scoped pair.
2954*e0680481Safresh1
2955*e0680481Safresh1 =cut
2956*e0680481Safresh1 */
2957*e0680481Safresh1
2958*e0680481Safresh1 void
Perl_resume_compcv(pTHX_ struct suspended_compcv * buffer,bool save)2959*e0680481Safresh1 Perl_resume_compcv(pTHX_ struct suspended_compcv *buffer, bool save)
2960*e0680481Safresh1 {
2961*e0680481Safresh1 PERL_ARGS_ASSERT_RESUME_COMPCV;
2962*e0680481Safresh1
2963*e0680481Safresh1 SAVESPTR(PL_compcv);
2964*e0680481Safresh1 PL_compcv = buffer->compcv;
2965*e0680481Safresh1 PAD_SET_CUR(CvPADLIST(PL_compcv), 1);
2966*e0680481Safresh1
2967*e0680481Safresh1 SAVESPTR(PL_comppad_name);
2968*e0680481Safresh1 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
2969*e0680481Safresh1
2970*e0680481Safresh1 SAVESTRLEN(PL_padix); PL_padix = buffer->padix;
2971*e0680481Safresh1 SAVESTRLEN(PL_constpadix); PL_constpadix = buffer->constpadix;
2972*e0680481Safresh1 SAVESTRLEN(PL_comppad_name_fill); PL_comppad_name_fill = buffer->comppad_name_fill;
2973*e0680481Safresh1 SAVESTRLEN(PL_min_intro_pending); PL_min_intro_pending = buffer->min_intro_pending;
2974*e0680481Safresh1 SAVESTRLEN(PL_max_intro_pending); PL_max_intro_pending = buffer->max_intro_pending;
2975*e0680481Safresh1
2976*e0680481Safresh1 SAVEBOOL(PL_cv_has_eval); PL_cv_has_eval = buffer->cv_has_eval;
2977*e0680481Safresh1 SAVEBOOL(PL_pad_reset_pending); PL_pad_reset_pending = buffer->pad_reset_pending;
2978*e0680481Safresh1
2979*e0680481Safresh1 if(save)
2980*e0680481Safresh1 SAVEDESTRUCTOR_X(&Perl_suspend_compcv, buffer);
2981*e0680481Safresh1 }
2982*e0680481Safresh1
2983*e0680481Safresh1 /*
298491f110e0Safresh1 * ex: set ts=8 sts=4 sw=4 et:
298552bd00bfSmillert */
2986