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