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);
288 av_store(padname, 0, &PL_sv_undef);
291 /* Most subroutines never recurse, hence only need 2 entries in the padlist
292 array - names, and depth=1. The default for av_store() is to allocate
293 0..3, and even an explicit call to av_extend() with <3 will be rounded
294 up, so we inline the allocation of the array here. */
296 PadlistMAX(padlist) = 1;
297 PadlistARRAY(padlist) = ary;
301 /* ... then update state variables */
304 PL_curpad = AvARRAY(pad);
306 if (! (flags & padnew_CLONE)) {
307 PL_comppad_name = padname;
308 PL_comppad_name_fill = 0;
309 PL_min_intro_pending = 0;
314 DEBUG_X(PerlIO_printf(Perl_debug_log,
315 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
316 " name=0x%"UVxf" flags=0x%"UVxf"\n",
317 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
318 PTR2UV(padname), (UV)flags
322 return (PADLIST*)padlist;
327 =head1 Embedding Functions
331 Clear out all the active components of a CV. This can happen either
332 by an explicit C<undef &foo>, or by the reference count going to zero.
333 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
334 children can still follow the full lexical scope chain.
340 Perl_cv_undef(pTHX_ CV *cv)
343 const PADLIST *padlist = CvPADLIST(cv);
344 bool const slabbed = !!CvSLABBED(cv);
346 PERL_ARGS_ASSERT_CV_UNDEF;
348 DEBUG_X(PerlIO_printf(Perl_debug_log,
349 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
350 PTR2UV(cv), PTR2UV(PL_comppad))
353 if (CvFILE(cv) && CvDYNFILE(cv)) {
354 Safefree(CvFILE(cv));
359 if (!CvISXSUB(cv) && CvROOT(cv)) {
360 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
361 Perl_croak(aTHX_ "Can't undef active subroutine");
364 PAD_SAVE_SETNULLPAD();
366 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
372 else if (slabbed && CvSTART(cv)) {
374 PAD_SAVE_SETNULLPAD();
376 /* discard any leaked ops */
378 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
379 opslab_force_free((OPSLAB *)CvSTART(cv));
385 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
387 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
388 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
389 if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
390 else CvGV_set(cv, NULL);
392 /* This statement and the subsequence if block was pad_undef(). */
393 pad_peg("pad_undef");
398 /* Free the padlist associated with a CV.
399 If parts of it happen to be current, we null the relevant PL_*pad*
400 global vars so that we don't have any dangling references left.
401 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
402 subs to the outer of this cv. */
404 DEBUG_X(PerlIO_printf(Perl_debug_log,
405 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
406 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
409 /* detach any '&' anon children in the pad; if afterwards they
410 * are still live, fix up their CvOUTSIDEs to point to our outside,
412 /* XXX DAPM for efficiency, we should only do this if we know we have
413 * children, or integrate this loop with general cleanup */
415 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
416 CV * const outercv = CvOUTSIDE(cv);
417 const U32 seq = CvOUTSIDE_SEQ(cv);
418 PAD * const comppad_name = PadlistARRAY(padlist)[0];
419 SV ** const namepad = AvARRAY(comppad_name);
420 PAD * const comppad = PadlistARRAY(padlist)[1];
421 SV ** const curpad = AvARRAY(comppad);
422 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
423 SV * const namesv = namepad[ix];
424 if (namesv && namesv != &PL_sv_undef
425 && *SvPVX_const(namesv) == '&')
427 CV * const innercv = MUTABLE_CV(curpad[ix]);
428 U32 inner_rc = SvREFCNT(innercv);
430 assert(SvTYPE(innercv) != SVt_PVFM);
432 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
434 SvREFCNT_dec_NN(innercv);
438 /* in use, not just a prototype */
439 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
440 assert(CvWEAKOUTSIDE(innercv));
441 /* don't relink to grandfather if he's being freed */
442 if (outercv && SvREFCNT(outercv)) {
443 CvWEAKOUTSIDE_off(innercv);
444 CvOUTSIDE(innercv) = outercv;
445 CvOUTSIDE_SEQ(innercv) = seq;
446 SvREFCNT_inc_simple_void_NN(outercv);
449 CvOUTSIDE(innercv) = NULL;
456 ix = PadlistMAX(padlist);
458 PAD * const sv = PadlistARRAY(padlist)[ix--];
460 if (sv == PL_comppad) {
468 PAD * const sv = PadlistARRAY(padlist)[0];
469 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
470 PL_comppad_name = NULL;
473 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
475 CvPADLIST(cv) = NULL;
479 /* remove CvOUTSIDE unless this is an undef rather than a free */
480 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
481 if (!CvWEAKOUTSIDE(cv))
482 SvREFCNT_dec(CvOUTSIDE(cv));
483 CvOUTSIDE(cv) = NULL;
486 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
489 if (CvISXSUB(cv) && CvXSUB(cv)) {
492 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
493 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
494 * to choose an error message */
495 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
499 =for apidoc cv_forget_slab
501 When a CV has a reference count on its slab (CvSLABBED), it is responsible
502 for making sure it is freed. (Hence, no two CVs should ever have a
503 reference count on the same slab.) The CV only needs to reference the slab
504 during compilation. Once it is compiled and CvROOT attached, it has
505 finished its job, so it can forget the slab.
511 Perl_cv_forget_slab(pTHX_ CV *cv)
513 const bool slabbed = !!CvSLABBED(cv);
516 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
518 if (!slabbed) return;
522 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
523 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
525 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
529 #ifdef PERL_DEBUG_READONLY_OPS
530 const size_t refcnt = slab->opslab_refcnt;
532 OpslabREFCNT_dec(slab);
533 #ifdef PERL_DEBUG_READONLY_OPS
534 if (refcnt > 1) Slab_to_ro(slab);
540 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
542 Allocates a place in the currently-compiling
543 pad (via L<perlapi/pad_alloc>) and
544 then stores a name for that entry. I<namesv> is adopted and becomes the
545 name entry; it must already contain the name string and be sufficiently
546 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
547 added to I<namesv>. None of the other
548 processing of L<perlapi/pad_add_name_pvn>
549 is done. Returns the offset of the allocated pad slot.
555 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
558 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
560 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
562 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
565 assert(SvTYPE(namesv) == SVt_PVMG);
566 SvPAD_TYPED_on(namesv);
567 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
570 SvPAD_OUR_on(namesv);
571 SvOURSTASH_set(namesv, ourstash);
572 SvREFCNT_inc_simple_void_NN(ourstash);
574 else if (flags & padadd_STATE) {
575 SvPAD_STATE_on(namesv);
578 av_store(PL_comppad_name, offset, namesv);
579 PadnamelistMAXNAMED(PL_comppad_name) = offset;
584 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
586 Allocates a place in the currently-compiling pad for a named lexical
587 variable. Stores the name and other metadata in the name part of the
588 pad, and makes preparations to manage the variable's lexical scoping.
589 Returns the offset of the allocated pad slot.
591 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
592 If I<typestash> is non-null, the name is for a typed lexical, and this
593 identifies the type. If I<ourstash> is non-null, it's a lexical reference
594 to a package variable, and this identifies the package. The following
595 flags can be OR'ed together:
597 padadd_OUR redundantly specifies if it's a package var
598 padadd_STATE variable will retain value persistently
599 padadd_NO_DUP_CHECK skip check for lexical shadowing
605 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
606 U32 flags, HV *typestash, HV *ourstash)
613 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
615 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
616 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
619 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
621 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
622 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
625 sv_setpvn(namesv, namepv, namelen);
628 flags |= padadd_UTF8_NAME;
632 flags &= ~padadd_UTF8_NAME;
634 if ((flags & padadd_NO_DUP_CHECK) == 0) {
636 SAVEFREESV(namesv); /* in case of fatal warnings */
637 /* check for duplicate declaration */
638 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
639 SvREFCNT_inc_simple_void_NN(namesv);
643 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
645 /* not yet introduced */
646 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
647 COP_SEQ_RANGE_HIGH_set(namesv, 0);
649 if (!PL_min_intro_pending)
650 PL_min_intro_pending = offset;
651 PL_max_intro_pending = offset;
652 /* if it's not a simple scalar, replace with an AV or HV */
653 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
654 assert(SvREFCNT(PL_curpad[offset]) == 1);
655 if (namelen != 0 && *namepv == '@')
656 sv_upgrade(PL_curpad[offset], SVt_PVAV);
657 else if (namelen != 0 && *namepv == '%')
658 sv_upgrade(PL_curpad[offset], SVt_PVHV);
659 else if (namelen != 0 && *namepv == '&')
660 sv_upgrade(PL_curpad[offset], SVt_PVCV);
661 assert(SvPADMY(PL_curpad[offset]));
662 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
663 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
664 (long)offset, SvPVX(namesv),
665 PTR2UV(PL_curpad[offset])));
671 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
673 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
674 instead of a string/length pair.
680 Perl_pad_add_name_pv(pTHX_ const char *name,
681 const U32 flags, HV *typestash, HV *ourstash)
683 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
684 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
688 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
690 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
691 of an SV instead of a string/length pair.
697 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
701 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
702 namepv = SvPV(name, namelen);
704 flags |= padadd_UTF8_NAME;
705 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
709 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
711 Allocates a place in the currently-compiling pad,
712 returning the offset of the allocated pad slot.
713 No name is initially attached to the pad slot.
714 I<tmptype> is a set of flags indicating the kind of pad entry required,
715 which will be set in the value SV for the allocated pad entry:
717 SVs_PADMY named lexical variable ("my", "our", "state")
718 SVs_PADTMP unnamed temporary store
719 SVf_READONLY constant shared between recursion levels
721 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
722 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
723 does not cause the SV in the pad slot to be marked read-only, but simply
724 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
725 least should be treated as such.
727 I<optype> should be an opcode indicating the type of operation that the
728 pad entry is to support. This doesn't affect operational semantics,
729 but is used for debugging.
734 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
735 * or at least rationalise ??? */
738 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
744 PERL_UNUSED_ARG(optype);
745 ASSERT_CURPAD_ACTIVE("pad_alloc");
747 if (AvARRAY(PL_comppad) != PL_curpad)
748 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
749 AvARRAY(PL_comppad), PL_curpad);
750 if (PL_pad_reset_pending)
752 if (tmptype & SVs_PADMY) {
753 /* For a my, simply push a null SV onto the end of PL_comppad. */
754 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
755 retval = AvFILLp(PL_comppad);
758 /* For a tmp, scan the pad from PL_padix upwards
759 * for a slot which has no name and no active value.
761 SV * const * const names = AvARRAY(PL_comppad_name);
762 const SSize_t names_fill = AvFILLp(PL_comppad_name);
765 * Entries that close over unavailable variables
766 * in outer subs contain values not marked PADMY.
767 * Thus we must skip, not just pad values that are
768 * marked as current pad values, but also those with names.
770 if (++PL_padix <= names_fill &&
771 (sv = names[PL_padix]) && sv != &PL_sv_undef)
773 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
774 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
778 if (tmptype & SVf_READONLY) {
779 av_store(PL_comppad_name, PL_padix, &PL_sv_no);
780 tmptype &= ~SVf_READONLY;
781 tmptype |= SVs_PADTMP;
785 SvFLAGS(sv) |= tmptype;
786 PL_curpad = AvARRAY(PL_comppad);
788 DEBUG_X(PerlIO_printf(Perl_debug_log,
789 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
790 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
791 PL_op_name[optype]));
792 #ifdef DEBUG_LEAKING_SCALARS
793 sv->sv_debug_optype = optype;
794 sv->sv_debug_inpad = 1;
796 return (PADOFFSET)retval;
800 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
802 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
803 for an anonymous function that is lexically scoped inside the
804 currently-compiling function.
805 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
806 to the outer scope is weakened to avoid a reference loop.
808 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
810 I<optype> should be an opcode indicating the type of operation that the
811 pad entry is to support. This doesn't affect operational semantics,
812 but is used for debugging.
818 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
822 SV* const name = newSV_type(SVt_PVNV);
824 PERL_ARGS_ASSERT_PAD_ADD_ANON;
827 sv_setpvs(name, "&");
828 /* These two aren't used; just make sure they're not equal to
829 * PERL_PADSEQ_INTRO */
830 COP_SEQ_RANGE_LOW_set(name, 0);
831 COP_SEQ_RANGE_HIGH_set(name, 0);
832 ix = pad_alloc(optype, SVs_PADMY);
833 av_store(PL_comppad_name, ix, name);
834 /* XXX DAPM use PL_curpad[] ? */
835 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
836 av_store(PL_comppad, ix, (SV*)func);
838 SV *rv = newRV_noinc((SV *)func);
840 assert (SvTYPE(func) == SVt_PVFM);
841 av_store(PL_comppad, ix, rv);
843 SvPADMY_on((SV*)func);
845 /* to avoid ref loops, we never have parent + child referencing each
846 * other simultaneously */
847 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
848 assert(!CvWEAKOUTSIDE(func));
849 CvWEAKOUTSIDE_on(func);
850 SvREFCNT_dec_NN(CvOUTSIDE(func));
856 =for apidoc pad_check_dup
858 Check for duplicate declarations: report any of:
860 * a my in the current scope with the same name;
861 * an our (anywhere in the pad) with the same name and the
862 same stash as C<ourstash>
864 C<is_our> indicates that the name to check is an 'our' declaration.
870 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
875 const U32 is_our = flags & padadd_OUR;
877 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
879 ASSERT_CURPAD_ACTIVE("pad_check_dup");
881 assert((flags & ~padadd_OUR) == 0);
883 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
884 return; /* nothing to check */
886 svp = AvARRAY(PL_comppad_name);
887 top = AvFILLp(PL_comppad_name);
888 /* check the current scope */
889 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
891 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
892 SV * const sv = svp[off];
896 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
897 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
900 if (is_our && (SvPAD_OUR(sv)))
901 break; /* "our" masking "our" */
902 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
903 Perl_warner(aTHX_ packWARN(WARN_MISC),
904 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
905 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
906 *SvPVX(sv) == '&' ? "subroutine" : "variable",
908 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
909 ? "scope" : "statement"));
914 /* check the rest of the pad */
917 SV * const sv = svp[off];
921 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
922 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
923 && SvOURSTASH(sv) == ourstash
926 Perl_warner(aTHX_ packWARN(WARN_MISC),
927 "\"our\" variable %"SVf" redeclared", sv);
928 if ((I32)off <= PL_comppad_name_floor)
929 Perl_warner(aTHX_ packWARN(WARN_MISC),
930 "\t(Did you mean \"local\" instead of \"our\"?)\n");
940 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
942 Given the name of a lexical variable, find its position in the
943 currently-compiling pad.
944 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
945 I<flags> is reserved and must be zero.
946 If it is not in the current pad but appears in the pad of any lexically
947 enclosing scope, then a pseudo-entry for it is added in the current pad.
948 Returns the offset in the current pad,
949 or C<NOT_IN_PAD> if no such lexical is in scope.
955 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
964 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
966 pad_peg("pad_findmy_pvn");
968 if (flags & ~padadd_UTF8_NAME)
969 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
972 if (flags & padadd_UTF8_NAME) {
974 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
977 flags |= padadd_UTF8_NAME;
979 flags &= ~padadd_UTF8_NAME;
982 offset = pad_findlex(namepv, namelen, flags,
983 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
984 if ((PADOFFSET)offset != NOT_IN_PAD)
987 /* look for an our that's being introduced; this allows
988 * our $foo = 0 unless defined $foo;
989 * to not give a warning. (Yes, this is a hack) */
991 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
992 name_svp = AvARRAY(nameav);
993 for (offset = AvFILLp(nameav); offset > 0; offset--) {
994 const SV * const namesv = name_svp[offset];
995 if (namesv && PadnameLEN(namesv) == namelen
997 && (SvPAD_OUR(namesv))
998 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
999 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
1000 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
1008 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
1010 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1011 instead of a string/length pair.
1017 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1019 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1020 return pad_findmy_pvn(name, strlen(name), flags);
1024 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1026 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1027 of an SV instead of a string/length pair.
1033 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1037 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1038 namepv = SvPV(name, namelen);
1040 flags |= padadd_UTF8_NAME;
1041 return pad_findmy_pvn(namepv, namelen, flags);
1045 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1047 Find the position of the lexical C<$_> in the pad of the
1048 currently-executing function. Returns the offset in the current pad,
1049 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1050 the global one should be used instead).
1051 L</find_rundefsv> is likely to be more convenient.
1057 Perl_find_rundefsvoffset(pTHX)
1062 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1063 NULL, &out_sv, &out_flags);
1067 =for apidoc Am|SV *|find_rundefsv
1069 Find and return the variable that is named C<$_> in the lexical scope
1070 of the currently-executing function. This may be a lexical C<$_>,
1071 or will otherwise be the global one.
1077 Perl_find_rundefsv(pTHX)
1083 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1084 NULL, &namesv, &flags);
1086 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1093 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1099 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1101 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1102 NULL, &namesv, &flags);
1104 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1107 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1111 =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
1113 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1114 in the inner pads if it's found in an outer one.
1116 Returns the offset in the bottom pad of the lex or the fake lex.
1117 cv is the CV in which to start the search, and seq is the current cop_seq
1118 to match against. If warn is true, print appropriate warnings. The out_*
1119 vars return values, and so are pointers to where the returned values
1120 should be stored. out_capture, if non-null, requests that the innermost
1121 instance of the lexical is captured; out_name_sv is set to the innermost
1122 matched namesv or fake namesv; out_flags returns the flags normally
1123 associated with the IVX field of a fake namesv.
1125 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1126 then comes back down, adding fake entries
1127 as it goes. It has to be this way
1128 because fake namesvs in anon protoypes have to store in xlow the index into
1134 /* the CV has finished being compiled. This is not a sufficient test for
1135 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1136 #define CvCOMPILED(cv) CvROOT(cv)
1138 /* the CV does late binding of its lexicals */
1139 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1142 S_unavailable(pTHX_ SV *namesv)
1144 /* diag_listed_as: Variable "%s" is not available */
1145 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1146 "%se \"%"SVf"\" is not available",
1147 *SvPVX_const(namesv) == '&'
1154 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1155 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1158 I32 offset, new_offset;
1161 const PADLIST * const padlist = CvPADLIST(cv);
1162 const bool staleok = !!(flags & padadd_STALEOK);
1164 PERL_ARGS_ASSERT_PAD_FINDLEX;
1166 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1167 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1169 flags &= ~ padadd_STALEOK; /* one-shot flag */
1173 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1174 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1175 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1176 out_capture ? " capturing" : "" ));
1178 /* first, search this pad */
1180 if (padlist) { /* not an undef CV */
1181 I32 fake_offset = 0;
1182 const AV * const nameav = PadlistARRAY(padlist)[0];
1183 SV * const * const name_svp = AvARRAY(nameav);
1185 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1186 const SV * const namesv = name_svp[offset];
1187 if (namesv && PadnameLEN(namesv) == namelen
1188 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1189 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1191 if (SvFAKE(namesv)) {
1192 fake_offset = offset; /* in case we don't find a real one */
1195 /* is seq within the range _LOW to _HIGH ?
1196 * This is complicated by the fact that PL_cop_seqmax
1197 * may have wrapped around at some point */
1198 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1199 continue; /* not yet introduced */
1201 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1202 /* in compiling scope */
1204 (seq > COP_SEQ_RANGE_LOW(namesv))
1205 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1206 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1211 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1213 ( seq > COP_SEQ_RANGE_LOW(namesv)
1214 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1216 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1217 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1223 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1224 if (offset > 0) { /* not fake */
1226 *out_name_sv = name_svp[offset]; /* return the namesv */
1228 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1229 * instances. For now, we just test !CvUNIQUE(cv), but
1230 * ideally, we should detect my's declared within loops
1231 * etc - this would allow a wider range of 'not stayed
1232 * shared' warnings. We also treated already-compiled
1233 * lexes as not multi as viewed from evals. */
1235 *out_flags = CvANON(cv) ?
1237 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1238 ? PAD_FAKELEX_MULTI : 0;
1240 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1241 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1242 PTR2UV(cv), (long)offset,
1243 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1244 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1246 else { /* fake match */
1247 offset = fake_offset;
1248 *out_name_sv = name_svp[offset]; /* return the namesv */
1249 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1250 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1251 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1252 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1253 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1257 /* return the lex? */
1262 if (SvPAD_OUR(*out_name_sv)) {
1263 *out_capture = NULL;
1267 /* trying to capture from an anon prototype? */
1269 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1270 : *out_flags & PAD_FAKELEX_ANON)
1274 newSVpvn_flags(namepv, namelen,
1276 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1278 *out_capture = NULL;
1284 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1285 && !SvPAD_STATE(name_svp[offset])
1286 && warn && ckWARN(WARN_CLOSURE)) {
1288 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1289 "Variable \"%"SVf"\" will not stay shared",
1290 newSVpvn_flags(namepv, namelen,
1292 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1295 if (fake_offset && CvANON(cv)
1296 && CvCLONE(cv) &&!CvCLONED(cv))
1299 /* not yet caught - look further up */
1300 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1301 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1304 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1306 newwarn, out_capture, out_name_sv, out_flags);
1311 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1312 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1313 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1314 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1315 PTR2UV(cv), PTR2UV(*out_capture)));
1317 if (SvPADSTALE(*out_capture)
1318 && (!CvDEPTH(cv) || !staleok)
1319 && !SvPAD_STATE(name_svp[offset]))
1322 newSVpvn_flags(namepv, namelen,
1324 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1325 *out_capture = NULL;
1328 if (!*out_capture) {
1329 if (namelen != 0 && *namepv == '@')
1330 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1331 else if (namelen != 0 && *namepv == '%')
1332 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1333 else if (namelen != 0 && *namepv == '&')
1334 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1336 *out_capture = sv_newmortal();
1344 /* it's not in this pad - try above */
1349 /* out_capture non-null means caller wants us to capture lex; in
1350 * addition we capture ourselves unless it's an ANON/format */
1351 new_capturep = out_capture ? out_capture :
1352 CvLATE(cv) ? NULL : &new_capture;
1354 offset = pad_findlex(namepv, namelen,
1355 flags | padadd_STALEOK*(new_capturep == &new_capture),
1356 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1357 new_capturep, out_name_sv, out_flags);
1358 if ((PADOFFSET)offset == NOT_IN_PAD)
1361 /* found in an outer CV. Add appropriate fake entry to this pad */
1363 /* don't add new fake entries (via eval) to CVs that we have already
1364 * finished compiling, or to undef CVs */
1365 if (CvCOMPILED(cv) || !padlist)
1366 return 0; /* this dummy (and invalid) value isnt used by the caller */
1369 /* This relies on sv_setsv_flags() upgrading the destination to the same
1370 type as the source, independent of the flags set, and on it being
1371 "good" and only copying flag bits and pointers that it understands.
1373 SV *new_namesv = newSVsv(*out_name_sv);
1374 AV * const ocomppad_name = PL_comppad_name;
1375 PAD * const ocomppad = PL_comppad;
1376 PL_comppad_name = PadlistARRAY(padlist)[0];
1377 PL_comppad = PadlistARRAY(padlist)[1];
1378 PL_curpad = AvARRAY(PL_comppad);
1381 = pad_alloc_name(new_namesv,
1382 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1383 SvPAD_TYPED(*out_name_sv)
1384 ? SvSTASH(*out_name_sv) : NULL,
1385 SvOURSTASH(*out_name_sv)
1388 SvFAKE_on(new_namesv);
1389 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1390 "Pad addname: %ld \"%.*s\" FAKE\n",
1392 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1393 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1395 PARENT_PAD_INDEX_set(new_namesv, 0);
1396 if (SvPAD_OUR(new_namesv)) {
1397 NOOP; /* do nothing */
1399 else if (CvLATE(cv)) {
1400 /* delayed creation - just note the offset within parent pad */
1401 PARENT_PAD_INDEX_set(new_namesv, offset);
1405 /* immediate creation - capture outer value right now */
1406 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1407 /* But also note the offset, as newMYSUB needs it */
1408 PARENT_PAD_INDEX_set(new_namesv, offset);
1409 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1410 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1411 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1413 *out_name_sv = new_namesv;
1414 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1416 PL_comppad_name = ocomppad_name;
1417 PL_comppad = ocomppad;
1418 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1426 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1428 Get the value at offset I<po> in the current (compiling or executing) pad.
1429 Use macro PAD_SV instead of calling this function directly.
1435 Perl_pad_sv(pTHX_ PADOFFSET po)
1438 ASSERT_CURPAD_ACTIVE("pad_sv");
1441 Perl_croak(aTHX_ "panic: pad_sv po");
1442 DEBUG_X(PerlIO_printf(Perl_debug_log,
1443 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1444 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1446 return PL_curpad[po];
1450 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1452 Set the value at offset I<po> in the current (compiling or executing) pad.
1453 Use the macro PAD_SETSV() rather than calling this function directly.
1459 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1463 PERL_ARGS_ASSERT_PAD_SETSV;
1465 ASSERT_CURPAD_ACTIVE("pad_setsv");
1467 DEBUG_X(PerlIO_printf(Perl_debug_log,
1468 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1469 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1474 #endif /* DEBUGGING */
1477 =for apidoc m|void|pad_block_start|int full
1479 Update the pad compilation state variables on entry to a new block.
1484 /* XXX DAPM perhaps:
1485 * - integrate this in general state-saving routine ???
1486 * - combine with the state-saving going on in pad_new ???
1487 * - introduce a new SAVE type that does all this in one go ?
1491 Perl_pad_block_start(pTHX_ int full)
1494 ASSERT_CURPAD_ACTIVE("pad_block_start");
1495 SAVEI32(PL_comppad_name_floor);
1496 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1498 PL_comppad_name_fill = PL_comppad_name_floor;
1499 if (PL_comppad_name_floor < 0)
1500 PL_comppad_name_floor = 0;
1501 SAVEI32(PL_min_intro_pending);
1502 SAVEI32(PL_max_intro_pending);
1503 PL_min_intro_pending = 0;
1504 SAVEI32(PL_comppad_name_fill);
1505 SAVEI32(PL_padix_floor);
1506 PL_padix_floor = PL_padix;
1507 PL_pad_reset_pending = FALSE;
1511 =for apidoc m|U32|intro_my
1513 "Introduce" my variables to visible status. This is called during parsing
1514 at the end of each statement to make lexical variables visible to
1515 subsequent statements.
1528 ASSERT_CURPAD_ACTIVE("intro_my");
1529 if (! PL_min_intro_pending)
1530 return PL_cop_seqmax;
1532 svp = AvARRAY(PL_comppad_name);
1533 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1534 SV * const sv = svp[i];
1536 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1537 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1539 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1540 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1541 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1542 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1543 (long)i, SvPVX_const(sv),
1544 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1545 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1549 seq = PL_cop_seqmax;
1551 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1553 PL_min_intro_pending = 0;
1554 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1555 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1556 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1562 =for apidoc m|void|pad_leavemy
1564 Cleanup at end of scope during compilation: set the max seq number for
1565 lexicals in this scope and warn of any lexicals that never got introduced.
1571 Perl_pad_leavemy(pTHX)
1576 SV * const * const svp = AvARRAY(PL_comppad_name);
1578 PL_pad_reset_pending = FALSE;
1580 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1581 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1582 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1583 const SV * const sv = svp[off];
1584 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1585 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1586 "%"SVf" never introduced",
1590 /* "Deintroduce" my variables that are leaving with this scope. */
1591 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1592 SV * const sv = svp[off];
1593 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1594 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1596 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1597 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1598 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1599 (long)off, SvPVX_const(sv),
1600 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1601 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1603 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1604 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1605 OP *kid = newOP(OP_INTROCV, 0);
1607 o = op_prepend_elem(OP_LINESEQ, kid, o);
1612 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1614 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1615 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1620 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1622 Abandon the tmp in the current pad at offset po and replace with a
1629 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1632 ASSERT_CURPAD_LEGAL("pad_swipe");
1635 if (AvARRAY(PL_comppad) != PL_curpad)
1636 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1637 AvARRAY(PL_comppad), PL_curpad);
1638 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1639 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1640 (long)po, (long)AvFILLp(PL_comppad));
1642 DEBUG_X(PerlIO_printf(Perl_debug_log,
1643 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1644 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1647 SvREFCNT_dec(PL_curpad[po]);
1650 /* if pad tmps aren't shared between ops, then there's no need to
1651 * create a new tmp when an existing op is freed */
1652 #ifdef USE_BROKEN_PAD_RESET
1653 PL_curpad[po] = newSV(0);
1654 SvPADTMP_on(PL_curpad[po]);
1656 PL_curpad[po] = NULL;
1658 if (PadnamelistMAX(PL_comppad_name) != -1
1659 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1660 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1661 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1663 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1665 if ((I32)po < PL_padix)
1670 =for apidoc m|void|pad_reset
1672 Mark all the current temporaries for reuse
1677 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1678 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1679 * on the stack by OPs that use them, there are several ways to get an alias
1680 * to a shared TARG. Such an alias will change randomly and unpredictably.
1681 * We avoid doing this until we can think of a Better Way.
1687 #ifdef USE_BROKEN_PAD_RESET
1688 if (AvARRAY(PL_comppad) != PL_curpad)
1689 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1690 AvARRAY(PL_comppad), PL_curpad);
1692 DEBUG_X(PerlIO_printf(Perl_debug_log,
1693 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1694 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1695 (long)PL_padix, (long)PL_padix_floor
1699 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1701 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1702 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1703 SvPADTMP_off(PL_curpad[po]);
1705 PL_padix = PL_padix_floor;
1708 PL_pad_reset_pending = FALSE;
1712 =for apidoc Amx|void|pad_tidy|padtidy_type type
1714 Tidy up a pad at the end of compilation of the code to which it belongs.
1715 Jobs performed here are: remove most stuff from the pads of anonsub
1716 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1717 the kind of subroutine:
1719 padtidy_SUB ordinary subroutine
1720 padtidy_SUBCLONE prototype for lexical closure
1721 padtidy_FORMAT format
1726 /* XXX DAPM surely most of this stuff should be done properly
1727 * at the right time beforehand, rather than going around afterwards
1728 * cleaning up our mistakes ???
1732 Perl_pad_tidy(pTHX_ padtidy_type type)
1736 ASSERT_CURPAD_ACTIVE("pad_tidy");
1738 /* If this CV has had any 'eval-capable' ops planted in it:
1739 * i.e. it contains any of:
1743 * * use re 'eval'; /$var/
1746 * Then any anon prototypes in the chain of CVs should be marked as
1747 * cloneable, so that for example the eval's CV in
1751 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1752 * potentially have an eval executed within it.
1755 if (PL_cv_has_eval || PL_perldb) {
1757 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1758 if (cv != PL_compcv && CvCOMPILED(cv))
1759 break; /* no need to mark already-compiled code */
1761 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1762 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1769 /* extend namepad to match curpad */
1770 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1771 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1773 if (type == padtidy_SUBCLONE) {
1774 SV ** const namep = AvARRAY(PL_comppad_name);
1777 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1779 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1782 * The only things that a clonable function needs in its
1783 * pad are anonymous subs, constants and GVs.
1784 * The rest are created anew during cloning.
1786 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1787 || IS_PADGV(PL_curpad[ix]))
1790 if (!(PadnamePV(namesv) &&
1791 (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1793 SvREFCNT_dec(PL_curpad[ix]);
1794 PL_curpad[ix] = NULL;
1798 else if (type == padtidy_SUB) {
1799 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1800 AV * const av = newAV(); /* Will be @_ */
1801 av_store(PL_comppad, 0, MUTABLE_SV(av));
1805 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1806 SV ** const namep = AvARRAY(PL_comppad_name);
1808 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1809 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1810 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1811 || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1813 if (!SvPADMY(PL_curpad[ix])) {
1814 SvPADTMP_on(PL_curpad[ix]);
1815 } else if (!SvFAKE(namep[ix])) {
1816 /* This is a work around for how the current implementation of
1817 ?{ } blocks in regexps interacts with lexicals.
1819 One of our lexicals.
1820 Can't do this on all lexicals, otherwise sub baz() won't
1829 because completion of compiling &bar calling pad_tidy()
1830 would cause (top level) $foo to be marked as stale, and
1831 "no longer available". */
1832 SvPADSTALE_on(PL_curpad[ix]);
1836 PL_curpad = AvARRAY(PL_comppad);
1840 =for apidoc m|void|pad_free|PADOFFSET po
1842 Free the SV at offset po in the current pad.
1847 /* XXX DAPM integrate with pad_swipe ???? */
1849 Perl_pad_free(pTHX_ PADOFFSET po)
1853 ASSERT_CURPAD_LEGAL("pad_free");
1856 if (AvARRAY(PL_comppad) != PL_curpad)
1857 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1858 AvARRAY(PL_comppad), PL_curpad);
1860 Perl_croak(aTHX_ "panic: pad_free po");
1862 DEBUG_X(PerlIO_printf(Perl_debug_log,
1863 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1864 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1869 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1870 SvFLAGS(sv) &= ~SVs_PADTMP;
1872 if ((I32)po < PL_padix)
1877 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1879 Dump the contents of a padlist
1885 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1894 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1899 pad_name = *PadlistARRAY(padlist);
1900 pad = PadlistARRAY(padlist)[1];
1901 pname = AvARRAY(pad_name);
1902 ppad = AvARRAY(pad);
1903 Perl_dump_indent(aTHX_ level, file,
1904 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1905 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1908 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1909 const SV *namesv = pname[ix];
1910 if (namesv && !PadnameLEN(namesv)) {
1915 Perl_dump_indent(aTHX_ level+1, file,
1916 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1919 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1920 SvPVX_const(namesv),
1921 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1922 (unsigned long)PARENT_PAD_INDEX(namesv)
1926 Perl_dump_indent(aTHX_ level+1, file,
1927 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1930 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1931 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1932 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1937 Perl_dump_indent(aTHX_ level+1, file,
1938 "%2d. 0x%"UVxf"<%lu>\n",
1941 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1950 =for apidoc m|void|cv_dump|CV *cv|const char *title
1952 dump the contents of a CV
1958 S_cv_dump(pTHX_ const CV *cv, const char *title)
1961 const CV * const outside = CvOUTSIDE(cv);
1962 PADLIST* const padlist = CvPADLIST(cv);
1964 PERL_ARGS_ASSERT_CV_DUMP;
1966 PerlIO_printf(Perl_debug_log,
1967 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1970 (CvANON(cv) ? "ANON"
1971 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1972 : (cv == PL_main_cv) ? "MAIN"
1973 : CvUNIQUE(cv) ? "UNIQUE"
1974 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1977 : CvANON(outside) ? "ANON"
1978 : (outside == PL_main_cv) ? "MAIN"
1979 : CvUNIQUE(outside) ? "UNIQUE"
1980 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1982 PerlIO_printf(Perl_debug_log,
1983 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1984 do_dump_pad(1, Perl_debug_log, padlist, 1);
1987 #endif /* DEBUGGING */
1990 =for apidoc Am|CV *|cv_clone|CV *proto
1992 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1993 of the function: its code, pad structure, and other attributes.
1994 The prototype is combined with a capture of outer lexicals to which the
1995 code refers, which are taken from the currently-executing instance of
1996 the immediately surrounding code.
2001 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
2004 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
2008 PADLIST* const protopadlist = CvPADLIST(proto);
2009 PAD *const protopad_name = *PadlistARRAY(protopadlist);
2010 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
2011 SV** const pname = AvARRAY(protopad_name);
2012 SV** const ppad = AvARRAY(protopad);
2013 const I32 fname = AvFILLp(protopad_name);
2014 const I32 fpad = AvFILLp(protopad);
2017 bool subclones = FALSE;
2019 assert(!CvUNIQUE(proto));
2021 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2022 * reliable. The currently-running sub is always the one we need to
2024 * For my subs, the currently-running sub may not be the one we want.
2025 * We have to check whether it is a clone of CvOUTSIDE.
2026 * Note that in general for formats, CvOUTSIDE != find_runcv.
2027 * Since formats may be nested inside closures, CvOUTSIDE may point
2028 * to a prototype; we instead want the cloned parent who called us.
2032 if (CvWEAKOUTSIDE(proto))
2033 outside = find_runcv(NULL);
2035 outside = CvOUTSIDE(proto);
2036 if ((CvCLONE(outside) && ! CvCLONED(outside))
2037 || !CvPADLIST(outside)
2038 || PadlistNAMES(CvPADLIST(outside))
2039 != protopadlist->xpadl_outid) {
2040 outside = find_runcv_where(
2041 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2043 /* outside could be null */
2047 depth = outside ? CvDEPTH(outside) : 0;
2052 SAVESPTR(PL_compcv);
2054 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2057 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2059 SAVESPTR(PL_comppad_name);
2060 PL_comppad_name = protopad_name;
2061 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2063 av_fill(PL_comppad, fpad);
2065 PL_curpad = AvARRAY(PL_comppad);
2067 outpad = outside && CvPADLIST(outside)
2068 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2071 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2073 for (ix = fpad; ix > 0; ix--) {
2074 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2076 if (namesv && PadnameLEN(namesv)) { /* lexical */
2077 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2081 if (SvFAKE(namesv)) { /* lexical from outside? */
2082 /* formats may have an inactive, or even undefined, parent;
2083 but state vars are always available. */
2084 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2085 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2086 && (!outside || !CvDEPTH(outside))) ) {
2087 S_unavailable(aTHX_ namesv);
2091 SvREFCNT_inc_simple_void_NN(sv);
2094 const char sigil = SvPVX_const(namesv)[0];
2096 /* If there are state subs, we need to clone them, too.
2097 But they may need to close over variables we have
2098 not cloned yet. So we will have to do a second
2099 pass. Furthermore, there may be state subs clos-
2100 ing over other state subs’ entries, so we have
2101 to put a stub here and then clone into it on the
2103 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2104 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2106 sv = newSV_type(SVt_PVCV);
2108 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2111 /* Just provide a stub, but name it. It will be
2112 upgrade to the real thing on scope entry. */
2113 sv = newSV_type(SVt_PVCV);
2116 share_hek(SvPVX_const(namesv)+1,
2118 * (SvUTF8(namesv) ? -1 : 1),
2122 else sv = SvREFCNT_inc(ppad[ix]);
2123 else if (sigil == '@')
2124 sv = MUTABLE_SV(newAV());
2125 else if (sigil == '%')
2126 sv = MUTABLE_SV(newHV());
2130 /* reset the 'assign only once' flag on each state var */
2131 if (sigil != '&' && SvPAD_STATE(namesv))
2136 else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
2137 sv = SvREFCNT_inc_NN(ppad[ix]);
2147 for (ix = fpad; ix > 0; ix--) {
2148 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2149 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2150 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2151 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2154 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2159 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2162 const bool newcv = !cv;
2164 assert(!CvUNIQUE(proto));
2166 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2167 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2171 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2174 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2175 else CvGV_set(cv,CvGV(proto));
2176 CvSTASH_set(cv, CvSTASH(proto));
2178 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2180 CvSTART(cv) = CvSTART(proto);
2181 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2184 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2186 SvUTF8_on(MUTABLE_SV(cv));
2189 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2191 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2194 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2195 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2196 cv_dump(proto, "Proto");
2201 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2202 * The prototype was marked as a candiate for const-ization,
2203 * so try to grab the current const value, and if successful,
2204 * turn into a const sub:
2206 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2208 SvREFCNT_dec_NN(cv);
2209 /* For this calling case, op_const_sv returns a *copy*, which we
2210 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2211 Need to fix how lib/constant.pm works to eliminate this. */
2212 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2223 Perl_cv_clone(pTHX_ CV *proto)
2225 PERL_ARGS_ASSERT_CV_CLONE;
2227 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2228 return S_cv_clone(aTHX_ proto, NULL, NULL);
2231 /* Called only by pp_clonecv */
2233 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2235 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2237 return S_cv_clone(aTHX_ proto, target, NULL);
2241 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2243 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2244 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2245 moved to a pre-existing CV struct.
2251 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2255 AV * const comppad_name = PadlistARRAY(padlist)[0];
2256 AV * const comppad = PadlistARRAY(padlist)[1];
2257 SV ** const namepad = AvARRAY(comppad_name);
2258 SV ** const curpad = AvARRAY(comppad);
2260 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2261 PERL_UNUSED_ARG(old_cv);
2263 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2264 const SV * const namesv = namepad[ix];
2265 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2266 && *SvPVX_const(namesv) == '&')
2268 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2270 SvMAGICAL(curpad[ix])
2271 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2273 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2274 if (CvOUTSIDE(innercv) == old_cv) {
2275 if (!CvWEAKOUTSIDE(innercv)) {
2276 SvREFCNT_dec(old_cv);
2277 SvREFCNT_inc_simple_void_NN(new_cv);
2279 CvOUTSIDE(innercv) = new_cv;
2282 else { /* format reference */
2283 SV * const rv = curpad[ix];
2285 if (!SvOK(rv)) continue;
2287 assert(SvWEAKREF(rv));
2288 innercv = (CV *)SvRV(rv);
2289 assert(!CvWEAKOUTSIDE(innercv));
2290 SvREFCNT_dec(CvOUTSIDE(innercv));
2291 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2298 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2300 Push a new pad frame onto the padlist, unless there's already a pad at
2301 this depth, in which case don't bother creating a new one. Then give
2302 the new pad an @_ in slot zero.
2308 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2312 PERL_ARGS_ASSERT_PAD_PUSH;
2314 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2315 PAD** const svp = PadlistARRAY(padlist);
2316 AV* const newpad = newAV();
2317 SV** const oldpad = AvARRAY(svp[depth-1]);
2318 I32 ix = AvFILLp((const AV *)svp[1]);
2319 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2320 SV** const names = AvARRAY(svp[0]);
2323 for ( ;ix > 0; ix--) {
2324 if (names_fill >= ix && PadnameLEN(names[ix])) {
2325 const char sigil = SvPVX_const(names[ix])[0];
2326 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2327 || (SvFLAGS(names[ix]) & SVpad_STATE)
2330 /* outer lexical or anon code */
2331 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2333 else { /* our own lexical */
2336 sv = MUTABLE_SV(newAV());
2337 else if (sigil == '%')
2338 sv = MUTABLE_SV(newHV());
2341 av_store(newpad, ix, sv);
2345 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2346 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2349 /* save temporaries on recursion? */
2350 SV * const sv = newSV(0);
2351 av_store(newpad, ix, sv);
2356 av_store(newpad, 0, MUTABLE_SV(av));
2359 padlist_store(padlist, depth, newpad);
2364 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2366 Looks up the type of the lexical variable at position I<po> in the
2367 currently-compiling pad. If the variable is typed, the stash of the
2368 class to which it is typed is returned. If not, C<NULL> is returned.
2374 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2377 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2378 if ( SvPAD_TYPED(*av) ) {
2379 return SvSTASH(*av);
2384 #if defined(USE_ITHREADS)
2386 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2389 =for apidoc padlist_dup
2397 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2403 PERL_ARGS_ASSERT_PADLIST_DUP;
2408 cloneall = param->flags & CLONEf_COPY_STACKS
2409 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2410 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2412 max = cloneall ? PadlistMAX(srcpad) : 1;
2414 Newx(dstpad, 1, PADLIST);
2415 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2416 PadlistMAX(dstpad) = max;
2417 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2421 for (depth = 0; depth <= max; ++depth)
2422 PadlistARRAY(dstpad)[depth] =
2423 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2425 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2426 to build anything other than the first level of pads. */
2427 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2429 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2430 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2431 SV **oldpad = AvARRAY(srcpad1);
2436 PadlistARRAY(dstpad)[0] =
2437 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2438 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2442 av_extend(pad1, ix);
2443 PadlistARRAY(dstpad)[1] = pad1;
2444 pad1a = AvARRAY(pad1);
2449 for ( ;ix > 0; ix--) {
2452 } else if (names_fill >= ix && names[ix] &&
2453 PadnameLEN(names[ix])) {
2454 const char sigil = SvPVX_const(names[ix])[0];
2455 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2456 || (SvFLAGS(names[ix]) & SVpad_STATE)
2459 /* outer lexical or anon code */
2460 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2462 else { /* our own lexical */
2463 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2464 /* This is a work around for how the current
2465 implementation of ?{ } blocks in regexps
2466 interacts with lexicals. */
2467 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2472 sv = MUTABLE_SV(newAV());
2473 else if (sigil == '%')
2474 sv = MUTABLE_SV(newHV());
2482 else if (IS_PADGV(oldpad[ix])
2483 || ( names_fill >= ix && names[ix]
2484 && PadnamePV(names[ix]) )) {
2485 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2488 /* save temporaries on recursion? */
2489 SV * const sv = newSV(0);
2492 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2493 FIXTHAT before merging this branch.
2494 (And I know how to) */
2495 if (SvPADMY(oldpad[ix]))
2503 args = newAV(); /* Will be @_ */
2505 pad1a[0] = (SV *)args;
2513 #endif /* USE_ITHREADS */
2516 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2520 SSize_t const oldmax = PadlistMAX(padlist);
2522 PERL_ARGS_ASSERT_PADLIST_STORE;
2526 if (key > PadlistMAX(padlist)) {
2527 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2528 (SV ***)&PadlistARRAY(padlist),
2529 (SV ***)&PadlistARRAY(padlist));
2530 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2533 ary = PadlistARRAY(padlist);
2534 SvREFCNT_dec(ary[key]);
2541 * c-indentation-style: bsd
2543 * indent-tabs-mode: nil
2546 * ex: set ts=8 sts=4 sw=4 et: