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