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