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