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