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
131 #define PAD_MAX I32_MAX
134 void pad_peg(const char* s) {
135 static int pegcnt; /* XXX not threadsafe */
138 PERL_ARGS_ASSERT_PAD_PEG;
147 Create a new compiling padlist, saving and updating the various global
148 vars at the same time as creating the pad itself. The following flags
149 can be OR'ed together:
151 padnew_CLONE this pad is for a cloned CV
152 padnew_SAVE save old globals
153 padnew_SAVESUB also save extra stuff for start of sub
159 Perl_pad_new(pTHX_ int flags)
162 AV *padlist, *padname, *pad;
165 ASSERT_CURPAD_LEGAL("pad_new");
167 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
168 * vars (based on flags) rather than storing vals + addresses for
169 * each individually. Also see pad_block_start.
170 * XXX DAPM Try to see whether all these conditionals are required
173 /* save existing state, ... */
175 if (flags & padnew_SAVE) {
177 SAVESPTR(PL_comppad_name);
178 if (! (flags & padnew_CLONE)) {
180 SAVEI32(PL_comppad_name_fill);
181 SAVEI32(PL_min_intro_pending);
182 SAVEI32(PL_max_intro_pending);
183 SAVEBOOL(PL_cv_has_eval);
184 if (flags & padnew_SAVESUB) {
185 SAVEBOOL(PL_pad_reset_pending);
189 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
190 * saved - check at some pt that this is okay */
192 /* ... create new pad ... */
198 if (flags & padnew_CLONE) {
199 /* XXX DAPM I dont know why cv_clone needs it
200 * doing differently yet - perhaps this separate branch can be
201 * dispensed with eventually ???
204 AV * const a0 = newAV(); /* will be @_ */
205 av_store(pad, 0, MUTABLE_SV(a0));
209 av_store(pad, 0, NULL);
213 /* Most subroutines never recurse, hence only need 2 entries in the padlist
214 array - names, and depth=1. The default for av_store() is to allocate
215 0..3, and even an explicit call to av_extend() with <3 will be rounded
216 up, so we inline the allocation of the array here. */
218 AvFILLp(padlist) = 1;
220 AvALLOC(padlist) = ary;
221 AvARRAY(padlist) = ary;
222 ary[0] = MUTABLE_SV(padname);
223 ary[1] = MUTABLE_SV(pad);
225 /* ... then update state variables */
227 PL_comppad_name = padname;
229 PL_curpad = AvARRAY(pad);
231 if (! (flags & padnew_CLONE)) {
232 PL_comppad_name_fill = 0;
233 PL_min_intro_pending = 0;
238 DEBUG_X(PerlIO_printf(Perl_debug_log,
239 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
240 " name=0x%"UVxf" flags=0x%"UVxf"\n",
241 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
242 PTR2UV(padname), (UV)flags
246 return (PADLIST*)padlist;
251 =head1 Embedding Functions
255 Clear out all the active components of a CV. This can happen either
256 by an explicit C<undef &foo>, or by the reference count going to zero.
257 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
258 children can still follow the full lexical scope chain.
264 Perl_cv_undef(pTHX_ CV *cv)
267 const PADLIST *padlist = CvPADLIST(cv);
269 PERL_ARGS_ASSERT_CV_UNDEF;
271 DEBUG_X(PerlIO_printf(Perl_debug_log,
272 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
273 PTR2UV(cv), PTR2UV(PL_comppad))
277 if (CvFILE(cv) && !CvISXSUB(cv)) {
278 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
279 Safefree(CvFILE(cv));
284 if (!CvISXSUB(cv) && CvROOT(cv)) {
285 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
286 Perl_croak(aTHX_ "Can't undef active subroutine");
289 PAD_SAVE_SETNULLPAD();
296 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
299 /* This statement and the subsequence if block was pad_undef(). */
300 pad_peg("pad_undef");
302 if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
306 /* Free the padlist associated with a CV.
307 If parts of it happen to be current, we null the relevant PL_*pad*
308 global vars so that we don't have any dangling references left.
309 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
310 subs to the outer of this cv. */
312 DEBUG_X(PerlIO_printf(Perl_debug_log,
313 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
314 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
317 /* detach any '&' anon children in the pad; if afterwards they
318 * are still live, fix up their CvOUTSIDEs to point to our outside,
320 /* XXX DAPM for efficiency, we should only do this if we know we have
321 * children, or integrate this loop with general cleanup */
323 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
324 CV * const outercv = CvOUTSIDE(cv);
325 const U32 seq = CvOUTSIDE_SEQ(cv);
326 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
327 SV ** const namepad = AvARRAY(comppad_name);
328 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
329 SV ** const curpad = AvARRAY(comppad);
330 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
331 SV * const namesv = namepad[ix];
332 if (namesv && namesv != &PL_sv_undef
333 && *SvPVX_const(namesv) == '&')
335 CV * const innercv = MUTABLE_CV(curpad[ix]);
336 U32 inner_rc = SvREFCNT(innercv);
339 SvREFCNT_dec(namesv);
341 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
343 SvREFCNT_dec(innercv);
347 /* in use, not just a prototype */
348 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
349 assert(CvWEAKOUTSIDE(innercv));
350 /* don't relink to grandfather if he's being freed */
351 if (outercv && SvREFCNT(outercv)) {
352 CvWEAKOUTSIDE_off(innercv);
353 CvOUTSIDE(innercv) = outercv;
354 CvOUTSIDE_SEQ(innercv) = seq;
355 SvREFCNT_inc_simple_void_NN(outercv);
358 CvOUTSIDE(innercv) = NULL;
365 ix = AvFILLp(padlist);
367 SV* const sv = AvARRAY(padlist)[ix--];
369 if (sv == (const SV *)PL_comppad) {
377 SV *const sv = AvARRAY(padlist)[0];
378 if (sv == (const SV *)PL_comppad_name)
379 PL_comppad_name = NULL;
382 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
383 CvPADLIST(cv) = NULL;
387 /* remove CvOUTSIDE unless this is an undef rather than a free */
388 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
389 if (!CvWEAKOUTSIDE(cv))
390 SvREFCNT_dec(CvOUTSIDE(cv));
391 CvOUTSIDE(cv) = NULL;
394 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
397 if (CvISXSUB(cv) && CvXSUB(cv)) {
400 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
401 * ref status of CvOUTSIDE and CvGV */
402 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
406 S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash,
410 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
412 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
414 ASSERT_CURPAD_ACTIVE("pad_add_name");
417 assert(SvTYPE(namesv) == SVt_PVMG);
418 SvPAD_TYPED_on(namesv);
419 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
422 SvPAD_OUR_on(namesv);
423 SvOURSTASH_set(namesv, ourstash);
424 SvREFCNT_inc_simple_void_NN(ourstash);
426 else if (flags & padadd_STATE) {
427 SvPAD_STATE_on(namesv);
430 av_store(PL_comppad_name, offset, namesv);
435 =for apidoc pad_add_name
437 Create a new name and associated PADMY SV in the current pad; return the
439 If C<typestash> is valid, the name is for a typed lexical; set the
440 name's stash to that value.
441 If C<ourstash> is valid, it's an our lexical, set the name's
442 SvOURSTASH to that value
444 If fake, it means we're cloning an existing entry
450 Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags,
451 HV *typestash, HV *ourstash)
457 PERL_ARGS_ASSERT_PAD_ADD_NAME;
459 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
460 Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf,
463 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
465 /* Until we're using the length for real, cross check that we're being told
467 PERL_UNUSED_ARG(len);
468 assert(strlen(name) == len);
470 sv_setpv(namesv, name);
472 if ((flags & padadd_NO_DUP_CHECK) == 0) {
473 /* check for duplicate declaration */
474 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
477 offset = pad_add_name_sv(namesv, flags, typestash, ourstash);
479 /* not yet introduced */
480 COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
481 COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */
483 if (!PL_min_intro_pending)
484 PL_min_intro_pending = offset;
485 PL_max_intro_pending = offset;
486 /* if it's not a simple scalar, replace with an AV or HV */
487 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
488 assert(SvREFCNT(PL_curpad[offset]) == 1);
490 sv_upgrade(PL_curpad[offset], SVt_PVAV);
491 else if (*name == '%')
492 sv_upgrade(PL_curpad[offset], SVt_PVHV);
493 assert(SvPADMY(PL_curpad[offset]));
494 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
495 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
496 (long)offset, name, PTR2UV(PL_curpad[offset])));
505 =for apidoc pad_alloc
507 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
508 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
509 for a slot which has no name and no active value.
514 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
515 * or at least rationalise ??? */
516 /* And flag whether the incoming name is UTF8 or 8 bit?
517 Could do this either with the +ve/-ve hack of the HV code, or expanding
518 the flag bits. Either way, this makes proper Unicode safe pad support.
523 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
529 PERL_UNUSED_ARG(optype);
530 ASSERT_CURPAD_ACTIVE("pad_alloc");
532 if (AvARRAY(PL_comppad) != PL_curpad)
533 Perl_croak(aTHX_ "panic: pad_alloc");
534 if (PL_pad_reset_pending)
536 if (tmptype & SVs_PADMY) {
537 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
538 retval = AvFILLp(PL_comppad);
541 SV * const * const names = AvARRAY(PL_comppad_name);
542 const SSize_t names_fill = AvFILLp(PL_comppad_name);
545 * "foreach" index vars temporarily become aliases to non-"my"
546 * values. Thus we must skip, not just pad values that are
547 * marked as current pad values, but also those with names.
549 /* HVDS why copy to sv here? we don't seem to use it */
550 if (++PL_padix <= names_fill &&
551 (sv = names[PL_padix]) && sv != &PL_sv_undef)
553 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
554 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
555 !IS_PADGV(sv) && !IS_PADCONST(sv))
560 SvFLAGS(sv) |= tmptype;
561 PL_curpad = AvARRAY(PL_comppad);
563 DEBUG_X(PerlIO_printf(Perl_debug_log,
564 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
565 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
566 PL_op_name[optype]));
567 #ifdef DEBUG_LEAKING_SCALARS
568 sv->sv_debug_optype = optype;
569 sv->sv_debug_inpad = 1;
571 return (PADOFFSET)retval;
575 =for apidoc pad_add_anon
577 Add an anon code entry to the current compiling pad
583 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
587 SV* const name = newSV_type(SVt_PVNV);
589 PERL_ARGS_ASSERT_PAD_ADD_ANON;
592 sv_setpvs(name, "&");
593 /* Are these two actually ever read? */
594 COP_SEQ_RANGE_HIGH_set(name, ~0);
595 COP_SEQ_RANGE_LOW_set(name, 1);
596 ix = pad_alloc(op_type, SVs_PADMY);
597 av_store(PL_comppad_name, ix, name);
598 /* XXX DAPM use PL_curpad[] ? */
599 av_store(PL_comppad, ix, sv);
602 /* to avoid ref loops, we never have parent + child referencing each
603 * other simultaneously */
604 if (CvOUTSIDE((const CV *)sv)) {
605 assert(!CvWEAKOUTSIDE((const CV *)sv));
606 CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
607 SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
615 =for apidoc pad_check_dup
617 Check for duplicate declarations: report any of:
618 * a my in the current scope with the same name;
619 * an our (anywhere in the pad) with the same name and the same stash
621 C<is_our> indicates that the name to check is an 'our' declaration
627 S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash)
632 const U32 is_our = flags & padadd_OUR;
634 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
636 ASSERT_CURPAD_ACTIVE("pad_check_dup");
638 assert((flags & ~padadd_OUR) == 0);
640 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
641 return; /* nothing to check */
643 svp = AvARRAY(PL_comppad_name);
644 top = AvFILLp(PL_comppad_name);
645 /* check the current scope */
646 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
648 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
649 SV * const sv = svp[off];
651 && sv != &PL_sv_undef
653 && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
656 if (is_our && (SvPAD_OUR(sv)))
657 break; /* "our" masking "our" */
658 Perl_warner(aTHX_ packWARN(WARN_MISC),
659 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
660 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
662 (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "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) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
675 && SvOURSTASH(sv) == ourstash
678 Perl_warner(aTHX_ packWARN(WARN_MISC),
679 "\"our\" variable %"SVf" redeclared", sv);
680 if ((I32)off <= PL_comppad_name_floor)
681 Perl_warner(aTHX_ packWARN(WARN_MISC),
682 "\t(Did you mean \"local\" instead of \"our\"?)\n");
692 =for apidoc pad_findmy
694 Given a lexical name, try to find its offset, first in the current pad,
695 or failing that, in the pads of any lexically enclosing subs (including
696 the complications introduced by eval). If the name is found in an outer pad,
697 then a fake entry is added to the current pad.
698 Returns the offset in the current pad, or NOT_IN_PAD on failure.
704 Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
713 PERL_ARGS_ASSERT_PAD_FINDMY;
715 pad_peg("pad_findmy");
718 Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf,
721 /* Yes, it is a bug (read work in progress) that we're not really using this
722 length parameter, and instead relying on strlen() later on. But I'm not
723 comfortable about changing the pad API piecemeal to use and rely on
724 lengths. This only exists to avoid an "unused parameter" warning. */
728 /* But until we're using the length for real, cross check that we're being
730 assert(strlen(name) == len);
732 offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
733 NULL, &out_sv, &out_flags);
734 if ((PADOFFSET)offset != NOT_IN_PAD)
737 /* look for an our that's being introduced; this allows
738 * our $foo = 0 unless defined $foo;
739 * to not give a warning. (Yes, this is a hack) */
741 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
742 name_svp = AvARRAY(nameav);
743 for (offset = AvFILLp(nameav); offset > 0; offset--) {
744 const SV * const namesv = name_svp[offset];
745 if (namesv && namesv != &PL_sv_undef
747 && (SvPAD_OUR(namesv))
748 && strEQ(SvPVX_const(namesv), name)
749 && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
757 * Returns the offset of a lexical $_, if there is one, at run time.
758 * Used by the UNDERBAR XS macro.
762 Perl_find_rundefsvoffset(pTHX)
767 return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
768 NULL, &out_sv, &out_flags);
772 * Returns a lexical $_, if there is one, at run time ; or the global one
777 Perl_find_rundefsv(pTHX)
783 po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
784 NULL, &namesv, &flags);
787 || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
794 =for apidoc pad_findlex
796 Find a named lexical anywhere in a chain of nested pads. Add fake entries
797 in the inner pads if it's found in an outer one.
799 Returns the offset in the bottom pad of the lex or the fake lex.
800 cv is the CV in which to start the search, and seq is the current cop_seq
801 to match against. If warn is true, print appropriate warnings. The out_*
802 vars return values, and so are pointers to where the returned values
803 should be stored. out_capture, if non-null, requests that the innermost
804 instance of the lexical is captured; out_name_sv is set to the innermost
805 matched namesv or fake namesv; out_flags returns the flags normally
806 associated with the IVX field of a fake namesv.
808 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
809 then comes back down, adding fake entries as it goes. It has to be this way
810 because fake namesvs in anon protoypes have to store in xlow the index into
816 /* the CV has finished being compiled. This is not a sufficient test for
817 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
818 #define CvCOMPILED(cv) CvROOT(cv)
820 /* the CV does late binding of its lexicals */
821 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
825 S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
826 SV** out_capture, SV** out_name_sv, int *out_flags)
829 I32 offset, new_offset;
832 const AV * const padlist = CvPADLIST(cv);
834 PERL_ARGS_ASSERT_PAD_FINDLEX;
838 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
839 "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
840 PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
842 /* first, search this pad */
844 if (padlist) { /* not an undef CV */
846 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
847 SV * const * const name_svp = AvARRAY(nameav);
849 for (offset = AvFILLp(nameav); offset > 0; offset--) {
850 const SV * const namesv = name_svp[offset];
851 if (namesv && namesv != &PL_sv_undef
852 && strEQ(SvPVX_const(namesv), name))
855 fake_offset = offset; /* in case we don't find a real one */
856 else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */
857 && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */
862 if (offset > 0 || fake_offset > 0 ) { /* a match! */
863 if (offset > 0) { /* not fake */
865 *out_name_sv = name_svp[offset]; /* return the namesv */
867 /* set PAD_FAKELEX_MULTI if this lex can have multiple
868 * instances. For now, we just test !CvUNIQUE(cv), but
869 * ideally, we should detect my's declared within loops
870 * etc - this would allow a wider range of 'not stayed
871 * shared' warnings. We also treated alreadly-compiled
872 * lexes as not multi as viewed from evals. */
874 *out_flags = CvANON(cv) ?
876 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
877 ? PAD_FAKELEX_MULTI : 0;
879 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
880 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
881 PTR2UV(cv), (long)offset,
882 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
883 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
885 else { /* fake match */
886 offset = fake_offset;
887 *out_name_sv = name_svp[offset]; /* return the namesv */
888 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
889 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
890 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
891 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
892 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
896 /* return the lex? */
901 if (SvPAD_OUR(*out_name_sv)) {
906 /* trying to capture from an anon prototype? */
908 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
909 : *out_flags & PAD_FAKELEX_ANON)
912 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
913 "Variable \"%s\" is not available", name);
920 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
921 && !SvPAD_STATE(name_svp[offset])
922 && warn && ckWARN(WARN_CLOSURE)) {
924 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
925 "Variable \"%s\" will not stay shared", name);
928 if (fake_offset && CvANON(cv)
929 && CvCLONE(cv) &&!CvCLONED(cv))
932 /* not yet caught - look further up */
933 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
934 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
937 (void) pad_findlex(name, CvOUTSIDE(cv),
939 newwarn, out_capture, out_name_sv, out_flags);
944 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
945 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
946 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
947 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
948 PTR2UV(cv), PTR2UV(*out_capture)));
950 if (SvPADSTALE(*out_capture)
951 && !SvPAD_STATE(name_svp[offset]))
953 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
954 "Variable \"%s\" is not available", name);
960 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
961 else if (*name == '%')
962 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
964 *out_capture = sv_newmortal();
972 /* it's not in this pad - try above */
977 /* out_capture non-null means caller wants us to capture lex; in
978 * addition we capture ourselves unless it's an ANON/format */
979 new_capturep = out_capture ? out_capture :
980 CvLATE(cv) ? NULL : &new_capture;
982 offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
983 new_capturep, out_name_sv, out_flags);
984 if ((PADOFFSET)offset == NOT_IN_PAD)
987 /* found in an outer CV. Add appropriate fake entry to this pad */
989 /* don't add new fake entries (via eval) to CVs that we have already
990 * finished compiling, or to undef CVs */
991 if (CvCOMPILED(cv) || !padlist)
992 return 0; /* this dummy (and invalid) value isnt used by the caller */
995 /* This relies on sv_setsv_flags() upgrading the destination to the same
996 type as the source, independant of the flags set, and on it being
997 "good" and only copying flag bits and pointers that it understands.
999 SV *new_namesv = newSVsv(*out_name_sv);
1000 AV * const ocomppad_name = PL_comppad_name;
1001 PAD * const ocomppad = PL_comppad;
1002 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1003 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1004 PL_curpad = AvARRAY(PL_comppad);
1007 = pad_add_name_sv(new_namesv,
1008 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1009 SvPAD_TYPED(*out_name_sv)
1010 ? SvSTASH(*out_name_sv) : NULL,
1011 SvOURSTASH(*out_name_sv)
1014 SvFAKE_on(new_namesv);
1015 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1016 "Pad addname: %ld \"%.*s\" FAKE\n",
1018 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1019 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1021 PARENT_PAD_INDEX_set(new_namesv, 0);
1022 if (SvPAD_OUR(new_namesv)) {
1023 NOOP; /* do nothing */
1025 else if (CvLATE(cv)) {
1026 /* delayed creation - just note the offset within parent pad */
1027 PARENT_PAD_INDEX_set(new_namesv, offset);
1031 /* immediate creation - capture outer value right now */
1032 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1033 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1034 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1035 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1037 *out_name_sv = new_namesv;
1038 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1040 PL_comppad_name = ocomppad_name;
1041 PL_comppad = ocomppad;
1042 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1052 Get the value at offset po in the current pad.
1053 Use macro PAD_SV instead of calling this function directly.
1060 Perl_pad_sv(pTHX_ PADOFFSET po)
1063 ASSERT_CURPAD_ACTIVE("pad_sv");
1066 Perl_croak(aTHX_ "panic: pad_sv po");
1067 DEBUG_X(PerlIO_printf(Perl_debug_log,
1068 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1069 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1071 return PL_curpad[po];
1076 =for apidoc pad_setsv
1078 Set the entry at offset po in the current pad to sv.
1079 Use the macro PAD_SETSV() rather than calling this function directly.
1085 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1089 PERL_ARGS_ASSERT_PAD_SETSV;
1091 ASSERT_CURPAD_ACTIVE("pad_setsv");
1093 DEBUG_X(PerlIO_printf(Perl_debug_log,
1094 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1095 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1104 =for apidoc pad_block_start
1106 Update the pad compilation state variables on entry to a new block
1111 /* XXX DAPM perhaps:
1112 * - integrate this in general state-saving routine ???
1113 * - combine with the state-saving going on in pad_new ???
1114 * - introduce a new SAVE type that does all this in one go ?
1118 Perl_pad_block_start(pTHX_ int full)
1121 ASSERT_CURPAD_ACTIVE("pad_block_start");
1122 SAVEI32(PL_comppad_name_floor);
1123 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1125 PL_comppad_name_fill = PL_comppad_name_floor;
1126 if (PL_comppad_name_floor < 0)
1127 PL_comppad_name_floor = 0;
1128 SAVEI32(PL_min_intro_pending);
1129 SAVEI32(PL_max_intro_pending);
1130 PL_min_intro_pending = 0;
1131 SAVEI32(PL_comppad_name_fill);
1132 SAVEI32(PL_padix_floor);
1133 PL_padix_floor = PL_padix;
1134 PL_pad_reset_pending = FALSE;
1139 =for apidoc intro_my
1141 "Introduce" my variables to visible status.
1153 ASSERT_CURPAD_ACTIVE("intro_my");
1154 if (! PL_min_intro_pending)
1155 return PL_cop_seqmax;
1157 svp = AvARRAY(PL_comppad_name);
1158 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1159 SV * const sv = svp[i];
1161 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
1162 COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* Don't know scope end yet. */
1163 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1164 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1165 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1166 (long)i, SvPVX_const(sv),
1167 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1168 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1172 PL_min_intro_pending = 0;
1173 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1174 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1175 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
1177 return PL_cop_seqmax++;
1181 =for apidoc pad_leavemy
1183 Cleanup at end of scope during compilation: set the max seq number for
1184 lexicals in this scope and warn of any lexicals that never got introduced.
1190 Perl_pad_leavemy(pTHX)
1194 SV * const * const svp = AvARRAY(PL_comppad_name);
1196 PL_pad_reset_pending = FALSE;
1198 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1199 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1200 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1201 const SV * const sv = svp[off];
1202 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1203 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1204 "%"SVf" never introduced",
1208 /* "Deintroduce" my variables that are leaving with this scope. */
1209 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1210 const SV * const sv = svp[off];
1211 if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
1212 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1213 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1214 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1215 (long)off, SvPVX_const(sv),
1216 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1217 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1222 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1223 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1228 =for apidoc pad_swipe
1230 Abandon the tmp in the current pad at offset po and replace with a
1237 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1240 ASSERT_CURPAD_LEGAL("pad_swipe");
1243 if (AvARRAY(PL_comppad) != PL_curpad)
1244 Perl_croak(aTHX_ "panic: pad_swipe curpad");
1246 Perl_croak(aTHX_ "panic: pad_swipe po");
1248 DEBUG_X(PerlIO_printf(Perl_debug_log,
1249 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1250 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1253 SvPADTMP_off(PL_curpad[po]);
1255 SvREFCNT_dec(PL_curpad[po]);
1258 /* if pad tmps aren't shared between ops, then there's no need to
1259 * create a new tmp when an existing op is freed */
1260 #ifdef USE_BROKEN_PAD_RESET
1261 PL_curpad[po] = newSV(0);
1262 SvPADTMP_on(PL_curpad[po]);
1264 PL_curpad[po] = &PL_sv_undef;
1266 if ((I32)po < PL_padix)
1272 =for apidoc pad_reset
1274 Mark all the current temporaries for reuse
1279 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1280 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1281 * on the stack by OPs that use them, there are several ways to get an alias
1282 * to a shared TARG. Such an alias will change randomly and unpredictably.
1283 * We avoid doing this until we can think of a Better Way.
1289 #ifdef USE_BROKEN_PAD_RESET
1290 if (AvARRAY(PL_comppad) != PL_curpad)
1291 Perl_croak(aTHX_ "panic: pad_reset curpad");
1293 DEBUG_X(PerlIO_printf(Perl_debug_log,
1294 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1295 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1296 (long)PL_padix, (long)PL_padix_floor
1300 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1302 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1303 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1304 SvPADTMP_off(PL_curpad[po]);
1306 PL_padix = PL_padix_floor;
1309 PL_pad_reset_pending = FALSE;
1314 =for apidoc pad_tidy
1316 Tidy up a pad after we've finished compiling it:
1317 * remove most stuff from the pads of anonsub prototypes;
1319 * mark tmps as such.
1324 /* XXX DAPM surely most of this stuff should be done properly
1325 * at the right time beforehand, rather than going around afterwards
1326 * cleaning up our mistakes ???
1330 Perl_pad_tidy(pTHX_ padtidy_type type)
1334 ASSERT_CURPAD_ACTIVE("pad_tidy");
1336 /* If this CV has had any 'eval-capable' ops planted in it
1337 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1338 * anon prototypes in the chain of CVs should be marked as cloneable,
1339 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1340 * the right CvOUTSIDE.
1341 * If running with -d, *any* sub may potentially have an eval
1342 * excuted within it.
1345 if (PL_cv_has_eval || PL_perldb) {
1347 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1348 if (cv != PL_compcv && CvCOMPILED(cv))
1349 break; /* no need to mark already-compiled code */
1351 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1352 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1358 /* extend curpad to match namepad */
1359 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1360 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1362 if (type == padtidy_SUBCLONE) {
1363 SV * const * const namep = AvARRAY(PL_comppad_name);
1366 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1369 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1372 * The only things that a clonable function needs in its
1373 * pad are anonymous subs.
1374 * The rest are created anew during cloning.
1376 if (!((namesv = namep[ix]) != NULL &&
1377 namesv != &PL_sv_undef &&
1378 *SvPVX_const(namesv) == '&'))
1380 SvREFCNT_dec(PL_curpad[ix]);
1381 PL_curpad[ix] = NULL;
1385 else if (type == padtidy_SUB) {
1386 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1387 AV * const av = newAV(); /* Will be @_ */
1388 av_store(PL_comppad, 0, MUTABLE_SV(av));
1392 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1393 SV * const * const namep = AvARRAY(PL_comppad_name);
1395 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1396 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1398 if (!SvPADMY(PL_curpad[ix])) {
1399 SvPADTMP_on(PL_curpad[ix]);
1400 } else if (!SvFAKE(namep[ix])) {
1401 /* This is a work around for how the current implementation of
1402 ?{ } blocks in regexps interacts with lexicals.
1404 One of our lexicals.
1405 Can't do this on all lexicals, otherwise sub baz() won't
1414 because completion of compiling &bar calling pad_tidy()
1415 would cause (top level) $foo to be marked as stale, and
1416 "no longer available". */
1417 SvPADSTALE_on(PL_curpad[ix]);
1421 PL_curpad = AvARRAY(PL_comppad);
1426 =for apidoc pad_free
1428 Free the SV at offset po in the current pad.
1433 /* XXX DAPM integrate with pad_swipe ???? */
1435 Perl_pad_free(pTHX_ PADOFFSET po)
1438 ASSERT_CURPAD_LEGAL("pad_free");
1441 if (AvARRAY(PL_comppad) != PL_curpad)
1442 Perl_croak(aTHX_ "panic: pad_free curpad");
1444 Perl_croak(aTHX_ "panic: pad_free po");
1446 DEBUG_X(PerlIO_printf(Perl_debug_log,
1447 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1448 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1451 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1452 SvPADTMP_off(PL_curpad[po]);
1454 /* SV could be a shared hash key (eg bugid #19022) */
1455 if (!SvIsCOW(PL_curpad[po]))
1456 SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
1459 if ((I32)po < PL_padix)
1466 =for apidoc do_dump_pad
1468 Dump the contents of a padlist
1474 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1483 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1488 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1489 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
1490 pname = AvARRAY(pad_name);
1491 ppad = AvARRAY(pad);
1492 Perl_dump_indent(aTHX_ level, file,
1493 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1494 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1497 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1498 const SV *namesv = pname[ix];
1499 if (namesv && namesv == &PL_sv_undef) {
1504 Perl_dump_indent(aTHX_ level+1, file,
1505 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1508 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1509 SvPVX_const(namesv),
1510 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1511 (unsigned long)PARENT_PAD_INDEX(namesv)
1515 Perl_dump_indent(aTHX_ level+1, file,
1516 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1519 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1520 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1521 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1526 Perl_dump_indent(aTHX_ level+1, file,
1527 "%2d. 0x%"UVxf"<%lu>\n",
1530 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1541 dump the contents of a CV
1548 S_cv_dump(pTHX_ const CV *cv, const char *title)
1551 const CV * const outside = CvOUTSIDE(cv);
1552 AV* const padlist = CvPADLIST(cv);
1554 PERL_ARGS_ASSERT_CV_DUMP;
1556 PerlIO_printf(Perl_debug_log,
1557 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1560 (CvANON(cv) ? "ANON"
1561 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1562 : (cv == PL_main_cv) ? "MAIN"
1563 : CvUNIQUE(cv) ? "UNIQUE"
1564 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1567 : CvANON(outside) ? "ANON"
1568 : (outside == PL_main_cv) ? "MAIN"
1569 : CvUNIQUE(outside) ? "UNIQUE"
1570 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1572 PerlIO_printf(Perl_debug_log,
1573 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1574 do_dump_pad(1, Perl_debug_log, padlist, 1);
1576 #endif /* DEBUGGING */
1583 =for apidoc cv_clone
1585 Clone a CV: make a new CV which points to the same code etc, but which
1586 has a newly-created pad built by copying the prototype pad and capturing
1593 Perl_cv_clone(pTHX_ CV *proto)
1597 AV* const protopadlist = CvPADLIST(proto);
1598 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1599 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
1600 SV** const pname = AvARRAY(protopad_name);
1601 SV** const ppad = AvARRAY(protopad);
1602 const I32 fname = AvFILLp(protopad_name);
1603 const I32 fpad = AvFILLp(protopad);
1609 PERL_ARGS_ASSERT_CV_CLONE;
1611 assert(!CvUNIQUE(proto));
1613 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1614 * to a prototype; we instead want the cloned parent who called us.
1615 * Note that in general for formats, CvOUTSIDE != find_runcv */
1617 outside = CvOUTSIDE(proto);
1618 if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1619 outside = find_runcv(NULL);
1620 depth = CvDEPTH(outside);
1621 assert(depth || SvTYPE(proto) == SVt_PVFM);
1624 assert(CvPADLIST(outside));
1627 SAVESPTR(PL_compcv);
1629 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
1630 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
1634 CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
1635 : savepv(CvFILE(proto));
1637 CvFILE(cv) = CvFILE(proto);
1639 CvGV_set(cv,CvGV(proto));
1640 CvSTASH_set(cv, CvSTASH(proto));
1642 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
1644 CvSTART(cv) = CvSTART(proto);
1645 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1646 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1649 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
1651 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
1653 av_fill(PL_comppad, fpad);
1654 for (ix = fname; ix >= 0; ix--)
1655 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1657 PL_curpad = AvARRAY(PL_comppad);
1659 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1661 for (ix = fpad; ix > 0; ix--) {
1662 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1664 if (namesv && namesv != &PL_sv_undef) { /* lexical */
1665 if (SvFAKE(namesv)) { /* lexical from outside? */
1666 sv = outpad[PARENT_PAD_INDEX(namesv)];
1668 /* formats may have an inactive parent,
1669 while my $x if $false can leave an active var marked as
1670 stale. And state vars are always available */
1671 if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
1672 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1673 "Variable \"%s\" is not available", SvPVX_const(namesv));
1677 SvREFCNT_inc_simple_void_NN(sv);
1680 const char sigil = SvPVX_const(namesv)[0];
1682 sv = SvREFCNT_inc(ppad[ix]);
1683 else if (sigil == '@')
1684 sv = MUTABLE_SV(newAV());
1685 else if (sigil == '%')
1686 sv = MUTABLE_SV(newHV());
1690 /* reset the 'assign only once' flag on each state var */
1691 if (SvPAD_STATE(namesv))
1695 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1696 sv = SvREFCNT_inc_NN(ppad[ix]);
1706 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1707 cv_dump(outside, "Outside");
1708 cv_dump(proto, "Proto");
1715 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1716 * The prototype was marked as a candiate for const-ization,
1717 * so try to grab the current const value, and if successful,
1718 * turn into a const sub:
1720 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
1723 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
1735 =for apidoc pad_fixup_inner_anons
1737 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1738 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1739 moved to a pre-existing CV struct.
1745 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1749 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1750 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
1751 SV ** const namepad = AvARRAY(comppad_name);
1752 SV ** const curpad = AvARRAY(comppad);
1754 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
1755 PERL_UNUSED_ARG(old_cv);
1757 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1758 const SV * const namesv = namepad[ix];
1759 if (namesv && namesv != &PL_sv_undef
1760 && *SvPVX_const(namesv) == '&')
1762 CV * const innercv = MUTABLE_CV(curpad[ix]);
1763 assert(CvWEAKOUTSIDE(innercv));
1764 assert(CvOUTSIDE(innercv) == old_cv);
1765 CvOUTSIDE(innercv) = new_cv;
1772 =for apidoc pad_push
1774 Push a new pad frame onto the padlist, unless there's already a pad at
1775 this depth, in which case don't bother creating a new one. Then give
1776 the new pad an @_ in slot zero.
1782 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
1786 PERL_ARGS_ASSERT_PAD_PUSH;
1788 if (depth > AvFILLp(padlist)) {
1789 SV** const svp = AvARRAY(padlist);
1790 AV* const newpad = newAV();
1791 SV** const oldpad = AvARRAY(svp[depth-1]);
1792 I32 ix = AvFILLp((const AV *)svp[1]);
1793 const I32 names_fill = AvFILLp((const AV *)svp[0]);
1794 SV** const names = AvARRAY(svp[0]);
1797 for ( ;ix > 0; ix--) {
1798 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1799 const char sigil = SvPVX_const(names[ix])[0];
1800 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1801 || (SvFLAGS(names[ix]) & SVpad_STATE)
1804 /* outer lexical or anon code */
1805 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1807 else { /* our own lexical */
1810 sv = MUTABLE_SV(newAV());
1811 else if (sigil == '%')
1812 sv = MUTABLE_SV(newHV());
1815 av_store(newpad, ix, sv);
1819 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1820 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
1823 /* save temporaries on recursion? */
1824 SV * const sv = newSV(0);
1825 av_store(newpad, ix, sv);
1830 av_store(newpad, 0, MUTABLE_SV(av));
1833 av_store(padlist, depth, MUTABLE_SV(newpad));
1834 AvFILLp(padlist) = depth;
1840 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
1843 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
1844 if ( SvPAD_TYPED(*av) ) {
1845 return SvSTASH(*av);
1850 #if defined(USE_ITHREADS)
1852 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
1855 Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
1858 PERL_ARGS_ASSERT_PADLIST_DUP;
1863 assert(!AvREAL(srcpad));
1865 if (param->flags & CLONEf_COPY_STACKS
1866 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
1867 /* XXX padlists are real, but pretend to be not */
1869 dstpad = av_dup_inc(srcpad, param);
1872 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
1874 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
1875 to build anything other than the first level of pads. */
1877 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
1879 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
1880 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
1881 SV **oldpad = AvARRAY(srcpad1);
1885 /* look for it in the table first.
1886 I *think* that it shouldn't be possible to find it there.
1887 Well, except for how Perl_sv_compile_2op() "works" :-( */
1888 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
1894 ptr_table_store(PL_ptr_table, srcpad, dstpad);
1896 av_extend(dstpad, 1);
1897 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
1898 names = AvARRAY(AvARRAY(dstpad)[0]);
1902 av_extend(pad1, ix);
1903 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
1904 pad1a = AvARRAY(pad1);
1905 AvFILLp(dstpad) = 1;
1910 for ( ;ix > 0; ix--) {
1913 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1914 const char sigil = SvPVX_const(names[ix])[0];
1915 if ((SvFLAGS(names[ix]) & SVf_FAKE)
1916 || (SvFLAGS(names[ix]) & SVpad_STATE)
1919 /* outer lexical or anon code */
1920 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1922 else { /* our own lexical */
1923 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
1924 /* This is a work around for how the current
1925 implementation of ?{ } blocks in regexps
1926 interacts with lexicals. */
1927 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1932 sv = MUTABLE_SV(newAV());
1933 else if (sigil == '%')
1934 sv = MUTABLE_SV(newHV());
1942 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1943 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
1946 /* save temporaries on recursion? */
1947 SV * const sv = newSV(0);
1950 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
1951 FIXTHAT before merging this branch.
1952 (And I know how to) */
1953 if (SvPADMY(oldpad[ix]))
1961 args = newAV(); /* Will be @_ */
1963 pad1a[0] = (SV *)args;
1975 * c-indentation-style: bsd
1977 * indent-tabs-mode: t
1980 * ex: set ts=8 sts=4 sw=4 noet: