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 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
32 CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
36 For these purposes "formats" are a kind-of CV; eval""s are too (except they're
37 not callable at will and are always thrown away after the eval"" is done
38 executing). Require'd files are simply evals without any outer lexical
41 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
45 The PADLIST has a C array where pads are stored.
47 The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
48 AV, but that may change) which represents the "names" or rather
49 the "static type information" for lexicals. The individual elements of a
50 PADNAMELIST are PADNAMEs (just SVs; but, again, that may change). Future
51 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
52 array, so don't rely on it. See L</PadlistNAMES>.
54 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
55 at that depth of recursion into the CV. The 0th slot of a frame AV is an
56 AV which is @_. Other entries are storage for variables and op targets.
58 Iterating over the PADNAMELIST iterates over all possible pad
59 items. Pad slots for targets (SVs_PADTMP) and GVs end up having &PL_sv_no
60 "names", while slots for constants have &PL_sv_no "names" (see
61 pad_alloc()). That &PL_sv_no is used is an implementation detail subject
62 to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
64 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
65 The rest are op targets/GVs/constants which are statically allocated
66 or resolved at compile time. These don't have names by which they
67 can be looked up from Perl code at run time through eval"" the way
68 my/our variables can be. Since they can't be looked up by "name"
69 but only by their index allocated at compile time (which is usually
70 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
72 The SVs in the names AV have their PV being the name of the variable.
73 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
74 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
75 _HIGH). During compilation, these fields may hold the special value
76 PERL_PADSEQ_INTRO to indicate various stages:
78 COP_SEQ_RANGE_LOW _HIGH
79 ----------------- -----
80 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
81 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
82 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
84 For typed lexicals name SV is SVt_PVMG and SvSTASH
85 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
86 SvOURSTASH slot pointing at the stash of the associated global (so that
87 duplicate C<our> declarations in the same package can be detected). SvUVX is
88 sometimes hijacked to store the generation number during compilation.
90 If PADNAME_OUTER (SvFAKE) is set on the
91 name SV, then that slot in the frame AV is
92 a REFCNT'ed reference to a lexical from "outside". In this case,
93 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
94 in scope throughout. Instead xhigh stores some flags containing info about
95 the real lexical (is it declared in an anon, and is it capable of being
96 instantiated multiple times?), and for fake ANONs, xlow contains the index
97 within the parent's pad where the lexical's value is stored, to make
100 If the 'name' is '&' the corresponding entry in the PAD
101 is a CV representing a possible closure.
102 (PADNAME_OUTER and name of '&' is not a
103 meaningful combination currently but could
104 become so if C<my sub foo {}> is implemented.)
106 Note that formats are treated as anon subs, and are cloned each time
107 write is called (if necessary).
109 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
110 and set on scope exit. This allows the
111 'Variable $x is not available' warning
112 to be generated in evals, such as
114 { my $x = 1; sub f { eval '$x'} } f();
116 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
118 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
120 During compilation, this points to the array containing the names part
121 of the pad for the currently-compiling code.
123 =for apidoc AmxU|PAD *|PL_comppad
125 During compilation, this points to the array containing the values
126 part of the pad for the currently-compiling code. (At runtime a CV may
127 have many such value arrays; at compile time just one is constructed.)
128 At runtime, this points to the array containing the currently-relevant
129 values for the pad for the currently-executing code.
131 =for apidoc AmxU|SV **|PL_curpad
133 Points directly to the body of the L</PL_comppad> array.
134 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
141 #define PERL_IN_PAD_C
143 #include "keywords.h"
145 #define COP_SEQ_RANGE_LOW_set(sv,val) \
146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
147 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
148 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
150 #define PARENT_PAD_INDEX_set(sv,val) \
151 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
152 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
153 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
156 =for apidoc mx|void|pad_peg|const char *s
158 When PERL_MAD is enabled, this is a small no-op function that gets called
159 at the start of each pad-related function. It can be breakpointed to
160 track all pad operations. The parameter is a string indicating the type
161 of pad operation being performed.
167 void pad_peg(const char* s) {
168 static int pegcnt; /* XXX not threadsafe */
171 PERL_ARGS_ASSERT_PAD_PEG;
178 This is basically sv_eq_flags() in sv.c, but we avoid the magic
183 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
184 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
185 const char *pv1 = SvPVX_const(sv);
186 STRLEN cur1 = SvCUR(sv);
187 const char *pv2 = pv;
192 svrecode = newSVpvn(pv2, cur2);
193 sv_recode_to_utf8(svrecode, PL_encoding);
194 pv2 = SvPV_const(svrecode, cur2);
197 svrecode = newSVpvn(pv1, cur1);
198 sv_recode_to_utf8(svrecode, PL_encoding);
199 pv1 = SvPV_const(svrecode, cur1);
201 SvREFCNT_dec_NN(svrecode);
203 if (flags & SVf_UTF8)
204 return (bytes_cmp_utf8(
205 (const U8*)pv1, cur1,
206 (const U8*)pv2, cur2) == 0);
208 return (bytes_cmp_utf8(
209 (const U8*)pv2, cur2,
210 (const U8*)pv1, cur1) == 0);
213 return ((SvPVX_const(sv) == pv)
214 || memEQ(SvPVX_const(sv), pv, pvlen));
219 =for apidoc Am|PADLIST *|pad_new|int flags
221 Create a new padlist, updating the global variables for the
222 currently-compiling padlist to point to the new padlist. The following
223 flags can be OR'ed together:
225 padnew_CLONE this pad is for a cloned CV
226 padnew_SAVE save old globals on the save stack
227 padnew_SAVESUB also save extra stuff for start of sub
233 Perl_pad_new(pTHX_ int flags)
240 ASSERT_CURPAD_LEGAL("pad_new");
242 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
243 * vars (based on flags) rather than storing vals + addresses for
244 * each individually. Also see pad_block_start.
245 * XXX DAPM Try to see whether all these conditionals are required
248 /* save existing state, ... */
250 if (flags & padnew_SAVE) {
252 if (! (flags & padnew_CLONE)) {
253 SAVESPTR(PL_comppad_name);
255 SAVEI32(PL_comppad_name_fill);
256 SAVEI32(PL_min_intro_pending);
257 SAVEI32(PL_max_intro_pending);
258 SAVEBOOL(PL_cv_has_eval);
259 if (flags & padnew_SAVESUB) {
260 SAVEBOOL(PL_pad_reset_pending);
264 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
265 * saved - check at some pt that this is okay */
267 /* ... create new pad ... */
269 Newxz(padlist, 1, PADLIST);
272 if (flags & padnew_CLONE) {
273 /* XXX DAPM I dont know why cv_clone needs it
274 * doing differently yet - perhaps this separate branch can be
275 * dispensed with eventually ???
278 AV * const a0 = newAV(); /* will be @_ */
279 av_store(pad, 0, MUTABLE_SV(a0));
282 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
285 av_store(pad, 0, NULL);
287 AvPAD_NAMELIST_on(padname);
290 /* Most subroutines never recurse, hence only need 2 entries in the padlist
291 array - names, and depth=1. The default for av_store() is to allocate
292 0..3, and even an explicit call to av_extend() with <3 will be rounded
293 up, so we inline the allocation of the array here. */
295 PadlistMAX(padlist) = 1;
296 PadlistARRAY(padlist) = ary;
300 /* ... then update state variables */
303 PL_curpad = AvARRAY(pad);
305 if (! (flags & padnew_CLONE)) {
306 PL_comppad_name = padname;
307 PL_comppad_name_fill = 0;
308 PL_min_intro_pending = 0;
313 DEBUG_X(PerlIO_printf(Perl_debug_log,
314 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
315 " name=0x%"UVxf" flags=0x%"UVxf"\n",
316 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
317 PTR2UV(padname), (UV)flags
321 return (PADLIST*)padlist;
326 =head1 Embedding Functions
330 Clear out all the active components of a CV. This can happen either
331 by an explicit C<undef &foo>, or by the reference count going to zero.
332 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
333 children can still follow the full lexical scope chain.
339 Perl_cv_undef(pTHX_ CV *cv)
342 const PADLIST *padlist = CvPADLIST(cv);
343 bool const slabbed = !!CvSLABBED(cv);
345 PERL_ARGS_ASSERT_CV_UNDEF;
347 DEBUG_X(PerlIO_printf(Perl_debug_log,
348 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
349 PTR2UV(cv), PTR2UV(PL_comppad))
352 if (CvFILE(cv) && CvDYNFILE(cv)) {
353 Safefree(CvFILE(cv));
358 if (!CvISXSUB(cv) && CvROOT(cv)) {
359 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
360 Perl_croak(aTHX_ "Can't undef active subroutine");
363 PAD_SAVE_SETNULLPAD();
365 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
371 else if (slabbed && CvSTART(cv)) {
373 PAD_SAVE_SETNULLPAD();
375 /* discard any leaked ops */
377 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
378 opslab_force_free((OPSLAB *)CvSTART(cv));
384 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
386 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
387 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
388 if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
389 else CvGV_set(cv, NULL);
391 /* This statement and the subsequence if block was pad_undef(). */
392 pad_peg("pad_undef");
397 /* Free the padlist associated with a CV.
398 If parts of it happen to be current, we null the relevant PL_*pad*
399 global vars so that we don't have any dangling references left.
400 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
401 subs to the outer of this cv. */
403 DEBUG_X(PerlIO_printf(Perl_debug_log,
404 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
405 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
408 /* detach any '&' anon children in the pad; if afterwards they
409 * are still live, fix up their CvOUTSIDEs to point to our outside,
411 /* XXX DAPM for efficiency, we should only do this if we know we have
412 * children, or integrate this loop with general cleanup */
414 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
415 CV * const outercv = CvOUTSIDE(cv);
416 const U32 seq = CvOUTSIDE_SEQ(cv);
417 PAD * const comppad_name = PadlistARRAY(padlist)[0];
418 SV ** const namepad = AvARRAY(comppad_name);
419 PAD * const comppad = PadlistARRAY(padlist)[1];
420 SV ** const curpad = AvARRAY(comppad);
421 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
422 SV * const namesv = namepad[ix];
423 if (namesv && namesv != &PL_sv_undef
424 && *SvPVX_const(namesv) == '&')
426 CV * const innercv = MUTABLE_CV(curpad[ix]);
427 U32 inner_rc = SvREFCNT(innercv);
429 assert(SvTYPE(innercv) != SVt_PVFM);
431 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
433 SvREFCNT_dec_NN(innercv);
437 /* in use, not just a prototype */
438 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
439 assert(CvWEAKOUTSIDE(innercv));
440 /* don't relink to grandfather if he's being freed */
441 if (outercv && SvREFCNT(outercv)) {
442 CvWEAKOUTSIDE_off(innercv);
443 CvOUTSIDE(innercv) = outercv;
444 CvOUTSIDE_SEQ(innercv) = seq;
445 SvREFCNT_inc_simple_void_NN(outercv);
448 CvOUTSIDE(innercv) = NULL;
455 ix = PadlistMAX(padlist);
457 PAD * const sv = PadlistARRAY(padlist)[ix--];
459 if (sv == PL_comppad) {
467 PAD * const sv = PadlistARRAY(padlist)[0];
468 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
469 PL_comppad_name = NULL;
472 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
474 CvPADLIST(cv) = NULL;
478 /* remove CvOUTSIDE unless this is an undef rather than a free */
479 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
480 if (!CvWEAKOUTSIDE(cv))
481 SvREFCNT_dec(CvOUTSIDE(cv));
482 CvOUTSIDE(cv) = NULL;
485 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
488 if (CvISXSUB(cv) && CvXSUB(cv)) {
491 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
492 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
493 * to choose an error message */
494 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
498 =for apidoc cv_forget_slab
500 When a CV has a reference count on its slab (CvSLABBED), it is responsible
501 for making sure it is freed. (Hence, no two CVs should ever have a
502 reference count on the same slab.) The CV only needs to reference the slab
503 during compilation. Once it is compiled and CvROOT attached, it has
504 finished its job, so it can forget the slab.
510 Perl_cv_forget_slab(pTHX_ CV *cv)
512 const bool slabbed = !!CvSLABBED(cv);
515 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
517 if (!slabbed) return;
521 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
522 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
524 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
528 #ifdef PERL_DEBUG_READONLY_OPS
529 const size_t refcnt = slab->opslab_refcnt;
531 OpslabREFCNT_dec(slab);
532 #ifdef PERL_DEBUG_READONLY_OPS
533 if (refcnt > 1) Slab_to_ro(slab);
539 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
541 Allocates a place in the currently-compiling
542 pad (via L<perlapi/pad_alloc>) and
543 then stores a name for that entry. I<namesv> is adopted and becomes the
544 name entry; it must already contain the name string and be sufficiently
545 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
546 added to I<namesv>. None of the other
547 processing of L<perlapi/pad_add_name_pvn>
548 is done. Returns the offset of the allocated pad slot.
554 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
557 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
559 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
561 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
564 assert(SvTYPE(namesv) == SVt_PVMG);
565 SvPAD_TYPED_on(namesv);
566 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
569 SvPAD_OUR_on(namesv);
570 SvOURSTASH_set(namesv, ourstash);
571 SvREFCNT_inc_simple_void_NN(ourstash);
573 else if (flags & padadd_STATE) {
574 SvPAD_STATE_on(namesv);
577 av_store(PL_comppad_name, offset, namesv);
578 PadnamelistMAXNAMED(PL_comppad_name) = offset;
583 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
585 Allocates a place in the currently-compiling pad for a named lexical
586 variable. Stores the name and other metadata in the name part of the
587 pad, and makes preparations to manage the variable's lexical scoping.
588 Returns the offset of the allocated pad slot.
590 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
591 If I<typestash> is non-null, the name is for a typed lexical, and this
592 identifies the type. If I<ourstash> is non-null, it's a lexical reference
593 to a package variable, and this identifies the package. The following
594 flags can be OR'ed together:
596 padadd_OUR redundantly specifies if it's a package var
597 padadd_STATE variable will retain value persistently
598 padadd_NO_DUP_CHECK skip check for lexical shadowing
604 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
605 U32 flags, HV *typestash, HV *ourstash)
612 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
614 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
615 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
618 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
620 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
621 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
624 sv_setpvn(namesv, namepv, namelen);
627 flags |= padadd_UTF8_NAME;
631 flags &= ~padadd_UTF8_NAME;
633 if ((flags & padadd_NO_DUP_CHECK) == 0) {
635 SAVEFREESV(namesv); /* in case of fatal warnings */
636 /* check for duplicate declaration */
637 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
638 SvREFCNT_inc_simple_void_NN(namesv);
642 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
644 /* not yet introduced */
645 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
646 COP_SEQ_RANGE_HIGH_set(namesv, 0);
648 if (!PL_min_intro_pending)
649 PL_min_intro_pending = offset;
650 PL_max_intro_pending = offset;
651 /* if it's not a simple scalar, replace with an AV or HV */
652 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
653 assert(SvREFCNT(PL_curpad[offset]) == 1);
654 if (namelen != 0 && *namepv == '@')
655 sv_upgrade(PL_curpad[offset], SVt_PVAV);
656 else if (namelen != 0 && *namepv == '%')
657 sv_upgrade(PL_curpad[offset], SVt_PVHV);
658 else if (namelen != 0 && *namepv == '&')
659 sv_upgrade(PL_curpad[offset], SVt_PVCV);
660 assert(SvPADMY(PL_curpad[offset]));
661 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
662 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
663 (long)offset, SvPVX(namesv),
664 PTR2UV(PL_curpad[offset])));
670 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
672 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
673 instead of a string/length pair.
679 Perl_pad_add_name_pv(pTHX_ const char *name,
680 const U32 flags, HV *typestash, HV *ourstash)
682 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
683 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
687 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
689 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
690 of an SV instead of a string/length pair.
696 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
700 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
701 namepv = SvPV(name, namelen);
703 flags |= padadd_UTF8_NAME;
704 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
708 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
710 Allocates a place in the currently-compiling pad,
711 returning the offset of the allocated pad slot.
712 No name is initially attached to the pad slot.
713 I<tmptype> is a set of flags indicating the kind of pad entry required,
714 which will be set in the value SV for the allocated pad entry:
716 SVs_PADMY named lexical variable ("my", "our", "state")
717 SVs_PADTMP unnamed temporary store
718 SVf_READONLY constant shared between recursion levels
720 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
721 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
722 does not cause the SV in the pad slot to be marked read-only, but simply
723 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
724 least should be treated as such.
726 I<optype> should be an opcode indicating the type of operation that the
727 pad entry is to support. This doesn't affect operational semantics,
728 but is used for debugging.
733 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
734 * or at least rationalise ??? */
737 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
743 PERL_UNUSED_ARG(optype);
744 ASSERT_CURPAD_ACTIVE("pad_alloc");
746 if (AvARRAY(PL_comppad) != PL_curpad)
747 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
748 AvARRAY(PL_comppad), PL_curpad);
749 if (PL_pad_reset_pending)
751 if (tmptype & SVs_PADMY) {
752 /* For a my, simply push a null SV onto the end of PL_comppad. */
753 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
754 retval = AvFILLp(PL_comppad);
757 /* For a tmp, scan the pad from PL_padix upwards
758 * for a slot which has no name and no active value.
760 SV * const * const names = AvARRAY(PL_comppad_name);
761 const SSize_t names_fill = AvFILLp(PL_comppad_name);
764 * Entries that close over unavailable variables
765 * in outer subs contain values not marked PADMY.
766 * Thus we must skip, not just pad values that are
767 * marked as current pad values, but also those with names.
769 if (++PL_padix <= names_fill &&
770 (sv = names[PL_padix]) && sv != &PL_sv_undef)
772 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
773 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
777 if (tmptype & SVf_READONLY) {
778 av_store(PL_comppad_name, PL_padix, &PL_sv_no);
779 tmptype &= ~SVf_READONLY;
780 tmptype |= SVs_PADTMP;
784 SvFLAGS(sv) |= tmptype;
785 PL_curpad = AvARRAY(PL_comppad);
787 DEBUG_X(PerlIO_printf(Perl_debug_log,
788 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
789 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
790 PL_op_name[optype]));
791 #ifdef DEBUG_LEAKING_SCALARS
792 sv->sv_debug_optype = optype;
793 sv->sv_debug_inpad = 1;
795 return (PADOFFSET)retval;
799 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
801 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
802 for an anonymous function that is lexically scoped inside the
803 currently-compiling function.
804 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
805 to the outer scope is weakened to avoid a reference loop.
807 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
809 I<optype> should be an opcode indicating the type of operation that the
810 pad entry is to support. This doesn't affect operational semantics,
811 but is used for debugging.
817 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
821 SV* const name = newSV_type(SVt_PVNV);
823 PERL_ARGS_ASSERT_PAD_ADD_ANON;
826 sv_setpvs(name, "&");
827 /* These two aren't used; just make sure they're not equal to
828 * PERL_PADSEQ_INTRO */
829 COP_SEQ_RANGE_LOW_set(name, 0);
830 COP_SEQ_RANGE_HIGH_set(name, 0);
831 ix = pad_alloc(optype, SVs_PADMY);
832 av_store(PL_comppad_name, ix, name);
833 /* XXX DAPM use PL_curpad[] ? */
834 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
835 av_store(PL_comppad, ix, (SV*)func);
837 SV *rv = newRV_noinc((SV *)func);
839 assert (SvTYPE(func) == SVt_PVFM);
840 av_store(PL_comppad, ix, rv);
842 SvPADMY_on((SV*)func);
844 /* to avoid ref loops, we never have parent + child referencing each
845 * other simultaneously */
846 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
847 assert(!CvWEAKOUTSIDE(func));
848 CvWEAKOUTSIDE_on(func);
849 SvREFCNT_dec_NN(CvOUTSIDE(func));
855 =for apidoc pad_check_dup
857 Check for duplicate declarations: report any of:
859 * a my in the current scope with the same name;
860 * an our (anywhere in the pad) with the same name and the
861 same stash as C<ourstash>
863 C<is_our> indicates that the name to check is an 'our' declaration.
869 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
874 const U32 is_our = flags & padadd_OUR;
876 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
878 ASSERT_CURPAD_ACTIVE("pad_check_dup");
880 assert((flags & ~padadd_OUR) == 0);
882 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
883 return; /* nothing to check */
885 svp = AvARRAY(PL_comppad_name);
886 top = AvFILLp(PL_comppad_name);
887 /* check the current scope */
888 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
890 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
891 SV * const sv = svp[off];
895 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
896 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
899 if (is_our && (SvPAD_OUR(sv)))
900 break; /* "our" masking "our" */
901 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
902 Perl_warner(aTHX_ packWARN(WARN_MISC),
903 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
904 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
905 *SvPVX(sv) == '&' ? "subroutine" : "variable",
907 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
908 ? "scope" : "statement"));
913 /* check the rest of the pad */
916 SV * const sv = svp[off];
920 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
921 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
922 && SvOURSTASH(sv) == ourstash
925 Perl_warner(aTHX_ packWARN(WARN_MISC),
926 "\"our\" variable %"SVf" redeclared", sv);
927 if ((I32)off <= PL_comppad_name_floor)
928 Perl_warner(aTHX_ packWARN(WARN_MISC),
929 "\t(Did you mean \"local\" instead of \"our\"?)\n");
939 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
941 Given the name of a lexical variable, find its position in the
942 currently-compiling pad.
943 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
944 I<flags> is reserved and must be zero.
945 If it is not in the current pad but appears in the pad of any lexically
946 enclosing scope, then a pseudo-entry for it is added in the current pad.
947 Returns the offset in the current pad,
948 or C<NOT_IN_PAD> if no such lexical is in scope.
954 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
963 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
965 pad_peg("pad_findmy_pvn");
967 if (flags & ~padadd_UTF8_NAME)
968 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
971 if (flags & padadd_UTF8_NAME) {
973 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
976 flags |= padadd_UTF8_NAME;
978 flags &= ~padadd_UTF8_NAME;
981 offset = pad_findlex(namepv, namelen, flags,
982 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
983 if ((PADOFFSET)offset != NOT_IN_PAD)
986 /* look for an our that's being introduced; this allows
987 * our $foo = 0 unless defined $foo;
988 * to not give a warning. (Yes, this is a hack) */
990 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
991 name_svp = AvARRAY(nameav);
992 for (offset = AvFILLp(nameav); offset > 0; offset--) {
993 const SV * const namesv = name_svp[offset];
994 if (namesv && PadnameLEN(namesv) == namelen
996 && (SvPAD_OUR(namesv))
997 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
998 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
999 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
1007 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
1009 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1010 instead of a string/length pair.
1016 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1018 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1019 return pad_findmy_pvn(name, strlen(name), flags);
1023 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1025 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1026 of an SV instead of a string/length pair.
1032 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1036 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1037 namepv = SvPV(name, namelen);
1039 flags |= padadd_UTF8_NAME;
1040 return pad_findmy_pvn(namepv, namelen, flags);
1044 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1046 Find the position of the lexical C<$_> in the pad of the
1047 currently-executing function. Returns the offset in the current pad,
1048 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1049 the global one should be used instead).
1050 L</find_rundefsv> is likely to be more convenient.
1056 Perl_find_rundefsvoffset(pTHX)
1061 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1062 NULL, &out_sv, &out_flags);
1066 =for apidoc Am|SV *|find_rundefsv
1068 Find and return the variable that is named C<$_> in the lexical scope
1069 of the currently-executing function. This may be a lexical C<$_>,
1070 or will otherwise be the global one.
1076 Perl_find_rundefsv(pTHX)
1082 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1083 NULL, &namesv, &flags);
1085 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1092 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1098 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1100 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1101 NULL, &namesv, &flags);
1103 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1106 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1110 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
1112 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1113 in the inner pads if it's found in an outer one.
1115 Returns the offset in the bottom pad of the lex or the fake lex.
1116 cv is the CV in which to start the search, and seq is the current cop_seq
1117 to match against. If warn is true, print appropriate warnings. The out_*
1118 vars return values, and so are pointers to where the returned values
1119 should be stored. out_capture, if non-null, requests that the innermost
1120 instance of the lexical is captured; out_name_sv is set to the innermost
1121 matched namesv or fake namesv; out_flags returns the flags normally
1122 associated with the IVX field of a fake namesv.
1124 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1125 then comes back down, adding fake entries as it goes. It has to be this way
1126 because fake namesvs in anon protoypes have to store in xlow the index into
1132 /* the CV has finished being compiled. This is not a sufficient test for
1133 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1134 #define CvCOMPILED(cv) CvROOT(cv)
1136 /* the CV does late binding of its lexicals */
1137 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1140 S_unavailable(pTHX_ SV *namesv)
1142 /* diag_listed_as: Variable "%s" is not available */
1143 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1144 "%se \"%"SVf"\" is not available",
1145 *SvPVX_const(namesv) == '&'
1152 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1153 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1156 I32 offset, new_offset;
1159 const PADLIST * const padlist = CvPADLIST(cv);
1160 const bool staleok = !!(flags & padadd_STALEOK);
1162 PERL_ARGS_ASSERT_PAD_FINDLEX;
1164 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1165 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1167 flags &= ~ padadd_STALEOK; /* one-shot flag */
1171 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1172 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1173 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1174 out_capture ? " capturing" : "" ));
1176 /* first, search this pad */
1178 if (padlist) { /* not an undef CV */
1179 I32 fake_offset = 0;
1180 const AV * const nameav = PadlistARRAY(padlist)[0];
1181 SV * const * const name_svp = AvARRAY(nameav);
1183 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1184 const SV * const namesv = name_svp[offset];
1185 if (namesv && PadnameLEN(namesv) == namelen
1186 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1187 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1189 if (SvFAKE(namesv)) {
1190 fake_offset = offset; /* in case we don't find a real one */
1193 /* is seq within the range _LOW to _HIGH ?
1194 * This is complicated by the fact that PL_cop_seqmax
1195 * may have wrapped around at some point */
1196 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1197 continue; /* not yet introduced */
1199 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1200 /* in compiling scope */
1202 (seq > COP_SEQ_RANGE_LOW(namesv))
1203 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1204 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1209 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1211 ( seq > COP_SEQ_RANGE_LOW(namesv)
1212 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1214 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1215 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1221 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1222 if (offset > 0) { /* not fake */
1224 *out_name_sv = name_svp[offset]; /* return the namesv */
1226 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1227 * instances. For now, we just test !CvUNIQUE(cv), but
1228 * ideally, we should detect my's declared within loops
1229 * etc - this would allow a wider range of 'not stayed
1230 * shared' warnings. We also treated already-compiled
1231 * lexes as not multi as viewed from evals. */
1233 *out_flags = CvANON(cv) ?
1235 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1236 ? PAD_FAKELEX_MULTI : 0;
1238 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1239 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1240 PTR2UV(cv), (long)offset,
1241 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1242 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1244 else { /* fake match */
1245 offset = fake_offset;
1246 *out_name_sv = name_svp[offset]; /* return the namesv */
1247 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1248 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1249 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1250 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1251 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1255 /* return the lex? */
1260 if (SvPAD_OUR(*out_name_sv)) {
1261 *out_capture = NULL;
1265 /* trying to capture from an anon prototype? */
1267 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1268 : *out_flags & PAD_FAKELEX_ANON)
1272 newSVpvn_flags(namepv, namelen,
1274 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1276 *out_capture = NULL;
1282 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1283 && !SvPAD_STATE(name_svp[offset])
1284 && warn && ckWARN(WARN_CLOSURE)) {
1286 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1287 "Variable \"%"SVf"\" will not stay shared",
1288 newSVpvn_flags(namepv, namelen,
1290 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1293 if (fake_offset && CvANON(cv)
1294 && CvCLONE(cv) &&!CvCLONED(cv))
1297 /* not yet caught - look further up */
1298 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1299 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1302 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1304 newwarn, out_capture, out_name_sv, out_flags);
1309 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1310 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1311 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1312 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1313 PTR2UV(cv), PTR2UV(*out_capture)));
1315 if (SvPADSTALE(*out_capture)
1316 && (!CvDEPTH(cv) || !staleok)
1317 && !SvPAD_STATE(name_svp[offset]))
1320 newSVpvn_flags(namepv, namelen,
1322 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1323 *out_capture = NULL;
1326 if (!*out_capture) {
1327 if (namelen != 0 && *namepv == '@')
1328 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1329 else if (namelen != 0 && *namepv == '%')
1330 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1331 else if (namelen != 0 && *namepv == '&')
1332 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1334 *out_capture = sv_newmortal();
1342 /* it's not in this pad - try above */
1347 /* out_capture non-null means caller wants us to capture lex; in
1348 * addition we capture ourselves unless it's an ANON/format */
1349 new_capturep = out_capture ? out_capture :
1350 CvLATE(cv) ? NULL : &new_capture;
1352 offset = pad_findlex(namepv, namelen,
1353 flags | padadd_STALEOK*(new_capturep == &new_capture),
1354 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1355 new_capturep, out_name_sv, out_flags);
1356 if ((PADOFFSET)offset == NOT_IN_PAD)
1359 /* found in an outer CV. Add appropriate fake entry to this pad */
1361 /* don't add new fake entries (via eval) to CVs that we have already
1362 * finished compiling, or to undef CVs */
1363 if (CvCOMPILED(cv) || !padlist)
1364 return 0; /* this dummy (and invalid) value isnt used by the caller */
1367 /* This relies on sv_setsv_flags() upgrading the destination to the same
1368 type as the source, independent of the flags set, and on it being
1369 "good" and only copying flag bits and pointers that it understands.
1371 SV *new_namesv = newSVsv(*out_name_sv);
1372 AV * const ocomppad_name = PL_comppad_name;
1373 PAD * const ocomppad = PL_comppad;
1374 PL_comppad_name = PadlistARRAY(padlist)[0];
1375 PL_comppad = PadlistARRAY(padlist)[1];
1376 PL_curpad = AvARRAY(PL_comppad);
1379 = pad_alloc_name(new_namesv,
1380 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1381 SvPAD_TYPED(*out_name_sv)
1382 ? SvSTASH(*out_name_sv) : NULL,
1383 SvOURSTASH(*out_name_sv)
1386 SvFAKE_on(new_namesv);
1387 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1388 "Pad addname: %ld \"%.*s\" FAKE\n",
1390 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1391 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1393 PARENT_PAD_INDEX_set(new_namesv, 0);
1394 if (SvPAD_OUR(new_namesv)) {
1395 NOOP; /* do nothing */
1397 else if (CvLATE(cv)) {
1398 /* delayed creation - just note the offset within parent pad */
1399 PARENT_PAD_INDEX_set(new_namesv, offset);
1403 /* immediate creation - capture outer value right now */
1404 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1405 /* But also note the offset, as newMYSUB needs it */
1406 PARENT_PAD_INDEX_set(new_namesv, offset);
1407 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1408 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1409 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1411 *out_name_sv = new_namesv;
1412 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1414 PL_comppad_name = ocomppad_name;
1415 PL_comppad = ocomppad;
1416 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1424 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1426 Get the value at offset I<po> in the current (compiling or executing) pad.
1427 Use macro PAD_SV instead of calling this function directly.
1433 Perl_pad_sv(pTHX_ PADOFFSET po)
1436 ASSERT_CURPAD_ACTIVE("pad_sv");
1439 Perl_croak(aTHX_ "panic: pad_sv po");
1440 DEBUG_X(PerlIO_printf(Perl_debug_log,
1441 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1442 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1444 return PL_curpad[po];
1448 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1450 Set the value at offset I<po> in the current (compiling or executing) pad.
1451 Use the macro PAD_SETSV() rather than calling this function directly.
1457 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1461 PERL_ARGS_ASSERT_PAD_SETSV;
1463 ASSERT_CURPAD_ACTIVE("pad_setsv");
1465 DEBUG_X(PerlIO_printf(Perl_debug_log,
1466 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1467 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1472 #endif /* DEBUGGING */
1475 =for apidoc m|void|pad_block_start|int full
1477 Update the pad compilation state variables on entry to a new block.
1482 /* XXX DAPM perhaps:
1483 * - integrate this in general state-saving routine ???
1484 * - combine with the state-saving going on in pad_new ???
1485 * - introduce a new SAVE type that does all this in one go ?
1489 Perl_pad_block_start(pTHX_ int full)
1492 ASSERT_CURPAD_ACTIVE("pad_block_start");
1493 SAVEI32(PL_comppad_name_floor);
1494 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1496 PL_comppad_name_fill = PL_comppad_name_floor;
1497 if (PL_comppad_name_floor < 0)
1498 PL_comppad_name_floor = 0;
1499 SAVEI32(PL_min_intro_pending);
1500 SAVEI32(PL_max_intro_pending);
1501 PL_min_intro_pending = 0;
1502 SAVEI32(PL_comppad_name_fill);
1503 SAVEI32(PL_padix_floor);
1504 PL_padix_floor = PL_padix;
1505 PL_pad_reset_pending = FALSE;
1509 =for apidoc m|U32|intro_my
1511 "Introduce" my variables to visible status. This is called during parsing
1512 at the end of each statement to make lexical variables visible to
1513 subsequent statements.
1526 ASSERT_CURPAD_ACTIVE("intro_my");
1527 if (! PL_min_intro_pending)
1528 return PL_cop_seqmax;
1530 svp = AvARRAY(PL_comppad_name);
1531 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1532 SV * const sv = svp[i];
1534 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1535 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1537 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1538 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1539 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1540 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1541 (long)i, SvPVX_const(sv),
1542 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1543 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1547 seq = PL_cop_seqmax;
1549 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1551 PL_min_intro_pending = 0;
1552 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1553 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1554 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1560 =for apidoc m|void|pad_leavemy
1562 Cleanup at end of scope during compilation: set the max seq number for
1563 lexicals in this scope and warn of any lexicals that never got introduced.
1569 Perl_pad_leavemy(pTHX)
1574 SV * const * const svp = AvARRAY(PL_comppad_name);
1576 PL_pad_reset_pending = FALSE;
1578 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1579 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1580 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1581 const SV * const sv = svp[off];
1582 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1583 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1584 "%"SVf" never introduced",
1588 /* "Deintroduce" my variables that are leaving with this scope. */
1589 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1590 SV * const sv = svp[off];
1591 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1592 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1594 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1595 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1596 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1597 (long)off, SvPVX_const(sv),
1598 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1599 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1601 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1602 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1603 OP *kid = newOP(OP_INTROCV, 0);
1605 o = op_prepend_elem(OP_LINESEQ, kid, o);
1610 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1612 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1613 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1618 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1620 Abandon the tmp in the current pad at offset po and replace with a
1627 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1630 ASSERT_CURPAD_LEGAL("pad_swipe");
1633 if (AvARRAY(PL_comppad) != PL_curpad)
1634 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1635 AvARRAY(PL_comppad), PL_curpad);
1636 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1637 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1638 (long)po, (long)AvFILLp(PL_comppad));
1640 DEBUG_X(PerlIO_printf(Perl_debug_log,
1641 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1642 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1645 SvREFCNT_dec(PL_curpad[po]);
1648 /* if pad tmps aren't shared between ops, then there's no need to
1649 * create a new tmp when an existing op is freed */
1650 #ifdef USE_BROKEN_PAD_RESET
1651 PL_curpad[po] = newSV(0);
1652 SvPADTMP_on(PL_curpad[po]);
1654 PL_curpad[po] = &PL_sv_undef;
1656 if (PadnamelistMAX(PL_comppad_name) != -1
1657 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1658 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1659 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1661 if ((I32)po < PL_padix)
1666 =for apidoc m|void|pad_reset
1668 Mark all the current temporaries for reuse
1673 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1674 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1675 * on the stack by OPs that use them, there are several ways to get an alias
1676 * to a shared TARG. Such an alias will change randomly and unpredictably.
1677 * We avoid doing this until we can think of a Better Way.
1683 #ifdef USE_BROKEN_PAD_RESET
1684 if (AvARRAY(PL_comppad) != PL_curpad)
1685 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1686 AvARRAY(PL_comppad), PL_curpad);
1688 DEBUG_X(PerlIO_printf(Perl_debug_log,
1689 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1690 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1691 (long)PL_padix, (long)PL_padix_floor
1695 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1697 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1698 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1699 SvPADTMP_off(PL_curpad[po]);
1701 PL_padix = PL_padix_floor;
1704 PL_pad_reset_pending = FALSE;
1708 =for apidoc Amx|void|pad_tidy|padtidy_type type
1710 Tidy up a pad at the end of compilation of the code to which it belongs.
1711 Jobs performed here are: remove most stuff from the pads of anonsub
1712 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1713 the kind of subroutine:
1715 padtidy_SUB ordinary subroutine
1716 padtidy_SUBCLONE prototype for lexical closure
1717 padtidy_FORMAT format
1722 /* XXX DAPM surely most of this stuff should be done properly
1723 * at the right time beforehand, rather than going around afterwards
1724 * cleaning up our mistakes ???
1728 Perl_pad_tidy(pTHX_ padtidy_type type)
1732 ASSERT_CURPAD_ACTIVE("pad_tidy");
1734 /* If this CV has had any 'eval-capable' ops planted in it:
1735 * i.e. it contains any of:
1739 * * use re 'eval'; /$var/
1742 * Then any anon prototypes in the chain of CVs should be marked as
1743 * cloneable, so that for example the eval's CV in
1747 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1748 * potentially have an eval executed within it.
1751 if (PL_cv_has_eval || PL_perldb) {
1753 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1754 if (cv != PL_compcv && CvCOMPILED(cv))
1755 break; /* no need to mark already-compiled code */
1757 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1758 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1765 /* extend namepad to match curpad */
1766 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1767 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1769 if (type == padtidy_SUBCLONE) {
1770 SV * const * const namep = AvARRAY(PL_comppad_name);
1773 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1776 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1779 * The only things that a clonable function needs in its
1780 * pad are anonymous subs.
1781 * The rest are created anew during cloning.
1783 if (!((namesv = namep[ix]) != NULL &&
1784 namesv != &PL_sv_undef &&
1785 *SvPVX_const(namesv) == '&'))
1787 SvREFCNT_dec(PL_curpad[ix]);
1788 PL_curpad[ix] = NULL;
1792 else if (type == padtidy_SUB) {
1793 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1794 AV * const av = newAV(); /* Will be @_ */
1795 av_store(PL_comppad, 0, MUTABLE_SV(av));
1799 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1800 SV * const * const namep = AvARRAY(PL_comppad_name);
1802 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1803 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1805 if (!SvPADMY(PL_curpad[ix])) {
1806 SvPADTMP_on(PL_curpad[ix]);
1807 } else if (!SvFAKE(namep[ix])) {
1808 /* This is a work around for how the current implementation of
1809 ?{ } blocks in regexps interacts with lexicals.
1811 One of our lexicals.
1812 Can't do this on all lexicals, otherwise sub baz() won't
1821 because completion of compiling &bar calling pad_tidy()
1822 would cause (top level) $foo to be marked as stale, and
1823 "no longer available". */
1824 SvPADSTALE_on(PL_curpad[ix]);
1828 PL_curpad = AvARRAY(PL_comppad);
1832 =for apidoc m|void|pad_free|PADOFFSET po
1834 Free the SV at offset po in the current pad.
1839 /* XXX DAPM integrate with pad_swipe ???? */
1841 Perl_pad_free(pTHX_ PADOFFSET po)
1845 ASSERT_CURPAD_LEGAL("pad_free");
1848 if (AvARRAY(PL_comppad) != PL_curpad)
1849 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1850 AvARRAY(PL_comppad), PL_curpad);
1852 Perl_croak(aTHX_ "panic: pad_free po");
1854 DEBUG_X(PerlIO_printf(Perl_debug_log,
1855 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1856 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1861 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1862 SvFLAGS(sv) &= ~SVs_PADTMP;
1864 if ((I32)po < PL_padix)
1869 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1871 Dump the contents of a padlist
1877 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1886 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1891 pad_name = *PadlistARRAY(padlist);
1892 pad = PadlistARRAY(padlist)[1];
1893 pname = AvARRAY(pad_name);
1894 ppad = AvARRAY(pad);
1895 Perl_dump_indent(aTHX_ level, file,
1896 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1897 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1900 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1901 const SV *namesv = pname[ix];
1902 if (namesv && !PadnameLEN(namesv)) {
1907 Perl_dump_indent(aTHX_ level+1, file,
1908 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1911 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1912 SvPVX_const(namesv),
1913 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1914 (unsigned long)PARENT_PAD_INDEX(namesv)
1918 Perl_dump_indent(aTHX_ level+1, file,
1919 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1922 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1923 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1924 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1929 Perl_dump_indent(aTHX_ level+1, file,
1930 "%2d. 0x%"UVxf"<%lu>\n",
1933 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1942 =for apidoc m|void|cv_dump|CV *cv|const char *title
1944 dump the contents of a CV
1950 S_cv_dump(pTHX_ const CV *cv, const char *title)
1953 const CV * const outside = CvOUTSIDE(cv);
1954 PADLIST* const padlist = CvPADLIST(cv);
1956 PERL_ARGS_ASSERT_CV_DUMP;
1958 PerlIO_printf(Perl_debug_log,
1959 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1962 (CvANON(cv) ? "ANON"
1963 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1964 : (cv == PL_main_cv) ? "MAIN"
1965 : CvUNIQUE(cv) ? "UNIQUE"
1966 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1969 : CvANON(outside) ? "ANON"
1970 : (outside == PL_main_cv) ? "MAIN"
1971 : CvUNIQUE(outside) ? "UNIQUE"
1972 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1974 PerlIO_printf(Perl_debug_log,
1975 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1976 do_dump_pad(1, Perl_debug_log, padlist, 1);
1979 #endif /* DEBUGGING */
1982 =for apidoc Am|CV *|cv_clone|CV *proto
1984 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1985 of the function: its code, pad structure, and other attributes.
1986 The prototype is combined with a capture of outer lexicals to which the
1987 code refers, which are taken from the currently-executing instance of
1988 the immediately surrounding code.
1993 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1996 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
2000 PADLIST* const protopadlist = CvPADLIST(proto);
2001 PAD *const protopad_name = *PadlistARRAY(protopadlist);
2002 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
2003 SV** const pname = AvARRAY(protopad_name);
2004 SV** const ppad = AvARRAY(protopad);
2005 const I32 fname = AvFILLp(protopad_name);
2006 const I32 fpad = AvFILLp(protopad);
2009 bool subclones = FALSE;
2011 assert(!CvUNIQUE(proto));
2013 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2014 * reliable. The currently-running sub is always the one we need to
2016 * For my subs, the currently-running sub may not be the one we want.
2017 * We have to check whether it is a clone of CvOUTSIDE.
2018 * Note that in general for formats, CvOUTSIDE != find_runcv.
2019 * Since formats may be nested inside closures, CvOUTSIDE may point
2020 * to a prototype; we instead want the cloned parent who called us.
2024 if (CvWEAKOUTSIDE(proto))
2025 outside = find_runcv(NULL);
2027 outside = CvOUTSIDE(proto);
2028 if ((CvCLONE(outside) && ! CvCLONED(outside))
2029 || !CvPADLIST(outside)
2030 || PadlistNAMES(CvPADLIST(outside))
2031 != protopadlist->xpadl_outid) {
2032 outside = find_runcv_where(
2033 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2035 /* outside could be null */
2039 depth = outside ? CvDEPTH(outside) : 0;
2044 SAVESPTR(PL_compcv);
2046 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2049 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2051 SAVESPTR(PL_comppad_name);
2052 PL_comppad_name = protopad_name;
2053 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2055 av_fill(PL_comppad, fpad);
2057 PL_curpad = AvARRAY(PL_comppad);
2059 outpad = outside && CvPADLIST(outside)
2060 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2063 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2065 for (ix = fpad; ix > 0; ix--) {
2066 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2068 if (namesv && PadnameLEN(namesv)) { /* lexical */
2069 if (SvFAKE(namesv)) { /* lexical from outside? */
2070 /* formats may have an inactive, or even undefined, parent;
2071 but state vars are always available. */
2072 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2073 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2074 && (!outside || !CvDEPTH(outside))) ) {
2075 S_unavailable(aTHX_ namesv);
2079 SvREFCNT_inc_simple_void_NN(sv);
2082 const char sigil = SvPVX_const(namesv)[0];
2084 /* If there are state subs, we need to clone them, too.
2085 But they may need to close over variables we have
2086 not cloned yet. So we will have to do a second
2087 pass. Furthermore, there may be state subs clos-
2088 ing over other state subs’ entries, so we have
2089 to put a stub here and then clone into it on the
2091 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2092 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2094 sv = newSV_type(SVt_PVCV);
2096 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2099 /* Just provide a stub, but name it. It will be
2100 upgrade to the real thing on scope entry. */
2101 sv = newSV_type(SVt_PVCV);
2104 share_hek(SvPVX_const(namesv)+1,
2106 * (SvUTF8(namesv) ? -1 : 1),
2110 else sv = SvREFCNT_inc(ppad[ix]);
2111 else if (sigil == '@')
2112 sv = MUTABLE_SV(newAV());
2113 else if (sigil == '%')
2114 sv = MUTABLE_SV(newHV());
2118 /* reset the 'assign only once' flag on each state var */
2119 if (sigil != '&' && SvPAD_STATE(namesv))
2123 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2124 sv = SvREFCNT_inc_NN(ppad[ix]);
2134 for (ix = fpad; ix > 0; ix--) {
2135 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2136 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2137 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2138 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2141 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2146 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2149 const bool newcv = !cv;
2151 assert(!CvUNIQUE(proto));
2153 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2154 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2158 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2161 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2162 else CvGV_set(cv,CvGV(proto));
2163 CvSTASH_set(cv, CvSTASH(proto));
2165 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2167 CvSTART(cv) = CvSTART(proto);
2168 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2171 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2173 SvUTF8_on(MUTABLE_SV(cv));
2176 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2178 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2181 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2182 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2183 cv_dump(proto, "Proto");
2191 Perl_cv_clone(pTHX_ CV *proto)
2193 PERL_ARGS_ASSERT_CV_CLONE;
2195 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2196 return S_cv_clone(aTHX_ proto, NULL, NULL);
2199 /* Called only by pp_clonecv */
2201 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2203 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2205 return S_cv_clone(aTHX_ proto, target, NULL);
2209 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2211 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2212 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2213 moved to a pre-existing CV struct.
2219 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2223 AV * const comppad_name = PadlistARRAY(padlist)[0];
2224 AV * const comppad = PadlistARRAY(padlist)[1];
2225 SV ** const namepad = AvARRAY(comppad_name);
2226 SV ** const curpad = AvARRAY(comppad);
2228 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2229 PERL_UNUSED_ARG(old_cv);
2231 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2232 const SV * const namesv = namepad[ix];
2233 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2234 && *SvPVX_const(namesv) == '&')
2236 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2238 SvMAGICAL(curpad[ix])
2239 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2241 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2242 if (CvOUTSIDE(innercv) == old_cv) {
2243 if (!CvWEAKOUTSIDE(innercv)) {
2244 SvREFCNT_dec(old_cv);
2245 SvREFCNT_inc_simple_void_NN(new_cv);
2247 CvOUTSIDE(innercv) = new_cv;
2250 else { /* format reference */
2251 SV * const rv = curpad[ix];
2253 if (!SvOK(rv)) continue;
2255 assert(SvWEAKREF(rv));
2256 innercv = (CV *)SvRV(rv);
2257 assert(!CvWEAKOUTSIDE(innercv));
2258 SvREFCNT_dec(CvOUTSIDE(innercv));
2259 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2266 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2268 Push a new pad frame onto the padlist, unless there's already a pad at
2269 this depth, in which case don't bother creating a new one. Then give
2270 the new pad an @_ in slot zero.
2276 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2280 PERL_ARGS_ASSERT_PAD_PUSH;
2282 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2283 PAD** const svp = PadlistARRAY(padlist);
2284 AV* const newpad = newAV();
2285 SV** const oldpad = AvARRAY(svp[depth-1]);
2286 I32 ix = AvFILLp((const AV *)svp[1]);
2287 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2288 SV** const names = AvARRAY(svp[0]);
2291 for ( ;ix > 0; ix--) {
2292 if (names_fill >= ix && PadnameLEN(names[ix])) {
2293 const char sigil = SvPVX_const(names[ix])[0];
2294 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2295 || (SvFLAGS(names[ix]) & SVpad_STATE)
2298 /* outer lexical or anon code */
2299 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2301 else { /* our own lexical */
2304 sv = MUTABLE_SV(newAV());
2305 else if (sigil == '%')
2306 sv = MUTABLE_SV(newHV());
2309 av_store(newpad, ix, sv);
2313 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2314 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2317 /* save temporaries on recursion? */
2318 SV * const sv = newSV(0);
2319 av_store(newpad, ix, sv);
2324 av_store(newpad, 0, MUTABLE_SV(av));
2327 padlist_store(padlist, depth, newpad);
2332 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2334 Looks up the type of the lexical variable at position I<po> in the
2335 currently-compiling pad. If the variable is typed, the stash of the
2336 class to which it is typed is returned. If not, C<NULL> is returned.
2342 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2345 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2346 if ( SvPAD_TYPED(*av) ) {
2347 return SvSTASH(*av);
2352 #if defined(USE_ITHREADS)
2354 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2357 =for apidoc padlist_dup
2365 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2371 PERL_ARGS_ASSERT_PADLIST_DUP;
2376 cloneall = param->flags & CLONEf_COPY_STACKS
2377 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2378 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2380 max = cloneall ? PadlistMAX(srcpad) : 1;
2382 Newx(dstpad, 1, PADLIST);
2383 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2384 PadlistMAX(dstpad) = max;
2385 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2389 for (depth = 0; depth <= max; ++depth)
2390 PadlistARRAY(dstpad)[depth] =
2391 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2393 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2394 to build anything other than the first level of pads. */
2395 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2397 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2398 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2399 SV **oldpad = AvARRAY(srcpad1);
2404 PadlistARRAY(dstpad)[0] =
2405 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2406 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2410 av_extend(pad1, ix);
2411 PadlistARRAY(dstpad)[1] = pad1;
2412 pad1a = AvARRAY(pad1);
2417 for ( ;ix > 0; ix--) {
2420 } else if (names_fill >= ix && PadnameLEN(names[ix])) {
2421 const char sigil = SvPVX_const(names[ix])[0];
2422 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2423 || (SvFLAGS(names[ix]) & SVpad_STATE)
2426 /* outer lexical or anon code */
2427 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2429 else { /* our own lexical */
2430 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2431 /* This is a work around for how the current
2432 implementation of ?{ } blocks in regexps
2433 interacts with lexicals. */
2434 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2439 sv = MUTABLE_SV(newAV());
2440 else if (sigil == '%')
2441 sv = MUTABLE_SV(newHV());
2449 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2450 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2453 /* save temporaries on recursion? */
2454 SV * const sv = newSV(0);
2457 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2458 FIXTHAT before merging this branch.
2459 (And I know how to) */
2460 if (SvPADMY(oldpad[ix]))
2468 args = newAV(); /* Will be @_ */
2470 pad1a[0] = (SV *)args;
2478 #endif /* USE_ITHREADS */
2481 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2485 SSize_t const oldmax = PadlistMAX(padlist);
2487 PERL_ARGS_ASSERT_PADLIST_STORE;
2491 if (key > PadlistMAX(padlist)) {
2492 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2493 (SV ***)&PadlistARRAY(padlist),
2494 (SV ***)&PadlistARRAY(padlist));
2495 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2498 ary = PadlistARRAY(padlist);
2499 SvREFCNT_dec(ary[key]);
2506 * c-indentation-style: bsd
2508 * indent-tabs-mode: nil
2511 * ex: set ts=8 sts=4 sw=4 et: