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