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