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 pad.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 During execution, C<PL_comppad> and C<PL_curpad> refer to the live
54 frame of the currently executing sub.
56 Iterating over the names AV iterates over all possible pad
57 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
58 &PL_sv_undef "names" (see pad_alloc()).
60 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
61 The rest are op targets/GVs/constants which are statically allocated
62 or resolved at compile time. These don't have names by which they
63 can be looked up from Perl code at run time through eval"" like
64 my/our variables can be. Since they can't be looked up by "name"
65 but only by their index allocated at compile time (which is usually
66 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
68 The SVs in the names AV have their PV being the name of the variable.
69 NV+1..IV inclusive is a range of cop_seq numbers for which the name is
70 valid. For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
71 type. For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
72 stash of the associated global (so that duplicate C<our> delarations in the
73 same package can be detected). SvCUR is sometimes hijacked to
74 store the generation number during compilation.
76 If SvFAKE is set on the name SV then slot in the frame AVs are
77 a REFCNT'ed references to a lexical from "outside".
79 If the 'name' is '&' the the corresponding entry in frame AV
80 is a CV representing a possible closure.
81 (SvFAKE and name of '&' is not a meaningful combination currently but could
82 become so if C<my sub foo {}> is implemented.)
93 #define PAD_MAX 999999999
100 Create a new compiling padlist, saving and updating the various global
101 vars at the same time as creating the pad itself. The following flags
102 can be OR'ed together:
104 padnew_CLONE this pad is for a cloned CV
105 padnew_SAVE save old globals
106 padnew_SAVESUB also save extra stuff for start of sub
112 Perl_pad_new(pTHX_ padnew_flags flags)
114 AV *padlist, *padname, *pad, *a0;
116 ASSERT_CURPAD_LEGAL("pad_new");
118 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
119 * vars (based on flags) rather than storing vals + addresses for
120 * each individually. Also see pad_block_start.
121 * XXX DAPM Try to see whether all these conditionals are required
124 /* save existing state, ... */
126 if (flags & padnew_SAVE) {
128 SAVESPTR(PL_comppad_name);
129 if (! (flags & padnew_CLONE)) {
131 SAVEI32(PL_comppad_name_fill);
132 SAVEI32(PL_min_intro_pending);
133 SAVEI32(PL_max_intro_pending);
134 if (flags & padnew_SAVESUB) {
135 SAVEI32(PL_pad_reset_pending);
139 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
140 * saved - check at some pt that this is okay */
142 /* ... create new pad ... */
148 if (flags & padnew_CLONE) {
149 /* XXX DAPM I dont know why cv_clone needs it
150 * doing differently yet - perhaps this separate branch can be
151 * dispensed with eventually ???
154 a0 = newAV(); /* will be @_ */
156 av_store(pad, 0, (SV*)a0);
157 AvFLAGS(a0) = AVf_REIFY;
160 av_store(pad, 0, Nullsv);
164 av_store(padlist, 0, (SV*)padname);
165 av_store(padlist, 1, (SV*)pad);
167 /* ... then update state variables */
169 PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE));
170 PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE));
171 PL_curpad = AvARRAY(PL_comppad);
173 if (! (flags & padnew_CLONE)) {
174 PL_comppad_name_fill = 0;
175 PL_min_intro_pending = 0;
179 DEBUG_X(PerlIO_printf(Perl_debug_log,
180 "Pad 0x%"UVxf"[0x%"UVxf"] new: padlist=0x%"UVxf
181 " name=0x%"UVxf" flags=0x%"UVxf"\n",
182 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(padlist),
183 PTR2UV(padname), (UV)flags
187 return (PADLIST*)padlist;
191 =for apidoc pad_undef
193 Free the padlist associated with a CV.
194 If parts of it happen to be current, we null the relevant
195 PL_*pad* global vars so that we don't have any dangling references left.
196 We also repoint the CvOUTSIDE of any about-to-be-orphaned
197 inner subs to outercv.
203 Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
206 PADLIST *padlist = CvPADLIST(cv);
210 if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
213 DEBUG_X(PerlIO_printf(Perl_debug_log,
214 "Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
217 /* pads may be cleared out already during global destruction */
218 if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
219 && !PL_dirty) || CvSPECIAL(cv))
221 /* XXX DAPM the following code is very similar to
222 * pad_fixup_inner_anons(). Merge??? */
224 /* inner references to eval's cv must be fixed up */
225 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
226 SV **namepad = AvARRAY(comppad_name);
227 AV *comppad = (AV*)AvARRAY(padlist)[1];
228 SV **curpad = AvARRAY(comppad);
229 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
230 SV *namesv = namepad[ix];
231 if (namesv && namesv != &PL_sv_undef
232 && *SvPVX(namesv) == '&'
233 && ix <= AvFILLp(comppad))
235 CV *innercv = (CV*)curpad[ix];
236 if (innercv && SvTYPE(innercv) == SVt_PVCV
237 && CvOUTSIDE(innercv) == cv)
239 CvOUTSIDE(innercv) = outercv;
240 if (!CvANON(innercv) || CvCLONED(innercv)) {
241 (void)SvREFCNT_inc(outercv);
249 ix = AvFILLp(padlist);
251 SV* sv = AvARRAY(padlist)[ix--];
254 if (sv == (SV*)PL_comppad_name)
255 PL_comppad_name = Nullav;
256 else if (sv == (SV*)PL_comppad) {
257 PL_comppad = Null(PAD*);
258 PL_curpad = Null(SV**);
262 SvREFCNT_dec((SV*)CvPADLIST(cv));
263 CvPADLIST(cv) = Null(PADLIST*);
270 =for apidoc pad_add_name
272 Create a new name in the current pad at the specified offset.
273 If C<typestash> is valid, the name is for a typed lexical; set the
274 name's stash to that value.
275 If C<ourstash> is valid, it's an our lexical, set the name's
276 GvSTASH to that value
278 Also, if the name is @.. or %.., create a new array or hash for that slot
280 If fake, it means we're cloning an existing entry
286 * XXX DAPM this doesn't seem the right place to create a new array/hash.
287 * Whatever we do, we should be consistent - create scalars too, and
288 * create even if fake. Really need to integrate better the whole entry
289 * creation business - when + where does the name and value get created?
293 Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
295 PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
296 SV* namesv = NEWSV(1102, 0);
299 ASSERT_CURPAD_ACTIVE("pad_add_name");
302 min = PL_curcop->cop_seq;
306 /* not yet introduced */
311 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
312 "Pad addname: %ld \"%s\", (%lu,%lu)%s\n",
313 (long)offset, name, (unsigned long)min, (unsigned long)max,
314 (fake ? " FAKE" : "")
318 sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
319 sv_setpv(namesv, name);
322 SvFLAGS(namesv) |= SVpad_TYPED;
323 SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
326 SvFLAGS(namesv) |= SVpad_OUR;
327 GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
330 av_store(PL_comppad_name, offset, namesv);
331 SvNVX(namesv) = (NV)min;
336 if (!PL_min_intro_pending)
337 PL_min_intro_pending = offset;
338 PL_max_intro_pending = offset;
339 /* XXX DAPM since slot has been allocated, replace
340 * av_store with PL_curpad[offset] ? */
342 av_store(PL_comppad, offset, (SV*)newAV());
343 else if (*name == '%')
344 av_store(PL_comppad, offset, (SV*)newHV());
345 SvPADMY_on(PL_curpad[offset]);
355 =for apidoc pad_alloc
357 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
358 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
359 for a slot which has no name and and no active value.
364 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
365 * or at least rationalise ??? */
369 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
374 ASSERT_CURPAD_ACTIVE("pad_alloc");
376 if (AvARRAY(PL_comppad) != PL_curpad)
377 Perl_croak(aTHX_ "panic: pad_alloc");
378 if (PL_pad_reset_pending)
380 if (tmptype & SVs_PADMY) {
382 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
383 } while (SvPADBUSY(sv)); /* need a fresh one */
384 retval = AvFILLp(PL_comppad);
387 SV **names = AvARRAY(PL_comppad_name);
388 SSize_t names_fill = AvFILLp(PL_comppad_name);
391 * "foreach" index vars temporarily become aliases to non-"my"
392 * values. Thus we must skip, not just pad values that are
393 * marked as current pad values, but also those with names.
395 /* HVDS why copy to sv here? we don't seem to use it */
396 if (++PL_padix <= names_fill &&
397 (sv = names[PL_padix]) && sv != &PL_sv_undef)
399 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
400 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
401 !IS_PADGV(sv) && !IS_PADCONST(sv))
406 SvFLAGS(sv) |= tmptype;
407 PL_curpad = AvARRAY(PL_comppad);
409 DEBUG_X(PerlIO_printf(Perl_debug_log,
410 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
411 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
412 PL_op_name[optype]));
413 return (PADOFFSET)retval;
417 =for apidoc pad_add_anon
419 Add an anon code entry to the current compiling pad
425 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
430 name = NEWSV(1106, 0);
431 sv_upgrade(name, SVt_PVNV);
432 sv_setpvn(name, "&", 1);
435 ix = pad_alloc(op_type, SVs_PADMY);
436 av_store(PL_comppad_name, ix, name);
437 /* XXX DAPM use PL_curpad[] ? */
438 av_store(PL_comppad, ix, sv);
446 =for apidoc pad_check_dup
448 Check for duplicate declarations: report any of:
449 * a my in the current scope with the same name;
450 * an our (anywhere in the pad) with the same name and the same stash
452 C<is_our> indicates that the name to check is an 'our' declaration
457 /* XXX DAPM integrate this into pad_add_name ??? */
460 Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
465 ASSERT_CURPAD_ACTIVE("pad_check_dup");
466 if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
467 return; /* nothing to check */
469 svp = AvARRAY(PL_comppad_name);
470 top = AvFILLp(PL_comppad_name);
471 /* check the current scope */
472 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
474 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
476 && sv != &PL_sv_undef
477 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
479 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
480 && strEQ(name, SvPVX(sv)))
482 Perl_warner(aTHX_ packWARN(WARN_MISC),
483 "\"%s\" variable %s masks earlier declaration in same %s",
484 (is_our ? "our" : "my"),
486 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
491 /* check the rest of the pad */
495 && sv != &PL_sv_undef
496 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
497 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
498 && strEQ(name, SvPVX(sv)))
500 Perl_warner(aTHX_ packWARN(WARN_MISC),
501 "\"our\" variable %s redeclared", name);
502 Perl_warner(aTHX_ packWARN(WARN_MISC),
503 "\t(Did you mean \"local\" instead of \"our\"?)\n");
506 } while ( off-- > 0 );
513 =for apidoc pad_findmy
515 Given a lexical name, try to find its offset, first in the current pad,
516 or failing that, in the pads of any lexically enclosing subs (including
517 the complications introduced by eval). If the name is found in an outer pad,
518 then a fake entry is added to the current pad.
519 Returns the offset in the current pad, or NOT_IN_PAD on failure.
525 Perl_pad_findmy(pTHX_ char *name)
530 SV **svp = AvARRAY(PL_comppad_name);
531 U32 seq = PL_cop_seqmax;
535 ASSERT_CURPAD_ACTIVE("pad_findmy");
536 DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy: \"%s\"\n", name));
538 /* The one we're looking for is probably just before comppad_name_fill. */
539 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
540 if ((sv = svp[off]) &&
541 sv != &PL_sv_undef &&
543 (seq <= (U32)SvIVX(sv) &&
544 seq > (U32)I_32(SvNVX(sv)))) &&
545 strEQ(SvPVX(sv), name))
547 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
548 return (PADOFFSET)off;
549 pendoff = off; /* this pending def. will override import */
553 outside = CvOUTSIDE(PL_compcv);
555 /* Check if if we're compiling an eval'', and adjust seq to be the
556 * eval's seq number. This depends on eval'' having a non-null
557 * CvOUTSIDE() while it is being compiled. The eval'' itself is
558 * identified by CvEVAL being true and CvGV being null. */
559 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
560 cx = &cxstack[cxstack_ix];
562 seq = cx->blk_oldcop->cop_seq;
565 /* See if it's in a nested scope */
566 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
567 if (!off) /* pad_findlex returns 0 for failure...*/
568 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
570 /* If there is a pending local definition, this new alias must die */
572 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
579 =for apidoc pad_findlex
581 Find a named lexical anywhere in a chain of nested pads. Add fake entries
582 in the inner pads if its found in an outer one.
584 If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts.
589 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
592 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
593 I32 cx_ix, I32 saweval, U32 flags)
599 register PERL_CONTEXT *cx;
601 ASSERT_CURPAD_ACTIVE("pad_findlex");
602 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
603 "Pad findlex: \"%s\" off=%ld seq=%lu cv=0x%"UVxf
604 " ix=%ld saweval=%d flags=%lu\n",
605 name, (long)newoff, (unsigned long)seq, PTR2UV(startcv),
606 (long)cx_ix, (int)saweval, (unsigned long)flags
610 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
611 AV *curlist = CvPADLIST(cv);
612 SV **svp = av_fetch(curlist, 0, FALSE);
615 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
616 " searching: cv=0x%"UVxf"\n", PTR2UV(cv))
619 if (!svp || *svp == &PL_sv_undef)
622 svp = AvARRAY(curname);
623 for (off = AvFILLp(curname); off > 0; off--) {
630 sv != &PL_sv_undef &&
631 seq <= (U32)SvIVX(sv) &&
632 seq > (U32)I_32(SvNVX(sv)) &&
633 strEQ(SvPVX(sv), name))
642 return 0; /* don't clone from inactive stack frame */
647 oldpad = (AV*)AvARRAY(curlist)[depth];
648 oldsv = *av_fetch(oldpad, off, TRUE);
650 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
651 " matched: offset %ld"
652 " %s(%lu,%lu), sv=0x%"UVxf"\n",
654 SvFAKE(sv) ? "FAKE " : "",
655 (unsigned long)I_32(SvNVX(sv)),
656 (unsigned long)SvIVX(sv),
661 if (!newoff) { /* Not a mere clone operation. */
662 newoff = pad_add_name(
664 (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
665 (SvFLAGS(sv) & SVpad_OUR) ? GvSTASH(sv) : Nullhv,
669 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
670 /* "It's closures all the way down." */
671 CvCLONE_on(PL_compcv);
673 if (CvANON(PL_compcv))
674 oldsv = Nullsv; /* no need to keep ref */
679 bcv && bcv != cv && !CvCLONE(bcv);
680 bcv = CvOUTSIDE(bcv))
683 /* install the missing pad entry in intervening
684 * nested subs and mark them cloneable. */
685 AV *ocomppad_name = PL_comppad_name;
686 PAD *ocomppad = PL_comppad;
687 AV *padlist = CvPADLIST(bcv);
688 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
689 PL_comppad = (AV*)AvARRAY(padlist)[1];
690 PL_curpad = AvARRAY(PL_comppad);
693 (SvFLAGS(sv) & SVpad_TYPED)
694 ? SvSTASH(sv) : Nullhv,
695 (SvFLAGS(sv) & SVpad_OUR)
696 ? GvSTASH(sv) : Nullhv,
700 PL_comppad_name = ocomppad_name;
701 PL_comppad = ocomppad;
702 PL_curpad = ocomppad ?
703 AvARRAY(ocomppad) : Null(SV **);
707 if (ckWARN(WARN_CLOSURE)
708 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
710 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
711 "Variable \"%s\" may be unavailable",
719 else if (!CvUNIQUE(PL_compcv)) {
720 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
721 && !(SvFLAGS(sv) & SVpad_OUR))
723 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
724 "Variable \"%s\" will not stay shared", name);
728 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
729 ASSERT_CURPAD_ACTIVE("pad_findlex 2");
730 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
731 "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
732 (long)newoff, PTR2UV(oldsv)
739 if (flags & FINDLEX_NOSEARCH)
742 /* Nothing in current lexical context--try eval's context, if any.
743 * This is necessary to let the perldb get at lexically scoped variables.
744 * XXX This will also probably interact badly with eval tree caching.
747 for (i = cx_ix; i >= 0; i--) {
749 switch (CxTYPE(cx)) {
751 if (i == 0 && saweval) {
752 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
756 switch (cx->blk_eval.old_op_type) {
758 if (CxREALEVAL(cx)) {
761 seq = cxstack[i].blk_oldcop->cop_seq;
762 startcv = cxstack[i].blk_eval.cv;
763 if (startcv && CvOUTSIDE(startcv)) {
764 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
766 if (off) /* continue looking if not found here */
773 /* require/do must have their own scope */
782 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
783 saweval = i; /* so we know where we were called from */
784 seq = cxstack[i].blk_oldcop->cop_seq;
787 return pad_findlex(name, newoff, seq, cv, i - 1, saweval, FINDLEX_NOSEARCH);
798 Get the value at offset po in the current pad.
799 Use macro PAD_SV instead of calling this function directly.
806 Perl_pad_sv(pTHX_ PADOFFSET po)
808 ASSERT_CURPAD_ACTIVE("pad_sv");
811 Perl_croak(aTHX_ "panic: pad_sv po");
812 DEBUG_X(PerlIO_printf(Perl_debug_log,
813 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
814 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
816 return PL_curpad[po];
821 =for apidoc pad_setsv
823 Set the entry at offset po in the current pad to sv.
824 Use the macro PAD_SETSV() rather than calling this function directly.
831 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
833 ASSERT_CURPAD_ACTIVE("pad_setsv");
835 DEBUG_X(PerlIO_printf(Perl_debug_log,
836 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
837 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
846 =for apidoc pad_block_start
848 Update the pad compilation state variables on entry to a new block
854 * - integrate this in general state-saving routine ???
855 * - combine with the state-saving going on in pad_new ???
856 * - introduce a new SAVE type that does all this in one go ?
860 Perl_pad_block_start(pTHX_ int full)
862 ASSERT_CURPAD_ACTIVE("pad_block_start");
863 SAVEI32(PL_comppad_name_floor);
864 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
866 PL_comppad_name_fill = PL_comppad_name_floor;
867 if (PL_comppad_name_floor < 0)
868 PL_comppad_name_floor = 0;
869 SAVEI32(PL_min_intro_pending);
870 SAVEI32(PL_max_intro_pending);
871 PL_min_intro_pending = 0;
872 SAVEI32(PL_comppad_name_fill);
873 SAVEI32(PL_padix_floor);
874 PL_padix_floor = PL_padix;
875 PL_pad_reset_pending = FALSE;
882 "Introduce" my variables to visible status.
894 ASSERT_CURPAD_ACTIVE("intro_my");
895 if (! PL_min_intro_pending)
896 return PL_cop_seqmax;
898 svp = AvARRAY(PL_comppad_name);
899 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
900 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
901 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
902 SvNVX(sv) = (NV)PL_cop_seqmax;
903 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
904 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
906 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
910 PL_min_intro_pending = 0;
911 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
912 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
913 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
915 return PL_cop_seqmax++;
919 =for apidoc pad_leavemy
921 Cleanup at end of scope during compilation: set the max seq number for
922 lexicals in this scope and warn of any lexicals that never got introduced.
928 Perl_pad_leavemy(pTHX)
931 SV **svp = AvARRAY(PL_comppad_name);
934 PL_pad_reset_pending = FALSE;
936 ASSERT_CURPAD_ACTIVE("pad_leavemy");
937 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
938 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
939 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
940 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
941 "%s never introduced", SvPVX(sv));
944 /* "Deintroduce" my variables that are leaving with this scope. */
945 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
946 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) {
947 SvIVX(sv) = PL_cop_seqmax;
948 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
949 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
950 (long)off, SvPVX(sv),
951 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
956 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
957 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
962 =for apidoc pad_swipe
964 Abandon the tmp in the current pad at offset po and replace with a
971 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
973 ASSERT_CURPAD_LEGAL("pad_swipe");
976 if (AvARRAY(PL_comppad) != PL_curpad)
977 Perl_croak(aTHX_ "panic: pad_swipe curpad");
979 Perl_croak(aTHX_ "panic: pad_swipe po");
981 DEBUG_X(PerlIO_printf(Perl_debug_log,
982 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
983 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
986 SvPADTMP_off(PL_curpad[po]);
988 SvREFCNT_dec(PL_curpad[po]);
990 PL_curpad[po] = NEWSV(1107,0);
991 SvPADTMP_on(PL_curpad[po]);
992 if ((I32)po < PL_padix)
998 =for apidoc pad_reset
1000 Mark all the current temporaries for reuse
1005 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1006 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1007 * on the stack by OPs that use them, there are several ways to get an alias
1008 * to a shared TARG. Such an alias will change randomly and unpredictably.
1009 * We avoid doing this until we can think of a Better Way.
1012 Perl_pad_reset(pTHX)
1014 #ifdef USE_BROKEN_PAD_RESET
1017 if (AvARRAY(PL_comppad) != PL_curpad)
1018 Perl_croak(aTHX_ "panic: pad_reset curpad");
1020 DEBUG_X(PerlIO_printf(Perl_debug_log,
1021 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1022 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1023 (long)PL_padix, (long)PL_padix_floor
1027 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1028 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1029 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1030 SvPADTMP_off(PL_curpad[po]);
1032 PL_padix = PL_padix_floor;
1035 PL_pad_reset_pending = FALSE;
1040 =for apidoc pad_tidy
1042 Tidy up a pad after we've finished compiling it:
1043 * remove most stuff from the pads of anonsub prototypes;
1045 * mark tmps as such.
1050 /* XXX DAPM surely most of this stuff should be done properly
1051 * at the right time beforehand, rather than going around afterwards
1052 * cleaning up our mistakes ???
1056 Perl_pad_tidy(pTHX_ padtidy_type type)
1060 ASSERT_CURPAD_ACTIVE("pad_tidy");
1061 /* extend curpad to match namepad */
1062 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1063 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1065 if (type == padtidy_SUBCLONE) {
1066 SV **namep = AvARRAY(PL_comppad_name);
1067 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1070 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1073 * The only things that a clonable function needs in its
1074 * pad are references to outer lexicals and anonymous subs.
1075 * The rest are created anew during cloning.
1077 if (!((namesv = namep[ix]) != Nullsv &&
1078 namesv != &PL_sv_undef &&
1080 *SvPVX(namesv) == '&')))
1082 SvREFCNT_dec(PL_curpad[ix]);
1083 PL_curpad[ix] = Nullsv;
1087 else if (type == padtidy_SUB) {
1088 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1089 AV *av = newAV(); /* Will be @_ */
1091 av_store(PL_comppad, 0, (SV*)av);
1092 AvFLAGS(av) = AVf_REIFY;
1095 /* XXX DAPM rationalise these two similar branches */
1097 if (type == padtidy_SUB) {
1098 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1099 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1101 if (!SvPADMY(PL_curpad[ix]))
1102 SvPADTMP_on(PL_curpad[ix]);
1105 else if (type == padtidy_FORMAT) {
1106 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1107 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1108 SvPADTMP_on(PL_curpad[ix]);
1111 PL_curpad = AvARRAY(PL_comppad);
1116 =for apidoc pad_free
1118 Free the SV at offet po in the current pad.
1123 /* XXX DAPM integrate with pad_swipe ???? */
1125 Perl_pad_free(pTHX_ PADOFFSET po)
1127 ASSERT_CURPAD_LEGAL("pad_free");
1130 if (AvARRAY(PL_comppad) != PL_curpad)
1131 Perl_croak(aTHX_ "panic: pad_free curpad");
1133 Perl_croak(aTHX_ "panic: pad_free po");
1135 DEBUG_X(PerlIO_printf(Perl_debug_log,
1136 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1137 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1140 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1141 SvPADTMP_off(PL_curpad[po]);
1143 #ifdef PERL_COPY_ON_WRITE
1144 if (SvIsCOW(PL_curpad[po])) {
1145 sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
1148 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
1152 if ((I32)po < PL_padix)
1159 =for apidoc do_dump_pad
1161 Dump the contents of a padlist
1167 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1179 pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1180 pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1181 pname = AvARRAY(pad_name);
1182 ppad = AvARRAY(pad);
1183 Perl_dump_indent(aTHX_ level, file,
1184 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1185 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1188 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1190 if (namesv && namesv == &PL_sv_undef) {
1194 Perl_dump_indent(aTHX_ level+1, file,
1195 "%2d. 0x%"UVxf"<%lu> %s (%lu,%lu) \"%s\"\n",
1198 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1199 SvFAKE(namesv) ? "FAKE" : " ",
1200 (unsigned long)I_32(SvNVX(namesv)),
1201 (unsigned long)SvIVX(namesv),
1206 Perl_dump_indent(aTHX_ level+1, file,
1207 "%2d. 0x%"UVxf"<%lu>\n",
1210 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1221 dump the contents of a CV
1228 S_cv_dump(pTHX_ CV *cv, char *title)
1230 CV *outside = CvOUTSIDE(cv);
1231 AV* padlist = CvPADLIST(cv);
1233 PerlIO_printf(Perl_debug_log,
1234 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1237 (CvANON(cv) ? "ANON"
1238 : (cv == PL_main_cv) ? "MAIN"
1239 : CvUNIQUE(cv) ? "UNIQUE"
1240 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1243 : CvANON(outside) ? "ANON"
1244 : (outside == PL_main_cv) ? "MAIN"
1245 : CvUNIQUE(outside) ? "UNIQUE"
1246 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1248 PerlIO_printf(Perl_debug_log,
1249 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1250 do_dump_pad(1, Perl_debug_log, padlist, 1);
1252 #endif /* DEBUGGING */
1259 =for apidoc cv_clone
1261 Clone a CV: make a new CV which points to the same code etc, but which
1262 has a newly-created pad built by copying the prototype pad and capturing
1269 Perl_cv_clone(pTHX_ CV *proto)
1273 LOCK_CRED_MUTEX; /* XXX create separate mutex */
1274 cv = cv_clone2(proto, CvOUTSIDE(proto));
1275 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
1280 /* XXX DAPM separate out cv and paddish bits ???
1281 * ideally the CV-related stuff shouldn't be in pad.c - how about
1285 S_cv_clone2(pTHX_ CV *proto, CV *outside)
1288 AV* protopadlist = CvPADLIST(proto);
1289 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1290 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1291 SV** pname = AvARRAY(protopad_name);
1292 SV** ppad = AvARRAY(protopad);
1293 I32 fname = AvFILLp(protopad_name);
1294 I32 fpad = AvFILLp(protopad);
1298 assert(!CvUNIQUE(proto));
1301 SAVESPTR(PL_compcv);
1303 cv = PL_compcv = (CV*)NEWSV(1104, 0);
1304 sv_upgrade((SV *)cv, SvTYPE(proto));
1305 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
1309 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
1310 : savepv(CvFILE(proto));
1312 CvFILE(cv) = CvFILE(proto);
1314 CvGV(cv) = CvGV(proto);
1315 CvSTASH(cv) = CvSTASH(proto);
1316 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1317 CvSTART(cv) = CvSTART(proto);
1319 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
1322 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1324 CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1326 for (ix = fname; ix >= 0; ix--)
1327 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1329 av_fill(PL_comppad, fpad);
1330 PL_curpad = AvARRAY(PL_comppad);
1332 for (ix = fpad; ix > 0; ix--) {
1333 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1334 if (namesv && namesv != &PL_sv_undef) {
1335 char *name = SvPVX(namesv); /* XXX */
1336 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
1337 I32 off = pad_findlex(name, ix, SvIVX(namesv),
1338 CvOUTSIDE(cv), cxstack_ix, 0, 0);
1340 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1342 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
1344 else { /* our own lexical */
1347 /* anon code -- we'll come back for it */
1348 sv = SvREFCNT_inc(ppad[ix]);
1350 else if (*name == '@')
1352 else if (*name == '%')
1361 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1362 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1365 SV* sv = NEWSV(0, 0);
1371 /* Now that vars are all in place, clone nested closures. */
1373 for (ix = fpad; ix > 0; ix--) {
1374 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1376 && namesv != &PL_sv_undef
1377 && !(SvFLAGS(namesv) & SVf_FAKE)
1378 && *SvPVX(namesv) == '&'
1379 && CvCLONE(ppad[ix]))
1381 CV *kid = cv_clone2((CV*)ppad[ix], cv);
1382 SvREFCNT_dec(ppad[ix]);
1385 PL_curpad[ix] = (SV*)kid;
1390 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1391 cv_dump(outside, "Outside");
1392 cv_dump(proto, "Proto");
1399 SV* const_sv = op_const_sv(CvSTART(cv), cv);
1401 /* constant sub () { $x } closing over $x - see lib/constant.pm */
1403 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1411 =for apidoc pad_fixup_inner_anons
1413 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1414 old_cv to new_cv if necessary.
1420 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1423 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1424 AV *comppad = (AV*)AvARRAY(padlist)[1];
1425 SV **namepad = AvARRAY(comppad_name);
1426 SV **curpad = AvARRAY(comppad);
1427 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1428 SV *namesv = namepad[ix];
1429 if (namesv && namesv != &PL_sv_undef
1430 && *SvPVX(namesv) == '&')
1432 CV *innercv = (CV*)curpad[ix];
1433 if (CvOUTSIDE(innercv) == old_cv) {
1434 CvOUTSIDE(innercv) = new_cv;
1435 if (!CvANON(innercv) || CvCLONED(innercv)) {
1436 (void)SvREFCNT_inc(new_cv);
1437 SvREFCNT_dec(old_cv);
1445 =for apidoc pad_push
1447 Push a new pad frame onto the padlist, unless there's already a pad at
1448 this depth, in which case don't bother creating a new one.
1449 If has_args is true, give the new pad an @_ in slot zero.
1455 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1457 if (depth <= AvFILLp(padlist))
1461 SV** svp = AvARRAY(padlist);
1462 AV *newpad = newAV();
1463 SV **oldpad = AvARRAY(svp[depth-1]);
1464 I32 ix = AvFILLp((AV*)svp[1]);
1465 I32 names_fill = AvFILLp((AV*)svp[0]);
1466 SV** names = AvARRAY(svp[0]);
1468 for ( ;ix > 0; ix--) {
1469 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1470 char *name = SvPVX(names[ix]);
1471 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1472 /* outer lexical or anon code */
1473 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1475 else { /* our own lexical */
1477 av_store(newpad, ix, sv = (SV*)newAV());
1478 else if (*name == '%')
1479 av_store(newpad, ix, sv = (SV*)newHV());
1481 av_store(newpad, ix, sv = NEWSV(0, 0));
1485 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1486 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1489 /* save temporaries on recursion? */
1490 av_store(newpad, ix, sv = NEWSV(0, 0));
1497 av_store(newpad, 0, (SV*)av);
1498 AvFLAGS(av) = AVf_REIFY;
1500 av_store(padlist, depth, (SV*)newpad);
1501 AvFILLp(padlist) = depth;