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