This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
assert nested CV existence when freeing CV
[perl5.git] / pad.c
CommitLineData
dd2155a4
DM
1/* pad.c
2 *
1129b882
NC
3 * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 * by Larry Wall and others
dd2155a4
DM
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
4ac71550
TC
8 */
9
10/*
11 * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12 * might say, among those queer Bucklanders, being brought up anyhow in
13 * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
14 * never had fewer than a couple of hundred relations in the place.
15 * Mr. Bilbo never did a kinder deed than when he brought the lad back
16 * to live among decent folk.' --the Gaffer
dd2155a4 17 *
4ac71550 18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
dd2155a4
DM
19 */
20
dd2155a4
DM
21/*
22=head1 Pad Data Structures
23
cc76b5cc 24=for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
166f8a29 25
58a9b2fe 26CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
cc76b5cc
Z
27scratchpad, which stores lexical variables and opcode temporary and
28per-thread values.
dd2155a4 29
58a9b2fe 30For these purposes "formats" are a kind-of CV; eval""s are too (except they're
dd2155a4 31not callable at will and are always thrown away after the eval"" is done
58a9b2fe 32executing). Require'd files are simply evals without any outer lexical
b5c19bd7 33scope.
dd2155a4 34
796b6530 35XSUBs do not have a C<CvPADLIST>. C<dXSTARG> fetches values from C<PL_curpad>,
dd2155a4 36but that is really the callers pad (a slot of which is allocated by
796b6530
KW
37every entersub). Do not get or set C<CvPADLIST> if a CV is an XSUB (as
38determined by C<CvISXSUB()>), C<CvPADLIST> slot is reused for a different
eacbb379 39internal purpose in XSUBs.
dd2155a4 40
58a9b2fe 41The PADLIST has a C array where pads are stored.
dd2155a4 42
9b7476d7
FC
43The 0th entry of the PADLIST is a PADNAMELIST
44which represents the "names" or rather
58a9b2fe 45the "static type information" for lexicals. The individual elements of a
9b7476d7 46PADNAMELIST are PADNAMEs. Future
7a5eb04d 47refactorings might stop the PADNAMELIST from being stored in the PADLIST's
86d2498c 48array, so don't rely on it. See L</PadlistNAMES>.
dd2155a4 49
58a9b2fe
FC
50The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
51at that depth of recursion into the CV. The 0th slot of a frame AV is an
796b6530 52AV which is C<@_>. Other entries are storage for variables and op targets.
dd2155a4 53
58a9b2fe 54Iterating over the PADNAMELIST iterates over all possible pad
796b6530 55items. Pad slots for targets (C<SVs_PADTMP>)
307a54be 56and GVs end up having &PL_padname_undef "names", while slots for constants
796b6530
KW
57have C<&PL_padname_const> "names" (see C<L</pad_alloc>>). That
58C<&PL_padname_undef>
59and C<&PL_padname_const> are used is an implementation detail subject to
60change. To test for them, use C<!PadnamePV(name)> and
61b16eb9 61S<C<PadnamePV(name) && !PadnameLEN(name)>>, respectively.
dd2155a4 62
796b6530 63Only C<my>/C<our> variable slots get valid names.
dd2155a4
DM
64The rest are op targets/GVs/constants which are statically allocated
65or resolved at compile time. These don't have names by which they
58a9b2fe 66can be looked up from Perl code at run time through eval"" the way
796b6530 67C<my>/C<our> variables can be. Since they can't be looked up by "name"
dd2155a4 68but only by their index allocated at compile time (which is usually
796b6530 69in C<PL_op->op_targ>), wasting a name SV for them doesn't make sense.
dd2155a4 70
307a54be 71The pad names in the PADNAMELIST have their PV holding the name of
796b6530 72the variable. The C<COP_SEQ_RANGE_LOW> and C<_HIGH> fields form a range
307a54be
FC
73(low+1..high inclusive) of cop_seq numbers for which the name is
74valid. During compilation, these fields may hold the special value
61f4bfbf 75PERL_PADSEQ_INTRO to indicate various stages:
0d311cdb 76
8560fbdd
KW
77 COP_SEQ_RANGE_LOW _HIGH
78 ----------------- -----
79 PERL_PADSEQ_INTRO 0 variable not yet introduced:
80 { my ($x
81 valid-seq# PERL_PADSEQ_INTRO variable in scope:
4e785f27 82 { my ($x);
8560fbdd 83 valid-seq# valid-seq# compilation of scope complete:
4e785f27
DM
84 { my ($x); .... }
85
86When a lexical var hasn't yet been introduced, it already exists from the
87perspective of duplicate declarations, but not for variable lookups, e.g.
88
89 my ($x, $x); # '"my" variable $x masks earlier declaration'
90 my $x = $x; # equal to my $x = $::x;
0d311cdb 91
796b6530
KW
92For typed lexicals C<PadnameTYPE> points at the type stash. For C<our>
93lexicals, C<PadnameOURSTASH> points at the stash of the associated global (so
307a54be 94that duplicate C<our> declarations in the same package can be detected).
796b6530 95C<PadnameGEN> is sometimes used to store the generation number during
307a54be
FC
96compilation.
97
796b6530 98If C<PadnameOUTER> is set on the pad name, then that slot in the frame AV
307a54be
FC
99is a REFCNT'ed reference to a lexical from "outside". Such entries
100are sometimes referred to as 'fake'. In this case, the name does not
101use 'low' and 'high' to store a cop_seq range, since it is in scope
102throughout. Instead 'high' stores some flags containing info about
b5c19bd7 103the real lexical (is it declared in an anon, and is it capable of being
307a54be 104instantiated multiple times?), and for fake ANONs, 'low' contains the index
b5c19bd7
DM
105within the parent's pad where the lexical's value is stored, to make
106cloning quicker.
dd2155a4 107
796b6530 108If the 'name' is C<&> the corresponding entry in the PAD
dd2155a4 109is a CV representing a possible closure.
dd2155a4 110
71f882da
DM
111Note that formats are treated as anon subs, and are cloned each time
112write is called (if necessary).
113
796b6530 114The flag C<SVs_PADSTALE> is cleared on lexicals each time the C<my()> is executed,
58a9b2fe 115and set on scope exit. This allows the
796b6530 116C<"Variable $x is not available"> warning
e6e7068b
DM
117to be generated in evals, such as
118
119 { my $x = 1; sub f { eval '$x'} } f();
120
796b6530 121For state vars, C<SVs_PADSTALE> is overloaded to mean 'not yet initialised',
c9956dca 122but this internal state is stored in a separate pad entry.
d1186544 123
36c300bb 124=for apidoc AmxU|PADNAMELIST *|PL_comppad_name
cc76b5cc
Z
125
126During compilation, this points to the array containing the names part
127of the pad for the currently-compiling code.
128
36c300bb 129=for apidoc AmxU|PAD *|PL_comppad
cc76b5cc
Z
130
131During compilation, this points to the array containing the values
132part of the pad for the currently-compiling code. (At runtime a CV may
133have many such value arrays; at compile time just one is constructed.)
134At runtime, this points to the array containing the currently-relevant
135values for the pad for the currently-executing code.
136
137=for apidoc AmxU|SV **|PL_curpad
138
139Points directly to the body of the L</PL_comppad> array.
c14a2249 140(I.e., this is C<PAD_ARRAY(PL_comppad)>.)
cc76b5cc 141
dd2155a4
DM
142=cut
143*/
144
145
146#include "EXTERN.h"
147#define PERL_IN_PAD_C
148#include "perl.h"
952306ac 149#include "keywords.h"
dd2155a4 150
3441fb63 151#define COP_SEQ_RANGE_LOW_set(sv,val) \
0f94cb1f 152 STMT_START { (sv)->xpadn_low = (val); } STMT_END
3441fb63 153#define COP_SEQ_RANGE_HIGH_set(sv,val) \
0f94cb1f 154 STMT_START { (sv)->xpadn_high = (val); } STMT_END
809abb02 155
0f94cb1f
FC
156#define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set
157#define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set
dd2155a4 158
eacbb379
DD
159#ifdef DEBUGGING
160void
e69651e7 161Perl_set_padlist(CV * cv, PADLIST *padlist){
eacbb379
DD
162 PERL_ARGS_ASSERT_SET_PADLIST;
163# if PTRSIZE == 8
e5964223 164 assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
eacbb379 165# elif PTRSIZE == 4
a1c99363 166 assert((Size_t)padlist != 0xEFEFEFEF);
eacbb379
DD
167# else
168# error unknown pointer size
169# endif
e5964223 170 assert(!CvISXSUB(cv));
eacbb379
DD
171 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
172}
173#endif
5b16296c
BF
174
175/*
cc76b5cc 176=for apidoc Am|PADLIST *|pad_new|int flags
dd2155a4 177
cc76b5cc
Z
178Create a new padlist, updating the global variables for the
179currently-compiling padlist to point to the new padlist. The following
180flags can be OR'ed together:
dd2155a4
DM
181
182 padnew_CLONE this pad is for a cloned CV
cc76b5cc 183 padnew_SAVE save old globals on the save stack
dd2155a4
DM
184 padnew_SAVESUB also save extra stuff for start of sub
185
186=cut
187*/
188
189PADLIST *
c7c737cb 190Perl_pad_new(pTHX_ int flags)
dd2155a4 191{
7261499d 192 PADLIST *padlist;
9b7476d7
FC
193 PADNAMELIST *padname;
194 PAD *pad;
7261499d 195 PAD **ary;
dd2155a4 196
f3548bdc
DM
197 ASSERT_CURPAD_LEGAL("pad_new");
198
dd2155a4
DM
199 /* save existing state, ... */
200
201 if (flags & padnew_SAVE) {
3979c56f 202 SAVECOMPPAD();
dd2155a4 203 if (! (flags & padnew_CLONE)) {
cbacc9aa 204 SAVESPTR(PL_comppad_name);
d12be05d
DM
205 save_strlen((STRLEN *)&PL_padix);
206 save_strlen((STRLEN *)&PL_constpadix);
207 save_strlen((STRLEN *)&PL_comppad_name_fill);
208 save_strlen((STRLEN *)&PL_min_intro_pending);
209 save_strlen((STRLEN *)&PL_max_intro_pending);
8bbe96d7 210 SAVEBOOL(PL_cv_has_eval);
dd2155a4 211 if (flags & padnew_SAVESUB) {
f0cb02e3 212 SAVEBOOL(PL_pad_reset_pending);
dd2155a4
DM
213 }
214 }
215 }
dd2155a4
DM
216
217 /* ... create new pad ... */
218
7261499d 219 Newxz(padlist, 1, PADLIST);
dd2155a4
DM
220 pad = newAV();
221
222 if (flags & padnew_CLONE) {
e1ec3a88 223 AV * const a0 = newAV(); /* will be @_ */
ad64d0ec 224 av_store(pad, 0, MUTABLE_SV(a0));
11ca45c0 225 AvREIFY_only(a0);
9ef8d569 226
9b7476d7 227 PadnamelistREFCNT(padname = PL_comppad_name)++;
dd2155a4
DM
228 }
229 else {
b4db5868 230 padlist->xpadl_id = PL_padlist_generation++;
a0714e2c 231 av_store(pad, 0, NULL);
9b7476d7 232 padname = newPADNAMELIST(0);
0f94cb1f 233 padnamelist_store(padname, 0, &PL_padname_undef);
dd2155a4
DM
234 }
235
7a6072a8
NC
236 /* Most subroutines never recurse, hence only need 2 entries in the padlist
237 array - names, and depth=1. The default for av_store() is to allocate
238 0..3, and even an explicit call to av_extend() with <3 will be rounded
239 up, so we inline the allocation of the array here. */
7261499d 240 Newx(ary, 2, PAD *);
86d2498c
FC
241 PadlistMAX(padlist) = 1;
242 PadlistARRAY(padlist) = ary;
9b7476d7 243 ary[0] = (PAD *)padname;
7261499d 244 ary[1] = pad;
dd2155a4
DM
245
246 /* ... then update state variables */
247
403799bf
NC
248 PL_comppad = pad;
249 PL_curpad = AvARRAY(pad);
dd2155a4
DM
250
251 if (! (flags & padnew_CLONE)) {
9ef8d569 252 PL_comppad_name = padname;
dd2155a4
DM
253 PL_comppad_name_fill = 0;
254 PL_min_intro_pending = 0;
255 PL_padix = 0;
b54c5e14 256 PL_constpadix = 0;
b5c19bd7 257 PL_cv_has_eval = 0;
dd2155a4
DM
258 }
259
260 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846
KW
261 "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf
262 " name=0x%" UVxf " flags=0x%" UVxf "\n",
b5c19bd7 263 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
dd2155a4
DM
264 PTR2UV(padname), (UV)flags
265 )
266 );
267
268 return (PADLIST*)padlist;
269}
270
dd2155a4 271
c4528262
NC
272/*
273=head1 Embedding Functions
274
275=for apidoc cv_undef
276
72d33970 277Clear out all the active components of a CV. This can happen either
c4528262 278by an explicit C<undef &foo>, or by the reference count going to zero.
796b6530 279In the former case, we keep the C<CvOUTSIDE> pointer, so that any anonymous
c4528262
NC
280children can still follow the full lexical scope chain.
281
282=cut
283*/
284
285void
286Perl_cv_undef(pTHX_ CV *cv)
287{
b7acb0a3
FC
288 PERL_ARGS_ASSERT_CV_UNDEF;
289 cv_undef_flags(cv, 0);
290}
291
292void
293Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
294{
52ec28d5
DD
295 CV cvbody;/*CV body will never be realloced inside this func,
296 so dont read it more than once, use fake CV so existing macros
297 will work, the indirection and CV head struct optimized away*/
298 SvANY(&cvbody) = SvANY(cv);
c4528262 299
b7acb0a3 300 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
c4528262
NC
301
302 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846 303 "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n",
c4528262
NC
304 PTR2UV(cv), PTR2UV(PL_comppad))
305 );
306
52ec28d5
DD
307 if (CvFILE(&cvbody)) {
308 char * file = CvFILE(&cvbody);
309 CvFILE(&cvbody) = NULL;
310 if(CvDYNFILE(&cvbody))
311 Safefree(file);
c4528262 312 }
dd2155a4 313
52ec28d5
DD
314 /* CvSLABBED_off(&cvbody); *//* turned off below */
315 /* release the sub's body */
316 if (!CvISXSUB(&cvbody)) {
317 if(CvROOT(&cvbody)) {
318 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
319 if (CvDEPTHunsafe(&cvbody)) {
320 assert(SvTYPE(cv) == SVt_PVCV);
321 Perl_croak_nocontext("Can't undef active subroutine");
322 }
323 ENTER;
324
325 PAD_SAVE_SETNULLPAD();
326
327 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
328 op_free(CvROOT(&cvbody));
329 CvROOT(&cvbody) = NULL;
330 CvSTART(&cvbody) = NULL;
331 LEAVE;
332 }
333 else if (CvSLABBED(&cvbody)) {
334 if( CvSTART(&cvbody)) {
335 ENTER;
336 PAD_SAVE_SETNULLPAD();
337
338 /* discard any leaked ops */
339 if (PL_parser)
340 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
341 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
342 CvSTART(&cvbody) = NULL;
343
344 LEAVE;
345 }
7aef8e5b 346#ifdef DEBUGGING
52ec28d5 347 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
8be227ab 348#endif
52ec28d5
DD
349 }
350 }
351 else { /* dont bother checking if CvXSUB(cv) is true, less branching */
352 CvXSUB(&cvbody) = NULL;
353 }
c4528262 354 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
2f14e398 355 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
b7acb0a3 356 if (!(flags & CV_UNDEF_KEEP_NAME)) {
52ec28d5
DD
357 if (CvNAMED(&cvbody)) {
358 CvNAME_HEK_set(&cvbody, NULL);
359 CvNAMED_off(&cvbody);
b7acb0a3
FC
360 }
361 else CvGV_set(cv, NULL);
362 }
c4528262 363
c2736fce
NC
364 /* This statement and the subsequence if block was pad_undef(). */
365 pad_peg("pad_undef");
366
eacbb379 367 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
d12be05d 368 PADOFFSET ix;
52ec28d5 369 const PADLIST *padlist = CvPADLIST(&cvbody);
c2736fce
NC
370
371 /* Free the padlist associated with a CV.
372 If parts of it happen to be current, we null the relevant PL_*pad*
373 global vars so that we don't have any dangling references left.
374 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
375 subs to the outer of this cv. */
376
377 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846 378 "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n",
c2736fce
NC
379 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
380 );
381
382 /* detach any '&' anon children in the pad; if afterwards they
383 * are still live, fix up their CvOUTSIDEs to point to our outside,
384 * bypassing us. */
c2736fce
NC
385
386 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
52ec28d5
DD
387 CV * const outercv = CvOUTSIDE(&cvbody);
388 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
9b7476d7 389 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
cab74fca 390 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
86d2498c 391 PAD * const comppad = PadlistARRAY(padlist)[1];
c2736fce 392 SV ** const curpad = AvARRAY(comppad);
9b7476d7 393 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
cab74fca
FC
394 PADNAME * const name = namepad[ix];
395 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
c2736fce
NC
396 {
397 CV * const innercv = MUTABLE_CV(curpad[ix]);
dce3f5c3
Z
398 U32 inner_rc;
399 assert(innercv);
e09ac076 400 assert(SvTYPE(innercv) != SVt_PVFM);
dce3f5c3
Z
401 inner_rc = SvREFCNT(innercv);
402 assert(inner_rc);
c2736fce
NC
403
404 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
405 curpad[ix] = NULL;
fc2b2dca 406 SvREFCNT_dec_NN(innercv);
c2736fce
NC
407 inner_rc--;
408 }
409
410 /* in use, not just a prototype */
b03210bf
FC
411 if (inner_rc && SvTYPE(innercv) == SVt_PVCV
412 && (CvOUTSIDE(innercv) == cv))
413 {
c2736fce
NC
414 assert(CvWEAKOUTSIDE(innercv));
415 /* don't relink to grandfather if he's being freed */
416 if (outercv && SvREFCNT(outercv)) {
417 CvWEAKOUTSIDE_off(innercv);
418 CvOUTSIDE(innercv) = outercv;
419 CvOUTSIDE_SEQ(innercv) = seq;
420 SvREFCNT_inc_simple_void_NN(outercv);
421 }
422 else {
423 CvOUTSIDE(innercv) = NULL;
424 }
425 }
426 }
427 }
428 }
429
86d2498c 430 ix = PadlistMAX(padlist);
aa2f79cf 431 while (ix > 0) {
86d2498c 432 PAD * const sv = PadlistARRAY(padlist)[ix--];
c2736fce 433 if (sv) {
7261499d 434 if (sv == PL_comppad) {
c2736fce
NC
435 PL_comppad = NULL;
436 PL_curpad = NULL;
437 }
fc2b2dca 438 SvREFCNT_dec_NN(sv);
c2736fce 439 }
aa2f79cf
NC
440 }
441 {
9b7476d7
FC
442 PADNAMELIST * const names = PadlistNAMES(padlist);
443 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
aa2f79cf 444 PL_comppad_name = NULL;
9b7476d7 445 PadnamelistREFCNT_dec(names);
c2736fce 446 }
86d2498c 447 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
7261499d 448 Safefree(padlist);
eacbb379 449 CvPADLIST_set(&cvbody, NULL);
c2736fce 450 }
db6e00bd
DD
451 else if (CvISXSUB(&cvbody))
452 CvHSCXT(&cvbody) = NULL;
eacbb379 453 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
c2736fce 454
c4528262
NC
455
456 /* remove CvOUTSIDE unless this is an undef rather than a free */
52ec28d5
DD
457 if (!SvREFCNT(cv)) {
458 CV * outside = CvOUTSIDE(&cvbody);
459 if(outside) {
460 CvOUTSIDE(&cvbody) = NULL;
461 if (!CvWEAKOUTSIDE(&cvbody))
462 SvREFCNT_dec_NN(outside);
463 }
c4528262 464 }
52ec28d5
DD
465 if (CvCONST(&cvbody)) {
466 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
467 /* CvCONST_off(cv); *//* turned off below */
c4528262
NC
468 }
469 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
b7acb0a3
FC
470 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
471 * LEXICAL, which are used to determine the sub's name. */
52ec28d5 472 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
b7acb0a3 473 |CVf_NAMED);
c4528262 474}
dd2155a4 475
50dc2bd3
FC
476/*
477=for apidoc cv_forget_slab
478
796b6530 479When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
50dc2bd3
FC
480for making sure it is freed. (Hence, no two CVs should ever have a
481reference count on the same slab.) The CV only needs to reference the slab
796b6530 482during compilation. Once it is compiled and C<CvROOT> attached, it has
50dc2bd3
FC
483finished its job, so it can forget the slab.
484
485=cut
486*/
487
8be227ab
FC
488void
489Perl_cv_forget_slab(pTHX_ CV *cv)
490{
de0885da 491 bool slabbed;
3107b51f 492 OPSLAB *slab = NULL;
8be227ab 493
de0885da
DM
494 if (!cv)
495 return;
496 slabbed = cBOOL(CvSLABBED(cv));
8be227ab
FC
497 if (!slabbed) return;
498
499 CvSLABBED_off(cv);
500
3107b51f
FC
501 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
502 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
7aef8e5b 503#ifdef DEBUGGING
eb212a1c 504 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
7aef8e5b 505#endif
3107b51f 506
3107b51f 507 if (slab) {
f3e29105
NC
508#ifdef PERL_DEBUG_READONLY_OPS
509 const size_t refcnt = slab->opslab_refcnt;
510#endif
3107b51f 511 OpslabREFCNT_dec(slab);
f3e29105 512#ifdef PERL_DEBUG_READONLY_OPS
3107b51f 513 if (refcnt > 1) Slab_to_ro(slab);
8be227ab 514#endif
f3e29105 515 }
7aef8e5b 516}
8be227ab 517
cc76b5cc 518/*
307a54be 519=for apidoc m|PADOFFSET|pad_alloc_name|PADNAME *name|U32 flags|HV *typestash|HV *ourstash
cc76b5cc 520
1a115e49
FC
521Allocates a place in the currently-compiling
522pad (via L<perlapi/pad_alloc>) and
2d7f6611 523then stores a name for that entry. C<name> is adopted and
307a54be 524becomes the name entry; it must already contain the name
2d7f6611
KW
525string. C<typestash> and C<ourstash> and the C<padadd_STATE>
526flag get added to C<name>. None of the other
1a115e49 527processing of L<perlapi/pad_add_name_pvn>
cc76b5cc
Z
528is done. Returns the offset of the allocated pad slot.
529
530=cut
531*/
532
3291825f 533static PADOFFSET
e1c02f84
FC
534S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
535 HV *ourstash)
3291825f 536{
3291825f
NC
537 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
538
cc76b5cc 539 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
3291825f 540
cc76b5cc 541 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
3291825f
NC
542
543 if (typestash) {
e1c02f84 544 SvPAD_TYPED_on(name);
0f94cb1f
FC
545 PadnameTYPE(name) =
546 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
3291825f
NC
547 }
548 if (ourstash) {
e1c02f84
FC
549 SvPAD_OUR_on(name);
550 SvOURSTASH_set(name, ourstash);
3291825f
NC
551 SvREFCNT_inc_simple_void_NN(ourstash);
552 }
59cfed7d 553 else if (flags & padadd_STATE) {
e1c02f84 554 SvPAD_STATE_on(name);
3291825f
NC
555 }
556
0f94cb1f 557 padnamelist_store(PL_comppad_name, offset, name);
dd5d1b89
FC
558 if (PadnameLEN(name) > 1)
559 PadnamelistMAXNAMED(PL_comppad_name) = offset;
3291825f
NC
560 return offset;
561}
562
dd2155a4 563/*
cc76b5cc 564=for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
dd2155a4 565
cc76b5cc
Z
566Allocates a place in the currently-compiling pad for a named lexical
567variable. Stores the name and other metadata in the name part of the
568pad, and makes preparations to manage the variable's lexical scoping.
569Returns the offset of the allocated pad slot.
dd2155a4 570
2d7f6611
KW
571C<namepv>/C<namelen> specify the variable's name, including leading sigil.
572If C<typestash> is non-null, the name is for a typed lexical, and this
573identifies the type. If C<ourstash> is non-null, it's a lexical reference
cc76b5cc
Z
574to a package variable, and this identifies the package. The following
575flags can be OR'ed together:
576
8560fbdd
KW
577 padadd_OUR redundantly specifies if it's a package var
578 padadd_STATE variable will retain value persistently
579 padadd_NO_DUP_CHECK skip check for lexical shadowing
dd2155a4
DM
580
581=cut
582*/
583
dd2155a4 584PADOFFSET
cc76b5cc
Z
585Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
586 U32 flags, HV *typestash, HV *ourstash)
dd2155a4 587{
3291825f 588 PADOFFSET offset;
e1c02f84 589 PADNAME *name;
dd2155a4 590
cc76b5cc 591 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
7918f24d 592
2502ffdf 593 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
cc76b5cc 594 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
cca43f78
NC
595 (UV)flags);
596
0f94cb1f 597 name = newPADNAMEpvn(namepv, namelen);
dd2155a4 598
59cfed7d 599 if ((flags & padadd_NO_DUP_CHECK) == 0) {
c2b36a6d 600 ENTER;
0f94cb1f 601 SAVEFREEPADNAME(name); /* in case of fatal warnings */
2d12d04f 602 /* check for duplicate declaration */
e1c02f84 603 pad_check_dup(name, flags & padadd_OUR, ourstash);
0f94cb1f 604 PadnameREFCNT(name)++;
c2b36a6d 605 LEAVE;
2d12d04f
NC
606 }
607
2502ffdf 608 offset = pad_alloc_name(name, flags, typestash, ourstash);
3291825f
NC
609
610 /* not yet introduced */
e1c02f84
FC
611 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
612 COP_SEQ_RANGE_HIGH_set(name, 0);
3291825f
NC
613
614 if (!PL_min_intro_pending)
615 PL_min_intro_pending = offset;
616 PL_max_intro_pending = offset;
617 /* if it's not a simple scalar, replace with an AV or HV */
c1bf42f3
NC
618 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
619 assert(SvREFCNT(PL_curpad[offset]) == 1);
cc76b5cc 620 if (namelen != 0 && *namepv == '@')
c1bf42f3 621 sv_upgrade(PL_curpad[offset], SVt_PVAV);
cc76b5cc 622 else if (namelen != 0 && *namepv == '%')
c1bf42f3 623 sv_upgrade(PL_curpad[offset], SVt_PVHV);
6d5c2147
FC
624 else if (namelen != 0 && *namepv == '&')
625 sv_upgrade(PL_curpad[offset], SVt_PVCV);
c1bf42f3 626 assert(SvPADMY(PL_curpad[offset]));
3291825f 627 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147e3846 628 "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n",
e1c02f84 629 (long)offset, PadnamePV(name),
cc76b5cc 630 PTR2UV(PL_curpad[offset])));
dd2155a4
DM
631
632 return offset;
633}
634
cc76b5cc
Z
635/*
636=for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
dd2155a4 637
cc76b5cc
Z
638Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
639instead of a string/length pair.
dd2155a4 640
cc76b5cc
Z
641=cut
642*/
643
644PADOFFSET
645Perl_pad_add_name_pv(pTHX_ const char *name,
0e1b3a4b 646 const U32 flags, HV *typestash, HV *ourstash)
cc76b5cc
Z
647{
648 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
649 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
650}
dd2155a4
DM
651
652/*
cc76b5cc 653=for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
dd2155a4 654
cc76b5cc
Z
655Exactly like L</pad_add_name_pvn>, but takes the name string in the form
656of an SV instead of a string/length pair.
657
658=cut
659*/
660
661PADOFFSET
662Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
663{
664 char *namepv;
665 STRLEN namelen;
666 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
2502ffdf 667 namepv = SvPVutf8(name, namelen);
cc76b5cc
Z
668 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
669}
670
671/*
672=for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
673
674Allocates a place in the currently-compiling pad,
675returning the offset of the allocated pad slot.
676No name is initially attached to the pad slot.
2d7f6611 677C<tmptype> is a set of flags indicating the kind of pad entry required,
cc76b5cc
Z
678which will be set in the value SV for the allocated pad entry:
679
680 SVs_PADMY named lexical variable ("my", "our", "state")
681 SVs_PADTMP unnamed temporary store
325e1816
FC
682 SVf_READONLY constant shared between recursion levels
683
684C<SVf_READONLY> has been supported here only since perl 5.20. To work with
c370bd2e
FC
685earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
686does not cause the SV in the pad slot to be marked read-only, but simply
687tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
688least should be treated as such.
cc76b5cc 689
2d7f6611 690C<optype> should be an opcode indicating the type of operation that the
cc76b5cc
Z
691pad entry is to support. This doesn't affect operational semantics,
692but is used for debugging.
dd2155a4
DM
693
694=cut
695*/
696
dd2155a4
DM
697PADOFFSET
698Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
699{
700 SV *sv;
d12be05d 701 PADOFFSET retval;
dd2155a4 702
6136c704 703 PERL_UNUSED_ARG(optype);
f3548bdc
DM
704 ASSERT_CURPAD_ACTIVE("pad_alloc");
705
dd2155a4 706 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
707 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
708 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
709 if (PL_pad_reset_pending)
710 pad_reset();
c0683843 711 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
cc76b5cc 712 /* For a my, simply push a null SV onto the end of PL_comppad. */
235cc2e3 713 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
d12be05d 714 retval = (PADOFFSET)AvFILLp(PL_comppad);
dd2155a4
DM
715 }
716 else {
cc76b5cc
Z
717 /* For a tmp, scan the pad from PL_padix upwards
718 * for a slot which has no name and no active value.
b54c5e14 719 * For a constant, likewise, but use PL_constpadix.
cc76b5cc 720 */
9b7476d7
FC
721 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
722 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
b54c5e14
FC
723 const bool konst = cBOOL(tmptype & SVf_READONLY);
724 retval = konst ? PL_constpadix : PL_padix;
dd2155a4
DM
725 for (;;) {
726 /*
833bf1cd
FC
727 * Entries that close over unavailable variables
728 * in outer subs contain values not marked PADMY.
729 * Thus we must skip, not just pad values that are
dd2155a4 730 * marked as current pad values, but also those with names.
1780e744
FC
731 * If pad_reset is enabled, ‘current’ means different
732 * things depending on whether we are allocating a con-
733 * stant or a target. For a target, things marked PADTMP
734 * can be reused; not so for constants.
dd2155a4 735 */
5e6246a7 736 PADNAME *pn;
b54c5e14 737 if (++retval <= names_fill &&
5e6246a7 738 (pn = names[retval]) && PadnamePV(pn))
dd2155a4 739 continue;
b54c5e14 740 sv = *av_fetch(PL_comppad, retval, TRUE);
a90643eb 741 if (!(SvFLAGS(sv) &
53de1311 742#ifdef USE_PAD_RESET
5debce0a 743 (konst ? SVs_PADTMP : 0)
a90643eb 744#else
145bf8ee 745 SVs_PADTMP
a90643eb 746#endif
13381c39 747 ))
dd2155a4
DM
748 break;
749 }
b54c5e14 750 if (konst) {
0f94cb1f 751 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
325e1816
FC
752 tmptype &= ~SVf_READONLY;
753 tmptype |= SVs_PADTMP;
754 }
b54c5e14 755 *(konst ? &PL_constpadix : &PL_padix) = retval;
dd2155a4
DM
756 }
757 SvFLAGS(sv) |= tmptype;
758 PL_curpad = AvARRAY(PL_comppad);
759
760 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846 761 "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n",
dd2155a4
DM
762 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
763 PL_op_name[optype]));
fd0854ff
DM
764#ifdef DEBUG_LEAKING_SCALARS
765 sv->sv_debug_optype = optype;
766 sv->sv_debug_inpad = 1;
fd0854ff 767#endif
d12be05d 768 return retval;
dd2155a4
DM
769}
770
771/*
cc76b5cc 772=for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
dd2155a4 773
cc76b5cc
Z
774Allocates a place in the currently-compiling pad (via L</pad_alloc>)
775for an anonymous function that is lexically scoped inside the
776currently-compiling function.
2d7f6611 777The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
cc76b5cc
Z
778to the outer scope is weakened to avoid a reference loop.
779
84eea980
FC
780One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
781
2d7f6611 782C<optype> should be an opcode indicating the type of operation that the
cc76b5cc
Z
783pad entry is to support. This doesn't affect operational semantics,
784but is used for debugging.
dd2155a4
DM
785
786=cut
787*/
788
789PADOFFSET
cc76b5cc 790Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
dd2155a4
DM
791{
792 PADOFFSET ix;
0f94cb1f 793 PADNAME * const name = newPADNAMEpvn("&", 1);
7918f24d
NC
794
795 PERL_ARGS_ASSERT_PAD_ADD_ANON;
74a9453a 796 assert (SvTYPE(func) == SVt_PVCV);
7918f24d 797
1dba731d 798 pad_peg("add_anon");
0d311cdb 799 /* These two aren't used; just make sure they're not equal to
0f94cb1f
FC
800 * PERL_PADSEQ_INTRO. They should be 0 by default. */
801 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
802 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
cc76b5cc 803 ix = pad_alloc(optype, SVs_PADMY);
9b7476d7 804 padnamelist_store(PL_comppad_name, ix, name);
74a9453a 805 av_store(PL_comppad, ix, (SV*)func);
7dafbf52
DM
806
807 /* to avoid ref loops, we never have parent + child referencing each
808 * other simultaneously */
74a9453a 809 if (CvOUTSIDE(func)) {
cc76b5cc
Z
810 assert(!CvWEAKOUTSIDE(func));
811 CvWEAKOUTSIDE_on(func);
fc2b2dca 812 SvREFCNT_dec_NN(CvOUTSIDE(func));
7dafbf52 813 }
dd2155a4
DM
814 return ix;
815}
816
a70f21d0
FC
817void
818Perl_pad_add_weakref(pTHX_ CV* func)
819{
820 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
821 PADNAME * const name = newPADNAMEpvn("&", 1);
822 SV * const rv = newRV_inc((SV *)func);
823
824 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
825
826 /* These two aren't used; just make sure they're not equal to
827 * PERL_PADSEQ_INTRO. They should be 0 by default. */
828 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
829 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
830 padnamelist_store(PL_comppad_name, ix, name);
831 sv_rvweaken(rv);
832 av_store(PL_comppad, ix, rv);
833}
834
dd2155a4 835/*
13087dd8 836=for apidoc pad_check_dup
dd2155a4
DM
837
838Check for duplicate declarations: report any of:
13087dd8 839
796b6530
KW
840 * a 'my' in the current scope with the same name;
841 * an 'our' (anywhere in the pad) with the same name and the
842 same stash as 'ourstash'
13087dd8 843
796b6530 844C<is_our> indicates that the name to check is an C<"our"> declaration.
dd2155a4
DM
845
846=cut
847*/
848
20381b50 849STATIC void
e1c02f84 850S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
dd2155a4 851{
0aaff5a1 852 PADNAME **svp;
dd2155a4 853 PADOFFSET top, off;
59cfed7d 854 const U32 is_our = flags & padadd_OUR;
dd2155a4 855
7918f24d
NC
856 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
857
f3548bdc 858 ASSERT_CURPAD_ACTIVE("pad_check_dup");
35f82371 859
59cfed7d 860 assert((flags & ~padadd_OUR) == 0);
35f82371 861
52e3acf8 862 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW))
dd2155a4
DM
863 return; /* nothing to check */
864
9b7476d7
FC
865 svp = PadnamelistARRAY(PL_comppad_name);
866 top = PadnamelistMAX(PL_comppad_name);
dd2155a4 867 /* check the current scope */
d12be05d 868 for (off = top; off > PL_comppad_name_floor; off--) {
0aaff5a1 869 PADNAME * const sv = svp[off];
53c1dcc0 870 if (sv
0aaff5a1
FC
871 && PadnameLEN(sv) == PadnameLEN(name)
872 && !PadnameOUTER(sv)
0d311cdb
DM
873 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
874 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
0aaff5a1 875 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
dd2155a4 876 {
00b1698f 877 if (is_our && (SvPAD_OUR(sv)))
7f73a9f1 878 break; /* "our" masking "our" */
4eb94d7c 879 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
52e3acf8 880 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
147e3846 881 "\"%s\" %s %" PNf " masks earlier declaration in same %s",
49fb8620
DM
882 ( is_our ? "our" :
883 PL_parser->in_my == KEY_my ? "my" :
884 PL_parser->in_my == KEY_sigvar ? "my" :
885 "state" ),
0aaff5a1
FC
886 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
887 PNfARG(sv),
2df5bdd7
DM
888 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
889 ? "scope" : "statement"));
dd2155a4
DM
890 --off;
891 break;
892 }
893 }
894 /* check the rest of the pad */
895 if (is_our) {
61c5492a 896 while (off > 0) {
0aaff5a1 897 PADNAME * const sv = svp[off];
53c1dcc0 898 if (sv
0aaff5a1
FC
899 && PadnameLEN(sv) == PadnameLEN(name)
900 && !PadnameOUTER(sv)
0d311cdb
DM
901 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
902 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
73d95100 903 && SvOURSTASH(sv) == ourstash
0aaff5a1 904 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
dd2155a4 905 {
52e3acf8 906 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
147e3846 907 "\"our\" variable %" PNf " redeclared", PNfARG(sv));
d12be05d 908 if (off <= PL_comppad_name_floor)
52e3acf8 909 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
7f73a9f1 910 "\t(Did you mean \"local\" instead of \"our\"?)\n");
dd2155a4
DM
911 break;
912 }
61c5492a
NC
913 --off;
914 }
dd2155a4
DM
915 }
916}
917
918
dd2155a4 919/*
cc76b5cc 920=for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
dd2155a4 921
cc76b5cc
Z
922Given the name of a lexical variable, find its position in the
923currently-compiling pad.
2d7f6611
KW
924C<namepv>/C<namelen> specify the variable's name, including leading sigil.
925C<flags> is reserved and must be zero.
cc76b5cc
Z
926If it is not in the current pad but appears in the pad of any lexically
927enclosing scope, then a pseudo-entry for it is added in the current pad.
928Returns the offset in the current pad,
929or C<NOT_IN_PAD> if no such lexical is in scope.
dd2155a4
DM
930
931=cut
932*/
933
934PADOFFSET
cc76b5cc 935Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
dd2155a4 936{
e1c02f84 937 PADNAME *out_pn;
b5c19bd7 938 int out_flags;
d12be05d 939 PADOFFSET offset;
9b7476d7 940 const PADNAMELIST *namelist;
e1c02f84 941 PADNAME **name_p;
dd2155a4 942
cc76b5cc 943 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
7918f24d 944
cc76b5cc 945 pad_peg("pad_findmy_pvn");
f8f98e0a 946
2502ffdf 947 if (flags)
cc76b5cc 948 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
f8f98e0a
NC
949 (UV)flags);
950
b12396ac
TC
951 /* compilation errors can zero PL_compcv */
952 if (!PL_compcv)
953 return NOT_IN_PAD;
954
fbb889c8 955 offset = pad_findlex(namepv, namelen, flags,
e1c02f84 956 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
d12be05d 957 if (offset != NOT_IN_PAD)
929a0744
DM
958 return offset;
959
f0727190
FC
960 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
961 */
962 if (*namepv == '&') return NOT_IN_PAD;
963
929a0744
DM
964 /* look for an our that's being introduced; this allows
965 * our $foo = 0 unless defined $foo;
966 * to not give a warning. (Yes, this is a hack) */
967
9b7476d7
FC
968 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
969 name_p = PadnamelistARRAY(namelist);
970 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
e1c02f84
FC
971 const PADNAME * const name = name_p[offset];
972 if (name && PadnameLEN(name) == namelen
973 && !PadnameOUTER(name)
974 && (PadnameIsOUR(name))
2502ffdf
FC
975 && ( PadnamePV(name) == namepv
976 || memEQ(PadnamePV(name), namepv, namelen) )
e1c02f84 977 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
929a0744
DM
978 )
979 return offset;
980 }
981 return NOT_IN_PAD;
dd2155a4
DM
982}
983
e1f795dc 984/*
cc76b5cc
Z
985=for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
986
987Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
988instead of a string/length pair.
989
990=cut
991*/
992
993PADOFFSET
994Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
995{
996 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
997 return pad_findmy_pvn(name, strlen(name), flags);
998}
999
1000/*
1001=for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1002
1003Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1004of an SV instead of a string/length pair.
1005
1006=cut
1007*/
1008
1009PADOFFSET
1010Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1011{
1012 char *namepv;
1013 STRLEN namelen;
1014 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
2502ffdf 1015 namepv = SvPVutf8(name, namelen);
cc76b5cc
Z
1016 return pad_findmy_pvn(namepv, namelen, flags);
1017}
1018
1019/*
1020=for apidoc Amp|PADOFFSET|find_rundefsvoffset
1021
af7ce3e6
FC
1022Until the lexical C<$_> feature was removed, this function would
1023find the position of the lexical C<$_> in the pad of the
1cdc5f0b 1024currently-executing function and return the offset in the current pad,
af7ce3e6
FC
1025or C<NOT_IN_PAD>.
1026
1027Now it always returns C<NOT_IN_PAD>.
cc76b5cc
Z
1028
1029=cut
1030*/
e1f795dc
RGS
1031
1032PADOFFSET
29289021 1033Perl_find_rundefsvoffset(pTHX)
e1f795dc 1034{
af7ce3e6
FC
1035 PERL_UNUSED_CONTEXT; /* Can we just remove the pTHX from the sig? */
1036 return NOT_IN_PAD;
e1f795dc 1037}
dd2155a4 1038
dd2155a4 1039/*
cc76b5cc
Z
1040=for apidoc Am|SV *|find_rundefsv
1041
af7ce3e6 1042Returns the global variable C<$_>.
cc76b5cc
Z
1043
1044=cut
1045*/
789bd863
VP
1046
1047SV *
1048Perl_find_rundefsv(pTHX)
1049{
af7ce3e6 1050 return DEFSV;
789bd863
VP
1051}
1052
1053/*
e1c02f84 1054=for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|PADNAME** out_name|int *out_flags
dd2155a4 1055
72d33970 1056Find a named lexical anywhere in a chain of nested pads. Add fake entries
b5c19bd7
DM
1057in the inner pads if it's found in an outer one.
1058
1059Returns the offset in the bottom pad of the lex or the fake lex.
796b6530
KW
1060C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1061to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
b5c19bd7 1062vars return values, and so are pointers to where the returned values
796b6530
KW
1063should be stored. C<out_capture>, if non-null, requests that the innermost
1064instance of the lexical is captured; C<out_name> is set to the innermost
1065matched pad name or fake pad name; C<out_flags> returns the flags normally
1066associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
b5c19bd7 1067
796b6530 1068Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
72d33970
FC
1069then comes back down, adding fake entries
1070as it goes. It has to be this way
9420b268
DM
1071because fake names in anon protoypes have to store in C<xpadn_low> the
1072index into the parent pad.
dd2155a4
DM
1073
1074=cut
1075*/
1076
b5c19bd7
DM
1077/* the CV has finished being compiled. This is not a sufficient test for
1078 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1079#define CvCOMPILED(cv) CvROOT(cv)
1080
71f882da 1081/* the CV does late binding of its lexicals */
e07561e6 1082#define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
71f882da 1083
445f13ff 1084static void
e6df7a56 1085S_unavailable(pTHX_ PADNAME *name)
445f13ff
FC
1086{
1087 /* diag_listed_as: Variable "%s" is not available */
1088 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
147e3846 1089 "%se \"%" PNf "\" is not available",
e6df7a56 1090 *PadnamePV(name) == '&'
445f13ff
FC
1091 ? "Subroutin"
1092 : "Variabl",
e6df7a56 1093 PNfARG(name));
445f13ff 1094}
b5c19bd7 1095
dd2155a4 1096STATIC PADOFFSET
fbb889c8 1097S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
e1c02f84 1098 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
dd2155a4 1099{
d12be05d 1100 PADOFFSET offset, new_offset;
b5c19bd7
DM
1101 SV *new_capture;
1102 SV **new_capturep;
b70d5558 1103 const PADLIST * const padlist = CvPADLIST(cv);
7ef30830 1104 const bool staleok = !!(flags & padadd_STALEOK);
dd2155a4 1105
7918f24d
NC
1106 PERL_ARGS_ASSERT_PAD_FINDLEX;
1107
2502ffdf
FC
1108 flags &= ~ padadd_STALEOK; /* one-shot flag */
1109 if (flags)
2435e5d3
BF
1110 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1111 (UV)flags);
1112
b5c19bd7 1113 *out_flags = 0;
a3985cdc 1114
b5c19bd7 1115 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147e3846 1116 "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n",
4c760560 1117 PTR2UV(cv), (int)namelen, namepv, (int)seq,
cc76b5cc 1118 out_capture ? " capturing" : "" ));
dd2155a4 1119
b5c19bd7 1120 /* first, search this pad */
dd2155a4 1121
b5c19bd7 1122 if (padlist) { /* not an undef CV */
d12be05d 1123 PADOFFSET fake_offset = 0;
9b7476d7
FC
1124 const PADNAMELIST * const names = PadlistNAMES(padlist);
1125 PADNAME * const * const name_p = PadnamelistARRAY(names);
ee6cee0c 1126
9b7476d7 1127 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
e1c02f84
FC
1128 const PADNAME * const name = name_p[offset];
1129 if (name && PadnameLEN(name) == namelen
2502ffdf
FC
1130 && ( PadnamePV(name) == namepv
1131 || memEQ(PadnamePV(name), namepv, namelen) ))
b5c19bd7 1132 {
e1c02f84 1133 if (PadnameOUTER(name)) {
b5c19bd7 1134 fake_offset = offset; /* in case we don't find a real one */
6012dc80
DM
1135 continue;
1136 }
e1c02f84 1137 if (PadnameIN_SCOPE(name, seq))
03414f05 1138 break;
ee6cee0c
DM
1139 }
1140 }
1141
b5c19bd7
DM
1142 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1143 if (offset > 0) { /* not fake */
1144 fake_offset = 0;
e1c02f84 1145 *out_name = name_p[offset]; /* return the name */
b5c19bd7
DM
1146
1147 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1148 * instances. For now, we just test !CvUNIQUE(cv), but
1149 * ideally, we should detect my's declared within loops
1150 * etc - this would allow a wider range of 'not stayed
486ec47a 1151 * shared' warnings. We also treated already-compiled
b5c19bd7
DM
1152 * lexes as not multi as viewed from evals. */
1153
1154 *out_flags = CvANON(cv) ?
1155 PAD_FAKELEX_ANON :
1156 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1157 ? PAD_FAKELEX_MULTI : 0;
1158
1159 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147e3846 1160 "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n",
809abb02 1161 PTR2UV(cv), (long)offset,
e1c02f84
FC
1162 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1163 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
b5c19bd7
DM
1164 }
1165 else { /* fake match */
1166 offset = fake_offset;
e1c02f84
FC
1167 *out_name = name_p[offset]; /* return the name */
1168 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
b5c19bd7 1169 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147e3846 1170 "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n",
b5c19bd7 1171 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
e1c02f84 1172 (unsigned long) PARENT_PAD_INDEX(*out_name)
b5c19bd7
DM
1173 ));
1174 }
dd2155a4 1175
b5c19bd7 1176 /* return the lex? */
dd2155a4 1177
b5c19bd7 1178 if (out_capture) {
dd2155a4 1179
b5c19bd7 1180 /* our ? */
e1c02f84 1181 if (PadnameIsOUR(*out_name)) {
a0714e2c 1182 *out_capture = NULL;
b5c19bd7
DM
1183 return offset;
1184 }
ee6cee0c 1185
b5c19bd7
DM
1186 /* trying to capture from an anon prototype? */
1187 if (CvCOMPILED(cv)
1188 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1189 : *out_flags & PAD_FAKELEX_ANON)
1190 {
a2a5de95 1191 if (warn)
445f13ff 1192 S_unavailable(aTHX_
f5658c36 1193 *out_name);
0727928e 1194
a0714e2c 1195 *out_capture = NULL;
b5c19bd7 1196 }
ee6cee0c 1197
b5c19bd7
DM
1198 /* real value */
1199 else {
1200 int newwarn = warn;
1201 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
e1c02f84 1202 && !PadnameIsSTATE(name_p[offset])
b5c19bd7
DM
1203 && warn && ckWARN(WARN_CLOSURE)) {
1204 newwarn = 0;
2a9203e9
FC
1205 /* diag_listed_as: Variable "%s" will not stay
1206 shared */
b5c19bd7 1207 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
147e3846 1208 "%se \"%" UTF8f "\" will not stay shared",
2a9203e9 1209 *namepv == '&' ? "Subroutin" : "Variabl",
8d98b5bc 1210 UTF8fARG(1, namelen, namepv));
b5c19bd7 1211 }
dd2155a4 1212
b5c19bd7
DM
1213 if (fake_offset && CvANON(cv)
1214 && CvCLONE(cv) &&!CvCLONED(cv))
1215 {
e1c02f84 1216 PADNAME *n;
b5c19bd7
DM
1217 /* not yet caught - look further up */
1218 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147e3846 1219 "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n",
b5c19bd7 1220 PTR2UV(cv)));
e1c02f84 1221 n = *out_name;
fbb889c8 1222 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
282e1742 1223 CvOUTSIDE_SEQ(cv),
e1c02f84
FC
1224 newwarn, out_capture, out_name, out_flags);
1225 *out_name = n;
b5c19bd7 1226 return offset;
dd2155a4 1227 }
b5c19bd7 1228
86d2498c 1229 *out_capture = AvARRAY(PadlistARRAY(padlist)[
7261499d 1230 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
b5c19bd7 1231 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147e3846 1232 "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n",
19a5c512 1233 PTR2UV(cv), PTR2UV(*out_capture)));
b5c19bd7 1234
d1186544 1235 if (SvPADSTALE(*out_capture)
7ef30830 1236 && (!CvDEPTH(cv) || !staleok)
e1c02f84 1237 && !PadnameIsSTATE(name_p[offset]))
d1186544 1238 {
445f13ff 1239 S_unavailable(aTHX_
f5658c36 1240 name_p[offset]);
a0714e2c 1241 *out_capture = NULL;
dd2155a4
DM
1242 }
1243 }
b5c19bd7 1244 if (!*out_capture) {
cc76b5cc 1245 if (namelen != 0 && *namepv == '@')
ad64d0ec 1246 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
cc76b5cc 1247 else if (namelen != 0 && *namepv == '%')
ad64d0ec 1248 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
6d5c2147
FC
1249 else if (namelen != 0 && *namepv == '&')
1250 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
b5c19bd7
DM
1251 else
1252 *out_capture = sv_newmortal();
1253 }
dd2155a4 1254 }
b5c19bd7
DM
1255
1256 return offset;
ee6cee0c 1257 }
b5c19bd7
DM
1258 }
1259
1260 /* it's not in this pad - try above */
1261
1262 if (!CvOUTSIDE(cv))
1263 return NOT_IN_PAD;
9f7d9405 1264
b5c19bd7 1265 /* out_capture non-null means caller wants us to capture lex; in
71f882da 1266 * addition we capture ourselves unless it's an ANON/format */
b5c19bd7 1267 new_capturep = out_capture ? out_capture :
4608196e 1268 CvLATE(cv) ? NULL : &new_capture;
b5c19bd7 1269
7ef30830
FC
1270 offset = pad_findlex(namepv, namelen,
1271 flags | padadd_STALEOK*(new_capturep == &new_capture),
1272 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
e1c02f84 1273 new_capturep, out_name, out_flags);
d12be05d 1274 if (offset == NOT_IN_PAD)
b5c19bd7 1275 return NOT_IN_PAD;
9f7d9405 1276
b5c19bd7
DM
1277 /* found in an outer CV. Add appropriate fake entry to this pad */
1278
1279 /* don't add new fake entries (via eval) to CVs that we have already
1280 * finished compiling, or to undef CVs */
1281 if (CvCOMPILED(cv) || !padlist)
1282 return 0; /* this dummy (and invalid) value isnt used by the caller */
1283
1284 {
0f94cb1f 1285 PADNAME *new_name = newPADNAMEouter(*out_name);
9b7476d7 1286 PADNAMELIST * const ocomppad_name = PL_comppad_name;
53c1dcc0 1287 PAD * const ocomppad = PL_comppad;
9b7476d7 1288 PL_comppad_name = PadlistNAMES(padlist);
86d2498c 1289 PL_comppad = PadlistARRAY(padlist)[1];
b5c19bd7
DM
1290 PL_curpad = AvARRAY(PL_comppad);
1291
3291825f 1292 new_offset
e1c02f84
FC
1293 = pad_alloc_name(new_name,
1294 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1295 PadnameTYPE(*out_name),
1296 PadnameOURSTASH(*out_name)
3291825f
NC
1297 );
1298
3291825f
NC
1299 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1300 "Pad addname: %ld \"%.*s\" FAKE\n",
1301 (long)new_offset,
e1c02f84
FC
1302 (int) PadnameLEN(new_name),
1303 PadnamePV(new_name)));
1304 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
b5c19bd7 1305
e1c02f84
FC
1306 PARENT_PAD_INDEX_set(new_name, 0);
1307 if (PadnameIsOUR(new_name)) {
6f207bd3 1308 NOOP; /* do nothing */
b5c19bd7 1309 }
71f882da 1310 else if (CvLATE(cv)) {
b5c19bd7 1311 /* delayed creation - just note the offset within parent pad */
e1c02f84 1312 PARENT_PAD_INDEX_set(new_name, offset);
b5c19bd7
DM
1313 CvCLONE_on(cv);
1314 }
1315 else {
1316 /* immediate creation - capture outer value right now */
1317 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
81df9f6f 1318 /* But also note the offset, as newMYSUB needs it */
e1c02f84 1319 PARENT_PAD_INDEX_set(new_name, offset);
b5c19bd7 1320 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147e3846 1321 "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n",
b5c19bd7 1322 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
dd2155a4 1323 }
e1c02f84
FC
1324 *out_name = new_name;
1325 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
b5c19bd7
DM
1326
1327 PL_comppad_name = ocomppad_name;
1328 PL_comppad = ocomppad;
4608196e 1329 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
dd2155a4 1330 }
b5c19bd7 1331 return new_offset;
dd2155a4
DM
1332}
1333
fb8a9836 1334#ifdef DEBUGGING
cc76b5cc 1335
dd2155a4 1336/*
cc76b5cc 1337=for apidoc Am|SV *|pad_sv|PADOFFSET po
dd2155a4 1338
2d7f6611 1339Get the value at offset C<po> in the current (compiling or executing) pad.
796b6530 1340Use macro C<PAD_SV> instead of calling this function directly.
dd2155a4
DM
1341
1342=cut
1343*/
1344
dd2155a4
DM
1345SV *
1346Perl_pad_sv(pTHX_ PADOFFSET po)
1347{
f3548bdc 1348 ASSERT_CURPAD_ACTIVE("pad_sv");
dd2155a4 1349
dd2155a4
DM
1350 if (!po)
1351 Perl_croak(aTHX_ "panic: pad_sv po");
dd2155a4 1352 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846 1353 "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n",
f3548bdc 1354 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
dd2155a4
DM
1355 );
1356 return PL_curpad[po];
1357}
1358
dd2155a4 1359/*
cc76b5cc 1360=for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
dd2155a4 1361
2d7f6611 1362Set the value at offset C<po> in the current (compiling or executing) pad.
796b6530 1363Use the macro C<PAD_SETSV()> rather than calling this function directly.
dd2155a4
DM
1364
1365=cut
1366*/
1367
dd2155a4
DM
1368void
1369Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1370{
7918f24d
NC
1371 PERL_ARGS_ASSERT_PAD_SETSV;
1372
f3548bdc 1373 ASSERT_CURPAD_ACTIVE("pad_setsv");
dd2155a4
DM
1374
1375 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846 1376 "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n",
f3548bdc 1377 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
dd2155a4
DM
1378 );
1379 PL_curpad[po] = sv;
1380}
dd2155a4 1381
cc76b5cc 1382#endif /* DEBUGGING */
dd2155a4
DM
1383
1384/*
cc76b5cc 1385=for apidoc m|void|pad_block_start|int full
dd2155a4 1386
e89fca5e 1387Update the pad compilation state variables on entry to a new block.
dd2155a4
DM
1388
1389=cut
1390*/
1391
dd2155a4
DM
1392void
1393Perl_pad_block_start(pTHX_ int full)
1394{
f3548bdc 1395 ASSERT_CURPAD_ACTIVE("pad_block_start");
d12be05d 1396 save_strlen((STRLEN *)&PL_comppad_name_floor);
9b7476d7 1397 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
dd2155a4
DM
1398 if (full)
1399 PL_comppad_name_fill = PL_comppad_name_floor;
1400 if (PL_comppad_name_floor < 0)
1401 PL_comppad_name_floor = 0;
d12be05d
DM
1402 save_strlen((STRLEN *)&PL_min_intro_pending);
1403 save_strlen((STRLEN *)&PL_max_intro_pending);
dd2155a4 1404 PL_min_intro_pending = 0;
d12be05d
DM
1405 save_strlen((STRLEN *)&PL_comppad_name_fill);
1406 save_strlen((STRLEN *)&PL_padix_floor);
1780e744
FC
1407 /* PL_padix_floor is what PL_padix is reset to at the start of each
1408 statement, by pad_reset(). We set it when entering a new scope
1409 to keep things like this working:
1410 print "$foo$bar", do { this(); that() . "foo" };
1411 We must not let "$foo$bar" and the later concatenation share the
1412 same target. */
dd2155a4
DM
1413 PL_padix_floor = PL_padix;
1414 PL_pad_reset_pending = FALSE;
1415}
1416
dd2155a4 1417/*
25f5d540 1418=for apidoc Am|U32|intro_my
dd2155a4 1419
25f5d540
LM
1420"Introduce" C<my> variables to visible status. This is called during parsing
1421at the end of each statement to make lexical variables visible to subsequent
1422statements.
dd2155a4
DM
1423
1424=cut
1425*/
1426
1427U32
1428Perl_intro_my(pTHX)
1429{
6a0435be 1430 PADNAME **svp;
d12be05d 1431 PADOFFSET i;
6012dc80 1432 U32 seq;
dd2155a4 1433
f3548bdc 1434 ASSERT_CURPAD_ACTIVE("intro_my");
8635e3c2
FC
1435 if (PL_compiling.cop_seq) {
1436 seq = PL_compiling.cop_seq;
1437 PL_compiling.cop_seq = 0;
1438 }
1439 else
1440 seq = PL_cop_seqmax;
dd2155a4 1441 if (! PL_min_intro_pending)
8635e3c2 1442 return seq;
dd2155a4 1443
9b7476d7 1444 svp = PadnamelistARRAY(PL_comppad_name);
dd2155a4 1445 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
6a0435be 1446 PADNAME * const sv = svp[i];
53c1dcc0 1447
6a0435be 1448 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
0d311cdb
DM
1449 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1450 {
2df5bdd7 1451 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
809abb02 1452 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
dd2155a4 1453 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1454 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
6a0435be 1455 (long)i, PadnamePV(sv),
809abb02
NC
1456 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1457 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1458 );
1459 }
1460 }
953c8b80 1461 COP_SEQMAX_INC;
dd2155a4
DM
1462 PL_min_intro_pending = 0;
1463 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1464 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
6012dc80 1465 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
dd2155a4 1466
6012dc80 1467 return seq;
dd2155a4
DM
1468}
1469
1470/*
cc76b5cc 1471=for apidoc m|void|pad_leavemy
dd2155a4
DM
1472
1473Cleanup at end of scope during compilation: set the max seq number for
1474lexicals in this scope and warn of any lexicals that never got introduced.
1475
1476=cut
1477*/
1478
6d5c2147 1479OP *
dd2155a4
DM
1480Perl_pad_leavemy(pTHX)
1481{
d12be05d 1482 PADOFFSET off;
6d5c2147 1483 OP *o = NULL;
9b7476d7 1484 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
dd2155a4
DM
1485
1486 PL_pad_reset_pending = FALSE;
1487
f3548bdc 1488 ASSERT_CURPAD_ACTIVE("pad_leavemy");
dd2155a4
DM
1489 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1490 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
01b9977c
FC
1491 const PADNAME * const name = svp[off];
1492 if (name && PadnameLEN(name) && !PadnameOUTER(name))
9b387841 1493 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
147e3846 1494 "%" PNf " never introduced",
01b9977c 1495 PNfARG(name));
dd2155a4
DM
1496 }
1497 }
1498 /* "Deintroduce" my variables that are leaving with this scope. */
9b7476d7
FC
1499 for (off = PadnamelistMAX(PL_comppad_name);
1500 off > PL_comppad_name_fill; off--) {
01b9977c
FC
1501 PADNAME * const sv = svp[off];
1502 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
2df5bdd7
DM
1503 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1504 {
809abb02 1505 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
dd2155a4 1506 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1507 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
01b9977c 1508 (long)off, PadnamePV(sv),
809abb02
NC
1509 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1510 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4 1511 );
6d5c2147
FC
1512 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1513 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1514 OP *kid = newOP(OP_INTROCV, 0);
1515 kid->op_targ = off;
1516 o = op_prepend_elem(OP_LINESEQ, kid, o);
1517 }
dd2155a4
DM
1518 }
1519 }
953c8b80 1520 COP_SEQMAX_INC;
dd2155a4
DM
1521 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1522 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
6d5c2147 1523 return o;
dd2155a4
DM
1524}
1525
dd2155a4 1526/*
cc76b5cc 1527=for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
dd2155a4 1528
796b6530 1529Abandon the tmp in the current pad at offset C<po> and replace with a
dd2155a4
DM
1530new one.
1531
1532=cut
1533*/
1534
1535void
1536Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1537{
f3548bdc 1538 ASSERT_CURPAD_LEGAL("pad_swipe");
dd2155a4
DM
1539 if (!PL_curpad)
1540 return;
1541 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1542 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1543 AvARRAY(PL_comppad), PL_curpad);
9100eeb1
Z
1544 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1545 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1546 (long)po, (long)AvFILLp(PL_comppad));
dd2155a4
DM
1547
1548 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846 1549 "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n",
dd2155a4
DM
1550 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1551
dd2155a4
DM
1552 if (refadjust)
1553 SvREFCNT_dec(PL_curpad[po]);
1554
9ad9869c
DM
1555
1556 /* if pad tmps aren't shared between ops, then there's no need to
1557 * create a new tmp when an existing op is freed */
53de1311 1558#ifdef USE_PAD_RESET
561b68a9 1559 PL_curpad[po] = newSV(0);
dd2155a4 1560 SvPADTMP_on(PL_curpad[po]);
9ad9869c 1561#else
ce0d59fd 1562 PL_curpad[po] = NULL;
97bf4a8d 1563#endif
325e1816 1564 if (PadnamelistMAX(PL_comppad_name) != -1
4891fdfa 1565 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
ce0d59fd
FC
1566 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1567 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1568 }
0f94cb1f 1569 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
325e1816 1570 }
b54c5e14
FC
1571 /* Use PL_constpadix here, not PL_padix. The latter may have been
1572 reset by pad_reset. We don’t want pad_alloc to have to scan the
1573 whole pad when allocating a constant. */
d12be05d 1574 if (po < PL_constpadix)
b54c5e14 1575 PL_constpadix = po - 1;
dd2155a4
DM
1576}
1577
dd2155a4 1578/*
cc76b5cc 1579=for apidoc m|void|pad_reset
dd2155a4
DM
1580
1581Mark all the current temporaries for reuse
1582
1583=cut
1584*/
1585
1780e744
FC
1586/* pad_reset() causes pad temp TARGs (operator targets) to be shared
1587 * between OPs from different statements. During compilation, at the start
1588 * of each statement pad_reset resets PL_padix back to its previous value.
1589 * When allocating a target, pad_alloc begins its scan through the pad at
1590 * PL_padix+1. */
1f676739 1591static void
82af08ae 1592S_pad_reset(pTHX)
dd2155a4 1593{
53de1311 1594#ifdef USE_PAD_RESET
dd2155a4 1595 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1596 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1597 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
1598
1599 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846 1600 "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld",
dd2155a4
DM
1601 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1602 (long)PL_padix, (long)PL_padix_floor
1603 )
1604 );
1605
284167a5 1606 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
dd2155a4
DM
1607 PL_padix = PL_padix_floor;
1608 }
1609#endif
1610 PL_pad_reset_pending = FALSE;
1611}
1612
dd2155a4 1613/*
cc76b5cc
Z
1614=for apidoc Amx|void|pad_tidy|padtidy_type type
1615
1616Tidy up a pad at the end of compilation of the code to which it belongs.
1617Jobs performed here are: remove most stuff from the pads of anonsub
796b6530 1618prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
cc76b5cc 1619the kind of subroutine:
dd2155a4 1620
cc76b5cc
Z
1621 padtidy_SUB ordinary subroutine
1622 padtidy_SUBCLONE prototype for lexical closure
1623 padtidy_FORMAT format
dd2155a4
DM
1624
1625=cut
1626*/
1627
dd2155a4
DM
1628void
1629Perl_pad_tidy(pTHX_ padtidy_type type)
1630{
27da23d5 1631 dVAR;
dd2155a4 1632
f3548bdc 1633 ASSERT_CURPAD_ACTIVE("pad_tidy");
b5c19bd7 1634
db21619c
DM
1635 /* If this CV has had any 'eval-capable' ops planted in it:
1636 * i.e. it contains any of:
1637 *
1638 * * eval '...',
1639 * * //ee,
1640 * * use re 'eval'; /$var/
1641 * * /(?{..})/),
1642 *
1643 * Then any anon prototypes in the chain of CVs should be marked as
1644 * cloneable, so that for example the eval's CV in
1645 *
1646 * sub { eval '$x' }
1647 *
1648 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1649 * potentially have an eval executed within it.
b5c19bd7
DM
1650 */
1651
1652 if (PL_cv_has_eval || PL_perldb) {
e1ec3a88 1653 const CV *cv;
b5c19bd7
DM
1654 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1655 if (cv != PL_compcv && CvCOMPILED(cv))
1656 break; /* no need to mark already-compiled code */
1657 if (CvANON(cv)) {
1658 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
147e3846 1659 "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
b5c19bd7
DM
1660 CvCLONE_on(cv);
1661 }
00cc8743 1662 CvHASEVAL_on(cv);
b5c19bd7
DM
1663 }
1664 }
1665
eb8137a9 1666 /* extend namepad to match curpad */
9b7476d7
FC
1667 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1668 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
dd2155a4
DM
1669
1670 if (type == padtidy_SUBCLONE) {
9b7476d7 1671 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
504618e9 1672 PADOFFSET ix;
b5c19bd7 1673
dd2155a4 1674 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
dbfcda05
FC
1675 PADNAME *namesv;
1676 if (!namep[ix]) namep[ix] = &PL_padname_undef;
dd2155a4 1677
dd2155a4
DM
1678 /*
1679 * The only things that a clonable function needs in its
3a6ce63a 1680 * pad are anonymous subs, constants and GVs.
dd2155a4
DM
1681 * The rest are created anew during cloning.
1682 */
b561f196 1683 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
3a6ce63a 1684 continue;
ce0d59fd
FC
1685 namesv = namep[ix];
1686 if (!(PadnamePV(namesv) &&
dbfcda05 1687 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
dd2155a4
DM
1688 {
1689 SvREFCNT_dec(PL_curpad[ix]);
a0714e2c 1690 PL_curpad[ix] = NULL;
dd2155a4
DM
1691 }
1692 }
1693 }
1694 else if (type == padtidy_SUB) {
53c1dcc0 1695 AV * const av = newAV(); /* Will be @_ */
ad64d0ec 1696 av_store(PL_comppad, 0, MUTABLE_SV(av));
11ca45c0 1697 AvREIFY_only(av);
dd2155a4
DM
1698 }
1699
4cee4ca8 1700 if (type == padtidy_SUB || type == padtidy_FORMAT) {
9b7476d7 1701 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
504618e9 1702 PADOFFSET ix;
dd2155a4 1703 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
0f94cb1f 1704 if (!namep[ix]) namep[ix] = &PL_padname_undef;
2347c8c0 1705 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
dd2155a4 1706 continue;
0f94cb1f 1707 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
adf8f095
NC
1708 /* This is a work around for how the current implementation of
1709 ?{ } blocks in regexps interacts with lexicals.
1710
1711 One of our lexicals.
1712 Can't do this on all lexicals, otherwise sub baz() won't
1713 compile in
1714
1715 my $foo;
1716
1717 sub bar { ++$foo; }
1718
1719 sub baz { ++$foo; }
1720
1721 because completion of compiling &bar calling pad_tidy()
1722 would cause (top level) $foo to be marked as stale, and
1723 "no longer available". */
1724 SvPADSTALE_on(PL_curpad[ix]);
1725 }
dd2155a4
DM
1726 }
1727 }
f3548bdc 1728 PL_curpad = AvARRAY(PL_comppad);
dd2155a4
DM
1729}
1730
dd2155a4 1731/*
cc76b5cc 1732=for apidoc m|void|pad_free|PADOFFSET po
dd2155a4 1733
8627550a 1734Free the SV at offset po in the current pad.
dd2155a4
DM
1735
1736=cut
1737*/
1738
dd2155a4
DM
1739void
1740Perl_pad_free(pTHX_ PADOFFSET po)
1741{
53de1311 1742#ifndef USE_PAD_RESET
ad9e6ae1 1743 SV *sv;
ff06c6b2 1744#endif
f3548bdc 1745 ASSERT_CURPAD_LEGAL("pad_free");
dd2155a4
DM
1746 if (!PL_curpad)
1747 return;
1748 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1749 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1750 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
1751 if (!po)
1752 Perl_croak(aTHX_ "panic: pad_free po");
1753
1754 DEBUG_X(PerlIO_printf(Perl_debug_log,
147e3846 1755 "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
dd2155a4
DM
1756 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1757 );
1758
53de1311 1759#ifndef USE_PAD_RESET
ad9e6ae1
DM
1760 sv = PL_curpad[po];
1761 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1762 SvFLAGS(sv) &= ~SVs_PADTMP;
1763
d12be05d 1764 if (po < PL_padix)
dd2155a4 1765 PL_padix = po - 1;
53d3c048 1766#endif
dd2155a4
DM
1767}
1768
dd2155a4 1769/*
cc76b5cc 1770=for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
dd2155a4
DM
1771
1772Dump the contents of a padlist
1773
1774=cut
1775*/
1776
1777void
1778Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1779{
9b7476d7 1780 const PADNAMELIST *pad_name;
e1ec3a88 1781 const AV *pad;
01326933 1782 PADNAME **pname;
dd2155a4 1783 SV **ppad;
d12be05d 1784 PADOFFSET ix;
dd2155a4 1785
7918f24d
NC
1786 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1787
dd2155a4
DM
1788 if (!padlist) {
1789 return;
1790 }
9b7476d7 1791 pad_name = PadlistNAMES(padlist);
86d2498c 1792 pad = PadlistARRAY(padlist)[1];
9b7476d7 1793 pname = PadnamelistARRAY(pad_name);
dd2155a4
DM
1794 ppad = AvARRAY(pad);
1795 Perl_dump_indent(aTHX_ level, file,
147e3846 1796 "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
dd2155a4
DM
1797 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1798 );
1799
9b7476d7 1800 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
01326933 1801 const PADNAME *namesv = pname[ix];
325e1816 1802 if (namesv && !PadnameLEN(namesv)) {
a0714e2c 1803 namesv = NULL;
dd2155a4
DM
1804 }
1805 if (namesv) {
01326933 1806 if (PadnameOUTER(namesv))
ee6cee0c 1807 Perl_dump_indent(aTHX_ level+1, file,
147e3846 1808 "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
ee6cee0c
DM
1809 (int) ix,
1810 PTR2UV(ppad[ix]),
1811 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
01326933 1812 PadnamePV(namesv),
809abb02
NC
1813 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1814 (unsigned long)PARENT_PAD_INDEX(namesv)
b5c19bd7 1815
ee6cee0c
DM
1816 );
1817 else
1818 Perl_dump_indent(aTHX_ level+1, file,
147e3846 1819 "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
ee6cee0c
DM
1820 (int) ix,
1821 PTR2UV(ppad[ix]),
1822 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
809abb02
NC
1823 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1824 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
01326933 1825 PadnamePV(namesv)
ee6cee0c 1826 );
dd2155a4
DM
1827 }
1828 else if (full) {
1829 Perl_dump_indent(aTHX_ level+1, file,
147e3846 1830 "%2d. 0x%" UVxf "<%lu>\n",
dd2155a4
DM
1831 (int) ix,
1832 PTR2UV(ppad[ix]),
1833 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1834 );
1835 }
1836 }
1837}
1838
cc76b5cc 1839#ifdef DEBUGGING
dd2155a4
DM
1840
1841/*
cc76b5cc 1842=for apidoc m|void|cv_dump|CV *cv|const char *title
dd2155a4
DM
1843
1844dump the contents of a CV
1845
1846=cut
1847*/
1848
dd2155a4 1849STATIC void
e1ec3a88 1850S_cv_dump(pTHX_ const CV *cv, const char *title)
dd2155a4 1851{
53c1dcc0 1852 const CV * const outside = CvOUTSIDE(cv);
b70d5558 1853 PADLIST* const padlist = CvPADLIST(cv);
dd2155a4 1854
7918f24d
NC
1855 PERL_ARGS_ASSERT_CV_DUMP;
1856
dd2155a4 1857 PerlIO_printf(Perl_debug_log,
147e3846 1858 " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
dd2155a4
DM
1859 title,
1860 PTR2UV(cv),
1861 (CvANON(cv) ? "ANON"
71f882da 1862 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
dd2155a4
DM
1863 : (cv == PL_main_cv) ? "MAIN"
1864 : CvUNIQUE(cv) ? "UNIQUE"
1865 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1866 PTR2UV(outside),
1867 (!outside ? "null"
1868 : CvANON(outside) ? "ANON"
1869 : (outside == PL_main_cv) ? "MAIN"
1870 : CvUNIQUE(outside) ? "UNIQUE"
1871 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1872
1873 PerlIO_printf(Perl_debug_log,
147e3846 1874 " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
dd2155a4
DM
1875 do_dump_pad(1, Perl_debug_log, padlist, 1);
1876}
dd2155a4 1877
cc76b5cc 1878#endif /* DEBUGGING */
dd2155a4
DM
1879
1880/*
cc76b5cc 1881=for apidoc Am|CV *|cv_clone|CV *proto
dd2155a4 1882
2d7f6611 1883Clone a CV, making a lexical closure. C<proto> supplies the prototype
cc76b5cc
Z
1884of the function: its code, pad structure, and other attributes.
1885The prototype is combined with a capture of outer lexicals to which the
1886code refers, which are taken from the currently-executing instance of
1887the immediately surrounding code.
dd2155a4
DM
1888
1889=cut
1890*/
1891
e0c6a6b8 1892static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
e10681aa 1893
21195f4d 1894static CV *
e0c6a6b8
FC
1895S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1896 bool newcv)
dd2155a4 1897{
d12be05d 1898 PADOFFSET ix;
b70d5558 1899 PADLIST* const protopadlist = CvPADLIST(proto);
9b7476d7 1900 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
86d2498c 1901 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
39899bf0 1902 PADNAME** const pname = PadnamelistARRAY(protopad_name);
53c1dcc0 1903 SV** const ppad = AvARRAY(protopad);
d12be05d
DM
1904 const PADOFFSET fname = PadnamelistMAX(protopad_name);
1905 const PADOFFSET fpad = AvFILLp(protopad);
b5c19bd7 1906 SV** outpad;
71f882da 1907 long depth;
e0c6a6b8
FC
1908 U32 subclones = 0;
1909 bool trouble = FALSE;
7918f24d 1910
dd2155a4
DM
1911 assert(!CvUNIQUE(proto));
1912
1b5aaca6
FC
1913 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1914 * reliable. The currently-running sub is always the one we need to
1915 * close over.
8d88fe29
FC
1916 * For my subs, the currently-running sub may not be the one we want.
1917 * We have to check whether it is a clone of CvOUTSIDE.
1b5aaca6
FC
1918 * Note that in general for formats, CvOUTSIDE != find_runcv.
1919 * Since formats may be nested inside closures, CvOUTSIDE may point
71f882da 1920 * to a prototype; we instead want the cloned parent who called us.
af41786f 1921 */
71f882da 1922
e07561e6 1923 if (!outside) {
ebfebee4 1924 if (CvWEAKOUTSIDE(proto))
71f882da 1925 outside = find_runcv(NULL);
e07561e6 1926 else {
af41786f 1927 outside = CvOUTSIDE(proto);
db4cf31d
FC
1928 if ((CvCLONE(outside) && ! CvCLONED(outside))
1929 || !CvPADLIST(outside)
b4db5868 1930 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
db4cf31d 1931 outside = find_runcv_where(
a56015b9 1932 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
70794f7b 1933 );
db4cf31d 1934 /* outside could be null */
5dff782d 1935 }
e07561e6 1936 }
5dff782d 1937 }
db4cf31d 1938 depth = outside ? CvDEPTH(outside) : 0;
71f882da
DM
1939 if (!depth)
1940 depth = 1;
b5c19bd7 1941
dd2155a4
DM
1942 ENTER;
1943 SAVESPTR(PL_compcv);
e07561e6 1944 PL_compcv = cv;
5fab0186 1945 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
dd2155a4 1946
a0d2bbd5
FC
1947 if (CvHASEVAL(cv))
1948 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
dd2155a4 1949
cbacc9aa 1950 SAVESPTR(PL_comppad_name);
9ef8d569 1951 PL_comppad_name = protopad_name;
eacbb379 1952 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
b4db5868 1953 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
dd2155a4 1954
b5c19bd7 1955 av_fill(PL_comppad, fpad);
dd2155a4 1956
dd2155a4
DM
1957 PL_curpad = AvARRAY(PL_comppad);
1958
db4cf31d 1959 outpad = outside && CvPADLIST(outside)
86d2498c 1960 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
f2ead8b8 1961 : NULL;
b4db5868 1962 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
b5c19bd7 1963
dd2155a4 1964 for (ix = fpad; ix > 0; ix--) {
39899bf0 1965 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
a0714e2c 1966 SV *sv = NULL;
325e1816 1967 if (namesv && PadnameLEN(namesv)) { /* lexical */
f2047bf1
FC
1968 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
1969 NOOP;
1970 }
1971 else {
39899bf0 1972 if (PadnameOUTER(namesv)) { /* lexical from outside? */
5aec98df
FC
1973 /* formats may have an inactive, or even undefined, parent;
1974 but state vars are always available. */
f2ead8b8 1975 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
cae5dbbe 1976 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
db4cf31d 1977 && (!outside || !CvDEPTH(outside))) ) {
445f13ff 1978 S_unavailable(aTHX_ namesv);
a0714e2c 1979 sv = NULL;
71f882da 1980 }
33894c1a 1981 else
f84c484e 1982 SvREFCNT_inc_simple_void_NN(sv);
dd2155a4 1983 }
71f882da 1984 if (!sv) {
39899bf0 1985 const char sigil = PadnamePV(namesv)[0];
e1ec3a88 1986 if (sigil == '&')
e07561e6
FC
1987 /* If there are state subs, we need to clone them, too.
1988 But they may need to close over variables we have
1989 not cloned yet. So we will have to do a second
1990 pass. Furthermore, there may be state subs clos-
1991 ing over other state subs’ entries, so we have
1992 to put a stub here and then clone into it on the
1993 second pass. */
6d5c2147
FC
1994 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
1995 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
e0c6a6b8
FC
1996 subclones ++;
1997 if (CvOUTSIDE(ppad[ix]) != proto)
1998 trouble = TRUE;
6d5c2147 1999 sv = newSV_type(SVt_PVCV);
f3feca7a 2000 CvLEXICAL_on(sv);
6d5c2147
FC
2001 }
2002 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2003 {
2004 /* my sub */
81df9f6f 2005 /* Just provide a stub, but name it. It will be
7600a9e5 2006 upgraded to the real thing on scope entry. */
f7cf2d13 2007 dVAR;
e1588866 2008 U32 hash;
39899bf0
FC
2009 PERL_HASH(hash, PadnamePV(namesv)+1,
2010 PadnameLEN(namesv) - 1);
81df9f6f 2011 sv = newSV_type(SVt_PVCV);
cf748c3c
FC
2012 CvNAME_HEK_set(
2013 sv,
39899bf0
FC
2014 share_hek(PadnamePV(namesv)+1,
2015 1 - PadnameLEN(namesv),
e1588866 2016 hash)
cf748c3c 2017 );
f3feca7a 2018 CvLEXICAL_on(sv);
6d5c2147
FC
2019 }
2020 else sv = SvREFCNT_inc(ppad[ix]);
e1ec3a88 2021 else if (sigil == '@')
ad64d0ec 2022 sv = MUTABLE_SV(newAV());
e1ec3a88 2023 else if (sigil == '%')
ad64d0ec 2024 sv = MUTABLE_SV(newHV());
dd2155a4 2025 else
561b68a9 2026 sv = newSV(0);
0d3b281c 2027 /* reset the 'assign only once' flag on each state var */
e07561e6 2028 if (sigil != '&' && SvPAD_STATE(namesv))
0d3b281c 2029 SvPADSTALE_on(sv);
dd2155a4 2030 }
f2047bf1 2031 }
dd2155a4 2032 }
4c894bf7 2033 else if (namesv && PadnamePV(namesv)) {
f84c484e 2034 sv = SvREFCNT_inc_NN(ppad[ix]);
dd2155a4
DM
2035 }
2036 else {
561b68a9 2037 sv = newSV(0);
dd2155a4 2038 SvPADTMP_on(sv);
dd2155a4 2039 }
71f882da 2040 PL_curpad[ix] = sv;
dd2155a4
DM
2041 }
2042
e07561e6 2043 if (subclones)
e0c6a6b8
FC
2044 {
2045 if (trouble || cloned) {
2046 /* Uh-oh, we have trouble! At least one of the state subs here
2047 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2048 could be pointing to another state protosub that we are
2049 about to clone. So we have to track which sub clones come
2050 from which protosubs. If the CvOUTSIDE pointer for a parti-
2051 cular sub points to something we have not cloned yet, we
2052 delay cloning it. We must loop through the pad entries,
2053 until we get a full pass with no cloning. If any uncloned
2054 subs remain (probably nested inside anonymous or ‘my’ subs),
2055 then they get cloned in a final pass.
2056 */
2057 bool cloned_in_this_pass;
2058 if (!cloned)
2059 cloned = (HV *)sv_2mortal((SV *)newHV());
2060 do {
2061 cloned_in_this_pass = FALSE;
2062 for (ix = fpad; ix > 0; ix--) {
2063 PADNAME * const name =
2064 (ix <= fname) ? pname[ix] : NULL;
2065 if (name && name != &PL_padname_undef
2066 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2067 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2068 {
2069 CV * const protokey = CvOUTSIDE(ppad[ix]);
2070 CV ** const cvp = protokey == proto
2071 ? &cv
2072 : (CV **)hv_fetch(cloned, (char *)&protokey,
2073 sizeof(CV *), 0);
2074 if (cvp && *cvp) {
2075 S_cv_clone(aTHX_ (CV *)ppad[ix],
2076 (CV *)PL_curpad[ix],
2077 *cvp, cloned);
b53eee5d 2078 (void)hv_store(cloned, (char *)&ppad[ix],
e0c6a6b8
FC
2079 sizeof(CV *),
2080 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2081 0);
2082 subclones--;
2083 cloned_in_this_pass = TRUE;
2084 }
2085 }
2086 }
2087 } while (cloned_in_this_pass);
2088 if (subclones)
2089 for (ix = fpad; ix > 0; ix--) {
2090 PADNAME * const name =
2091 (ix <= fname) ? pname[ix] : NULL;
2092 if (name && name != &PL_padname_undef
2093 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2094 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2095 S_cv_clone(aTHX_ (CV *)ppad[ix],
2096 (CV *)PL_curpad[ix],
2097 CvOUTSIDE(ppad[ix]), cloned);
2098 }
2099 }
2100 else for (ix = fpad; ix > 0; ix--) {
39899bf0
FC
2101 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2102 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2103 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
e0c6a6b8
FC
2104 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2105 NULL);
e07561e6 2106 }
e0c6a6b8 2107 }
e07561e6 2108
5fab0186 2109 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
e10681aa 2110 LEAVE;
21195f4d 2111
1567c65a
FC
2112 if (CvCONST(cv)) {
2113 /* Constant sub () { $x } closing over $x:
2114 * The prototype was marked as a candiate for const-ization,
2115 * so try to grab the current const value, and if successful,
2116 * turn into a const sub:
2117 */
d8d6ddf8
FC
2118 SV* const_sv;
2119 OP *o = CvSTART(cv);
1567c65a 2120 assert(newcv);
d8d6ddf8
FC
2121 for (; o; o = o->op_next)
2122 if (o->op_type == OP_PADSV)
2123 break;
2124 ASSUME(o->op_type == OP_PADSV);
2125 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2126 /* the candidate should have 1 ref from this pad and 1 ref
2127 * from the parent */
2128 if (const_sv && SvREFCNT(const_sv) == 2) {
1567c65a 2129 const bool was_method = cBOOL(CvMETHOD(cv));
04472a84 2130 bool copied = FALSE;
d8d6ddf8
FC
2131 if (outside) {
2132 PADNAME * const pn =
2133 PadlistNAMESARRAY(CvPADLIST(outside))
2134 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2135 CvPADLIST(cv))[o->op_targ])];
2136 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2137 [o->op_targ]));
2138 if (PadnameLVALUE(pn)) {
2139 /* We have a lexical that is potentially modifiable
2140 elsewhere, so making a constant will break clo-
2141 sure behaviour. If this is a ‘simple lexical
2142 op tree’, i.e., sub(){$x}, emit a deprecation
2143 warning, but continue to exhibit the old behav-
2144 iour of making it a constant based on the ref-
2145 count of the candidate variable.
2146
2147 A simple lexical op tree looks like this:
2148
2149 leavesub
2150 lineseq
2151 nextstate
2152 padsv
2153 */
e6dae479 2154 if (OpSIBLING(
d8d6ddf8
FC
2155 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2156 ) == o
e6dae479 2157 && !OpSIBLING(o))
04472a84 2158 {
d8d6ddf8
FC
2159 Perl_ck_warner_d(aTHX_
2160 packWARN(WARN_DEPRECATED),
2161 "Constants from lexical "
2162 "variables potentially "
2163 "modified elsewhere are "
9840d1d6
A
2164 "deprecated. This will not "
2165 "be allowed in Perl 5.32");
04472a84
FC
2166 /* We *copy* the lexical variable, and donate the
2167 copy to newCONSTSUB. Yes, this is ugly, and
2168 should be killed. We need to do this for the
2169 time being, however, because turning on SvPADTMP
2170 on a lexical will have observable effects
2171 elsewhere. */
2172 const_sv = newSVsv(const_sv);
2173 copied = TRUE;
2174 }
d8d6ddf8
FC
2175 else
2176 goto constoff;
2177 }
2178 }
04472a84
FC
2179 if (!copied)
2180 SvREFCNT_inc_simple_void_NN(const_sv);
2181 /* If the lexical is not used elsewhere, it is safe to turn on
2182 SvPADTMP, since it is only when it is used in lvalue con-
2183 text that the difference is observable. */
6dfba0aa 2184 SvREADONLY_on(const_sv);
d8d6ddf8 2185 SvPADTMP_on(const_sv);
1567c65a 2186 SvREFCNT_dec_NN(cv);
1567c65a
FC
2187 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2188 if (was_method)
2189 CvMETHOD_on(cv);
2190 }
2191 else {
d8d6ddf8 2192 constoff:
1567c65a
FC
2193 CvCONST_off(cv);
2194 }
2195 }
2196
21195f4d 2197 return cv;
e10681aa
FC
2198}
2199
2200static CV *
e0c6a6b8 2201S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
e10681aa 2202{
20b7effb 2203#ifdef USE_ITHREADS
c04ef36e 2204 dVAR;
20b7effb 2205#endif
5fab0186 2206 const bool newcv = !cv;
c04ef36e 2207
e10681aa
FC
2208 assert(!CvUNIQUE(proto));
2209
2210 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2211 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2212 |CVf_SLABBED);
2213 CvCLONED_on(cv);
2214
2215 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2216 : CvFILE(proto);
2217 if (CvNAMED(proto))
2e800d79 2218 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
e10681aa
FC
2219 else CvGV_set(cv,CvGV(proto));
2220 CvSTASH_set(cv, CvSTASH(proto));
2221 OP_REFCNT_LOCK;
2222 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2223 OP_REFCNT_UNLOCK;
2224 CvSTART(cv) = CvSTART(proto);
2225 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2226
fdf416b6 2227 if (SvPOK(proto)) {
e10681aa 2228 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
fdf416b6
BF
2229 if (SvUTF8(proto))
2230 SvUTF8_on(MUTABLE_SV(cv));
2231 }
e10681aa
FC
2232 if (SvMAGIC(proto))
2233 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2234
21195f4d 2235 if (CvPADLIST(proto))
e0c6a6b8 2236 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
e10681aa 2237
dd2155a4
DM
2238 DEBUG_Xv(
2239 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
e10681aa 2240 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
dd2155a4
DM
2241 cv_dump(proto, "Proto");
2242 cv_dump(cv, "To");
2243 );
2244
dd2155a4
DM
2245 return cv;
2246}
2247
e07561e6
FC
2248CV *
2249Perl_cv_clone(pTHX_ CV *proto)
2250{
2251 PERL_ARGS_ASSERT_CV_CLONE;
2252
fead5351 2253 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
e0c6a6b8 2254 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
e07561e6
FC
2255}
2256
6d5c2147
FC
2257/* Called only by pp_clonecv */
2258CV *
2259Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2260{
2261 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2262 cv_undef(target);
e0c6a6b8 2263 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
6d5c2147
FC
2264}
2265
fb094047
FC
2266/*
2267=for apidoc cv_name
2268
2269Returns an SV containing the name of the CV, mainly for use in error
2270reporting. The CV may actually be a GV instead, in which case the returned
7a275a2e
FC
2271SV holds the GV's name. Anything other than a GV or CV is treated as a
2272string already holding the sub name, but this could change in the future.
fb094047
FC
2273
2274An SV may be passed as a second argument. If so, the name will be assigned
2275to it and it will be returned. Otherwise the returned SV will be a new
2276mortal.
2277
c5608a1f 2278If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
ecf05a58
FC
2279included. If the first argument is neither a CV nor a GV, this flag is
2280ignored (subject to change).
2281
fb094047
FC
2282=cut
2283*/
2284
c5569a55 2285SV *
ecf05a58 2286Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
c5569a55
FC
2287{
2288 PERL_ARGS_ASSERT_CV_NAME;
2289 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2290 if (sv) sv_setsv(sv,(SV *)cv);
2291 return sv ? (sv) : (SV *)cv;
2292 }
2293 {
f3fb6cf3 2294 SV * const retsv = sv ? (sv) : sv_newmortal();
c5569a55
FC
2295 if (SvTYPE(cv) == SVt_PVCV) {
2296 if (CvNAMED(cv)) {
ecf05a58
FC
2297 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2298 sv_sethek(retsv, CvNAME_HEK(cv));
c5569a55 2299 else {
6881372e
FC
2300 if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
2301 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2302 else
2303 sv_setpvs(retsv, "__ANON__");
c5569a55 2304 sv_catpvs(retsv, "::");
f34d8cdd 2305 sv_cathek(retsv, CvNAME_HEK(cv));
c5569a55
FC
2306 }
2307 }
ecf05a58 2308 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
c5569a55
FC
2309 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2310 else gv_efullname3(retsv, CvGV(cv), NULL);
2311 }
ecf05a58 2312 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
c5569a55
FC
2313 else gv_efullname3(retsv,(GV *)cv,NULL);
2314 return retsv;
2315 }
2316}
2317
dd2155a4 2318/*
cc76b5cc 2319=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
dd2155a4 2320
796b6530
KW
2321For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2322C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
7dafbf52 2323moved to a pre-existing CV struct.
dd2155a4
DM
2324
2325=cut
2326*/
2327
2328void
2329Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2330{
d12be05d 2331 PADOFFSET ix;
9b7476d7 2332 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
86d2498c 2333 AV * const comppad = PadlistARRAY(padlist)[1];
0f94cb1f 2334 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
53c1dcc0 2335 SV ** const curpad = AvARRAY(comppad);
7918f24d
NC
2336
2337 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
294a48e9
AL
2338 PERL_UNUSED_ARG(old_cv);
2339
9b7476d7 2340 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
307cbb9f
FC
2341 const PADNAME *name = namepad[ix];
2342 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
0f94cb1f 2343 && *PadnamePV(name) == '&')
dd2155a4 2344 {
307cbb9f
FC
2345 CV *innercv = MUTABLE_CV(curpad[ix]);
2346 if (UNLIKELY(PadnameOUTER(name))) {
2347 CV *cv = new_cv;
2348 PADNAME **names = namepad;
2349 PADOFFSET i = ix;
2350 while (PadnameOUTER(name)) {
95c0a761 2351 assert(SvTYPE(cv) == SVt_PVCV);
307cbb9f
FC
2352 cv = CvOUTSIDE(cv);
2353 names = PadlistNAMESARRAY(CvPADLIST(cv));
2354 i = PARENT_PAD_INDEX(name);
2355 name = names[i];
2356 }
2357 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2358 }
2359 if (SvTYPE(innercv) == SVt_PVCV) {
0f94cb1f
FC
2360 /* XXX 0afba48f added code here to check for a proto CV
2361 attached to the pad entry by magic. But shortly there-
2362 after 81df9f6f95 moved the magic to the pad name. The
2363 code here was never updated, so it wasn’t doing anything
2364 and got deleted when PADNAME became a distinct type. Is
2365 there any bug as a result? */
0afba48f 2366 if (CvOUTSIDE(innercv) == old_cv) {
1f122f9b
FC
2367 if (!CvWEAKOUTSIDE(innercv)) {
2368 SvREFCNT_dec(old_cv);
2369 SvREFCNT_inc_simple_void_NN(new_cv);
2370 }
0afba48f
FC
2371 CvOUTSIDE(innercv) = new_cv;
2372 }
e09ac076
FC
2373 }
2374 else { /* format reference */
2375 SV * const rv = curpad[ix];
2376 CV *innercv;
2377 if (!SvOK(rv)) continue;
2378 assert(SvROK(rv));
2379 assert(SvWEAKREF(rv));
2380 innercv = (CV *)SvRV(rv);
2381 assert(!CvWEAKOUTSIDE(innercv));
95c0a761 2382 assert(CvOUTSIDE(innercv) == old_cv);
e09ac076
FC
2383 SvREFCNT_dec(CvOUTSIDE(innercv));
2384 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2385 }
dd2155a4
DM
2386 }
2387 }
2388}
2389
2390/*
cc76b5cc 2391=for apidoc m|void|pad_push|PADLIST *padlist|int depth
dd2155a4
DM
2392
2393Push a new pad frame onto the padlist, unless there's already a pad at
26019298 2394this depth, in which case don't bother creating a new one. Then give
796b6530 2395the new pad an C<@_> in slot zero.
dd2155a4
DM
2396
2397=cut
2398*/
2399
2400void
26019298 2401Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
dd2155a4 2402{
7918f24d
NC
2403 PERL_ARGS_ASSERT_PAD_PUSH;
2404
86d2498c
FC
2405 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2406 PAD** const svp = PadlistARRAY(padlist);
44f8325f
AL
2407 AV* const newpad = newAV();
2408 SV** const oldpad = AvARRAY(svp[depth-1]);
d12be05d
DM
2409 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
2410 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
a2ddd1d1 2411 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
26019298
AL
2412 AV *av;
2413
dd2155a4 2414 for ( ;ix > 0; ix--) {
325e1816 2415 if (names_fill >= ix && PadnameLEN(names[ix])) {
a2ddd1d1
FC
2416 const char sigil = PadnamePV(names[ix])[0];
2417 if (PadnameOUTER(names[ix])
2418 || PadnameIsSTATE(names[ix])
fda94784
RGS
2419 || sigil == '&')
2420 {
dd2155a4
DM
2421 /* outer lexical or anon code */
2422 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2423 }
2424 else { /* our own lexical */
26019298
AL
2425 SV *sv;
2426 if (sigil == '@')
ad64d0ec 2427 sv = MUTABLE_SV(newAV());
26019298 2428 else if (sigil == '%')
ad64d0ec 2429 sv = MUTABLE_SV(newHV());
dd2155a4 2430 else
561b68a9 2431 sv = newSV(0);
26019298 2432 av_store(newpad, ix, sv);
dd2155a4
DM
2433 }
2434 }
778f1807 2435 else if (PadnamePV(names[ix])) {
f84c484e 2436 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
dd2155a4
DM
2437 }
2438 else {
2439 /* save temporaries on recursion? */
561b68a9 2440 SV * const sv = newSV(0);
26019298 2441 av_store(newpad, ix, sv);
dd2155a4
DM
2442 SvPADTMP_on(sv);
2443 }
2444 }
26019298 2445 av = newAV();
ad64d0ec 2446 av_store(newpad, 0, MUTABLE_SV(av));
11ca45c0 2447 AvREIFY_only(av);
26019298 2448
7261499d 2449 padlist_store(padlist, depth, newpad);
dd2155a4
DM
2450 }
2451}
b21dc031 2452
d5b1589c
NC
2453#if defined(USE_ITHREADS)
2454
2455# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2456
cc76b5cc 2457/*
b70d5558 2458=for apidoc padlist_dup
cc76b5cc
Z
2459
2460Duplicates a pad.
2461
2462=cut
2463*/
2464
b70d5558
FC
2465PADLIST *
2466Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
d5b1589c 2467{
7261499d
FC
2468 PADLIST *dstpad;
2469 bool cloneall;
2470 PADOFFSET max;
2471
d5b1589c
NC
2472 PERL_ARGS_ASSERT_PADLIST_DUP;
2473
71c165d4 2474 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
86d2498c 2475 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
7261499d 2476
86d2498c 2477 max = cloneall ? PadlistMAX(srcpad) : 1;
7261499d
FC
2478
2479 Newx(dstpad, 1, PADLIST);
2480 ptr_table_store(PL_ptr_table, srcpad, dstpad);
86d2498c
FC
2481 PadlistMAX(dstpad) = max;
2482 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
7261499d 2483
9b7476d7
FC
2484 PadlistARRAY(dstpad)[0] = (PAD *)
2485 padnamelist_dup(PadlistNAMES(srcpad), param);
2486 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
7261499d
FC
2487 if (cloneall) {
2488 PADOFFSET depth;
9b7476d7 2489 for (depth = 1; depth <= max; ++depth)
86d2498c
FC
2490 PadlistARRAY(dstpad)[depth] =
2491 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
6de654a5
NC
2492 } else {
2493 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2494 to build anything other than the first level of pads. */
d12be05d 2495 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
6de654a5 2496 AV *pad1;
d12be05d 2497 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
86d2498c 2498 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
6de654a5 2499 SV **oldpad = AvARRAY(srcpad1);
3e020df5 2500 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
6de654a5
NC
2501 SV **pad1a;
2502 AV *args;
6de654a5 2503
6de654a5
NC
2504 pad1 = newAV();
2505
2506 av_extend(pad1, ix);
86d2498c 2507 PadlistARRAY(dstpad)[1] = pad1;
6de654a5 2508 pad1a = AvARRAY(pad1);
6de654a5
NC
2509
2510 if (ix > -1) {
2511 AvFILLp(pad1) = ix;
2512
2513 for ( ;ix > 0; ix--) {
05d04d9c
NC
2514 if (!oldpad[ix]) {
2515 pad1a[ix] = NULL;
ce0d59fd
FC
2516 } else if (names_fill >= ix && names[ix] &&
2517 PadnameLEN(names[ix])) {
3e020df5
FC
2518 const char sigil = PadnamePV(names[ix])[0];
2519 if (PadnameOUTER(names[ix])
2520 || PadnameIsSTATE(names[ix])
05d04d9c
NC
2521 || sigil == '&')
2522 {
2523 /* outer lexical or anon code */
2524 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2525 }
2526 else { /* our own lexical */
adf8f095
NC
2527 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2528 /* This is a work around for how the current
2529 implementation of ?{ } blocks in regexps
2530 interacts with lexicals. */
05d04d9c
NC
2531 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2532 } else {
2533 SV *sv;
2534
2535 if (sigil == '@')
2536 sv = MUTABLE_SV(newAV());
2537 else if (sigil == '%')
2538 sv = MUTABLE_SV(newHV());
2539 else
2540 sv = newSV(0);
2541 pad1a[ix] = sv;
05d04d9c
NC
2542 }
2543 }
2544 }
92154801 2545 else if (( names_fill >= ix && names[ix]
ce0d59fd 2546 && PadnamePV(names[ix]) )) {
05d04d9c
NC
2547 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2548 }
2549 else {
2550 /* save temporaries on recursion? */
2551 SV * const sv = newSV(0);
2552 pad1a[ix] = sv;
2553
2554 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2555 FIXTHAT before merging this branch.
2556 (And I know how to) */
145bf8ee 2557 if (SvPADTMP(oldpad[ix]))
05d04d9c
NC
2558 SvPADTMP_on(sv);
2559 }
6de654a5
NC
2560 }
2561
2562 if (oldpad[0]) {
2563 args = newAV(); /* Will be @_ */
2564 AvREIFY_only(args);
2565 pad1a[0] = (SV *)args;
2566 }
2567 }
2568 }
d5b1589c
NC
2569
2570 return dstpad;
2571}
2572
cc76b5cc 2573#endif /* USE_ITHREADS */
d5b1589c 2574
7261499d 2575PAD **
5aaab254 2576Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
7261499d 2577{
7261499d 2578 PAD **ary;
86d2498c 2579 SSize_t const oldmax = PadlistMAX(padlist);
7261499d
FC
2580
2581 PERL_ARGS_ASSERT_PADLIST_STORE;
2582
2583 assert(key >= 0);
2584
86d2498c
FC
2585 if (key > PadlistMAX(padlist)) {
2586 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2587 (SV ***)&PadlistARRAY(padlist),
2588 (SV ***)&PadlistARRAY(padlist));
2589 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
7261499d
FC
2590 PAD *);
2591 }
86d2498c 2592 ary = PadlistARRAY(padlist);
7261499d
FC
2593 SvREFCNT_dec(ary[key]);
2594 ary[key] = val;
2595 return &ary[key];
2596}
2597
66610fdd 2598/*
9b7476d7
FC
2599=for apidoc newPADNAMELIST
2600
2601Creates a new pad name list. C<max> is the highest index for which space
2602is allocated.
2603
2604=cut
2605*/
2606
2607PADNAMELIST *
a0e9f837 2608Perl_newPADNAMELIST(size_t max)
9b7476d7
FC
2609{
2610 PADNAMELIST *pnl;
2611 Newx(pnl, 1, PADNAMELIST);
2612 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2613 PadnamelistMAX(pnl) = -1;
2614 PadnamelistREFCNT(pnl) = 1;
2615 PadnamelistMAXNAMED(pnl) = 0;
2616 pnl->xpadnl_max = max;
2617 return pnl;
2618}
2619
2620/*
2621=for apidoc padnamelist_store
2622
2623Stores the pad name (which may be null) at the given index, freeing any
2624existing pad name in that slot.
2625
2626=cut
2627*/
2628
2629PADNAME **
2630Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2631{
2632 PADNAME **ary;
2633
2634 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2635
2636 assert(key >= 0);
2637
2638 if (key > pnl->xpadnl_max)
2639 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2640 (SV ***)&PadnamelistARRAY(pnl),
2641 (SV ***)&PadnamelistARRAY(pnl));
2642 if (PadnamelistMAX(pnl) < key) {
2643 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2644 key-PadnamelistMAX(pnl), PADNAME *);
2645 PadnamelistMAX(pnl) = key;
2646 }
2647 ary = PadnamelistARRAY(pnl);
0f94cb1f
FC
2648 if (ary[key])
2649 PadnameREFCNT_dec(ary[key]);
9b7476d7
FC
2650 ary[key] = val;
2651 return &ary[key];
2652}
2653
2654/*
2655=for apidoc padnamelist_fetch
2656
2657Fetches the pad name from the given index.
2658
2659=cut
2660*/
2661
2662PADNAME *
a0e9f837 2663Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
9b7476d7
FC
2664{
2665 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2666 ASSUME(key >= 0);
2667
2668 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2669}
2670
2671void
2672Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2673{
2674 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2675 if (!--PadnamelistREFCNT(pnl)) {
2676 while(PadnamelistMAX(pnl) >= 0)
0f94cb1f
FC
2677 {
2678 PADNAME * const pn =
2679 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2680 if (pn)
2681 PadnameREFCNT_dec(pn);
2682 }
9b7476d7
FC
2683 Safefree(PadnamelistARRAY(pnl));
2684 Safefree(pnl);
2685 }
2686}
2687
2688#if defined(USE_ITHREADS)
2689
2690/*
2691=for apidoc padnamelist_dup
2692
2693Duplicates a pad name list.
2694
2695=cut
2696*/
2697
2698PADNAMELIST *
2699Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2700{
2701 PADNAMELIST *dstpad;
2702 SSize_t max = PadnamelistMAX(srcpad);
2703
2704 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2705
2706 /* look for it in the table first */
2707 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2708 if (dstpad)
2709 return dstpad;
2710
2711 dstpad = newPADNAMELIST(max);
2712 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2713 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2714 PadnamelistMAX(dstpad) = max;
2715
2716 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2717 for (; max >= 0; max--)
0f94cb1f 2718 if (PadnamelistARRAY(srcpad)[max]) {
9b7476d7 2719 PadnamelistARRAY(dstpad)[max] =
0f94cb1f
FC
2720 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2721 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2722 }
9b7476d7
FC
2723
2724 return dstpad;
2725}
2726
2727#endif /* USE_ITHREADS */
2728
0f94cb1f
FC
2729/*
2730=for apidoc newPADNAMEpvn
2731
4a4088c4 2732Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
0f94cb1f 2733use this for pad names that point to outer lexicals. See
fbe13c60 2734C<L</newPADNAMEouter>>.
0f94cb1f
FC
2735
2736=cut
2737*/
2738
2739PADNAME *
a0e9f837 2740Perl_newPADNAMEpvn(const char *s, STRLEN len)
0f94cb1f
FC
2741{
2742 struct padname_with_str *alloc;
2743 char *alloc2; /* for Newxz */
2744 PADNAME *pn;
2745 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2746 Newxz(alloc2,
2747 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2748 char);
2749 alloc = (struct padname_with_str *)alloc2;
2750 pn = (PADNAME *)alloc;
2751 PadnameREFCNT(pn) = 1;
2752 PadnamePV(pn) = alloc->xpadn_str;
2753 Copy(s, PadnamePV(pn), len, char);
2754 *(PadnamePV(pn) + len) = '\0';
2755 PadnameLEN(pn) = len;
2756 return pn;
2757}
2758
2759/*
2760=for apidoc newPADNAMEouter
2761
2762Constructs and returns a new pad name. Only use this function for names
2d7f6611 2763that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
0f94cb1f 2764the outer pad name that this one mirrors. The returned pad name has the
796b6530 2765C<PADNAMEt_OUTER> flag already set.
0f94cb1f
FC
2766
2767=cut
2768*/
2769
2770PADNAME *
a0e9f837 2771Perl_newPADNAMEouter(PADNAME *outer)
0f94cb1f
FC
2772{
2773 PADNAME *pn;
2774 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2775 Newxz(pn, 1, PADNAME);
2776 PadnameREFCNT(pn) = 1;
2777 PadnamePV(pn) = PadnamePV(outer);
2778 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2779 another entry. The original pad name owns the buffer. */
2780 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2781 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2782 PadnameLEN(pn) = PadnameLEN(outer);
2783 return pn;
2784}
2785
2786void
2787Perl_padname_free(pTHX_ PADNAME *pn)
2788{
2789 PERL_ARGS_ASSERT_PADNAME_FREE;
2790 if (!--PadnameREFCNT(pn)) {
2791 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2792 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2793 return;
2794 }
2795 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2796 SvREFCNT_dec(PadnameOURSTASH(pn));
2797 if (PadnameOUTER(pn))
2798 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2799 Safefree(pn);
2800 }
2801}
2802
2803#if defined(USE_ITHREADS)
2804
2805/*
2806=for apidoc padname_dup
2807
2808Duplicates a pad name.
2809
2810=cut
2811*/
2812
2813PADNAME *
2814Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2815{
2816 PADNAME *dst;
2817
2818 PERL_ARGS_ASSERT_PADNAME_DUP;
2819
2820 /* look for it in the table first */
2821 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2822 if (dst)
2823 return dst;
2824
2825 if (!PadnamePV(src)) {
2826 dst = &PL_padname_undef;
2827 ptr_table_store(PL_ptr_table, src, dst);
2828 return dst;
2829 }
2830
2831 dst = PadnameOUTER(src)
2832 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2833 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2834 ptr_table_store(PL_ptr_table, src, dst);
2835 PadnameLEN(dst) = PadnameLEN(src);
2836 PadnameFLAGS(dst) = PadnameFLAGS(src);
2837 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2838 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2839 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2840 param);
2841 dst->xpadn_low = src->xpadn_low;
2842 dst->xpadn_high = src->xpadn_high;
2843 dst->xpadn_gen = src->xpadn_gen;
2844 return dst;
2845}
2846
2847#endif /* USE_ITHREADS */
9b7476d7
FC
2848
2849/*
14d04a33 2850 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2851 */