3 * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 * by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
11 * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12 * might say, among those queer Bucklanders, being brought up anyhow in
13 * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
14 * never had fewer than a couple of hundred relations in the place.
15 * Mr. Bilbo never did a kinder deed than when he brought the lad back
16 * to live among decent folk.' --the Gaffer
18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 * As of Sept 2002, this file is new and may be in a state of flux for
23 * a while. I've marked things I intent to come back and look at further
24 * with an 'XXX DAPM' comment.
28 =head1 Pad Data Structures
30 This file contains the functions that create and manipulate scratchpads,
31 which are array-of-array data structures attached to a CV (ie a sub)
32 and which store lexical variables and opcode temporary and per-thread
35 =for apidoc m|AV *|CvPADLIST|CV *cv
36 CV's can have CvPADLIST(cv) set to point to an AV.
38 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
39 not callable at will and are always thrown away after the eval"" is done
40 executing). Require'd files are simply evals without any outer lexical
43 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
44 but that is really the callers pad (a slot of which is allocated by
47 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
48 is managed "manual" (mostly in pad.c) rather than normal av.c rules.
49 The items in the AV are not SVs as for a normal AV, but other AVs:
51 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
52 the "static type information" for lexicals.
54 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
55 depth of recursion into the CV.
56 The 0'th slot of a frame AV is an AV which is @_.
57 other entries are storage for variables and op targets.
60 C<PL_comppad_name> is set to the names AV.
61 C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
62 C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
64 During execution, C<PL_comppad> and C<PL_curpad> refer to the live
65 frame of the currently executing sub.
67 Iterating over the names AV iterates over all possible pad
68 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
69 &PL_sv_undef "names" (see pad_alloc()).
71 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
72 The rest are op targets/GVs/constants which are statically allocated
73 or resolved at compile time. These don't have names by which they
74 can be looked up from Perl code at run time through eval"" like
75 my/our variables can be. Since they can't be looked up by "name"
76 but only by their index allocated at compile time (which is usually
77 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
79 The SVs in the names AV have their PV being the name of the variable.
80 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
81 which the name is valid. For typed lexicals name SV is SVt_PVMG and SvSTASH
82 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
83 SvOURSTASH slot pointing at the stash of the associated global (so that
84 duplicate C<our> declarations in the same package can be detected). SvUVX is
85 sometimes hijacked to store the generation number during compilation.
87 If SvFAKE is set on the name SV, then that slot in the frame AV is
88 a REFCNT'ed reference to a lexical from "outside". In this case,
89 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
90 in scope throughout. Instead xhigh stores some flags containing info about
91 the real lexical (is it declared in an anon, and is it capable of being
92 instantiated multiple times?), and for fake ANONs, xlow contains the index
93 within the parent's pad where the lexical's value is stored, to make
96 If the 'name' is '&' the corresponding entry in frame AV
97 is a CV representing a possible closure.
98 (SvFAKE and name of '&' is not a meaningful combination currently but could
99 become so if C<my sub foo {}> is implemented.)
101 Note that formats are treated as anon subs, and are cloned each time
102 write is called (if necessary).
104 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
105 and set on scope exit. This allows the 'Variable $x is not available' warning
106 to be generated in evals, such as
108 { my $x = 1; sub f { eval '$x'} } f();
110 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
117 #define PERL_IN_PAD_C
119 #include "keywords.h"
121 #define COP_SEQ_RANGE_LOW_set(sv,val) \
122 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
123 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
124 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
126 #define PARENT_PAD_INDEX_set(sv,val) \
127 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
128 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
129 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
132 void pad_peg(const char* s) {
133 static int pegcnt; /* XXX not threadsafe */
136 PERL_ARGS_ASSERT_PAD_PEG;
145 Create a new compiling padlist, saving and updating the various global
146 vars at the same time as creating the pad itself. The following flags
147 can be OR'ed together:
149 padnew_CLONE this pad is for a cloned CV
150 padnew_SAVE save old globals
151 padnew_SAVESUB also save extra stuff for start of sub
157 Perl_pad_new(pTHX_ int flags)
160 AV *padlist, *padname, *pad;
163 ASSERT_CURPAD_LEGAL("pad_new");
165 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
166 * vars (based on flags) rather than storing vals + addresses for
167 * each individually. Also see pad_block_start.
168 * XXX DAPM Try to see whether all these conditionals are required
171 /* save existing state, ... */
173 if (flags & padnew_SAVE) {
175 SAVESPTR(PL_comppad_name);
176 if (! (flags & padnew_CLONE)) {
178 SAVEI32(PL_comppad_name_fill);
179 SAVEI32(PL_min_intro_pending);
180 SAVEI32(PL_max_intro_pending);
181 SAVEBOOL(PL_cv_has_eval);
182 if (flags & padnew_SAVESUB) {
183 SAVEBOOL(PL_pad_reset_pending);
187 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
188 * saved - check at some pt that this is okay */
190 /* ... create new pad ... */
196 if (flags & padnew_CLONE) {
197 /* XXX DAPM I dont know why cv_clone needs it
198 * doing differently yet - perhaps this separate branch can be
199 * dispensed with eventually ???
202 AV * const a0 = newAV(); /* will be @_ */
203 av_store(pad, 0, MUTABLE_SV(a0));
207 av_store(pad, 0, NULL);
211 /* Most subroutines never recurse, hence only need 2 entries in the padlist
212 array - names, and depth=1. The default for av_store() is to allocate
213 0..3, and even an explicit call to av_extend() with <3 will be rounded
214 up, so we inline the allocation of the array here. */
216 AvFILLp(padlist) = 1;
218 AvALLOC(padlist) = ary;
219 AvARRAY(padlist) = ary;
220 ary[0] = MUTABLE_SV(padname);
221 ary[1] = MUTABLE_SV(pad);
223 /* ... then update state variables */
225 PL_comppad_name = padname;
227 PL_curpad = AvARRAY(pad);
229 if (! (flags & padnew_CLONE)) {
230 PL_comppad_name_fill = 0;
231 PL_min_intro_pending = 0;
236 DEBUG_X(PerlIO_printf(Perl_debug_log,
237 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
238 " name=0x%"UVxf" flags=0x%"UVxf"\n",
239 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
240 PTR2UV(padname), (UV)flags
244 return (PADLIST*)padlist;
249 =head1 Embedding Functions
253 Clear out all the active components of a CV. This can happen either
254 by an explicit C<undef &foo>, or by the reference count going to zero.
255 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
256 children can still follow the full lexical scope chain.
262 Perl_cv_undef(pTHX_ CV *cv)
265 const PADLIST *padlist = CvPADLIST(cv);
267 PERL_ARGS_ASSERT_CV_UNDEF;
269 DEBUG_X(PerlIO_printf(Perl_debug_log,
270 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
271 PTR2UV(cv), PTR2UV(PL_comppad))
275 if (CvFILE(cv) && !CvISXSUB(cv)) {
276 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
277 Safefree(CvFILE(cv));
282 if (!CvISXSUB(cv) && CvROOT(cv)) {
283 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
284 Perl_croak(aTHX_ "Can't undef active subroutine");
287 PAD_SAVE_SETNULLPAD();
294 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
297 /* This statement and the subsequence if block was pad_undef(). */
298 pad_peg("pad_undef");
300 if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
304 /* Free the padlist associated with a CV.
305 If parts of it happen to be current, we null the relevant PL_*pad*
306 global vars so that we don't have any dangling references left.
307 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
308 subs to the outer of this cv. */
310 DEBUG_X(PerlIO_printf(Perl_debug_log,
311 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
312 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
315 /* detach any '&' anon children in the pad; if afterwards they
316 * are still live, fix up their CvOUTSIDEs to point to our outside,
318 /* XXX DAPM for efficiency, we should only do this if we know we have
319 * children, or integrate this loop with general cleanup */
321 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
322 CV * const outercv = CvOUTSIDE(cv);
323 const U32 seq = CvOUTSIDE_SEQ(cv);
324 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
325 SV ** const namepad = AvARRAY(comppad_name);
326 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
327 SV ** const curpad = AvARRAY(comppad);
328 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
329 SV * const namesv = namepad[ix];
330 if (namesv && namesv != &PL_sv_undef
331 && *SvPVX_const(namesv) == '&')
333 CV * const innercv = MUTABLE_CV(curpad[ix]);
334 U32 inner_rc = SvREFCNT(innercv);
337 SvREFCNT_dec(namesv);
339 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
341 SvREFCNT_dec(innercv);
345 /* in use, not just a prototype */
346 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
347 assert(CvWEAKOUTSIDE(innercv));
348 /* don't relink to grandfather if he's being freed */
349 if (outercv && SvREFCNT(outercv)) {
350 CvWEAKOUTSIDE_off(innercv);
351 CvOUTSIDE(innercv) = outercv;
352 CvOUTSIDE_SEQ(innercv) = seq;
353 SvREFCNT_inc_simple_void_NN(outercv);
356 CvOUTSIDE(innercv) = NULL;
363 ix = AvFILLp(padlist);
365 SV* const sv = AvARRAY(padlist)[ix--];
367 if (sv == (const SV *)PL_comppad) {
375 SV *const sv = AvARRAY(padlist)[0];
376 if (sv == (const SV *)PL_comppad_name)
377 PL_comppad_name = NULL;
380 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
381 CvPADLIST(cv) = NULL;
385 /* remove CvOUTSIDE unless this is an undef rather than a free */
386 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
387 if (!CvWEAKOUTSIDE(cv))
388 SvREFCNT_dec(CvOUTSIDE(cv));
389 CvOUTSIDE(cv) = NULL;
392 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
395 if (CvISXSUB(cv) && CvXSUB(cv)) {
398 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
399 * ref status of CvOUTSIDE and CvGV */
400 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
404 S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash,
408 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
410 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
412 ASSERT_CURPAD_ACTIVE("pad_add_name");
415 assert(SvTYPE(namesv) == SVt_PVMG);
416 SvPAD_TYPED_on(namesv);
417 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
420 SvPAD_OUR_on(namesv);
421 SvOURSTASH_set(namesv, ourstash);
422 SvREFCNT_inc_simple_void_NN(ourstash);
424 else if (flags & padadd_STATE) {
425 SvPAD_STATE_on(namesv);
428 av_store(PL_comppad_name, offset, namesv);
433 =for apidoc pad_add_name
435 Create a new name and associated PADMY SV in the current pad; return the
437 If C<typestash> is valid, the name is for a typed lexical; set the
438 name's stash to that value.
439 If C<ourstash> is valid, it's an our lexical, set the name's
440 SvOURSTASH to that value
442 If fake, it means we're cloning an existing entry
448 Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags,
449 HV *typestash, HV *ourstash)
455 PERL_ARGS_ASSERT_PAD_ADD_NAME;
457 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
458 Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf,
461 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
463 /* Until we're using the length for real, cross check that we're being told
465 PERL_UNUSED_ARG(len);
466 assert(strlen(name) == len);
468 sv_setpv(namesv, name);
470 if ((flags & padadd_NO_DUP_CHECK) == 0) {
471 /* check for duplicate declaration */
472 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
475 offset = pad_add_name_sv(namesv, flags, typestash, ourstash);
477 /* not yet introduced */
478 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
479 COP_SEQ_RANGE_HIGH_set(namesv, 0);
481 if (!PL_min_intro_pending)
482 PL_min_intro_pending = offset;
483 PL_max_intro_pending = offset;
484 /* if it's not a simple scalar, replace with an AV or HV */
485 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
486 assert(SvREFCNT(PL_curpad[offset]) == 1);
488 sv_upgrade(PL_curpad[offset], SVt_PVAV);
489 else if (*name == '%')
490 sv_upgrade(PL_curpad[offset], SVt_PVHV);
491 assert(SvPADMY(PL_curpad[offset]));
492 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
493 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
494 (long)offset, name, PTR2UV(PL_curpad[offset])));
503 =for apidoc pad_alloc
505 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
506 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
507 for a slot which has no name and no active value.
512 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
513 * or at least rationalise ??? */
514 /* And flag whether the incoming name is UTF8 or 8 bit?
515 Could do this either with the +ve/-ve hack of the HV code, or expanding
516 the flag bits. Either way, this makes proper Unicode safe pad support.
521 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
527 PERL_UNUSED_ARG(optype);
528 ASSERT_CURPAD_ACTIVE("pad_alloc");
530 if (AvARRAY(PL_comppad) != PL_curpad)
531 Perl_croak(aTHX_ "panic: pad_alloc");
532 if (PL_pad_reset_pending)
534 if (tmptype & SVs_PADMY) {
535 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
536 retval = AvFILLp(PL_comppad);
539 SV * const * const names = AvARRAY(PL_comppad_name);
540 const SSize_t names_fill = AvFILLp(PL_comppad_name);
543 * "foreach" index vars temporarily become aliases to non-"my"
544 * values. Thus we must skip, not just pad values that are
545 * marked as current pad values, but also those with names.
547 /* HVDS why copy to sv here? we don't seem to use it */
548 if (++PL_padix <= names_fill &&
549 (sv = names[PL_padix]) && sv != &PL_sv_undef)
551 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
552 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
553 !IS_PADGV(sv) && !IS_PADCONST(sv))
558 SvFLAGS(sv) |= tmptype;
559 PL_curpad = AvARRAY(PL_comppad);
561 DEBUG_X(PerlIO_printf(Perl_debug_log,
562 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
563 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
564 PL_op_name[optype]));
565 #ifdef DEBUG_LEAKING_SCALARS
566 sv->sv_debug_optype = optype;
567 sv->sv_debug_inpad = 1;
569 return (PADOFFSET)retval;
573 =for apidoc pad_add_anon
575 Add an anon code entry to the current compiling pad
581 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
585 SV* const name = newSV_type(SVt_PVNV);
587 PERL_ARGS_ASSERT_PAD_ADD_ANON;
590 sv_setpvs(name, "&");
591 /* Are these two actually ever read? */
592 COP_SEQ_RANGE_HIGH_set(name, PERL_PADSEQ_INTRO);
593 COP_SEQ_RANGE_LOW_set(name, 1);
594 ix = pad_alloc(op_type, SVs_PADMY);
595 av_store(PL_comppad_name, ix, name);
596 /* XXX DAPM use PL_curpad[] ? */
597 av_store(PL_comppad, ix, sv);
600 /* to avoid ref loops, we never have parent + child referencing each
601 * other simultaneously */
602 if (CvOUTSIDE((const CV *)sv)) {
603 assert(!CvWEAKOUTSIDE((const CV *)sv));
604 CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
605 SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
613 =for apidoc pad_check_dup
615 Check for duplicate declarations: report any of:
616 * a my in the current scope with the same name;
617 * an our (anywhere in the pad) with the same name and the same stash
619 C<is_our> indicates that the name to check is an 'our' declaration
625 S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash)
630 const U32 is_our = flags & padadd_OUR;
632 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
634 ASSERT_CURPAD_ACTIVE("pad_check_dup");
636 assert((flags & ~padadd_OUR) == 0);
638 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
639 return; /* nothing to check */
641 svp = AvARRAY(PL_comppad_name);
642 top = AvFILLp(PL_comppad_name);
643 /* check the current scope */
644 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
646 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
647 SV * const sv = svp[off];
649 && sv != &PL_sv_undef
651 && ( COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
652 || COP_SEQ_RANGE_HIGH(sv) == 0)
655 if (is_our && (SvPAD_OUR(sv)))
656 break; /* "our" masking "our" */
657 Perl_warner(aTHX_ packWARN(WARN_MISC),
658 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
659 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
661 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
662 ? "scope" : "statement"));
667 /* check the rest of the pad */
670 SV * const sv = svp[off];
672 && sv != &PL_sv_undef
674 && ( COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
675 || COP_SEQ_RANGE_HIGH(sv) == 0)
676 && SvOURSTASH(sv) == ourstash
679 Perl_warner(aTHX_ packWARN(WARN_MISC),
680 "\"our\" variable %"SVf" redeclared", sv);
681 if ((I32)off <= PL_comppad_name_floor)
682 Perl_warner(aTHX_ packWARN(WARN_MISC),
683 "\t(Did you mean \"local\" instead of \"our\"?)\n");
693 =for apidoc pad_findmy
695 Given a lexical name, try to find its offset, first in the current pad,
696 or failing that, in the pads of any lexically enclosing subs (including
697 the complications introduced by eval). If the name is found in an outer pad,
698 then a fake entry is added to the current pad.
699 Returns the offset in the current pad, or NOT_IN_PAD on failure.
705 Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
714 PERL_ARGS_ASSERT_PAD_FINDMY;
716 pad_peg("pad_findmy");
719 Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf,
722 /* Yes, it is a bug (read work in progress) that we're not really using this
723 length parameter, and instead relying on strlen() later on. But I'm not
724 comfortable about changing the pad API piecemeal to use and rely on
725 lengths. This only exists to avoid an "unused parameter" warning. */
729 /* But until we're using the length for real, cross check that we're being
731 assert(strlen(name) == len);
733 offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
734 NULL, &out_sv, &out_flags);
735 if ((PADOFFSET)offset != NOT_IN_PAD)
738 /* look for an our that's being introduced; this allows
739 * our $foo = 0 unless defined $foo;
740 * to not give a warning. (Yes, this is a hack) */
742 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
743 name_svp = AvARRAY(nameav);
744 for (offset = AvFILLp(nameav); offset > 0; offset--) {
745 const SV * const namesv = name_svp[offset];
746 if (namesv && namesv != &PL_sv_undef
748 && (SvPAD_OUR(namesv))
749 && strEQ(SvPVX_const(namesv), name)
750 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
758 * Returns the offset of a lexical $_, if there is one, at run time.
759 * Used by the UNDERBAR XS macro.
763 Perl_find_rundefsvoffset(pTHX)
768 return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
769 NULL, &out_sv, &out_flags);
773 * Returns a lexical $_, if there is one, at run time ; or the global one
778 Perl_find_rundefsv(pTHX)
784 po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
785 NULL, &namesv, &flags);
788 || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
795 =for apidoc pad_findlex
797 Find a named lexical anywhere in a chain of nested pads. Add fake entries
798 in the inner pads if it's found in an outer one.
800 Returns the offset in the bottom pad of the lex or the fake lex.
801 cv is the CV in which to start the search, and seq is the current cop_seq
802 to match against. If warn is true, print appropriate warnings. The out_*
803 vars return values, and so are pointers to where the returned values
804 should be stored. out_capture, if non-null, requests that the innermost
805 instance of the lexical is captured; out_name_sv is set to the innermost
806 matched namesv or fake namesv; out_flags returns the flags normally
807 associated with the IVX field of a fake namesv.
809 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
810 then comes back down, adding fake entries as it goes. It has to be this way
811 because fake namesvs in anon protoypes have to store in xlow the index into
817 /* the CV has finished being compiled. This is not a sufficient test for
818 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
819 #define CvCOMPILED(cv) CvROOT(cv)
821 /* the CV does late binding of its lexicals */
822 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
826 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
827 SV** out_capture, SV** out_name_sv, int *out_flags)
830 I32 offset, new_offset;
833 const AV * const padlist = CvPADLIST(cv);
835 PERL_ARGS_ASSERT_PAD_FINDLEX;
839 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
840 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
841 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
843 /* first, search this pad */
845 if (padlist) { /* not an undef CV */
847 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
848 SV * const * const name_svp = AvARRAY(nameav);
850 for (offset = AvFILLp(nameav); offset > 0; offset--) {
851 const SV * const namesv = name_svp[offset];
852 if (namesv && namesv != &PL_sv_undef
853 && strEQ(SvPVX_const(namesv), name))
856 fake_offset = offset; /* in case we don't find a real one */
857 else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */
858 && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */
863 if (offset > 0 || fake_offset > 0 ) { /* a match! */
864 if (offset > 0) { /* not fake */
866 *out_name_sv = name_svp[offset]; /* return the namesv */
868 /* set PAD_FAKELEX_MULTI if this lex can have multiple
869 * instances. For now, we just test !CvUNIQUE(cv), but
870 * ideally, we should detect my's declared within loops
871 * etc - this would allow a wider range of 'not stayed
872 * shared' warnings. We also treated already-compiled
873 * lexes as not multi as viewed from evals. */
875 *out_flags = CvANON(cv) ?
877 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
878 ? PAD_FAKELEX_MULTI : 0;
880 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
881 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
882 PTR2UV(cv), (long)offset,
883 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
884 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
886 else { /* fake match */
887 offset = fake_offset;
888 *out_name_sv = name_svp[offset]; /* return the namesv */
889 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
890 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
891 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
892 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
893 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
897 /* return the lex? */
902 if (SvPAD_OUR(*out_name_sv)) {
907 /* trying to capture from an anon prototype? */
909 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
910 : *out_flags & PAD_FAKELEX_ANON)
913 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
914 "Variable \"%s\" is not available", name);
921 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
922 && !SvPAD_STATE(name_svp[offset])
923 && warn && ckWARN(WARN_CLOSURE)) {
925 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
926 "Variable \"%s\" will not stay shared", name);
929 if (fake_offset && CvANON(cv)
930 && CvCLONE(cv) &&!CvCLONED(cv))
933 /* not yet caught - look further up */
934 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
935 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
938 (void) pad_findlex(name, CvOUTSIDE(cv),
940 newwarn, out_capture, out_name_sv, out_flags);
945 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
946 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
947 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
948 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
949 PTR2UV(cv), PTR2UV(*out_capture)));
951 if (SvPADSTALE(*out_capture)
952 && !SvPAD_STATE(name_svp[offset]))
954 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
955 "Variable \"%s\" is not available", name);
961 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
962 else if (*name == '%')
963 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
965 *out_capture = sv_newmortal();
973 /* it's not in this pad - try above */
978 /* out_capture non-null means caller wants us to capture lex; in
979 * addition we capture ourselves unless it's an ANON/format */
980 new_capturep = out_capture ? out_capture :
981 CvLATE(cv) ? NULL : &new_capture;
983 offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
984 new_capturep, out_name_sv, out_flags);
985 if ((PADOFFSET)offset == NOT_IN_PAD)
988 /* found in an outer CV. Add appropriate fake entry to this pad */
990 /* don't add new fake entries (via eval) to CVs that we have already
991 * finished compiling, or to undef CVs */
992 if (CvCOMPILED(cv) || !padlist)
993 return 0; /* this dummy (and invalid) value isnt used by the caller */
996 /* This relies on sv_setsv_flags() upgrading the destination to the same
997 type as the source, independent of the flags set, and on it being
998 "good" and only copying flag bits and pointers that it understands.
1000 SV *new_namesv = newSVsv(*out_name_sv);
1001 AV * const ocomppad_name = PL_comppad_name;
1002 PAD * const ocomppad = PL_comppad;
1003 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1004 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1005 PL_curpad = AvARRAY(PL_comppad);
1008 = pad_add_name_sv(new_namesv,
1009 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1010 SvPAD_TYPED(*out_name_sv)
1011 ? SvSTASH(*out_name_sv) : NULL,
1012 SvOURSTASH(*out_name_sv)
1015 SvFAKE_on(new_namesv);
1016 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1017 "Pad addname: %ld \"%.*s\" FAKE\n",
1019 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1020 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1022 PARENT_PAD_INDEX_set(new_namesv, 0);
1023 if (SvPAD_OUR(new_namesv)) {
1024 NOOP; /* do nothing */
1026 else if (CvLATE(cv)) {
1027 /* delayed creation - just note the offset within parent pad */
1028 PARENT_PAD_INDEX_set(new_namesv, offset);
1032 /* immediate creation - capture outer value right now */
1033 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1034 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1035 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1036 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1038 *out_name_sv = new_namesv;
1039 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1041 PL_comppad_name = ocomppad_name;
1042 PL_comppad = ocomppad;
1043 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1053 Get the value at offset po in the current pad.
1054 Use macro PAD_SV instead of calling this function directly.
1061 Perl_pad_sv(pTHX_ PADOFFSET po)
1064 ASSERT_CURPAD_ACTIVE("pad_sv");
1067 Perl_croak(aTHX_ "panic: pad_sv po");
1068 DEBUG_X(PerlIO_printf(Perl_debug_log,
1069 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1070 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1072 return PL_curpad[po];
1077 =for apidoc pad_setsv
1079 Set the entry at offset po in the current pad to sv.
1080 Use the macro PAD_SETSV() rather than calling this function directly.
1086 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1090 PERL_ARGS_ASSERT_PAD_SETSV;
1092 ASSERT_CURPAD_ACTIVE("pad_setsv");
1094 DEBUG_X(PerlIO_printf(Perl_debug_log,
1095 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1096 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1105 =for apidoc pad_block_start
1107 Update the pad compilation state variables on entry to a new block
1112 /* XXX DAPM perhaps:
1113 * - integrate this in general state-saving routine ???
1114 * - combine with the state-saving going on in pad_new ???
1115 * - introduce a new SAVE type that does all this in one go ?
1119 Perl_pad_block_start(pTHX_ int full)
1122 ASSERT_CURPAD_ACTIVE("pad_block_start");
1123 SAVEI32(PL_comppad_name_floor);
1124 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1126 PL_comppad_name_fill = PL_comppad_name_floor;
1127 if (PL_comppad_name_floor < 0)
1128 PL_comppad_name_floor = 0;
1129 SAVEI32(PL_min_intro_pending);
1130 SAVEI32(PL_max_intro_pending);
1131 PL_min_intro_pending = 0;
1132 SAVEI32(PL_comppad_name_fill);
1133 SAVEI32(PL_padix_floor);
1134 PL_padix_floor = PL_padix;
1135 PL_pad_reset_pending = FALSE;
1140 =for apidoc intro_my
1142 "Introduce" my variables to visible status.
1154 ASSERT_CURPAD_ACTIVE("intro_my");
1155 if (! PL_min_intro_pending)
1156 return PL_cop_seqmax;
1158 svp = AvARRAY(PL_comppad_name);
1159 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1160 SV * const sv = svp[i];
1162 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
1163 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1164 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1165 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1166 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1167 (long)i, SvPVX_const(sv),
1168 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1169 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1173 PL_min_intro_pending = 0;
1174 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1175 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1176 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
1178 return PL_cop_seqmax++;
1182 =for apidoc pad_leavemy
1184 Cleanup at end of scope during compilation: set the max seq number for
1185 lexicals in this scope and warn of any lexicals that never got introduced.
1191 Perl_pad_leavemy(pTHX)
1195 SV * const * const svp = AvARRAY(PL_comppad_name);
1197 PL_pad_reset_pending = FALSE;
1199 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1200 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1201 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1202 const SV * const sv = svp[off];
1203 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1204 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1205 "%"SVf" never introduced",
1209 /* "Deintroduce" my variables that are leaving with this scope. */
1210 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1211 const SV * const sv = svp[off];
1212 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1213 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1215 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1216 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1217 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1218 (long)off, SvPVX_const(sv),
1219 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1220 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1225 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1226 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1231 =for apidoc pad_swipe
1233 Abandon the tmp in the current pad at offset po and replace with a
1240 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1243 ASSERT_CURPAD_LEGAL("pad_swipe");
1246 if (AvARRAY(PL_comppad) != PL_curpad)
1247 Perl_croak(aTHX_ "panic: pad_swipe curpad");
1249 Perl_croak(aTHX_ "panic: pad_swipe po");
1251 DEBUG_X(PerlIO_printf(Perl_debug_log,
1252 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1253 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1256 SvPADTMP_off(PL_curpad[po]);
1258 SvREFCNT_dec(PL_curpad[po]);
1261 /* if pad tmps aren't shared between ops, then there's no need to
1262 * create a new tmp when an existing op is freed */
1263 #ifdef USE_BROKEN_PAD_RESET
1264 PL_curpad[po] = newSV(0);
1265 SvPADTMP_on(PL_curpad[po]);
1267 PL_curpad[po] = &PL_sv_undef;
1269 if ((I32)po < PL_padix)
1275 =for apidoc pad_reset
1277 Mark all the current temporaries for reuse
1282 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1283 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1284 * on the stack by OPs that use them, there are several ways to get an alias
1285 * to a shared TARG. Such an alias will change randomly and unpredictably.
1286 * We avoid doing this until we can think of a Better Way.
1292 #ifdef USE_BROKEN_PAD_RESET
1293 if (AvARRAY(PL_comppad) != PL_curpad)
1294 Perl_croak(aTHX_ "panic: pad_reset curpad");
1296 DEBUG_X(PerlIO_printf(Perl_debug_log,
1297 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1298 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1299 (long)PL_padix, (long)PL_padix_floor
1303 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1305 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1306 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1307 SvPADTMP_off(PL_curpad[po]);
1309 PL_padix = PL_padix_floor;
1312 PL_pad_reset_pending = FALSE;
1317 =for apidoc pad_tidy
1319 Tidy up a pad after we've finished compiling it:
1320 * remove most stuff from the pads of anonsub prototypes;
1322 * mark tmps as such.
1327 /* XXX DAPM surely most of this stuff should be done properly
1328 * at the right time beforehand, rather than going around afterwards
1329 * cleaning up our mistakes ???
1333 Perl_pad_tidy(pTHX_ padtidy_type type)
1337 ASSERT_CURPAD_ACTIVE("pad_tidy");
1339 /* If this CV has had any 'eval-capable' ops planted in it
1340 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1341 * anon prototypes in the chain of CVs should be marked as cloneable,
1342 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1343 * the right CvOUTSIDE.
1344 * If running with -d, *any* sub may potentially have an eval
1345 * executed within it.
1348 if (PL_cv_has_eval || PL_perldb) {
1350 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1351 if (cv != PL_compcv && CvCOMPILED(cv))
1352 break; /* no need to mark already-compiled code */
1354 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1355 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1361 /* extend curpad to match namepad */
1362 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1363 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1365 if (type == padtidy_SUBCLONE) {
1366 SV * const * const namep = AvARRAY(PL_comppad_name);
1369 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1372 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1375 * The only things that a clonable function needs in its
1376 * pad are anonymous subs.
1377 * The rest are created anew during cloning.
1379 if (!((namesv = namep[ix]) != NULL &&
1380 namesv != &PL_sv_undef &&
1381 *SvPVX_const(namesv) == '&'))
1383 SvREFCNT_dec(PL_curpad[ix]);
1384 PL_curpad[ix] = NULL;
1388 else if (type == padtidy_SUB) {
1389 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1390 AV * const av = newAV(); /* Will be @_ */
1391 av_store(PL_comppad, 0, MUTABLE_SV(av));
1395 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1396 SV * const * const namep = AvARRAY(PL_comppad_name);
1398 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1399 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1401 if (!SvPADMY(PL_curpad[ix])) {
1402 SvPADTMP_on(PL_curpad[ix]);
1403 } else if (!SvFAKE(namep[ix])) {
1404 /* This is a work around for how the current implementation of
1405 ?{ } blocks in regexps interacts with lexicals.
1407 One of our lexicals.
1408 Can't do this on all lexicals, otherwise sub baz() won't
1417 because completion of compiling &bar calling pad_tidy()
1418 would cause (top level) $foo to be marked as stale, and
1419 "no longer available". */
1420 SvPADSTALE_on(PL_curpad[ix]);
1424 PL_curpad = AvARRAY(PL_comppad);
1429 =for apidoc pad_free
1431 Free the SV at offset po in the current pad.
1436 /* XXX DAPM integrate with pad_swipe ???? */
1438 Perl_pad_free(pTHX_ PADOFFSET po)
1441 ASSERT_CURPAD_LEGAL("pad_free");
1444 if (AvARRAY(PL_comppad) != PL_curpad)
1445 Perl_croak(aTHX_ "panic: pad_free curpad");
1447 Perl_croak(aTHX_ "panic: pad_free po");
1449 DEBUG_X(PerlIO_printf(Perl_debug_log,
1450 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1451 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1454 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1455 SvPADTMP_off(PL_curpad[po]);
1457 if ((I32)po < PL_padix)
1464 =for apidoc do_dump_pad
1466 Dump the contents of a padlist
1472 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1481 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1486 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1487 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1488 pname = AvARRAY(pad_name);
1489 ppad = AvARRAY(pad);
1490 Perl_dump_indent(aTHX_ level, file,
1491 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1492 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1495 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1496 const SV *namesv = pname[ix];
1497 if (namesv && namesv == &PL_sv_undef) {
1502 Perl_dump_indent(aTHX_ level+1, file,
1503 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1506 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1507 SvPVX_const(namesv),
1508 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1509 (unsigned long)PARENT_PAD_INDEX(namesv)
1513 Perl_dump_indent(aTHX_ level+1, file,
1514 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1517 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1518 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1519 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1524 Perl_dump_indent(aTHX_ level+1, file,
1525 "%2d. 0x%"UVxf"<%lu>\n",
1528 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1539 dump the contents of a CV
1546 S_cv_dump(pTHX_ const CV *cv, const char *title)
1549 const CV * const outside = CvOUTSIDE(cv);
1550 AV* const padlist = CvPADLIST(cv);
1552 PERL_ARGS_ASSERT_CV_DUMP;
1554 PerlIO_printf(Perl_debug_log,
1555 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1558 (CvANON(cv) ? "ANON"
1559 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1560 : (cv == PL_main_cv) ? "MAIN"
1561 : CvUNIQUE(cv) ? "UNIQUE"
1562 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1565 : CvANON(outside) ? "ANON"
1566 : (outside == PL_main_cv) ? "MAIN"
1567 : CvUNIQUE(outside) ? "UNIQUE"
1568 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1570 PerlIO_printf(Perl_debug_log,
1571 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1572 do_dump_pad(1, Perl_debug_log, padlist, 1);
1574 #endif /* DEBUGGING */
1581 =for apidoc cv_clone
1583 Clone a CV: make a new CV which points to the same code etc, but which
1584 has a newly-created pad built by copying the prototype pad and capturing
1591 Perl_cv_clone(pTHX_ CV *proto)
1595 AV* const protopadlist = CvPADLIST(proto);
1596 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1597 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1598 SV** const pname = AvARRAY(protopad_name);
1599 SV** const ppad = AvARRAY(protopad);
1600 const I32 fname = AvFILLp(protopad_name);
1601 const I32 fpad = AvFILLp(protopad);
1607 PERL_ARGS_ASSERT_CV_CLONE;
1609 assert(!CvUNIQUE(proto));
1611 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1612 * to a prototype; we instead want the cloned parent who called us.
1613 * Note that in general for formats, CvOUTSIDE != find_runcv */
1615 outside = CvOUTSIDE(proto);
1616 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1617 outside = find_runcv(NULL);
1618 depth = CvDEPTH(outside);
1619 assert(depth || SvTYPE(proto) == SVt_PVFM);
1622 assert(CvPADLIST(outside));
1625 SAVESPTR(PL_compcv);
1627 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1628 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
1632 CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
1633 : savepv(CvFILE(proto));
1635 CvFILE(cv) = CvFILE(proto);
1637 CvGV_set(cv,CvGV(proto));
1638 CvSTASH_set(cv, CvSTASH(proto));
1640 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1642 CvSTART(cv) = CvSTART(proto);
1643 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1644 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1647 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1649 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1651 av_fill(PL_comppad, fpad);
1652 for (ix = fname; ix > 0; ix--)
1653 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1655 PL_curpad = AvARRAY(PL_comppad);
1657 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1659 for (ix = fpad; ix > 0; ix--) {
1660 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1662 if (namesv && namesv != &PL_sv_undef) { /* lexical */
1663 if (SvFAKE(namesv)) { /* lexical from outside? */
1664 sv = outpad[PARENT_PAD_INDEX(namesv)];
1666 /* formats may have an inactive parent,
1667 while my $x if $false can leave an active var marked as
1668 stale. And state vars are always available */
1669 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1670 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1671 "Variable \"%s\" is not available", SvPVX_const(namesv));
1675 SvREFCNT_inc_simple_void_NN(sv);
1678 const char sigil = SvPVX_const(namesv)[0];
1680 sv = SvREFCNT_inc(ppad[ix]);
1681 else if (sigil == '@')
1682 sv = MUTABLE_SV(newAV());
1683 else if (sigil == '%')
1684 sv = MUTABLE_SV(newHV());
1688 /* reset the 'assign only once' flag on each state var */
1689 if (SvPAD_STATE(namesv))
1693 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1694 sv = SvREFCNT_inc_NN(ppad[ix]);
1704 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1705 cv_dump(outside, "Outside");
1706 cv_dump(proto, "Proto");
1713 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1714 * The prototype was marked as a candiate for const-ization,
1715 * so try to grab the current const value, and if successful,
1716 * turn into a const sub:
1718 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1721 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1733 =for apidoc pad_fixup_inner_anons
1735 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1736 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1737 moved to a pre-existing CV struct.
1743 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1747 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1748 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1749 SV ** const namepad = AvARRAY(comppad_name);
1750 SV ** const curpad = AvARRAY(comppad);
1752 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1753 PERL_UNUSED_ARG(old_cv);
1755 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1756 const SV * const namesv = namepad[ix];
1757 if (namesv && namesv != &PL_sv_undef
1758 && *SvPVX_const(namesv) == '&')
1760 CV * const innercv = MUTABLE_CV(curpad[ix]);
1761 assert(CvWEAKOUTSIDE(innercv));
1762 assert(CvOUTSIDE(innercv) == old_cv);
1763 CvOUTSIDE(innercv) = new_cv;
1770 =for apidoc pad_push
1772 Push a new pad frame onto the padlist, unless there's already a pad at
1773 this depth, in which case don't bother creating a new one. Then give
1774 the new pad an @_ in slot zero.
1780 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1784 PERL_ARGS_ASSERT_PAD_PUSH;
1786 if (depth > AvFILLp(padlist)) {
1787 SV** const svp = AvARRAY(padlist);
1788 AV* const newpad = newAV();
1789 SV** const oldpad = AvARRAY(svp[depth-1]);
1790 I32 ix = AvFILLp((const AV *)svp[1]);
1791 const I32 names_fill = AvFILLp((const AV *)svp[0]);
1792 SV** const names = AvARRAY(svp[0]);
1795 for ( ;ix > 0; ix--) {
1796 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1797 const char sigil = SvPVX_const(names[ix])[0];
1798 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1799 || (SvFLAGS(names[ix]) & SVpad_STATE)
1802 /* outer lexical or anon code */
1803 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1805 else { /* our own lexical */
1808 sv = MUTABLE_SV(newAV());
1809 else if (sigil == '%')
1810 sv = MUTABLE_SV(newHV());
1813 av_store(newpad, ix, sv);
1817 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1818 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1821 /* save temporaries on recursion? */
1822 SV * const sv = newSV(0);
1823 av_store(newpad, ix, sv);
1828 av_store(newpad, 0, MUTABLE_SV(av));
1831 av_store(padlist, depth, MUTABLE_SV(newpad));
1832 AvFILLp(padlist) = depth;
1838 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1841 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1842 if ( SvPAD_TYPED(*av) ) {
1843 return SvSTASH(*av);
1848 #if defined(USE_ITHREADS)
1850 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
1853 Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
1856 PERL_ARGS_ASSERT_PADLIST_DUP;
1861 assert(!AvREAL(srcpad));
1863 if (param->flags & CLONEf_COPY_STACKS
1864 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
1865 /* XXX padlists are real, but pretend to be not */
1867 dstpad = av_dup_inc(srcpad, param);
1870 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
1872 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
1873 to build anything other than the first level of pads. */
1875 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
1877 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
1878 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
1879 SV **oldpad = AvARRAY(srcpad1);
1883 /* look for it in the table first.
1884 I *think* that it shouldn't be possible to find it there.
1885 Well, except for how Perl_sv_compile_2op() "works" :-( */
1886 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
1892 ptr_table_store(PL_ptr_table, srcpad, dstpad);
1894 av_extend(dstpad, 1);
1895 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
1896 names = AvARRAY(AvARRAY(dstpad)[0]);
1900 av_extend(pad1, ix);
1901 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
1902 pad1a = AvARRAY(pad1);
1903 AvFILLp(dstpad) = 1;
1908 for ( ;ix > 0; ix--) {
1911 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1912 const char sigil = SvPVX_const(names[ix])[0];
1913 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1914 || (SvFLAGS(names[ix]) & SVpad_STATE)
1917 /* outer lexical or anon code */
1918 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1920 else { /* our own lexical */
1921 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
1922 /* This is a work around for how the current
1923 implementation of ?{ } blocks in regexps
1924 interacts with lexicals. */
1925 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1930 sv = MUTABLE_SV(newAV());
1931 else if (sigil == '%')
1932 sv = MUTABLE_SV(newHV());
1940 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1941 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1944 /* save temporaries on recursion? */
1945 SV * const sv = newSV(0);
1948 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
1949 FIXTHAT before merging this branch.
1950 (And I know how to) */
1951 if (SvPADMY(oldpad[ix]))
1959 args = newAV(); /* Will be @_ */
1961 pad1a[0] = (SV *)args;
1973 * c-indentation-style: bsd
1975 * indent-tabs-mode: t
1978 * ex: set ts=8 sts=4 sw=4 noet: