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