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