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