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