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