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