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