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