This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
change #31447 was wrong. Really handle cloning a stale lexical var
[perl5.git] / pad.c
CommitLineData
dd2155a4
DM
1/* pad.c
2 *
fdf8c088 3 * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
dd2155a4
DM
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 * "Anyway: there was this Mr Frodo left an orphan and stranded, as you
9 * might say, among those queer Bucklanders, being brought up anyhow in
10 * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
11 * never had fewer than a couple of hundred relations in the place. Mr
12 * Bilbo never did a kinder deed than when he brought the lad back to
13 * live among decent folk." --the Gaffer
14 */
15
16/* XXX DAPM
17 * As of Sept 2002, this file is new and may be in a state of flux for
18 * a while. I've marked things I intent to come back and look at further
19 * with an 'XXX DAPM' comment.
20 */
21
22/*
23=head1 Pad Data Structures
24
61296642 25This file contains the functions that create and manipulate scratchpads,
166f8a29 26which are array-of-array data structures attached to a CV (ie a sub)
61296642 27and which store lexical variables and opcode temporary and per-thread
166f8a29
DM
28values.
29
dd2155a4
DM
30=for apidoc m|AV *|CvPADLIST|CV *cv
31CV's can have CvPADLIST(cv) set to point to an AV.
32
33For these purposes "forms" are a kind-of CV, eval""s are too (except they're
34not callable at will and are always thrown away after the eval"" is done
b5c19bd7
DM
35executing). Require'd files are simply evals without any outer lexical
36scope.
dd2155a4
DM
37
38XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
39but that is really the callers pad (a slot of which is allocated by
40every entersub).
41
42The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
f3548bdc 43is managed "manual" (mostly in pad.c) rather than normal av.c rules.
dd2155a4
DM
44The items in the AV are not SVs as for a normal AV, but other AVs:
45
460'th Entry of the CvPADLIST is an AV which represents the "names" or rather
47the "static type information" for lexicals.
48
49The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
50depth of recursion into the CV.
51The 0'th slot of a frame AV is an AV which is @_.
52other entries are storage for variables and op targets.
53
54During compilation:
a6d05634
TM
55C<PL_comppad_name> is set to the names AV.
56C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
57C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
dd2155a4 58
f3548bdc
DM
59During execution, C<PL_comppad> and C<PL_curpad> refer to the live
60frame of the currently executing sub.
61
62Iterating over the names AV iterates over all possible pad
dd2155a4
DM
63items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
64&PL_sv_undef "names" (see pad_alloc()).
65
66Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
67The rest are op targets/GVs/constants which are statically allocated
68or resolved at compile time. These don't have names by which they
69can be looked up from Perl code at run time through eval"" like
70my/our variables can be. Since they can't be looked up by "name"
71but only by their index allocated at compile time (which is usually
72in PL_op->op_targ), wasting a name SV for them doesn't make sense.
73
74The SVs in the names AV have their PV being the name of the variable.
3441fb63
NC
75xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
76which the name is valid. For typed lexicals name SV is SVt_PVMG and SvSTASH
77points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
73d95100 78SvOURSTASH slot pointing at the stash of the associated global (so that
931b58fb 79duplicate C<our> declarations in the same package can be detected). SvUVX is
3441fb63 80sometimes hijacked to store the generation number during compilation.
dd2155a4 81
b5c19bd7
DM
82If SvFAKE is set on the name SV, then that slot in the frame AV is
83a REFCNT'ed reference to a lexical from "outside". In this case,
3441fb63
NC
84the name SV does not use xlow and xhigh to store a cop_seq range, since it is
85in scope throughout. Instead xhigh stores some flags containing info about
b5c19bd7 86the real lexical (is it declared in an anon, and is it capable of being
3441fb63 87instantiated multiple times?), and for fake ANONs, xlow contains the index
b5c19bd7
DM
88within the parent's pad where the lexical's value is stored, to make
89cloning quicker.
dd2155a4 90
a6d05634 91If the 'name' is '&' the corresponding entry in frame AV
dd2155a4
DM
92is a CV representing a possible closure.
93(SvFAKE and name of '&' is not a meaningful combination currently but could
94become so if C<my sub foo {}> is implemented.)
95
71f882da
DM
96Note that formats are treated as anon subs, and are cloned each time
97write is called (if necessary).
98
e6e7068b
DM
99The flag SVf_PADSTALE is cleared on lexicals each time the my() is executed,
100and set on scope exit. This allows the 'Variable $x is not available' warning
101to be generated in evals, such as
102
103 { my $x = 1; sub f { eval '$x'} } f();
104
dd2155a4
DM
105=cut
106*/
107
108
109#include "EXTERN.h"
110#define PERL_IN_PAD_C
111#include "perl.h"
952306ac 112#include "keywords.h"
dd2155a4 113
3441fb63
NC
114#define COP_SEQ_RANGE_LOW_set(sv,val) \
115 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
116#define COP_SEQ_RANGE_HIGH_set(sv,val) \
117 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
809abb02 118
3441fb63
NC
119#define PARENT_PAD_INDEX_set(sv,val) \
120 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
121#define PARENT_FAKELEX_FLAGS_set(sv,val) \
122 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
dd2155a4 123
c8185ac5 124#define PAD_MAX I32_MAX
dd2155a4 125
1dba731d
NC
126#ifdef PERL_MAD
127void pad_peg(const char* s) {
128 static int pegcnt;
129 pegcnt++;
130}
131#endif
dd2155a4
DM
132
133/*
134=for apidoc pad_new
135
136Create a new compiling padlist, saving and updating the various global
137vars at the same time as creating the pad itself. The following flags
138can be OR'ed together:
139
140 padnew_CLONE this pad is for a cloned CV
141 padnew_SAVE save old globals
142 padnew_SAVESUB also save extra stuff for start of sub
143
144=cut
145*/
146
147PADLIST *
c7c737cb 148Perl_pad_new(pTHX_ int flags)
dd2155a4 149{
97aff369 150 dVAR;
e1ec3a88 151 AV *padlist, *padname, *pad;
dd2155a4 152
f3548bdc
DM
153 ASSERT_CURPAD_LEGAL("pad_new");
154
dd2155a4
DM
155 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
156 * vars (based on flags) rather than storing vals + addresses for
157 * each individually. Also see pad_block_start.
158 * XXX DAPM Try to see whether all these conditionals are required
159 */
160
161 /* save existing state, ... */
162
163 if (flags & padnew_SAVE) {
3979c56f 164 SAVECOMPPAD();
dd2155a4
DM
165 SAVESPTR(PL_comppad_name);
166 if (! (flags & padnew_CLONE)) {
167 SAVEI32(PL_padix);
168 SAVEI32(PL_comppad_name_fill);
169 SAVEI32(PL_min_intro_pending);
170 SAVEI32(PL_max_intro_pending);
8bbe96d7 171 SAVEBOOL(PL_cv_has_eval);
dd2155a4
DM
172 if (flags & padnew_SAVESUB) {
173 SAVEI32(PL_pad_reset_pending);
174 }
175 }
176 }
177 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
178 * saved - check at some pt that this is okay */
179
180 /* ... create new pad ... */
181
182 padlist = newAV();
183 padname = newAV();
184 pad = newAV();
185
186 if (flags & padnew_CLONE) {
187 /* XXX DAPM I dont know why cv_clone needs it
188 * doing differently yet - perhaps this separate branch can be
189 * dispensed with eventually ???
190 */
191
e1ec3a88 192 AV * const a0 = newAV(); /* will be @_ */
dd2155a4
DM
193 av_extend(a0, 0);
194 av_store(pad, 0, (SV*)a0);
11ca45c0 195 AvREIFY_only(a0);
dd2155a4
DM
196 }
197 else {
a0714e2c 198 av_store(pad, 0, NULL);
dd2155a4
DM
199 }
200
201 AvREAL_off(padlist);
202 av_store(padlist, 0, (SV*)padname);
203 av_store(padlist, 1, (SV*)pad);
204
205 /* ... then update state variables */
206
207 PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE));
208 PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE));
209 PL_curpad = AvARRAY(PL_comppad);
210
211 if (! (flags & padnew_CLONE)) {
212 PL_comppad_name_fill = 0;
213 PL_min_intro_pending = 0;
214 PL_padix = 0;
b5c19bd7 215 PL_cv_has_eval = 0;
dd2155a4
DM
216 }
217
218 DEBUG_X(PerlIO_printf(Perl_debug_log,
b5c19bd7 219 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
dd2155a4 220 " name=0x%"UVxf" flags=0x%"UVxf"\n",
b5c19bd7 221 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
dd2155a4
DM
222 PTR2UV(padname), (UV)flags
223 )
224 );
225
226 return (PADLIST*)padlist;
227}
228
229/*
230=for apidoc pad_undef
231
232Free the padlist associated with a CV.
233If parts of it happen to be current, we null the relevant
234PL_*pad* global vars so that we don't have any dangling references left.
235We also repoint the CvOUTSIDE of any about-to-be-orphaned
a3985cdc 236inner subs to the outer of this cv.
dd2155a4 237
7dafbf52
DM
238(This function should really be called pad_free, but the name was already
239taken)
240
dd2155a4
DM
241=cut
242*/
243
244void
a3985cdc 245Perl_pad_undef(pTHX_ CV* cv)
dd2155a4 246{
97aff369 247 dVAR;
dd2155a4 248 I32 ix;
b64e5050 249 const PADLIST * const padlist = CvPADLIST(cv);
dd2155a4 250
1dba731d 251 pad_peg("pad_undef");
dd2155a4
DM
252 if (!padlist)
253 return;
0565a181 254 if (SvIS_FREED(padlist)) /* may be during global destruction */
dd2155a4
DM
255 return;
256
257 DEBUG_X(PerlIO_printf(Perl_debug_log,
503de470
DM
258 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
259 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
dd2155a4
DM
260 );
261
7dafbf52
DM
262 /* detach any '&' anon children in the pad; if afterwards they
263 * are still live, fix up their CvOUTSIDEs to point to our outside,
264 * bypassing us. */
265 /* XXX DAPM for efficiency, we should only do this if we know we have
266 * children, or integrate this loop with general cleanup */
dd2155a4 267
7dafbf52 268 if (!PL_dirty) { /* don't bother during global destruction */
53c1dcc0 269 CV * const outercv = CvOUTSIDE(cv);
e1ec3a88 270 const U32 seq = CvOUTSIDE_SEQ(cv);
53c1dcc0
AL
271 AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
272 SV ** const namepad = AvARRAY(comppad_name);
273 AV * const comppad = (AV*)AvARRAY(padlist)[1];
274 SV ** const curpad = AvARRAY(comppad);
dd2155a4 275 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
504618e9 276 SV * const namesv = namepad[ix];
dd2155a4 277 if (namesv && namesv != &PL_sv_undef
b15aece3 278 && *SvPVX_const(namesv) == '&')
dd2155a4 279 {
7fc63493 280 CV * const innercv = (CV*)curpad[ix];
10dc53a8
DM
281 U32 inner_rc = SvREFCNT(innercv);
282 assert(inner_rc);
a0714e2c 283 namepad[ix] = NULL;
7dafbf52 284 SvREFCNT_dec(namesv);
01773faa
DM
285
286 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
a0714e2c 287 curpad[ix] = NULL;
01773faa 288 SvREFCNT_dec(innercv);
10dc53a8 289 inner_rc--;
01773faa 290 }
b37c2d43
AL
291
292 /* in use, not just a prototype */
293 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
7dafbf52 294 assert(CvWEAKOUTSIDE(innercv));
9d1ce744
JH
295 /* don't relink to grandfather if he's being freed */
296 if (outercv && SvREFCNT(outercv)) {
297 CvWEAKOUTSIDE_off(innercv);
298 CvOUTSIDE(innercv) = outercv;
299 CvOUTSIDE_SEQ(innercv) = seq;
f84c484e 300 SvREFCNT_inc_simple_void_NN(outercv);
9d1ce744
JH
301 }
302 else {
601f1833 303 CvOUTSIDE(innercv) = NULL;
9d1ce744 304 }
dd2155a4
DM
305 }
306 }
307 }
308 }
7dafbf52 309
dd2155a4
DM
310 ix = AvFILLp(padlist);
311 while (ix >= 0) {
b37c2d43
AL
312 const SV* const sv = AvARRAY(padlist)[ix--];
313 if (sv) {
314 if (sv == (SV*)PL_comppad_name)
315 PL_comppad_name = NULL;
316 else if (sv == (SV*)PL_comppad) {
317 PL_comppad = NULL;
318 PL_curpad = NULL;
319 }
dd2155a4
DM
320 }
321 SvREFCNT_dec(sv);
322 }
323 SvREFCNT_dec((SV*)CvPADLIST(cv));
4608196e 324 CvPADLIST(cv) = NULL;
dd2155a4
DM
325}
326
327
328
329
330/*
331=for apidoc pad_add_name
332
b5c19bd7
DM
333Create a new name and associated PADMY SV in the current pad; return the
334offset.
dd2155a4
DM
335If C<typestash> is valid, the name is for a typed lexical; set the
336name's stash to that value.
337If C<ourstash> is valid, it's an our lexical, set the name's
73d95100 338SvOURSTASH to that value
dd2155a4 339
dd2155a4
DM
340If fake, it means we're cloning an existing entry
341
342=cut
343*/
344
dd2155a4 345PADOFFSET
952306ac 346Perl_pad_add_name(pTHX_ const char *name, HV* typestash, HV* ourstash, bool fake, bool state)
dd2155a4 347{
97aff369 348 dVAR;
504618e9 349 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
b9f83d2f
NC
350 SV* const namesv
351 = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
dd2155a4 352
f3548bdc
DM
353 ASSERT_CURPAD_ACTIVE("pad_add_name");
354
dd2155a4
DM
355 sv_setpv(namesv, name);
356
357 if (typestash) {
63f10712 358 assert(SvTYPE(namesv) == SVt_PVMG);
00b1698f 359 SvPAD_TYPED_on(namesv);
b37c2d43 360 SvSTASH_set(namesv, (HV*)SvREFCNT_inc_simple_NN((SV*)typestash));
dd2155a4
DM
361 }
362 if (ourstash) {
00b1698f 363 SvPAD_OUR_on(namesv);
73d95100 364 SvOURSTASH_set(namesv, ourstash);
f84c484e 365 SvREFCNT_inc_simple_void_NN(ourstash);
dd2155a4 366 }
952306ac
RGS
367 else if (state) {
368 SvPAD_STATE_on(namesv);
369 }
dd2155a4
DM
370
371 av_store(PL_comppad_name, offset, namesv);
b5c19bd7 372 if (fake) {
dd2155a4 373 SvFAKE_on(namesv);
b5c19bd7
DM
374 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
375 "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
376 }
dd2155a4 377 else {
ee6cee0c 378 /* not yet introduced */
809abb02
NC
379 COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
380 COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */
ee6cee0c 381
dd2155a4
DM
382 if (!PL_min_intro_pending)
383 PL_min_intro_pending = offset;
384 PL_max_intro_pending = offset;
b5c19bd7 385 /* if it's not a simple scalar, replace with an AV or HV */
f3548bdc
DM
386 /* XXX DAPM since slot has been allocated, replace
387 * av_store with PL_curpad[offset] ? */
dd2155a4
DM
388 if (*name == '@')
389 av_store(PL_comppad, offset, (SV*)newAV());
390 else if (*name == '%')
391 av_store(PL_comppad, offset, (SV*)newHV());
392 SvPADMY_on(PL_curpad[offset]);
b5c19bd7
DM
393 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
394 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
395 (long)offset, name, PTR2UV(PL_curpad[offset])));
dd2155a4
DM
396 }
397
398 return offset;
399}
400
401
402
403
404/*
405=for apidoc pad_alloc
406
407Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
408the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
cf525c36 409for a slot which has no name and no active value.
dd2155a4
DM
410
411=cut
412*/
413
414/* XXX DAPM integrate alloc(), add_name() and add_anon(),
415 * or at least rationalise ??? */
6d640399
NC
416/* And flag whether the incoming name is UTF8 or 8 bit?
417 Could do this either with the +ve/-ve hack of the HV code, or expanding
418 the flag bits. Either way, this makes proper Unicode safe pad support.
6d640399
NC
419 NWC
420*/
dd2155a4
DM
421
422PADOFFSET
423Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
424{
97aff369 425 dVAR;
dd2155a4
DM
426 SV *sv;
427 I32 retval;
428
6136c704 429 PERL_UNUSED_ARG(optype);
f3548bdc
DM
430 ASSERT_CURPAD_ACTIVE("pad_alloc");
431
dd2155a4
DM
432 if (AvARRAY(PL_comppad) != PL_curpad)
433 Perl_croak(aTHX_ "panic: pad_alloc");
434 if (PL_pad_reset_pending)
435 pad_reset();
436 if (tmptype & SVs_PADMY) {
235cc2e3 437 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
dd2155a4
DM
438 retval = AvFILLp(PL_comppad);
439 }
440 else {
551405c4 441 SV * const * const names = AvARRAY(PL_comppad_name);
e1ec3a88 442 const SSize_t names_fill = AvFILLp(PL_comppad_name);
dd2155a4
DM
443 for (;;) {
444 /*
445 * "foreach" index vars temporarily become aliases to non-"my"
446 * values. Thus we must skip, not just pad values that are
447 * marked as current pad values, but also those with names.
448 */
449 /* HVDS why copy to sv here? we don't seem to use it */
450 if (++PL_padix <= names_fill &&
451 (sv = names[PL_padix]) && sv != &PL_sv_undef)
452 continue;
453 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
454 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
455 !IS_PADGV(sv) && !IS_PADCONST(sv))
456 break;
457 }
458 retval = PL_padix;
459 }
460 SvFLAGS(sv) |= tmptype;
461 PL_curpad = AvARRAY(PL_comppad);
462
463 DEBUG_X(PerlIO_printf(Perl_debug_log,
464 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
465 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
466 PL_op_name[optype]));
fd0854ff
DM
467#ifdef DEBUG_LEAKING_SCALARS
468 sv->sv_debug_optype = optype;
469 sv->sv_debug_inpad = 1;
fd0854ff 470#endif
a212c8b5 471 return (PADOFFSET)retval;
dd2155a4
DM
472}
473
474/*
475=for apidoc pad_add_anon
476
477Add an anon code entry to the current compiling pad
478
479=cut
480*/
481
482PADOFFSET
483Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
484{
97aff369 485 dVAR;
dd2155a4 486 PADOFFSET ix;
b9f83d2f 487 SV* const name = newSV_type(SVt_PVNV);
1dba731d 488 pad_peg("add_anon");
dd2155a4 489 sv_setpvn(name, "&", 1);
809abb02
NC
490 /* Are these two actually ever read? */
491 COP_SEQ_RANGE_HIGH_set(name, ~0);
492 COP_SEQ_RANGE_LOW_set(name, 1);
dd2155a4
DM
493 ix = pad_alloc(op_type, SVs_PADMY);
494 av_store(PL_comppad_name, ix, name);
f3548bdc 495 /* XXX DAPM use PL_curpad[] ? */
dd2155a4
DM
496 av_store(PL_comppad, ix, sv);
497 SvPADMY_on(sv);
7dafbf52
DM
498
499 /* to avoid ref loops, we never have parent + child referencing each
500 * other simultaneously */
501 if (CvOUTSIDE((CV*)sv)) {
502 assert(!CvWEAKOUTSIDE((CV*)sv));
503 CvWEAKOUTSIDE_on((CV*)sv);
504 SvREFCNT_dec(CvOUTSIDE((CV*)sv));
505 }
dd2155a4
DM
506 return ix;
507}
508
509
510
511/*
512=for apidoc pad_check_dup
513
514Check for duplicate declarations: report any of:
515 * a my in the current scope with the same name;
516 * an our (anywhere in the pad) with the same name and the same stash
517 as C<ourstash>
518C<is_our> indicates that the name to check is an 'our' declaration
519
520=cut
521*/
522
523/* XXX DAPM integrate this into pad_add_name ??? */
524
525void
e1ec3a88 526Perl_pad_check_dup(pTHX_ const char *name, bool is_our, const HV *ourstash)
dd2155a4 527{
97aff369 528 dVAR;
53c1dcc0 529 SV **svp;
dd2155a4
DM
530 PADOFFSET top, off;
531
f3548bdc 532 ASSERT_CURPAD_ACTIVE("pad_check_dup");
041457d9 533 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
dd2155a4
DM
534 return; /* nothing to check */
535
536 svp = AvARRAY(PL_comppad_name);
537 top = AvFILLp(PL_comppad_name);
538 /* check the current scope */
539 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
540 * type ? */
541 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
53c1dcc0
AL
542 SV * const sv = svp[off];
543 if (sv
dd2155a4 544 && sv != &PL_sv_undef
ee6cee0c 545 && !SvFAKE(sv)
809abb02 546 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
b15aece3 547 && strEQ(name, SvPVX_const(sv)))
dd2155a4 548 {
00b1698f 549 if (is_our && (SvPAD_OUR(sv)))
7f73a9f1 550 break; /* "our" masking "our" */
dd2155a4
DM
551 Perl_warner(aTHX_ packWARN(WARN_MISC),
552 "\"%s\" variable %s masks earlier declaration in same %s",
12bd6ede 553 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
dd2155a4 554 name,
809abb02 555 (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
dd2155a4
DM
556 --off;
557 break;
558 }
559 }
560 /* check the rest of the pad */
561 if (is_our) {
562 do {
53c1dcc0
AL
563 SV * const sv = svp[off];
564 if (sv
dd2155a4 565 && sv != &PL_sv_undef
ee6cee0c 566 && !SvFAKE(sv)
809abb02 567 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
73d95100 568 && SvOURSTASH(sv) == ourstash
b15aece3 569 && strEQ(name, SvPVX_const(sv)))
dd2155a4
DM
570 {
571 Perl_warner(aTHX_ packWARN(WARN_MISC),
572 "\"our\" variable %s redeclared", name);
624f69f5 573 if ((I32)off <= PL_comppad_name_floor)
7f73a9f1
RGS
574 Perl_warner(aTHX_ packWARN(WARN_MISC),
575 "\t(Did you mean \"local\" instead of \"our\"?)\n");
dd2155a4
DM
576 break;
577 }
578 } while ( off-- > 0 );
579 }
580}
581
582
dd2155a4
DM
583/*
584=for apidoc pad_findmy
585
586Given a lexical name, try to find its offset, first in the current pad,
587or failing that, in the pads of any lexically enclosing subs (including
588the complications introduced by eval). If the name is found in an outer pad,
589then a fake entry is added to the current pad.
590Returns the offset in the current pad, or NOT_IN_PAD on failure.
591
592=cut
593*/
594
595PADOFFSET
e1ec3a88 596Perl_pad_findmy(pTHX_ const char *name)
dd2155a4 597{
97aff369 598 dVAR;
b5c19bd7
DM
599 SV *out_sv;
600 int out_flags;
929a0744 601 I32 offset;
e1ec3a88 602 const AV *nameav;
929a0744 603 SV **name_svp;
dd2155a4 604
1dba731d 605 pad_peg("pad_findmy");
9f7d9405 606 offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
4608196e 607 NULL, &out_sv, &out_flags);
9f7d9405 608 if ((PADOFFSET)offset != NOT_IN_PAD)
929a0744
DM
609 return offset;
610
611 /* look for an our that's being introduced; this allows
612 * our $foo = 0 unless defined $foo;
613 * to not give a warning. (Yes, this is a hack) */
614
615 nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
616 name_svp = AvARRAY(nameav);
617 for (offset = AvFILLp(nameav); offset > 0; offset--) {
551405c4 618 const SV * const namesv = name_svp[offset];
929a0744
DM
619 if (namesv && namesv != &PL_sv_undef
620 && !SvFAKE(namesv)
00b1698f 621 && (SvPAD_OUR(namesv))
b15aece3 622 && strEQ(SvPVX_const(namesv), name)
809abb02 623 && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
929a0744
DM
624 )
625 return offset;
626 }
627 return NOT_IN_PAD;
dd2155a4
DM
628}
629
e1f795dc
RGS
630/*
631 * Returns the offset of a lexical $_, if there is one, at run time.
632 * Used by the UNDERBAR XS macro.
633 */
634
635PADOFFSET
29289021 636Perl_find_rundefsvoffset(pTHX)
e1f795dc 637{
97aff369 638 dVAR;
e1f795dc
RGS
639 SV *out_sv;
640 int out_flags;
641 return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
4608196e 642 NULL, &out_sv, &out_flags);
e1f795dc 643}
dd2155a4 644
dd2155a4
DM
645/*
646=for apidoc pad_findlex
647
648Find a named lexical anywhere in a chain of nested pads. Add fake entries
b5c19bd7
DM
649in the inner pads if it's found in an outer one.
650
651Returns the offset in the bottom pad of the lex or the fake lex.
652cv is the CV in which to start the search, and seq is the current cop_seq
653to match against. If warn is true, print appropriate warnings. The out_*
654vars return values, and so are pointers to where the returned values
655should be stored. out_capture, if non-null, requests that the innermost
656instance of the lexical is captured; out_name_sv is set to the innermost
657matched namesv or fake namesv; out_flags returns the flags normally
658associated with the IVX field of a fake namesv.
659
660Note that pad_findlex() is recursive; it recurses up the chain of CVs,
661then comes back down, adding fake entries as it goes. It has to be this way
3441fb63 662because fake namesvs in anon protoypes have to store in xlow the index into
b5c19bd7 663the parent pad.
dd2155a4
DM
664
665=cut
666*/
667
b5c19bd7
DM
668/* the CV has finished being compiled. This is not a sufficient test for
669 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
670#define CvCOMPILED(cv) CvROOT(cv)
671
71f882da
DM
672/* the CV does late binding of its lexicals */
673#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
674
b5c19bd7 675
dd2155a4 676STATIC PADOFFSET
e1ec3a88 677S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
b5c19bd7 678 SV** out_capture, SV** out_name_sv, int *out_flags)
dd2155a4 679{
97aff369 680 dVAR;
b5c19bd7
DM
681 I32 offset, new_offset;
682 SV *new_capture;
683 SV **new_capturep;
b64e5050 684 const AV * const padlist = CvPADLIST(cv);
dd2155a4 685
b5c19bd7 686 *out_flags = 0;
a3985cdc 687
b5c19bd7
DM
688 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
689 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
690 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
dd2155a4 691
b5c19bd7 692 /* first, search this pad */
dd2155a4 693
b5c19bd7
DM
694 if (padlist) { /* not an undef CV */
695 I32 fake_offset = 0;
551405c4
AL
696 const AV * const nameav = (AV*)AvARRAY(padlist)[0];
697 SV * const * const name_svp = AvARRAY(nameav);
ee6cee0c 698
b5c19bd7 699 for (offset = AvFILLp(nameav); offset > 0; offset--) {
551405c4 700 const SV * const namesv = name_svp[offset];
b5c19bd7 701 if (namesv && namesv != &PL_sv_undef
b15aece3 702 && strEQ(SvPVX_const(namesv), name))
b5c19bd7
DM
703 {
704 if (SvFAKE(namesv))
705 fake_offset = offset; /* in case we don't find a real one */
809abb02
NC
706 else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */
707 && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */
b5c19bd7 708 break;
ee6cee0c
DM
709 }
710 }
711
b5c19bd7
DM
712 if (offset > 0 || fake_offset > 0 ) { /* a match! */
713 if (offset > 0) { /* not fake */
714 fake_offset = 0;
715 *out_name_sv = name_svp[offset]; /* return the namesv */
716
717 /* set PAD_FAKELEX_MULTI if this lex can have multiple
718 * instances. For now, we just test !CvUNIQUE(cv), but
719 * ideally, we should detect my's declared within loops
720 * etc - this would allow a wider range of 'not stayed
721 * shared' warnings. We also treated alreadly-compiled
722 * lexes as not multi as viewed from evals. */
723
724 *out_flags = CvANON(cv) ?
725 PAD_FAKELEX_ANON :
726 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
727 ? PAD_FAKELEX_MULTI : 0;
728
729 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02
NC
730 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
731 PTR2UV(cv), (long)offset,
732 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
733 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
b5c19bd7
DM
734 }
735 else { /* fake match */
736 offset = fake_offset;
737 *out_name_sv = name_svp[offset]; /* return the namesv */
809abb02 738 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
b5c19bd7 739 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
19a5c512 740 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
b5c19bd7 741 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
809abb02 742 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
b5c19bd7
DM
743 ));
744 }
dd2155a4 745
b5c19bd7 746 /* return the lex? */
dd2155a4 747
b5c19bd7 748 if (out_capture) {
dd2155a4 749
b5c19bd7 750 /* our ? */
00b1698f 751 if (SvPAD_OUR(*out_name_sv)) {
a0714e2c 752 *out_capture = NULL;
b5c19bd7
DM
753 return offset;
754 }
ee6cee0c 755
b5c19bd7
DM
756 /* trying to capture from an anon prototype? */
757 if (CvCOMPILED(cv)
758 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
759 : *out_flags & PAD_FAKELEX_ANON)
760 {
761 if (warn && ckWARN(WARN_CLOSURE))
762 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
763 "Variable \"%s\" is not available", name);
a0714e2c 764 *out_capture = NULL;
b5c19bd7 765 }
ee6cee0c 766
b5c19bd7
DM
767 /* real value */
768 else {
769 int newwarn = warn;
770 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
771 && warn && ckWARN(WARN_CLOSURE)) {
772 newwarn = 0;
773 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
774 "Variable \"%s\" will not stay shared", name);
775 }
dd2155a4 776
b5c19bd7
DM
777 if (fake_offset && CvANON(cv)
778 && CvCLONE(cv) &&!CvCLONED(cv))
779 {
780 SV *n;
781 /* not yet caught - look further up */
782 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
783 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
784 PTR2UV(cv)));
785 n = *out_name_sv;
282e1742
DM
786 (void) pad_findlex(name, CvOUTSIDE(cv),
787 CvOUTSIDE_SEQ(cv),
b5c19bd7
DM
788 newwarn, out_capture, out_name_sv, out_flags);
789 *out_name_sv = n;
790 return offset;
dd2155a4 791 }
b5c19bd7
DM
792
793 *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
794 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
795 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
796 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
19a5c512 797 PTR2UV(cv), PTR2UV(*out_capture)));
b5c19bd7
DM
798
799 if (SvPADSTALE(*out_capture)) {
800 if (ckWARN(WARN_CLOSURE))
ee6cee0c 801 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
b5c19bd7 802 "Variable \"%s\" is not available", name);
a0714e2c 803 *out_capture = NULL;
dd2155a4
DM
804 }
805 }
b5c19bd7
DM
806 if (!*out_capture) {
807 if (*name == '@')
808 *out_capture = sv_2mortal((SV*)newAV());
809 else if (*name == '%')
810 *out_capture = sv_2mortal((SV*)newHV());
811 else
812 *out_capture = sv_newmortal();
813 }
dd2155a4 814 }
b5c19bd7
DM
815
816 return offset;
ee6cee0c 817 }
b5c19bd7
DM
818 }
819
820 /* it's not in this pad - try above */
821
822 if (!CvOUTSIDE(cv))
823 return NOT_IN_PAD;
9f7d9405 824
b5c19bd7 825 /* out_capture non-null means caller wants us to capture lex; in
71f882da 826 * addition we capture ourselves unless it's an ANON/format */
b5c19bd7 827 new_capturep = out_capture ? out_capture :
4608196e 828 CvLATE(cv) ? NULL : &new_capture;
b5c19bd7
DM
829
830 offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
831 new_capturep, out_name_sv, out_flags);
9f7d9405 832 if ((PADOFFSET)offset == NOT_IN_PAD)
b5c19bd7 833 return NOT_IN_PAD;
9f7d9405 834
b5c19bd7
DM
835 /* found in an outer CV. Add appropriate fake entry to this pad */
836
837 /* don't add new fake entries (via eval) to CVs that we have already
838 * finished compiling, or to undef CVs */
839 if (CvCOMPILED(cv) || !padlist)
840 return 0; /* this dummy (and invalid) value isnt used by the caller */
841
842 {
843 SV *new_namesv;
53c1dcc0
AL
844 AV * const ocomppad_name = PL_comppad_name;
845 PAD * const ocomppad = PL_comppad;
b5c19bd7
DM
846 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
847 PL_comppad = (AV*)AvARRAY(padlist)[1];
848 PL_curpad = AvARRAY(PL_comppad);
849
850 new_offset = pad_add_name(
b15aece3 851 SvPVX_const(*out_name_sv),
00b1698f 852 SvPAD_TYPED(*out_name_sv)
5c284bb0 853 ? SvSTASH(*out_name_sv) : NULL,
73d95100 854 SvOURSTASH(*out_name_sv),
952306ac
RGS
855 1, /* fake */
856 0 /* not a state variable */
b5c19bd7
DM
857 );
858
859 new_namesv = AvARRAY(PL_comppad_name)[new_offset];
809abb02 860 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
b5c19bd7 861
809abb02 862 PARENT_PAD_INDEX_set(new_namesv, 0);
00b1698f 863 if (SvPAD_OUR(new_namesv)) {
6f207bd3 864 NOOP; /* do nothing */
b5c19bd7 865 }
71f882da 866 else if (CvLATE(cv)) {
b5c19bd7 867 /* delayed creation - just note the offset within parent pad */
809abb02 868 PARENT_PAD_INDEX_set(new_namesv, offset);
b5c19bd7
DM
869 CvCLONE_on(cv);
870 }
871 else {
872 /* immediate creation - capture outer value right now */
873 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
874 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
875 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
876 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
dd2155a4 877 }
b5c19bd7 878 *out_name_sv = new_namesv;
809abb02 879 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
b5c19bd7
DM
880
881 PL_comppad_name = ocomppad_name;
882 PL_comppad = ocomppad;
4608196e 883 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
dd2155a4 884 }
b5c19bd7 885 return new_offset;
dd2155a4
DM
886}
887
fb8a9836
AL
888
889#ifdef DEBUGGING
dd2155a4
DM
890/*
891=for apidoc pad_sv
892
893Get the value at offset po in the current pad.
894Use macro PAD_SV instead of calling this function directly.
895
896=cut
897*/
898
899
900SV *
901Perl_pad_sv(pTHX_ PADOFFSET po)
902{
97aff369 903 dVAR;
f3548bdc 904 ASSERT_CURPAD_ACTIVE("pad_sv");
dd2155a4 905
dd2155a4
DM
906 if (!po)
907 Perl_croak(aTHX_ "panic: pad_sv po");
dd2155a4
DM
908 DEBUG_X(PerlIO_printf(Perl_debug_log,
909 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
f3548bdc 910 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
dd2155a4
DM
911 );
912 return PL_curpad[po];
913}
914
915
916/*
917=for apidoc pad_setsv
918
919Set the entry at offset po in the current pad to sv.
920Use the macro PAD_SETSV() rather than calling this function directly.
921
922=cut
923*/
924
dd2155a4
DM
925void
926Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
927{
97aff369 928 dVAR;
f3548bdc 929 ASSERT_CURPAD_ACTIVE("pad_setsv");
dd2155a4
DM
930
931 DEBUG_X(PerlIO_printf(Perl_debug_log,
932 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
f3548bdc 933 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
dd2155a4
DM
934 );
935 PL_curpad[po] = sv;
936}
937#endif
938
939
940
941/*
942=for apidoc pad_block_start
943
944Update the pad compilation state variables on entry to a new block
945
946=cut
947*/
948
949/* XXX DAPM perhaps:
950 * - integrate this in general state-saving routine ???
951 * - combine with the state-saving going on in pad_new ???
952 * - introduce a new SAVE type that does all this in one go ?
953 */
954
955void
956Perl_pad_block_start(pTHX_ int full)
957{
97aff369 958 dVAR;
f3548bdc 959 ASSERT_CURPAD_ACTIVE("pad_block_start");
dd2155a4
DM
960 SAVEI32(PL_comppad_name_floor);
961 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
962 if (full)
963 PL_comppad_name_fill = PL_comppad_name_floor;
964 if (PL_comppad_name_floor < 0)
965 PL_comppad_name_floor = 0;
966 SAVEI32(PL_min_intro_pending);
967 SAVEI32(PL_max_intro_pending);
968 PL_min_intro_pending = 0;
969 SAVEI32(PL_comppad_name_fill);
970 SAVEI32(PL_padix_floor);
971 PL_padix_floor = PL_padix;
972 PL_pad_reset_pending = FALSE;
973}
974
975
976/*
977=for apidoc intro_my
978
979"Introduce" my variables to visible status.
980
981=cut
982*/
983
984U32
985Perl_intro_my(pTHX)
986{
97aff369 987 dVAR;
dd2155a4 988 SV **svp;
dd2155a4
DM
989 I32 i;
990
f3548bdc 991 ASSERT_CURPAD_ACTIVE("intro_my");
dd2155a4
DM
992 if (! PL_min_intro_pending)
993 return PL_cop_seqmax;
994
995 svp = AvARRAY(PL_comppad_name);
996 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
53c1dcc0
AL
997 SV * const sv = svp[i];
998
809abb02
NC
999 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
1000 COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* Don't know scope end yet. */
1001 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
dd2155a4 1002 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1003 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
b15aece3 1004 (long)i, SvPVX_const(sv),
809abb02
NC
1005 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1006 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1007 );
1008 }
1009 }
1010 PL_min_intro_pending = 0;
1011 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1012 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1013 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
1014
1015 return PL_cop_seqmax++;
1016}
1017
1018/*
1019=for apidoc pad_leavemy
1020
1021Cleanup at end of scope during compilation: set the max seq number for
1022lexicals in this scope and warn of any lexicals that never got introduced.
1023
1024=cut
1025*/
1026
1027void
1028Perl_pad_leavemy(pTHX)
1029{
97aff369 1030 dVAR;
dd2155a4 1031 I32 off;
551405c4 1032 SV * const * const svp = AvARRAY(PL_comppad_name);
dd2155a4
DM
1033
1034 PL_pad_reset_pending = FALSE;
1035
f3548bdc 1036 ASSERT_CURPAD_ACTIVE("pad_leavemy");
dd2155a4
DM
1037 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1038 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
53c1dcc0
AL
1039 const SV * const sv = svp[off];
1040 if (sv && sv != &PL_sv_undef
ee6cee0c 1041 && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
dd2155a4 1042 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
95b63a38 1043 "%"SVf" never introduced",
be2597df 1044 SVfARG(sv));
dd2155a4
DM
1045 }
1046 }
1047 /* "Deintroduce" my variables that are leaving with this scope. */
1048 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
53c1dcc0 1049 const SV * const sv = svp[off];
809abb02
NC
1050 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
1051 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
dd2155a4 1052 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1053 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
b15aece3 1054 (long)off, SvPVX_const(sv),
809abb02
NC
1055 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1056 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1057 );
1058 }
1059 }
1060 PL_cop_seqmax++;
1061 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1062 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1063}
1064
1065
1066/*
1067=for apidoc pad_swipe
1068
1069Abandon the tmp in the current pad at offset po and replace with a
1070new one.
1071
1072=cut
1073*/
1074
1075void
1076Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1077{
97aff369 1078 dVAR;
f3548bdc 1079 ASSERT_CURPAD_LEGAL("pad_swipe");
dd2155a4
DM
1080 if (!PL_curpad)
1081 return;
1082 if (AvARRAY(PL_comppad) != PL_curpad)
1083 Perl_croak(aTHX_ "panic: pad_swipe curpad");
1084 if (!po)
1085 Perl_croak(aTHX_ "panic: pad_swipe po");
1086
1087 DEBUG_X(PerlIO_printf(Perl_debug_log,
1088 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1089 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1090
1091 if (PL_curpad[po])
1092 SvPADTMP_off(PL_curpad[po]);
1093 if (refadjust)
1094 SvREFCNT_dec(PL_curpad[po]);
1095
9ad9869c
DM
1096
1097 /* if pad tmps aren't shared between ops, then there's no need to
1098 * create a new tmp when an existing op is freed */
1099#ifdef USE_BROKEN_PAD_RESET
561b68a9 1100 PL_curpad[po] = newSV(0);
dd2155a4 1101 SvPADTMP_on(PL_curpad[po]);
9ad9869c
DM
1102#else
1103 PL_curpad[po] = &PL_sv_undef;
97bf4a8d 1104#endif
dd2155a4
DM
1105 if ((I32)po < PL_padix)
1106 PL_padix = po - 1;
1107}
1108
1109
1110/*
1111=for apidoc pad_reset
1112
1113Mark all the current temporaries for reuse
1114
1115=cut
1116*/
1117
1118/* XXX pad_reset() is currently disabled because it results in serious bugs.
1119 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1120 * on the stack by OPs that use them, there are several ways to get an alias
1121 * to a shared TARG. Such an alias will change randomly and unpredictably.
1122 * We avoid doing this until we can think of a Better Way.
1123 * GSAR 97-10-29 */
1124void
1125Perl_pad_reset(pTHX)
1126{
97aff369 1127 dVAR;
dd2155a4 1128#ifdef USE_BROKEN_PAD_RESET
dd2155a4
DM
1129 if (AvARRAY(PL_comppad) != PL_curpad)
1130 Perl_croak(aTHX_ "panic: pad_reset curpad");
1131
1132 DEBUG_X(PerlIO_printf(Perl_debug_log,
1133 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1134 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1135 (long)PL_padix, (long)PL_padix_floor
1136 )
1137 );
1138
1139 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
e1ec3a88 1140 register I32 po;
dd2155a4
DM
1141 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1142 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1143 SvPADTMP_off(PL_curpad[po]);
1144 }
1145 PL_padix = PL_padix_floor;
1146 }
1147#endif
1148 PL_pad_reset_pending = FALSE;
1149}
1150
1151
1152/*
1153=for apidoc pad_tidy
1154
1155Tidy up a pad after we've finished compiling it:
1156 * remove most stuff from the pads of anonsub prototypes;
1157 * give it a @_;
1158 * mark tmps as such.
1159
1160=cut
1161*/
1162
1163/* XXX DAPM surely most of this stuff should be done properly
1164 * at the right time beforehand, rather than going around afterwards
1165 * cleaning up our mistakes ???
1166 */
1167
1168void
1169Perl_pad_tidy(pTHX_ padtidy_type type)
1170{
27da23d5 1171 dVAR;
dd2155a4 1172
f3548bdc 1173 ASSERT_CURPAD_ACTIVE("pad_tidy");
b5c19bd7
DM
1174
1175 /* If this CV has had any 'eval-capable' ops planted in it
1176 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1177 * anon prototypes in the chain of CVs should be marked as cloneable,
1178 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1179 * the right CvOUTSIDE.
1180 * If running with -d, *any* sub may potentially have an eval
1181 * excuted within it.
1182 */
1183
1184 if (PL_cv_has_eval || PL_perldb) {
e1ec3a88 1185 const CV *cv;
b5c19bd7
DM
1186 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1187 if (cv != PL_compcv && CvCOMPILED(cv))
1188 break; /* no need to mark already-compiled code */
1189 if (CvANON(cv)) {
1190 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1191 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1192 CvCLONE_on(cv);
1193 }
1194 }
1195 }
1196
dd2155a4
DM
1197 /* extend curpad to match namepad */
1198 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
a0714e2c 1199 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
dd2155a4
DM
1200
1201 if (type == padtidy_SUBCLONE) {
551405c4 1202 SV * const * const namep = AvARRAY(PL_comppad_name);
504618e9 1203 PADOFFSET ix;
b5c19bd7 1204
dd2155a4
DM
1205 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1206 SV *namesv;
1207
1208 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1209 continue;
1210 /*
1211 * The only things that a clonable function needs in its
b5c19bd7 1212 * pad are anonymous subs.
dd2155a4
DM
1213 * The rest are created anew during cloning.
1214 */
a0714e2c 1215 if (!((namesv = namep[ix]) != NULL &&
dd2155a4 1216 namesv != &PL_sv_undef &&
b15aece3 1217 *SvPVX_const(namesv) == '&'))
dd2155a4
DM
1218 {
1219 SvREFCNT_dec(PL_curpad[ix]);
a0714e2c 1220 PL_curpad[ix] = NULL;
dd2155a4
DM
1221 }
1222 }
1223 }
1224 else if (type == padtidy_SUB) {
1225 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
53c1dcc0 1226 AV * const av = newAV(); /* Will be @_ */
dd2155a4
DM
1227 av_extend(av, 0);
1228 av_store(PL_comppad, 0, (SV*)av);
11ca45c0 1229 AvREIFY_only(av);
dd2155a4
DM
1230 }
1231
1232 /* XXX DAPM rationalise these two similar branches */
1233
1234 if (type == padtidy_SUB) {
504618e9 1235 PADOFFSET ix;
dd2155a4
DM
1236 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1237 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1238 continue;
1239 if (!SvPADMY(PL_curpad[ix]))
1240 SvPADTMP_on(PL_curpad[ix]);
1241 }
1242 }
1243 else if (type == padtidy_FORMAT) {
504618e9 1244 PADOFFSET ix;
dd2155a4
DM
1245 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1246 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1247 SvPADTMP_on(PL_curpad[ix]);
1248 }
1249 }
f3548bdc 1250 PL_curpad = AvARRAY(PL_comppad);
dd2155a4
DM
1251}
1252
1253
1254/*
1255=for apidoc pad_free
1256
8627550a 1257Free the SV at offset po in the current pad.
dd2155a4
DM
1258
1259=cut
1260*/
1261
1262/* XXX DAPM integrate with pad_swipe ???? */
1263void
1264Perl_pad_free(pTHX_ PADOFFSET po)
1265{
97aff369 1266 dVAR;
f3548bdc 1267 ASSERT_CURPAD_LEGAL("pad_free");
dd2155a4
DM
1268 if (!PL_curpad)
1269 return;
1270 if (AvARRAY(PL_comppad) != PL_curpad)
1271 Perl_croak(aTHX_ "panic: pad_free curpad");
1272 if (!po)
1273 Perl_croak(aTHX_ "panic: pad_free po");
1274
1275 DEBUG_X(PerlIO_printf(Perl_debug_log,
1276 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1277 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1278 );
1279
1280 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1281 SvPADTMP_off(PL_curpad[po]);
1282#ifdef USE_ITHREADS
7e736055
HS
1283 /* SV could be a shared hash key (eg bugid #19022) */
1284 if (
f8c7b90f 1285#ifdef PERL_OLD_COPY_ON_WRITE
7e736055
HS
1286 !SvIsCOW(PL_curpad[po])
1287#else
1288 !SvFAKE(PL_curpad[po])
dd2155a4 1289#endif
7e736055 1290 )
dd2155a4 1291 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
dd2155a4
DM
1292#endif
1293 }
1294 if ((I32)po < PL_padix)
1295 PL_padix = po - 1;
1296}
1297
1298
1299
1300/*
1301=for apidoc do_dump_pad
1302
1303Dump the contents of a padlist
1304
1305=cut
1306*/
1307
1308void
1309Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1310{
97aff369 1311 dVAR;
e1ec3a88
AL
1312 const AV *pad_name;
1313 const AV *pad;
dd2155a4
DM
1314 SV **pname;
1315 SV **ppad;
dd2155a4
DM
1316 I32 ix;
1317
1318 if (!padlist) {
1319 return;
1320 }
1321 pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1322 pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1323 pname = AvARRAY(pad_name);
1324 ppad = AvARRAY(pad);
1325 Perl_dump_indent(aTHX_ level, file,
1326 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1327 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1328 );
1329
1330 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
e1ec3a88 1331 const SV *namesv = pname[ix];
dd2155a4 1332 if (namesv && namesv == &PL_sv_undef) {
a0714e2c 1333 namesv = NULL;
dd2155a4
DM
1334 }
1335 if (namesv) {
ee6cee0c
DM
1336 if (SvFAKE(namesv))
1337 Perl_dump_indent(aTHX_ level+1, file,
c0fd1b42 1338 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
ee6cee0c
DM
1339 (int) ix,
1340 PTR2UV(ppad[ix]),
1341 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
b15aece3 1342 SvPVX_const(namesv),
809abb02
NC
1343 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1344 (unsigned long)PARENT_PAD_INDEX(namesv)
b5c19bd7 1345
ee6cee0c
DM
1346 );
1347 else
1348 Perl_dump_indent(aTHX_ level+1, file,
809abb02 1349 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
ee6cee0c
DM
1350 (int) ix,
1351 PTR2UV(ppad[ix]),
1352 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
809abb02
NC
1353 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1354 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
b15aece3 1355 SvPVX_const(namesv)
ee6cee0c 1356 );
dd2155a4
DM
1357 }
1358 else if (full) {
1359 Perl_dump_indent(aTHX_ level+1, file,
1360 "%2d. 0x%"UVxf"<%lu>\n",
1361 (int) ix,
1362 PTR2UV(ppad[ix]),
1363 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1364 );
1365 }
1366 }
1367}
1368
1369
1370
1371/*
1372=for apidoc cv_dump
1373
1374dump the contents of a CV
1375
1376=cut
1377*/
1378
1379#ifdef DEBUGGING
1380STATIC void
e1ec3a88 1381S_cv_dump(pTHX_ const CV *cv, const char *title)
dd2155a4 1382{
97aff369 1383 dVAR;
53c1dcc0
AL
1384 const CV * const outside = CvOUTSIDE(cv);
1385 AV* const padlist = CvPADLIST(cv);
dd2155a4
DM
1386
1387 PerlIO_printf(Perl_debug_log,
1388 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1389 title,
1390 PTR2UV(cv),
1391 (CvANON(cv) ? "ANON"
71f882da 1392 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
dd2155a4
DM
1393 : (cv == PL_main_cv) ? "MAIN"
1394 : CvUNIQUE(cv) ? "UNIQUE"
1395 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1396 PTR2UV(outside),
1397 (!outside ? "null"
1398 : CvANON(outside) ? "ANON"
1399 : (outside == PL_main_cv) ? "MAIN"
1400 : CvUNIQUE(outside) ? "UNIQUE"
1401 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1402
1403 PerlIO_printf(Perl_debug_log,
1404 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1405 do_dump_pad(1, Perl_debug_log, padlist, 1);
1406}
1407#endif /* DEBUGGING */
1408
1409
1410
1411
1412
1413/*
1414=for apidoc cv_clone
1415
1416Clone a CV: make a new CV which points to the same code etc, but which
1417has a newly-created pad built by copying the prototype pad and capturing
1418any outer lexicals.
1419
1420=cut
1421*/
1422
1423CV *
1424Perl_cv_clone(pTHX_ CV *proto)
1425{
27da23d5 1426 dVAR;
dd2155a4 1427 I32 ix;
53c1dcc0
AL
1428 AV* const protopadlist = CvPADLIST(proto);
1429 const AV* const protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1430 const AV* const protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1431 SV** const pname = AvARRAY(protopad_name);
1432 SV** const ppad = AvARRAY(protopad);
e1ec3a88
AL
1433 const I32 fname = AvFILLp(protopad_name);
1434 const I32 fpad = AvFILLp(protopad);
dd2155a4 1435 CV* cv;
b5c19bd7
DM
1436 SV** outpad;
1437 CV* outside;
71f882da 1438 long depth;
dd2155a4
DM
1439
1440 assert(!CvUNIQUE(proto));
1441
71f882da
DM
1442 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1443 * to a prototype; we instead want the cloned parent who called us.
1444 * Note that in general for formats, CvOUTSIDE != find_runcv */
1445
1446 outside = CvOUTSIDE(proto);
1447 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1448 outside = find_runcv(NULL);
1449 depth = CvDEPTH(outside);
1450 assert(depth || SvTYPE(proto) == SVt_PVFM);
1451 if (!depth)
1452 depth = 1;
b5c19bd7
DM
1453 assert(CvPADLIST(outside));
1454
dd2155a4
DM
1455 ENTER;
1456 SAVESPTR(PL_compcv);
1457
b9f83d2f 1458 cv = PL_compcv = (CV*)newSV_type(SvTYPE(proto));
7dafbf52 1459 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
dd2155a4
DM
1460 CvCLONED_on(cv);
1461
dd2155a4 1462#ifdef USE_ITHREADS
aed2304a
NC
1463 CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
1464 : savepv(CvFILE(proto));
dd2155a4
DM
1465#else
1466 CvFILE(cv) = CvFILE(proto);
1467#endif
1468 CvGV(cv) = CvGV(proto);
1469 CvSTASH(cv) = CvSTASH(proto);
b34c0dd4 1470 OP_REFCNT_LOCK;
dd2155a4 1471 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
b34c0dd4 1472 OP_REFCNT_UNLOCK;
dd2155a4 1473 CvSTART(cv) = CvSTART(proto);
b37c2d43 1474 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc_simple(outside);
b5c19bd7 1475 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
dd2155a4
DM
1476
1477 if (SvPOK(proto))
b15aece3 1478 sv_setpvn((SV*)cv, SvPVX_const(proto), SvCUR(proto));
dd2155a4 1479
b7787f18 1480 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
dd2155a4 1481
b5c19bd7 1482 av_fill(PL_comppad, fpad);
dd2155a4
DM
1483 for (ix = fname; ix >= 0; ix--)
1484 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1485
dd2155a4
DM
1486 PL_curpad = AvARRAY(PL_comppad);
1487
71f882da 1488 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
b5c19bd7 1489
dd2155a4 1490 for (ix = fpad; ix > 0; ix--) {
a0714e2c
SS
1491 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1492 SV *sv = NULL;
71f882da 1493 if (namesv && namesv != &PL_sv_undef) { /* lexical */
b5c19bd7 1494 if (SvFAKE(namesv)) { /* lexical from outside? */
809abb02 1495 sv = outpad[PARENT_PAD_INDEX(namesv)];
71f882da 1496 assert(sv);
33894c1a
DM
1497 /* formats may have an inactive parent,
1498 while my $x if $false can leave an active var marked as
1499 stale */
1500 if (SvPADSTALE(sv)) {
71f882da
DM
1501 if (ckWARN(WARN_CLOSURE))
1502 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
b15aece3 1503 "Variable \"%s\" is not available", SvPVX_const(namesv));
a0714e2c 1504 sv = NULL;
71f882da 1505 }
33894c1a 1506 else
f84c484e 1507 SvREFCNT_inc_simple_void_NN(sv);
dd2155a4 1508 }
71f882da 1509 if (!sv) {
b15aece3 1510 const char sigil = SvPVX_const(namesv)[0];
e1ec3a88 1511 if (sigil == '&')
dd2155a4 1512 sv = SvREFCNT_inc(ppad[ix]);
e1ec3a88 1513 else if (sigil == '@')
dd2155a4 1514 sv = (SV*)newAV();
e1ec3a88 1515 else if (sigil == '%')
dd2155a4
DM
1516 sv = (SV*)newHV();
1517 else
561b68a9 1518 sv = newSV(0);
235cc2e3 1519 SvPADMY_on(sv);
0d3b281c
DM
1520 /* reset the 'assign only once' flag on each state var */
1521 if (SvPAD_STATE(namesv))
1522 SvPADSTALE_on(sv);
dd2155a4
DM
1523 }
1524 }
1525 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
f84c484e 1526 sv = SvREFCNT_inc_NN(ppad[ix]);
dd2155a4
DM
1527 }
1528 else {
561b68a9 1529 sv = newSV(0);
dd2155a4 1530 SvPADTMP_on(sv);
dd2155a4 1531 }
71f882da 1532 PL_curpad[ix] = sv;
dd2155a4
DM
1533 }
1534
dd2155a4
DM
1535 DEBUG_Xv(
1536 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1537 cv_dump(outside, "Outside");
1538 cv_dump(proto, "Proto");
1539 cv_dump(cv, "To");
1540 );
1541
1542 LEAVE;
1543
1544 if (CvCONST(cv)) {
b5c19bd7
DM
1545 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1546 * The prototype was marked as a candiate for const-ization,
1547 * so try to grab the current const value, and if successful,
1548 * turn into a const sub:
1549 */
551405c4 1550 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
b5c19bd7
DM
1551 if (const_sv) {
1552 SvREFCNT_dec(cv);
bd61b366 1553 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
b5c19bd7
DM
1554 }
1555 else {
1556 CvCONST_off(cv);
1557 }
dd2155a4
DM
1558 }
1559
1560 return cv;
1561}
1562
1563
1564/*
1565=for apidoc pad_fixup_inner_anons
1566
1567For any anon CVs in the pad, change CvOUTSIDE of that CV from
7dafbf52
DM
1568old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1569moved to a pre-existing CV struct.
dd2155a4
DM
1570
1571=cut
1572*/
1573
1574void
1575Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1576{
97aff369 1577 dVAR;
dd2155a4 1578 I32 ix;
66a1b24b
AL
1579 AV * const comppad_name = (AV*)AvARRAY(padlist)[0];
1580 AV * const comppad = (AV*)AvARRAY(padlist)[1];
53c1dcc0
AL
1581 SV ** const namepad = AvARRAY(comppad_name);
1582 SV ** const curpad = AvARRAY(comppad);
294a48e9
AL
1583 PERL_UNUSED_ARG(old_cv);
1584
dd2155a4 1585 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
551405c4 1586 const SV * const namesv = namepad[ix];
dd2155a4 1587 if (namesv && namesv != &PL_sv_undef
b15aece3 1588 && *SvPVX_const(namesv) == '&')
dd2155a4 1589 {
46c461b5 1590 CV * const innercv = (CV*)curpad[ix];
7dafbf52
DM
1591 assert(CvWEAKOUTSIDE(innercv));
1592 assert(CvOUTSIDE(innercv) == old_cv);
1593 CvOUTSIDE(innercv) = new_cv;
dd2155a4
DM
1594 }
1595 }
1596}
1597
7dafbf52 1598
dd2155a4
DM
1599/*
1600=for apidoc pad_push
1601
1602Push a new pad frame onto the padlist, unless there's already a pad at
26019298
AL
1603this depth, in which case don't bother creating a new one. Then give
1604the new pad an @_ in slot zero.
dd2155a4
DM
1605
1606=cut
1607*/
1608
1609void
26019298 1610Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
dd2155a4 1611{
97aff369 1612 dVAR;
b37c2d43 1613 if (depth > AvFILLp(padlist)) {
44f8325f
AL
1614 SV** const svp = AvARRAY(padlist);
1615 AV* const newpad = newAV();
1616 SV** const oldpad = AvARRAY(svp[depth-1]);
dd2155a4 1617 I32 ix = AvFILLp((AV*)svp[1]);
e1ec3a88 1618 const I32 names_fill = AvFILLp((AV*)svp[0]);
44f8325f 1619 SV** const names = AvARRAY(svp[0]);
26019298
AL
1620 AV *av;
1621
dd2155a4
DM
1622 for ( ;ix > 0; ix--) {
1623 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
b15aece3 1624 const char sigil = SvPVX_const(names[ix])[0];
fda94784
RGS
1625 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1626 || (SvFLAGS(names[ix]) & SVpad_STATE)
1627 || sigil == '&')
1628 {
dd2155a4
DM
1629 /* outer lexical or anon code */
1630 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1631 }
1632 else { /* our own lexical */
26019298
AL
1633 SV *sv;
1634 if (sigil == '@')
1635 sv = (SV*)newAV();
1636 else if (sigil == '%')
1637 sv = (SV*)newHV();
dd2155a4 1638 else
561b68a9 1639 sv = newSV(0);
26019298 1640 av_store(newpad, ix, sv);
dd2155a4
DM
1641 SvPADMY_on(sv);
1642 }
1643 }
1644 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
f84c484e 1645 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
dd2155a4
DM
1646 }
1647 else {
1648 /* save temporaries on recursion? */
561b68a9 1649 SV * const sv = newSV(0);
26019298 1650 av_store(newpad, ix, sv);
dd2155a4
DM
1651 SvPADTMP_on(sv);
1652 }
1653 }
26019298
AL
1654 av = newAV();
1655 av_extend(av, 0);
1656 av_store(newpad, 0, (SV*)av);
11ca45c0 1657 AvREIFY_only(av);
26019298 1658
dd2155a4
DM
1659 av_store(padlist, depth, (SV*)newpad);
1660 AvFILLp(padlist) = depth;
1661 }
1662}
b21dc031
AL
1663
1664
1665HV *
1666Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1667{
97aff369 1668 dVAR;
551405c4 1669 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
00b1698f 1670 if ( SvPAD_TYPED(*av) ) {
b21dc031
AL
1671 return SvSTASH(*av);
1672 }
5c284bb0 1673 return NULL;
b21dc031 1674}
66610fdd
RGS
1675
1676/*
1677 * Local variables:
1678 * c-indentation-style: bsd
1679 * c-basic-offset: 4
1680 * indent-tabs-mode: t
1681 * End:
1682 *
37442d52
RGS
1683 * ex: set ts=8 sts=4 sw=4 noet:
1684 */