3 * Copyright (c) 2002, Larry Wall
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.
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
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.
23 =head1 Pad Data Structures
25 =for apidoc m|AV *|CvPADLIST|CV *cv
26 CV's can have CvPADLIST(cv) set to point to an AV.
28 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
29 not callable at will and are always thrown away after the eval"" is done
32 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
33 but that is really the callers pad (a slot of which is allocated by
36 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
37 is managed "manual" (mostly in op.c) rather than normal av.c rules.
38 The items in the AV are not SVs as for a normal AV, but other AVs:
40 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
41 the "static type information" for lexicals.
43 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
44 depth of recursion into the CV.
45 The 0'th slot of a frame AV is an AV which is @_.
46 other entries are storage for variables and op targets.
49 C<PL_comppad_name> is set the the the names AV.
50 C<PL_comppad> is set the the frame AV for the frame CvDEPTH == 1.
51 C<PL_curpad> is set the body of the frame AV (i.e. AvARRAY(PL_comppad)).
53 Itterating over the names AV itterates over all possible pad
54 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
55 &PL_sv_undef "names" (see pad_alloc()).
57 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
58 The rest are op targets/GVs/constants which are statically allocated
59 or resolved at compile time. These don't have names by which they
60 can be looked up from Perl code at run time through eval"" like
61 my/our variables can be. Since they can't be looked up by "name"
62 but only by their index allocated at compile time (which is usually
63 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
65 The SVs in the names AV have their PV being the name of the variable.
66 NV+1..IV inclusive is a range of cop_seq numbers for which the name is
67 valid. For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
68 type. For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
69 stash of the associated global (so that duplicate C<our> delarations in the
70 same package can be detected). SvCUR is sometimes hijacked to
71 store the generation number during compilation.
73 If SvFAKE is set on the name SV then slot in the frame AVs are
74 a REFCNT'ed references to a lexical from "outside".
76 If the 'name' is '&' the the corresponding entry in frame AV
77 is a CV representing a possible closure.
78 (SvFAKE and name of '&' is not a meaningful combination currently but could
79 become so if C<my sub foo {}> is implemented.)
90 #define PAD_MAX 999999999
97 Create a new compiling padlist, saving and updating the various global
98 vars at the same time as creating the pad itself. The following flags
99 can be OR'ed together:
101 padnew_CLONE this pad is for a cloned CV
102 padnew_SAVE save old globals
103 padnew_SAVESUB also save extra stuff for start of sub
109 Perl_pad_new(pTHX_ padnew_flags flags)
111 AV *padlist, *padname, *pad, *a0;
113 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
114 * vars (based on flags) rather than storing vals + addresses for
115 * each individually. Also see pad_block_start.
116 * XXX DAPM Try to see whether all these conditionals are required
119 /* save existing state, ... */
121 if (flags & padnew_SAVE) {
123 SAVESPTR(PL_comppad_name);
124 if (! (flags & padnew_CLONE)) {
126 SAVEI32(PL_comppad_name_fill);
127 SAVEI32(PL_min_intro_pending);
128 SAVEI32(PL_max_intro_pending);
129 if (flags & padnew_SAVESUB) {
130 SAVEI32(PL_pad_reset_pending);
134 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
135 * saved - check at some pt that this is okay */
137 /* ... create new pad ... */
143 if (flags & padnew_CLONE) {
144 /* XXX DAPM I dont know why cv_clone needs it
145 * doing differently yet - perhaps this separate branch can be
146 * dispensed with eventually ???
149 a0 = newAV(); /* will be @_ */
151 av_store(pad, 0, (SV*)a0);
152 AvFLAGS(a0) = AVf_REIFY;
155 av_store(pad, 0, Nullsv);
159 av_store(padlist, 0, (SV*)padname);
160 av_store(padlist, 1, (SV*)pad);
162 /* ... then update state variables */
164 PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE));
165 PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE));
166 PL_curpad = AvARRAY(PL_comppad);
168 if (! (flags & padnew_CLONE)) {
169 PL_comppad_name_fill = 0;
170 PL_min_intro_pending = 0;
174 DEBUG_X(PerlIO_printf(Perl_debug_log,
175 "Pad 0x%"UVxf"[0x%"UVxf"] new: padlist=0x%"UVxf
176 " name=0x%"UVxf" flags=0x%"UVxf"\n",
177 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(padlist),
178 PTR2UV(padname), (UV)flags
182 return (PADLIST*)padlist;
186 =for apidoc pad_undef
188 Free the padlist associated with a CV.
189 If parts of it happen to be current, we null the relevant
190 PL_*pad* global vars so that we don't have any dangling references left.
191 We also repoint the CvOUTSIDE of any about-to-be-orphaned
192 inner subs to outercv.
198 Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
201 PADLIST *padlist = CvPADLIST(cv);
205 if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
208 DEBUG_X(PerlIO_printf(Perl_debug_log,
209 "Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
212 /* pads may be cleared out already during global destruction */
213 if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
214 && !PL_dirty) || CvSPECIAL(cv))
216 /* XXX DAPM the following code is very similar to
217 * pad_fixup_inner_anons(). Merge??? */
219 /* inner references to eval's cv must be fixed up */
220 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
221 SV **namepad = AvARRAY(comppad_name);
222 AV *comppad = (AV*)AvARRAY(padlist)[1];
223 SV **curpad = AvARRAY(comppad);
224 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
225 SV *namesv = namepad[ix];
226 if (namesv && namesv != &PL_sv_undef
227 && *SvPVX(namesv) == '&'
228 && ix <= AvFILLp(comppad))
230 CV *innercv = (CV*)curpad[ix];
231 if (innercv && SvTYPE(innercv) == SVt_PVCV
232 && CvOUTSIDE(innercv) == cv)
234 CvOUTSIDE(innercv) = outercv;
235 if (!CvANON(innercv) || CvCLONED(innercv)) {
236 (void)SvREFCNT_inc(outercv);
244 ix = AvFILLp(padlist);
246 SV* sv = AvARRAY(padlist)[ix--];
249 if (sv == (SV*)PL_comppad_name)
250 PL_comppad_name = Nullav;
251 else if (sv == (SV*)PL_comppad) {
253 PL_curpad = Null(SV**);
257 SvREFCNT_dec((SV*)CvPADLIST(cv));
258 CvPADLIST(cv) = Null(PADLIST*);
265 =for apidoc pad_add_name
267 Create a new name in the current pad at the specified offset.
268 If C<typestash> is valid, the name is for a typed lexical; set the
269 name's stash to that value.
270 If C<ourstash> is valid, it's an our lexical, set the name's
271 GvSTASH to that value
273 Also, if the name is @.. or %.., create a new array or hash for that slot
275 If fake, it means we're cloning an existing entry
281 * XXX DAPM this doesn't seem the right place to create a new array/hash.
282 * Whatever we do, we should be consistent - create scalars too, and
283 * create even if fake. Really need to integrate better the whole entry
284 * creation business - when + where does the name and value get created?
288 Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
290 PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
291 SV* namesv = NEWSV(1102, 0);
295 min = PL_curcop->cop_seq;
299 /* not yet introduced */
304 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
305 "Pad addname: %ld \"%s\", (%lu,%lu)%s\n",
306 (long)offset, name, (unsigned long)min, (unsigned long)max,
307 (fake ? " FAKE" : "")
311 sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
312 sv_setpv(namesv, name);
315 SvFLAGS(namesv) |= SVpad_TYPED;
316 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
319 SvFLAGS(namesv) |= SVpad_OUR;
320 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
323 av_store(PL_comppad_name, offset, namesv);
324 SvNVX(namesv) = (NV)min;
329 if (!PL_min_intro_pending)
330 PL_min_intro_pending = offset;
331 PL_max_intro_pending = offset;
333 av_store(PL_comppad, offset, (SV*)newAV());
334 else if (*name == '%')
335 av_store(PL_comppad, offset, (SV*)newHV());
336 SvPADMY_on(PL_curpad[offset]);
346 =for apidoc pad_alloc
348 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
349 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
350 for a slot which has no name and and no active value.
355 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
356 * or at least rationalise ??? */
360 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
365 if (AvARRAY(PL_comppad) != PL_curpad)
366 Perl_croak(aTHX_ "panic: pad_alloc");
367 if (PL_pad_reset_pending)
369 if (tmptype & SVs_PADMY) {
371 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
372 } while (SvPADBUSY(sv)); /* need a fresh one */
373 retval = AvFILLp(PL_comppad);
376 SV **names = AvARRAY(PL_comppad_name);
377 SSize_t names_fill = AvFILLp(PL_comppad_name);
380 * "foreach" index vars temporarily become aliases to non-"my"
381 * values. Thus we must skip, not just pad values that are
382 * marked as current pad values, but also those with names.
384 /* HVDS why copy to sv here? we don't seem to use it */
385 if (++PL_padix <= names_fill &&
386 (sv = names[PL_padix]) && sv != &PL_sv_undef)
388 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
389 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
390 !IS_PADGV(sv) && !IS_PADCONST(sv))
395 SvFLAGS(sv) |= tmptype;
396 PL_curpad = AvARRAY(PL_comppad);
398 DEBUG_X(PerlIO_printf(Perl_debug_log,
399 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
400 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
401 PL_op_name[optype]));
402 return (PADOFFSET)retval;
406 =for apidoc pad_add_anon
408 Add an anon code entry to the current compiling pad
414 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
419 name = NEWSV(1106, 0);
420 sv_upgrade(name, SVt_PVNV);
421 sv_setpvn(name, "&", 1);
424 ix = pad_alloc(op_type, SVs_PADMY);
425 av_store(PL_comppad_name, ix, name);
426 av_store(PL_comppad, ix, sv);
434 =for apidoc pad_check_dup
436 Check for duplicate declarations: report any of:
437 * a my in the current scope with the same name;
438 * an our (anywhere in the pad) with the same name and the same stash
440 C<is_our> indicates that the name to check is an 'our' declaration
445 /* XXX DAPM integrate this into pad_add_name ??? */
448 Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
453 if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
454 return; /* nothing to check */
456 svp = AvARRAY(PL_comppad_name);
457 top = AvFILLp(PL_comppad_name);
458 /* check the current scope */
459 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
461 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
463 && sv != &PL_sv_undef
464 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
466 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
467 && strEQ(name, SvPVX(sv)))
469 Perl_warner(aTHX_ packWARN(WARN_MISC),
470 "\"%s\" variable %s masks earlier declaration in same %s",
471 (is_our ? "our" : "my"),
473 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
478 /* check the rest of the pad */
482 && sv != &PL_sv_undef
483 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
484 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
485 && strEQ(name, SvPVX(sv)))
487 Perl_warner(aTHX_ packWARN(WARN_MISC),
488 "\"our\" variable %s redeclared", name);
489 Perl_warner(aTHX_ packWARN(WARN_MISC),
490 "\t(Did you mean \"local\" instead of \"our\"?)\n");
493 } while ( off-- > 0 );
500 =for apidoc pad_findmy
502 Given a lexical name, try to find its offset, first in the current pad,
503 or failing that, in the pads of any lexically enclosing subs (including
504 the complications introduced by eval). If the name is found in an outer pad,
505 then a fake entry is added to the current pad.
506 Returns the offset in the current pad, or NOT_IN_PAD on failure.
512 Perl_pad_findmy(pTHX_ char *name)
517 SV **svp = AvARRAY(PL_comppad_name);
518 U32 seq = PL_cop_seqmax;
522 DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy: \"%s\"\n", name));
524 /* The one we're looking for is probably just before comppad_name_fill. */
525 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
526 if ((sv = svp[off]) &&
527 sv != &PL_sv_undef &&
529 (seq <= (U32)SvIVX(sv) &&
530 seq > (U32)I_32(SvNVX(sv)))) &&
531 strEQ(SvPVX(sv), name))
533 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
534 return (PADOFFSET)off;
535 pendoff = off; /* this pending def. will override import */
539 outside = CvOUTSIDE(PL_compcv);
541 /* Check if if we're compiling an eval'', and adjust seq to be the
542 * eval's seq number. This depends on eval'' having a non-null
543 * CvOUTSIDE() while it is being compiled. The eval'' itself is
544 * identified by CvEVAL being true and CvGV being null. */
545 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
546 cx = &cxstack[cxstack_ix];
548 seq = cx->blk_oldcop->cop_seq;
551 /* See if it's in a nested scope */
552 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
553 if (!off) /* pad_findlex returns 0 for failure...*/
554 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
556 /* If there is a pending local definition, this new alias must die */
558 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
565 =for apidoc pad_findlex
567 Find a named lexical anywhere in a chain of nested pads. Add fake entries
568 in the inner pads if its found in an outer one.
570 If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts.
575 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
578 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
579 I32 cx_ix, I32 saweval, U32 flags)
585 register PERL_CONTEXT *cx;
587 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
588 "Pad findlex: \"%s\" off=%ld seq=%lu cv=0x%"UVxf
589 " ix=%ld saweval=%d flags=%lu\n",
590 name, (long)newoff, (unsigned long)seq, PTR2UV(startcv),
591 (long)cx_ix, (int)saweval, (unsigned long)flags
595 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
596 AV *curlist = CvPADLIST(cv);
597 SV **svp = av_fetch(curlist, 0, FALSE);
600 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
601 " searching: cv=0x%"UVxf"\n", PTR2UV(cv))
604 if (!svp || *svp == &PL_sv_undef)
607 svp = AvARRAY(curname);
608 for (off = AvFILLp(curname); off > 0; off--) {
615 sv != &PL_sv_undef &&
616 seq <= (U32)SvIVX(sv) &&
617 seq > (U32)I_32(SvNVX(sv)) &&
618 strEQ(SvPVX(sv), name))
627 return 0; /* don't clone from inactive stack frame */
632 oldpad = (AV*)AvARRAY(curlist)[depth];
633 oldsv = *av_fetch(oldpad, off, TRUE);
635 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
636 " matched: offset %ld"
637 " %s(%lu,%lu), sv=0x%"UVxf"\n",
639 SvFAKE(sv) ? "FAKE " : "",
640 (unsigned long)I_32(SvNVX(sv)),
641 (unsigned long)SvIVX(sv),
646 if (!newoff) { /* Not a mere clone operation. */
647 newoff = pad_add_name(
649 (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
650 (SvFLAGS(sv) & SVpad_OUR) ? GvSTASH(sv) : Nullhv,
654 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
655 /* "It's closures all the way down." */
656 CvCLONE_on(PL_compcv);
658 if (CvANON(PL_compcv))
659 oldsv = Nullsv; /* no need to keep ref */
664 bcv && bcv != cv && !CvCLONE(bcv);
665 bcv = CvOUTSIDE(bcv))
668 /* install the missing pad entry in intervening
669 * nested subs and mark them cloneable. */
670 AV *ocomppad_name = PL_comppad_name;
671 AV *ocomppad = PL_comppad;
672 SV **ocurpad = PL_curpad;
673 AV *padlist = CvPADLIST(bcv);
674 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
675 PL_comppad = (AV*)AvARRAY(padlist)[1];
676 PL_curpad = AvARRAY(PL_comppad);
679 (SvFLAGS(sv) & SVpad_TYPED)
680 ? SvSTASH(sv) : Nullhv,
681 (SvFLAGS(sv) & SVpad_OUR)
682 ? GvSTASH(sv) : Nullhv,
686 PL_comppad_name = ocomppad_name;
687 PL_comppad = ocomppad;
692 if (ckWARN(WARN_CLOSURE)
693 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
695 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
696 "Variable \"%s\" may be unavailable",
704 else if (!CvUNIQUE(PL_compcv)) {
705 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
706 && !(SvFLAGS(sv) & SVpad_OUR))
708 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
709 "Variable \"%s\" will not stay shared", name);
713 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
714 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
715 "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
716 (long)newoff, PTR2UV(oldsv)
723 if (flags & FINDLEX_NOSEARCH)
726 /* Nothing in current lexical context--try eval's context, if any.
727 * This is necessary to let the perldb get at lexically scoped variables.
728 * XXX This will also probably interact badly with eval tree caching.
731 for (i = cx_ix; i >= 0; i--) {
733 switch (CxTYPE(cx)) {
735 if (i == 0 && saweval) {
736 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
740 switch (cx->blk_eval.old_op_type) {
742 if (CxREALEVAL(cx)) {
745 seq = cxstack[i].blk_oldcop->cop_seq;
746 startcv = cxstack[i].blk_eval.cv;
747 if (startcv && CvOUTSIDE(startcv)) {
748 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
750 if (off) /* continue looking if not found here */
757 /* require/do must have their own scope */
766 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
767 saweval = i; /* so we know where we were called from */
768 seq = cxstack[i].blk_oldcop->cop_seq;
771 return pad_findlex(name, newoff, seq, cv, i - 1, saweval, FINDLEX_NOSEARCH);
782 Get the value at offset po in the current pad.
783 Use macro PAD_SV instead of calling this function directly.
790 Perl_pad_sv(pTHX_ PADOFFSET po)
793 /* for display purposes, try to guess the AV corresponding to
796 if (cp && AvARRAY(cp) != PL_curpad)
801 Perl_croak(aTHX_ "panic: pad_sv po");
802 DEBUG_X(PerlIO_printf(Perl_debug_log,
803 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
804 PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
806 return PL_curpad[po];
811 =for apidoc pad_setsv
813 Set the entry at offset po in the current pad to sv.
814 Use the macro PAD_SETSV() rather than calling this function directly.
821 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
823 /* for display purposes, try to guess the AV corresponding to
826 if (cp && AvARRAY(cp) != PL_curpad)
829 DEBUG_X(PerlIO_printf(Perl_debug_log,
830 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
831 PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
840 =for apidoc pad_block_start
842 Update the pad compilation state variables on entry to a new block
848 * - integrate this in general state-saving routine ???
849 * - combine with the state-saving going on in pad_new ???
850 * - introduce a new SAVE type that does all this in one go ?
854 Perl_pad_block_start(pTHX_ int full)
856 SAVEI32(PL_comppad_name_floor);
857 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
859 PL_comppad_name_fill = PL_comppad_name_floor;
860 if (PL_comppad_name_floor < 0)
861 PL_comppad_name_floor = 0;
862 SAVEI32(PL_min_intro_pending);
863 SAVEI32(PL_max_intro_pending);
864 PL_min_intro_pending = 0;
865 SAVEI32(PL_comppad_name_fill);
866 SAVEI32(PL_padix_floor);
867 PL_padix_floor = PL_padix;
868 PL_pad_reset_pending = FALSE;
875 "Introduce" my variables to visible status.
887 if (! PL_min_intro_pending)
888 return PL_cop_seqmax;
890 svp = AvARRAY(PL_comppad_name);
891 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
892 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
893 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
894 SvNVX(sv) = (NV)PL_cop_seqmax;
895 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
896 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
898 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
902 PL_min_intro_pending = 0;
903 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
904 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
905 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
907 return PL_cop_seqmax++;
911 =for apidoc pad_leavemy
913 Cleanup at end of scope during compilation: set the max seq number for
914 lexicals in this scope and warn of any lexicals that never got introduced.
920 Perl_pad_leavemy(pTHX)
923 SV **svp = AvARRAY(PL_comppad_name);
926 PL_pad_reset_pending = FALSE;
928 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
929 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
930 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
931 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
932 "%s never introduced", SvPVX(sv));
935 /* "Deintroduce" my variables that are leaving with this scope. */
936 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
937 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) {
938 SvIVX(sv) = PL_cop_seqmax;
939 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
940 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
941 (long)off, SvPVX(sv),
942 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
947 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
948 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
953 =for apidoc pad_swipe
955 Abandon the tmp in the current pad at offset po and replace with a
962 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
966 if (AvARRAY(PL_comppad) != PL_curpad)
967 Perl_croak(aTHX_ "panic: pad_swipe curpad");
969 Perl_croak(aTHX_ "panic: pad_swipe po");
971 DEBUG_X(PerlIO_printf(Perl_debug_log,
972 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
973 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
976 SvPADTMP_off(PL_curpad[po]);
978 SvREFCNT_dec(PL_curpad[po]);
980 PL_curpad[po] = NEWSV(1107,0);
981 SvPADTMP_on(PL_curpad[po]);
982 if ((I32)po < PL_padix)
988 =for apidoc pad_reset
990 Mark all the current temporaries for reuse
995 /* XXX pad_reset() is currently disabled because it results in serious bugs.
996 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
997 * on the stack by OPs that use them, there are several ways to get an alias
998 * to a shared TARG. Such an alias will change randomly and unpredictably.
999 * We avoid doing this until we can think of a Better Way.
1002 Perl_pad_reset(pTHX)
1004 #ifdef USE_BROKEN_PAD_RESET
1007 if (AvARRAY(PL_comppad) != PL_curpad)
1008 Perl_croak(aTHX_ "panic: pad_reset curpad");
1010 DEBUG_X(PerlIO_printf(Perl_debug_log,
1011 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1012 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1013 (long)PL_padix, (long)PL_padix_floor
1017 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1018 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1019 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1020 SvPADTMP_off(PL_curpad[po]);
1022 PL_padix = PL_padix_floor;
1025 PL_pad_reset_pending = FALSE;
1030 =for apidoc pad_tidy
1032 Tidy up a pad after we've finished compiling it:
1033 * remove most stuff from the pads of anonsub prototypes;
1035 * mark tmps as such.
1040 /* XXX DAPM surely most of this stuff should be done properly
1041 * at the right time beforehand, rather than going around afterwards
1042 * cleaning up our mistakes ???
1046 Perl_pad_tidy(pTHX_ padtidy_type type)
1050 /* extend curpad to match namepad */
1051 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1052 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1054 if (type == padtidy_SUBCLONE) {
1055 SV **namep = AvARRAY(PL_comppad_name);
1056 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1059 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1062 * The only things that a clonable function needs in its
1063 * pad are references to outer lexicals and anonymous subs.
1064 * The rest are created anew during cloning.
1066 if (!((namesv = namep[ix]) != Nullsv &&
1067 namesv != &PL_sv_undef &&
1069 *SvPVX(namesv) == '&')))
1071 SvREFCNT_dec(PL_curpad[ix]);
1072 PL_curpad[ix] = Nullsv;
1076 else if (type == padtidy_SUB) {
1077 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1078 AV *av = newAV(); /* Will be @_ */
1080 av_store(PL_comppad, 0, (SV*)av);
1081 AvFLAGS(av) = AVf_REIFY;
1084 /* XXX DAPM rationalise these two similar branches */
1086 if (type == padtidy_SUB) {
1087 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1088 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1090 if (!SvPADMY(PL_curpad[ix]))
1091 SvPADTMP_on(PL_curpad[ix]);
1094 else if (type == padtidy_FORMAT) {
1095 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1096 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1097 SvPADTMP_on(PL_curpad[ix]);
1104 =for apidoc pad_free
1106 Free the SV at offet po in the current pad.
1111 /* XXX DAPM integrate with pad_swipe ???? */
1113 Perl_pad_free(pTHX_ PADOFFSET po)
1117 if (AvARRAY(PL_comppad) != PL_curpad)
1118 Perl_croak(aTHX_ "panic: pad_free curpad");
1120 Perl_croak(aTHX_ "panic: pad_free po");
1122 DEBUG_X(PerlIO_printf(Perl_debug_log,
1123 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1124 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1127 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1128 SvPADTMP_off(PL_curpad[po]);
1130 #ifdef PERL_COPY_ON_WRITE
1131 if (SvIsCOW(PL_curpad[po])) {
1132 sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
1135 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
1139 if ((I32)po < PL_padix)
1146 =for apidoc do_dump_pad
1148 Dump the contents of a padlist
1154 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1166 pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1167 pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1168 pname = AvARRAY(pad_name);
1169 ppad = AvARRAY(pad);
1170 Perl_dump_indent(aTHX_ level, file,
1171 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1172 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1175 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1177 if (namesv && namesv == &PL_sv_undef) {
1181 Perl_dump_indent(aTHX_ level+1, file,
1182 "%2d. 0x%"UVxf"<%lu> %s (%lu,%lu) \"%s\"\n",
1185 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1186 SvFAKE(namesv) ? "FAKE" : " ",
1187 (unsigned long)I_32(SvNVX(namesv)),
1188 (unsigned long)SvIVX(namesv),
1193 Perl_dump_indent(aTHX_ level+1, file,
1194 "%2d. 0x%"UVxf"<%lu>\n",
1197 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1208 dump the contents of a CV
1215 S_cv_dump(pTHX_ CV *cv, char *title)
1217 CV *outside = CvOUTSIDE(cv);
1218 AV* padlist = CvPADLIST(cv);
1220 PerlIO_printf(Perl_debug_log,
1221 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1224 (CvANON(cv) ? "ANON"
1225 : (cv == PL_main_cv) ? "MAIN"
1226 : CvUNIQUE(cv) ? "UNIQUE"
1227 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1230 : CvANON(outside) ? "ANON"
1231 : (outside == PL_main_cv) ? "MAIN"
1232 : CvUNIQUE(outside) ? "UNIQUE"
1233 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1235 PerlIO_printf(Perl_debug_log,
1236 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1237 do_dump_pad(1, Perl_debug_log, padlist, 1);
1239 #endif /* DEBUGGING */
1246 =for apidoc cv_clone
1248 Clone a CV: make a new CV which points to the same code etc, but which
1249 has a newly-created pad built by copying the prototype pad and capturing
1256 Perl_cv_clone(pTHX_ CV *proto)
1260 LOCK_CRED_MUTEX; /* XXX create separate mutex */
1261 cv = cv_clone2(proto, CvOUTSIDE(proto));
1262 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
1267 /* XXX DAPM separate out cv and paddish bits ???
1268 * ideally the CV-related stuff shouldn't be in pad.c - how about
1272 S_cv_clone2(pTHX_ CV *proto, CV *outside)
1275 AV* protopadlist = CvPADLIST(proto);
1276 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1277 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1278 SV** pname = AvARRAY(protopad_name);
1279 SV** ppad = AvARRAY(protopad);
1280 I32 fname = AvFILLp(protopad_name);
1281 I32 fpad = AvFILLp(protopad);
1285 assert(!CvUNIQUE(proto));
1288 SAVESPTR(PL_compcv);
1290 cv = PL_compcv = (CV*)NEWSV(1104, 0);
1291 sv_upgrade((SV *)cv, SvTYPE(proto));
1292 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
1296 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
1297 : savepv(CvFILE(proto));
1299 CvFILE(cv) = CvFILE(proto);
1301 CvGV(cv) = CvGV(proto);
1302 CvSTASH(cv) = CvSTASH(proto);
1303 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1304 CvSTART(cv) = CvSTART(proto);
1306 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
1309 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1311 CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1313 for (ix = fname; ix >= 0; ix--)
1314 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1316 av_fill(PL_comppad, fpad);
1317 PL_curpad = AvARRAY(PL_comppad);
1319 for (ix = fpad; ix > 0; ix--) {
1320 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1321 if (namesv && namesv != &PL_sv_undef) {
1322 char *name = SvPVX(namesv); /* XXX */
1323 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
1324 I32 off = pad_findlex(name, ix, SvIVX(namesv),
1325 CvOUTSIDE(cv), cxstack_ix, 0, 0);
1327 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1329 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
1331 else { /* our own lexical */
1334 /* anon code -- we'll come back for it */
1335 sv = SvREFCNT_inc(ppad[ix]);
1337 else if (*name == '@')
1339 else if (*name == '%')
1348 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1349 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1352 SV* sv = NEWSV(0, 0);
1358 /* Now that vars are all in place, clone nested closures. */
1360 for (ix = fpad; ix > 0; ix--) {
1361 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1363 && namesv != &PL_sv_undef
1364 && !(SvFLAGS(namesv) & SVf_FAKE)
1365 && *SvPVX(namesv) == '&'
1366 && CvCLONE(ppad[ix]))
1368 CV *kid = cv_clone2((CV*)ppad[ix], cv);
1369 SvREFCNT_dec(ppad[ix]);
1372 PL_curpad[ix] = (SV*)kid;
1377 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1378 cv_dump(outside, "Outside");
1379 cv_dump(proto, "Proto");
1386 SV* const_sv = op_const_sv(CvSTART(cv), cv);
1388 /* constant sub () { $x } closing over $x - see lib/constant.pm */
1390 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1398 =for apidoc pad_fixup_inner_anons
1400 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1401 old_cv to new_cv if necessary.
1407 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1410 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1411 AV *comppad = (AV*)AvARRAY(padlist)[1];
1412 SV **namepad = AvARRAY(comppad_name);
1413 SV **curpad = AvARRAY(comppad);
1414 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1415 SV *namesv = namepad[ix];
1416 if (namesv && namesv != &PL_sv_undef
1417 && *SvPVX(namesv) == '&')
1419 CV *innercv = (CV*)curpad[ix];
1420 if (CvOUTSIDE(innercv) == old_cv) {
1421 CvOUTSIDE(innercv) = new_cv;
1422 if (!CvANON(innercv) || CvCLONED(innercv)) {
1423 (void)SvREFCNT_inc(new_cv);
1424 SvREFCNT_dec(old_cv);
1432 =for apidoc pad_push
1434 Push a new pad frame onto the padlist, unless there's already a pad at
1435 this depth, in which case don't bother creating a new one.
1436 If has_args is true, give the new pad an @_ in slot zero.
1442 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1444 if (depth <= AvFILLp(padlist))
1448 SV** svp = AvARRAY(padlist);
1449 AV *newpad = newAV();
1450 SV **oldpad = AvARRAY(svp[depth-1]);
1451 I32 ix = AvFILLp((AV*)svp[1]);
1452 I32 names_fill = AvFILLp((AV*)svp[0]);
1453 SV** names = AvARRAY(svp[0]);
1455 for ( ;ix > 0; ix--) {
1456 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1457 char *name = SvPVX(names[ix]);
1458 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1459 /* outer lexical or anon code */
1460 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1462 else { /* our own lexical */
1464 av_store(newpad, ix, sv = (SV*)newAV());
1465 else if (*name == '%')
1466 av_store(newpad, ix, sv = (SV*)newHV());
1468 av_store(newpad, ix, sv = NEWSV(0, 0));
1472 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1473 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1476 /* save temporaries on recursion? */
1477 av_store(newpad, ix, sv = NEWSV(0, 0));
1484 av_store(newpad, 0, (SV*)av);
1485 AvFLAGS(av) = AVf_REIFY;
1487 av_store(padlist, depth, (SV*)newpad);
1488 AvFILLp(padlist) = depth;