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 #ifdef USE_5005THREADS
156 av_store(padname, 0, newSVpvn("@_", 2));
158 SvPADMY_on((SV*)a0); /* XXX Needed? */
159 av_store(pad, 0, (SV*)a0);
161 av_store(pad, 0, Nullsv);
162 #endif /* USE_THREADS */
166 av_store(padlist, 0, (SV*)padname);
167 av_store(padlist, 1, (SV*)pad);
169 /* ... then update state variables */
171 PL_comppad_name = (AV*)(*av_fetch(padlist, 0, FALSE));
172 PL_comppad = (AV*)(*av_fetch(padlist, 1, FALSE));
173 PL_curpad = AvARRAY(PL_comppad);
175 if (! (flags & padnew_CLONE)) {
176 PL_comppad_name_fill = 0;
177 PL_min_intro_pending = 0;
181 DEBUG_X(PerlIO_printf(Perl_debug_log,
182 "Pad 0x%"UVxf"[0x%"UVxf"] new: padlist=0x%"UVxf
183 " name=0x%"UVxf" flags=0x%"UVxf"\n",
184 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(padlist),
185 PTR2UV(padname), (UV)flags
189 return (PADLIST*)padlist;
193 =for apidoc pad_undef
195 Free the padlist associated with a CV.
196 If parts of it happen to be current, we null the relevant
197 PL_*pad* global vars so that we don't have any dangling references left.
198 We also repoint the CvOUTSIDE of any about-to-be-orphaned
199 inner subs to outercv.
205 Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
208 PADLIST *padlist = CvPADLIST(cv);
212 if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
215 DEBUG_X(PerlIO_printf(Perl_debug_log,
216 "Pad undef: padlist=0x%"UVxf"\n" , PTR2UV(padlist))
219 /* pads may be cleared out already during global destruction */
220 if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
221 && !PL_dirty) || CvSPECIAL(cv))
223 /* XXX DAPM the following code is very similar to
224 * pad_fixup_inner_anons(). Merge??? */
226 /* inner references to eval's cv must be fixed up */
227 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
228 SV **namepad = AvARRAY(comppad_name);
229 AV *comppad = (AV*)AvARRAY(padlist)[1];
230 SV **curpad = AvARRAY(comppad);
231 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
232 SV *namesv = namepad[ix];
233 if (namesv && namesv != &PL_sv_undef
234 && *SvPVX(namesv) == '&'
235 && ix <= AvFILLp(comppad))
237 CV *innercv = (CV*)curpad[ix];
238 if (innercv && SvTYPE(innercv) == SVt_PVCV
239 && CvOUTSIDE(innercv) == cv)
241 CvOUTSIDE(innercv) = outercv;
242 if (!CvANON(innercv) || CvCLONED(innercv)) {
243 (void)SvREFCNT_inc(outercv);
251 ix = AvFILLp(padlist);
253 SV* sv = AvARRAY(padlist)[ix--];
256 if (sv == (SV*)PL_comppad_name)
257 PL_comppad_name = Nullav;
258 else if (sv == (SV*)PL_comppad) {
260 PL_curpad = Null(SV**);
264 SvREFCNT_dec((SV*)CvPADLIST(cv));
265 CvPADLIST(cv) = Null(PADLIST*);
272 =for apidoc pad_add_name
274 Create a new name in the current pad at the specified offset.
275 If C<typestash> is valid, the name is for a typed lexical; set the
276 name's stash to that value.
277 If C<ourstash> is valid, it's an our lexical, set the name's
278 GvSTASH to that value
280 Also, if the name is @.. or %.., create a new array or hash for that slot
282 If fake, it means we're cloning an existing entry
288 * XXX DAPM this doesn't seem the right place to create a new array/hash.
289 * Whatever we do, we should be consistent - create scalars too, and
290 * create even if fake. Really need to integrate better the whole entry
291 * creation business - when + where does the name and value get created?
295 Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
297 PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
298 SV* namesv = NEWSV(1102, 0);
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;
340 av_store(PL_comppad, offset, (SV*)newAV());
341 else if (*name == '%')
342 av_store(PL_comppad, offset, (SV*)newHV());
343 SvPADMY_on(PL_curpad[offset]);
353 =for apidoc pad_alloc
355 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
356 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
357 for a slot which has no name and and no active value.
362 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
363 * or at least rationalise ??? */
367 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
372 if (AvARRAY(PL_comppad) != PL_curpad)
373 Perl_croak(aTHX_ "panic: pad_alloc");
374 if (PL_pad_reset_pending)
376 if (tmptype & SVs_PADMY) {
378 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
379 } while (SvPADBUSY(sv)); /* need a fresh one */
380 retval = AvFILLp(PL_comppad);
383 SV **names = AvARRAY(PL_comppad_name);
384 SSize_t names_fill = AvFILLp(PL_comppad_name);
387 * "foreach" index vars temporarily become aliases to non-"my"
388 * values. Thus we must skip, not just pad values that are
389 * marked as current pad values, but also those with names.
391 /* HVDS why copy to sv here? we don't seem to use it */
392 if (++PL_padix <= names_fill &&
393 (sv = names[PL_padix]) && sv != &PL_sv_undef)
395 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
396 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
397 !IS_PADGV(sv) && !IS_PADCONST(sv))
402 SvFLAGS(sv) |= tmptype;
403 PL_curpad = AvARRAY(PL_comppad);
405 DEBUG_X(PerlIO_printf(Perl_debug_log,
406 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
407 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
408 PL_op_name[optype]));
409 return (PADOFFSET)retval;
413 =for apidoc pad_add_anon
415 Add an anon code entry to the current compiling pad
421 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
426 name = NEWSV(1106, 0);
427 sv_upgrade(name, SVt_PVNV);
428 sv_setpvn(name, "&", 1);
431 ix = pad_alloc(op_type, SVs_PADMY);
432 av_store(PL_comppad_name, ix, name);
433 av_store(PL_comppad, ix, sv);
441 =for apidoc pad_check_dup
443 Check for duplicate declarations: report any of:
444 * a my in the current scope with the same name;
445 * an our (anywhere in the pad) with the same name and the same stash
447 C<is_our> indicates that the name to check is an 'our' declaration
452 /* XXX DAPM integrate this into pad_add_name ??? */
455 Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
460 if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
461 return; /* nothing to check */
463 svp = AvARRAY(PL_comppad_name);
464 top = AvFILLp(PL_comppad_name);
465 /* check the current scope */
466 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
468 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
470 && sv != &PL_sv_undef
471 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
473 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
474 && strEQ(name, SvPVX(sv)))
476 Perl_warner(aTHX_ packWARN(WARN_MISC),
477 "\"%s\" variable %s masks earlier declaration in same %s",
478 (is_our ? "our" : "my"),
480 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
485 /* check the rest of the pad */
489 && sv != &PL_sv_undef
490 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
491 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
492 && strEQ(name, SvPVX(sv)))
494 Perl_warner(aTHX_ packWARN(WARN_MISC),
495 "\"our\" variable %s redeclared", name);
496 Perl_warner(aTHX_ packWARN(WARN_MISC),
497 "\t(Did you mean \"local\" instead of \"our\"?)\n");
500 } while ( off-- > 0 );
507 =for apidoc pad_findmy
509 Given a lexical name, try to find its offset, first in the current pad,
510 or failing that, in the pads of any lexically enclosing subs (including
511 the complications introduced by eval). If the name is found in an outer pad,
512 then a fake entry is added to the current pad.
513 Returns the offset in the current pad, or NOT_IN_PAD on failure.
519 Perl_pad_findmy(pTHX_ char *name)
524 SV **svp = AvARRAY(PL_comppad_name);
525 U32 seq = PL_cop_seqmax;
529 DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy: \"%s\"\n", name));
531 #ifdef USE_5005THREADS
533 * Special case to get lexical (and hence per-thread) @_.
534 * XXX I need to find out how to tell at parse-time whether use
535 * of @_ should refer to a lexical (from a sub) or defgv (global
536 * scope and maybe weird sub-ish things like formats). See
537 * startsub in perly.y. It's possible that @_ could be lexical
538 * (at least from subs) even in non-threaded perl.
540 if (strEQ(name, "@_"))
541 return 0; /* success. (NOT_IN_PAD indicates failure) */
542 #endif /* USE_5005THREADS */
544 /* The one we're looking for is probably just before comppad_name_fill. */
545 for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
546 if ((sv = svp[off]) &&
547 sv != &PL_sv_undef &&
549 (seq <= (U32)SvIVX(sv) &&
550 seq > (U32)I_32(SvNVX(sv)))) &&
551 strEQ(SvPVX(sv), name))
553 if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
554 return (PADOFFSET)off;
555 pendoff = off; /* this pending def. will override import */
559 outside = CvOUTSIDE(PL_compcv);
561 /* Check if if we're compiling an eval'', and adjust seq to be the
562 * eval's seq number. This depends on eval'' having a non-null
563 * CvOUTSIDE() while it is being compiled. The eval'' itself is
564 * identified by CvEVAL being true and CvGV being null. */
565 if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
566 cx = &cxstack[cxstack_ix];
568 seq = cx->blk_oldcop->cop_seq;
571 /* See if it's in a nested scope */
572 off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
573 if (!off) /* pad_findlex returns 0 for failure...*/
574 return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
576 /* If there is a pending local definition, this new alias must die */
578 SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
585 =for apidoc pad_findlex
587 Find a named lexical anywhere in a chain of nested pads. Add fake entries
588 in the inner pads if its found in an outer one.
590 If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts.
595 #define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
598 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
599 I32 cx_ix, I32 saweval, U32 flags)
605 register PERL_CONTEXT *cx;
607 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
608 "Pad findlex: \"%s\" off=%ld seq=%lu cv=0x%"UVxf
609 " ix=%ld saweval=%d flags=%lu\n",
610 name, (long)newoff, (unsigned long)seq, PTR2UV(startcv),
611 (long)cx_ix, (int)saweval, (unsigned long)flags
615 for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
616 AV *curlist = CvPADLIST(cv);
617 SV **svp = av_fetch(curlist, 0, FALSE);
620 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
621 " searching: cv=0x%"UVxf"\n", PTR2UV(cv))
624 if (!svp || *svp == &PL_sv_undef)
627 svp = AvARRAY(curname);
628 for (off = AvFILLp(curname); off > 0; off--) {
635 sv != &PL_sv_undef &&
636 seq <= (U32)SvIVX(sv) &&
637 seq > (U32)I_32(SvNVX(sv)) &&
638 strEQ(SvPVX(sv), name))
647 return 0; /* don't clone from inactive stack frame */
652 oldpad = (AV*)AvARRAY(curlist)[depth];
653 oldsv = *av_fetch(oldpad, off, TRUE);
655 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
656 " matched: offset %ld"
657 " %s(%lu,%lu), sv=0x%"UVxf"\n",
659 SvFAKE(sv) ? "FAKE " : "",
660 (unsigned long)I_32(SvNVX(sv)),
661 (unsigned long)SvIVX(sv),
666 if (!newoff) { /* Not a mere clone operation. */
667 newoff = pad_add_name(
669 (SvFLAGS(sv) & SVpad_TYPED) ? SvSTASH(sv) : Nullhv,
670 (SvFLAGS(sv) & SVpad_OUR) ? GvSTASH(sv) : Nullhv,
674 if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
675 /* "It's closures all the way down." */
676 CvCLONE_on(PL_compcv);
678 if (CvANON(PL_compcv))
679 oldsv = Nullsv; /* no need to keep ref */
684 bcv && bcv != cv && !CvCLONE(bcv);
685 bcv = CvOUTSIDE(bcv))
688 /* install the missing pad entry in intervening
689 * nested subs and mark them cloneable. */
690 AV *ocomppad_name = PL_comppad_name;
691 AV *ocomppad = PL_comppad;
692 SV **ocurpad = PL_curpad;
693 AV *padlist = CvPADLIST(bcv);
694 PL_comppad_name = (AV*)AvARRAY(padlist)[0];
695 PL_comppad = (AV*)AvARRAY(padlist)[1];
696 PL_curpad = AvARRAY(PL_comppad);
699 (SvFLAGS(sv) & SVpad_TYPED)
700 ? SvSTASH(sv) : Nullhv,
701 (SvFLAGS(sv) & SVpad_OUR)
702 ? GvSTASH(sv) : Nullhv,
706 PL_comppad_name = ocomppad_name;
707 PL_comppad = ocomppad;
712 if (ckWARN(WARN_CLOSURE)
713 && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
715 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
716 "Variable \"%s\" may be unavailable",
724 else if (!CvUNIQUE(PL_compcv)) {
725 if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
726 && !(SvFLAGS(sv) & SVpad_OUR))
728 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
729 "Variable \"%s\" will not stay shared", name);
733 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
734 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
735 "Pad findlex: set offset %ld to sv 0x%"UVxf"\n",
736 (long)newoff, PTR2UV(oldsv)
743 if (flags & FINDLEX_NOSEARCH)
746 /* Nothing in current lexical context--try eval's context, if any.
747 * This is necessary to let the perldb get at lexically scoped variables.
748 * XXX This will also probably interact badly with eval tree caching.
751 for (i = cx_ix; i >= 0; i--) {
753 switch (CxTYPE(cx)) {
755 if (i == 0 && saweval) {
756 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
760 switch (cx->blk_eval.old_op_type) {
762 if (CxREALEVAL(cx)) {
765 seq = cxstack[i].blk_oldcop->cop_seq;
766 startcv = cxstack[i].blk_eval.cv;
767 if (startcv && CvOUTSIDE(startcv)) {
768 off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
770 if (off) /* continue looking if not found here */
777 /* require/do must have their own scope */
786 if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
787 saweval = i; /* so we know where we were called from */
788 seq = cxstack[i].blk_oldcop->cop_seq;
791 return pad_findlex(name, newoff, seq, cv, i - 1, saweval, FINDLEX_NOSEARCH);
802 Get the value at offset po in the current pad.
803 Use macro PAD_SV instead of calling this function directly.
810 Perl_pad_sv(pTHX_ PADOFFSET po)
813 /* for display purposes, try to guess the AV corresponding to
816 if (cp && AvARRAY(cp) != PL_curpad)
820 #ifndef USE_5005THREADS
822 Perl_croak(aTHX_ "panic: pad_sv po");
824 DEBUG_X(PerlIO_printf(Perl_debug_log,
825 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
826 PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
828 return PL_curpad[po];
833 =for apidoc pad_setsv
835 Set the entry at offset po in the current pad to sv.
836 Use the macro PAD_SETSV() rather than calling this function directly.
843 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
845 /* for display purposes, try to guess the AV corresponding to
848 if (cp && AvARRAY(cp) != PL_curpad)
851 DEBUG_X(PerlIO_printf(Perl_debug_log,
852 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
853 PTR2UV(cp), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
862 =for apidoc pad_block_start
864 Update the pad compilation state variables on entry to a new block
870 * - integrate this in general state-saving routine ???
871 * - combine with the state-saving going on in pad_new ???
872 * - introduce a new SAVE type that does all this in one go ?
876 Perl_pad_block_start(pTHX_ int full)
878 SAVEI32(PL_comppad_name_floor);
879 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
881 PL_comppad_name_fill = PL_comppad_name_floor;
882 if (PL_comppad_name_floor < 0)
883 PL_comppad_name_floor = 0;
884 SAVEI32(PL_min_intro_pending);
885 SAVEI32(PL_max_intro_pending);
886 PL_min_intro_pending = 0;
887 SAVEI32(PL_comppad_name_fill);
888 SAVEI32(PL_padix_floor);
889 PL_padix_floor = PL_padix;
890 PL_pad_reset_pending = FALSE;
897 "Introduce" my variables to visible status.
909 if (! PL_min_intro_pending)
910 return PL_cop_seqmax;
912 svp = AvARRAY(PL_comppad_name);
913 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
914 if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
915 SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
916 SvNVX(sv) = (NV)PL_cop_seqmax;
917 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
918 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
920 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
924 PL_min_intro_pending = 0;
925 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
926 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
927 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
929 return PL_cop_seqmax++;
933 =for apidoc pad_leavemy
935 Cleanup at end of scope during compilation: set the max seq number for
936 lexicals in this scope and warn of any lexicals that never got introduced.
942 Perl_pad_leavemy(pTHX)
945 SV **svp = AvARRAY(PL_comppad_name);
948 PL_pad_reset_pending = FALSE;
950 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
951 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
952 if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
953 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
954 "%s never introduced", SvPVX(sv));
957 /* "Deintroduce" my variables that are leaving with this scope. */
958 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
959 if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) {
960 SvIVX(sv) = PL_cop_seqmax;
961 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
962 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
963 (long)off, SvPVX(sv),
964 (unsigned long)I_32(SvNVX(sv)), (unsigned long)SvIVX(sv))
969 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
970 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
975 =for apidoc pad_swipe
977 Abandon the tmp in the current pad at offset po and replace with a
984 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
988 if (AvARRAY(PL_comppad) != PL_curpad)
989 Perl_croak(aTHX_ "panic: pad_swipe curpad");
991 Perl_croak(aTHX_ "panic: pad_swipe po");
993 DEBUG_X(PerlIO_printf(Perl_debug_log,
994 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
995 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
998 SvPADTMP_off(PL_curpad[po]);
1000 SvREFCNT_dec(PL_curpad[po]);
1002 PL_curpad[po] = NEWSV(1107,0);
1003 SvPADTMP_on(PL_curpad[po]);
1004 if ((I32)po < PL_padix)
1010 =for apidoc pad_reset
1012 Mark all the current temporaries for reuse
1017 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1018 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1019 * on the stack by OPs that use them, there are several ways to get an alias
1020 * to a shared TARG. Such an alias will change randomly and unpredictably.
1021 * We avoid doing this until we can think of a Better Way.
1024 Perl_pad_reset(pTHX)
1026 #ifdef USE_BROKEN_PAD_RESET
1029 if (AvARRAY(PL_comppad) != PL_curpad)
1030 Perl_croak(aTHX_ "panic: pad_reset curpad");
1032 DEBUG_X(PerlIO_printf(Perl_debug_log,
1033 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1034 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1035 (long)PL_padix, (long)PL_padix_floor
1039 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1040 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1041 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1042 SvPADTMP_off(PL_curpad[po]);
1044 PL_padix = PL_padix_floor;
1047 PL_pad_reset_pending = FALSE;
1052 =for apidoc pad_tidy
1054 Tidy up a pad after we've finished compiling it:
1055 * remove most stuff from the pads of anonsub prototypes;
1057 * mark tmps as such.
1062 /* XXX DAPM surely most of this stuff should be done properly
1063 * at the right time beforehand, rather than going around afterwards
1064 * cleaning up our mistakes ???
1068 Perl_pad_tidy(pTHX_ padtidy_type type)
1072 /* extend curpad to match namepad */
1073 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1074 av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1076 if (type == padtidy_SUBCLONE) {
1077 SV **namep = AvARRAY(PL_comppad_name);
1078 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1081 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1084 * The only things that a clonable function needs in its
1085 * pad are references to outer lexicals and anonymous subs.
1086 * The rest are created anew during cloning.
1088 if (!((namesv = namep[ix]) != Nullsv &&
1089 namesv != &PL_sv_undef &&
1091 *SvPVX(namesv) == '&')))
1093 SvREFCNT_dec(PL_curpad[ix]);
1094 PL_curpad[ix] = Nullsv;
1098 else if (type == padtidy_SUB) {
1099 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1100 AV *av = newAV(); /* Will be @_ */
1102 av_store(PL_comppad, 0, (SV*)av);
1103 AvFLAGS(av) = AVf_REIFY;
1106 /* XXX DAPM rationalise these two similar branches */
1108 if (type == padtidy_SUB) {
1109 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1110 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1112 if (!SvPADMY(PL_curpad[ix]))
1113 SvPADTMP_on(PL_curpad[ix]);
1116 else if (type == padtidy_FORMAT) {
1117 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1118 if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1119 SvPADTMP_on(PL_curpad[ix]);
1126 =for apidoc pad_free
1128 Free the SV at offet po in the current pad.
1133 /* XXX DAPM integrate with pad_swipe ???? */
1135 Perl_pad_free(pTHX_ PADOFFSET po)
1139 if (AvARRAY(PL_comppad) != PL_curpad)
1140 Perl_croak(aTHX_ "panic: pad_free curpad");
1142 Perl_croak(aTHX_ "panic: pad_free po");
1144 DEBUG_X(PerlIO_printf(Perl_debug_log,
1145 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1146 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1149 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1150 SvPADTMP_off(PL_curpad[po]);
1152 #ifdef PERL_COPY_ON_WRITE
1153 if (SvIsCOW(PL_curpad[po])) {
1154 sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
1157 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
1161 if ((I32)po < PL_padix)
1168 =for apidoc do_dump_pad
1170 Dump the contents of a padlist
1176 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1188 pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1189 pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1190 pname = AvARRAY(pad_name);
1191 ppad = AvARRAY(pad);
1192 Perl_dump_indent(aTHX_ level, file,
1193 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1194 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1197 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1199 if (namesv && namesv == &PL_sv_undef) {
1203 Perl_dump_indent(aTHX_ level+1, file,
1204 "%2d. 0x%"UVxf"<%lu> %s (%lu,%lu) \"%s\"\n",
1207 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1208 SvFAKE(namesv) ? "FAKE" : " ",
1209 (unsigned long)I_32(SvNVX(namesv)),
1210 (unsigned long)SvIVX(namesv),
1215 Perl_dump_indent(aTHX_ level+1, file,
1216 "%2d. 0x%"UVxf"<%lu>\n",
1219 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1230 dump the contents of a CV
1237 S_cv_dump(pTHX_ CV *cv, char *title)
1239 CV *outside = CvOUTSIDE(cv);
1240 AV* padlist = CvPADLIST(cv);
1242 PerlIO_printf(Perl_debug_log,
1243 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1246 (CvANON(cv) ? "ANON"
1247 : (cv == PL_main_cv) ? "MAIN"
1248 : CvUNIQUE(cv) ? "UNIQUE"
1249 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1252 : CvANON(outside) ? "ANON"
1253 : (outside == PL_main_cv) ? "MAIN"
1254 : CvUNIQUE(outside) ? "UNIQUE"
1255 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1257 PerlIO_printf(Perl_debug_log,
1258 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1259 do_dump_pad(1, Perl_debug_log, padlist, 1);
1261 #endif /* DEBUGGING */
1268 =for apidoc cv_clone
1270 Clone a CV: make a new CV which points to the same code etc, but which
1271 has a newly-created pad built by copying the prototype pad and capturing
1278 Perl_cv_clone(pTHX_ CV *proto)
1282 LOCK_CRED_MUTEX; /* XXX create separate mutex */
1283 cv = cv_clone2(proto, CvOUTSIDE(proto));
1284 UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
1289 /* XXX DAPM separate out cv and paddish bits ???
1290 * ideally the CV-related stuff shouldn't be in pad.c - how about
1294 S_cv_clone2(pTHX_ CV *proto, CV *outside)
1297 AV* protopadlist = CvPADLIST(proto);
1298 AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1299 AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1300 SV** pname = AvARRAY(protopad_name);
1301 SV** ppad = AvARRAY(protopad);
1302 I32 fname = AvFILLp(protopad_name);
1303 I32 fpad = AvFILLp(protopad);
1307 assert(!CvUNIQUE(proto));
1310 SAVESPTR(PL_compcv);
1312 cv = PL_compcv = (CV*)NEWSV(1104, 0);
1313 sv_upgrade((SV *)cv, SvTYPE(proto));
1314 CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
1317 #ifdef USE_5005THREADS
1318 New(666, CvMUTEXP(cv), 1, perl_mutex);
1319 MUTEX_INIT(CvMUTEXP(cv));
1321 #endif /* USE_5005THREADS */
1323 CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
1324 : savepv(CvFILE(proto));
1326 CvFILE(cv) = CvFILE(proto);
1328 CvGV(cv) = CvGV(proto);
1329 CvSTASH(cv) = CvSTASH(proto);
1330 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1331 CvSTART(cv) = CvSTART(proto);
1333 CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
1336 sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1338 CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1340 for (ix = fname; ix >= 0; ix--)
1341 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1343 av_fill(PL_comppad, fpad);
1344 PL_curpad = AvARRAY(PL_comppad);
1346 for (ix = fpad; ix > 0; ix--) {
1347 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1348 if (namesv && namesv != &PL_sv_undef) {
1349 char *name = SvPVX(namesv); /* XXX */
1350 if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
1351 I32 off = pad_findlex(name, ix, SvIVX(namesv),
1352 CvOUTSIDE(cv), cxstack_ix, 0, 0);
1354 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1356 Perl_croak(aTHX_ "panic: cv_clone: %s", name);
1358 else { /* our own lexical */
1361 /* anon code -- we'll come back for it */
1362 sv = SvREFCNT_inc(ppad[ix]);
1364 else if (*name == '@')
1366 else if (*name == '%')
1375 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1376 PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
1379 SV* sv = NEWSV(0, 0);
1385 /* Now that vars are all in place, clone nested closures. */
1387 for (ix = fpad; ix > 0; ix--) {
1388 SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1390 && namesv != &PL_sv_undef
1391 && !(SvFLAGS(namesv) & SVf_FAKE)
1392 && *SvPVX(namesv) == '&'
1393 && CvCLONE(ppad[ix]))
1395 CV *kid = cv_clone2((CV*)ppad[ix], cv);
1396 SvREFCNT_dec(ppad[ix]);
1399 PL_curpad[ix] = (SV*)kid;
1404 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1405 cv_dump(outside, "Outside");
1406 cv_dump(proto, "Proto");
1413 SV* const_sv = op_const_sv(CvSTART(cv), cv);
1415 /* constant sub () { $x } closing over $x - see lib/constant.pm */
1417 cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1425 =for apidoc pad_fixup_inner_anons
1427 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1428 old_cv to new_cv if necessary.
1434 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1437 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1438 AV *comppad = (AV*)AvARRAY(padlist)[1];
1439 SV **namepad = AvARRAY(comppad_name);
1440 SV **curpad = AvARRAY(comppad);
1441 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1442 SV *namesv = namepad[ix];
1443 if (namesv && namesv != &PL_sv_undef
1444 && *SvPVX(namesv) == '&')
1446 CV *innercv = (CV*)curpad[ix];
1447 if (CvOUTSIDE(innercv) == old_cv) {
1448 CvOUTSIDE(innercv) = new_cv;
1449 if (!CvANON(innercv) || CvCLONED(innercv)) {
1450 (void)SvREFCNT_inc(new_cv);
1451 SvREFCNT_dec(old_cv);
1459 =for apidoc pad_push
1461 Push a new pad frame onto the padlist, unless there's already a pad at
1462 this depth, in which case don't bother creating a new one.
1463 If has_args is true, give the new pad an @_ in slot zero.
1469 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1471 if (depth <= AvFILLp(padlist))
1475 SV** svp = AvARRAY(padlist);
1476 AV *newpad = newAV();
1477 SV **oldpad = AvARRAY(svp[depth-1]);
1478 I32 ix = AvFILLp((AV*)svp[1]);
1479 I32 names_fill = AvFILLp((AV*)svp[0]);
1480 SV** names = AvARRAY(svp[0]);
1482 for ( ;ix > 0; ix--) {
1483 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1484 char *name = SvPVX(names[ix]);
1485 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1486 /* outer lexical or anon code */
1487 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1489 else { /* our own lexical */
1491 av_store(newpad, ix, sv = (SV*)newAV());
1492 else if (*name == '%')
1493 av_store(newpad, ix, sv = (SV*)newHV());
1495 av_store(newpad, ix, sv = NEWSV(0, 0));
1499 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1500 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1503 /* save temporaries on recursion? */
1504 av_store(newpad, ix, sv = NEWSV(0, 0));
1511 av_store(newpad, 0, (SV*)av);
1512 AvFLAGS(av) = AVf_REIFY;
1514 av_store(padlist, depth, (SV*)newpad);
1515 AvFILLp(padlist) = depth;