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