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 as it goes. It has to be this way
1127 because fake namesvs in anon protoypes have to store in xlow the index into
1133 /* the CV has finished being compiled. This is not a sufficient test for
1134 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1135 #define CvCOMPILED(cv) CvROOT(cv)
1137 /* the CV does late binding of its lexicals */
1138 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1141 S_unavailable(pTHX_ SV *namesv)
1143 /* diag_listed_as: Variable "%s" is not available */
1144 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1145 "%se \"%"SVf"\" is not available",
1146 *SvPVX_const(namesv) == '&'
1153 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1154 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1157 I32 offset, new_offset;
1160 const PADLIST * const padlist = CvPADLIST(cv);
1161 const bool staleok = !!(flags & padadd_STALEOK);
1163 PERL_ARGS_ASSERT_PAD_FINDLEX;
1165 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1166 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1168 flags &= ~ padadd_STALEOK; /* one-shot flag */
1172 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1173 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1174 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1175 out_capture ? " capturing" : "" ));
1177 /* first, search this pad */
1179 if (padlist) { /* not an undef CV */
1180 I32 fake_offset = 0;
1181 const AV * const nameav = PadlistARRAY(padlist)[0];
1182 SV * const * const name_svp = AvARRAY(nameav);
1184 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1185 const SV * const namesv = name_svp[offset];
1186 if (namesv && PadnameLEN(namesv) == namelen
1187 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1188 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1190 if (SvFAKE(namesv)) {
1191 fake_offset = offset; /* in case we don't find a real one */
1194 /* is seq within the range _LOW to _HIGH ?
1195 * This is complicated by the fact that PL_cop_seqmax
1196 * may have wrapped around at some point */
1197 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1198 continue; /* not yet introduced */
1200 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1201 /* in compiling scope */
1203 (seq > COP_SEQ_RANGE_LOW(namesv))
1204 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1205 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1210 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1212 ( seq > COP_SEQ_RANGE_LOW(namesv)
1213 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1215 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1216 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1222 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1223 if (offset > 0) { /* not fake */
1225 *out_name_sv = name_svp[offset]; /* return the namesv */
1227 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1228 * instances. For now, we just test !CvUNIQUE(cv), but
1229 * ideally, we should detect my's declared within loops
1230 * etc - this would allow a wider range of 'not stayed
1231 * shared' warnings. We also treated already-compiled
1232 * lexes as not multi as viewed from evals. */
1234 *out_flags = CvANON(cv) ?
1236 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1237 ? PAD_FAKELEX_MULTI : 0;
1239 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1240 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1241 PTR2UV(cv), (long)offset,
1242 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1243 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1245 else { /* fake match */
1246 offset = fake_offset;
1247 *out_name_sv = name_svp[offset]; /* return the namesv */
1248 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1249 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1250 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1251 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1252 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1256 /* return the lex? */
1261 if (SvPAD_OUR(*out_name_sv)) {
1262 *out_capture = NULL;
1266 /* trying to capture from an anon prototype? */
1268 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1269 : *out_flags & PAD_FAKELEX_ANON)
1273 newSVpvn_flags(namepv, namelen,
1275 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1277 *out_capture = NULL;
1283 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1284 && !SvPAD_STATE(name_svp[offset])
1285 && warn && ckWARN(WARN_CLOSURE)) {
1287 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1288 "Variable \"%"SVf"\" will not stay shared",
1289 newSVpvn_flags(namepv, namelen,
1291 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1294 if (fake_offset && CvANON(cv)
1295 && CvCLONE(cv) &&!CvCLONED(cv))
1298 /* not yet caught - look further up */
1299 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1300 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1303 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1305 newwarn, out_capture, out_name_sv, out_flags);
1310 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1311 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1312 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1313 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1314 PTR2UV(cv), PTR2UV(*out_capture)));
1316 if (SvPADSTALE(*out_capture)
1317 && (!CvDEPTH(cv) || !staleok)
1318 && !SvPAD_STATE(name_svp[offset]))
1321 newSVpvn_flags(namepv, namelen,
1323 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1324 *out_capture = NULL;
1327 if (!*out_capture) {
1328 if (namelen != 0 && *namepv == '@')
1329 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1330 else if (namelen != 0 && *namepv == '%')
1331 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1332 else if (namelen != 0 && *namepv == '&')
1333 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1335 *out_capture = sv_newmortal();
1343 /* it's not in this pad - try above */
1348 /* out_capture non-null means caller wants us to capture lex; in
1349 * addition we capture ourselves unless it's an ANON/format */
1350 new_capturep = out_capture ? out_capture :
1351 CvLATE(cv) ? NULL : &new_capture;
1353 offset = pad_findlex(namepv, namelen,
1354 flags | padadd_STALEOK*(new_capturep == &new_capture),
1355 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1356 new_capturep, out_name_sv, out_flags);
1357 if ((PADOFFSET)offset == NOT_IN_PAD)
1360 /* found in an outer CV. Add appropriate fake entry to this pad */
1362 /* don't add new fake entries (via eval) to CVs that we have already
1363 * finished compiling, or to undef CVs */
1364 if (CvCOMPILED(cv) || !padlist)
1365 return 0; /* this dummy (and invalid) value isnt used by the caller */
1368 /* This relies on sv_setsv_flags() upgrading the destination to the same
1369 type as the source, independent of the flags set, and on it being
1370 "good" and only copying flag bits and pointers that it understands.
1372 SV *new_namesv = newSVsv(*out_name_sv);
1373 AV * const ocomppad_name = PL_comppad_name;
1374 PAD * const ocomppad = PL_comppad;
1375 PL_comppad_name = PadlistARRAY(padlist)[0];
1376 PL_comppad = PadlistARRAY(padlist)[1];
1377 PL_curpad = AvARRAY(PL_comppad);
1380 = pad_alloc_name(new_namesv,
1381 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1382 SvPAD_TYPED(*out_name_sv)
1383 ? SvSTASH(*out_name_sv) : NULL,
1384 SvOURSTASH(*out_name_sv)
1387 SvFAKE_on(new_namesv);
1388 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1389 "Pad addname: %ld \"%.*s\" FAKE\n",
1391 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1392 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1394 PARENT_PAD_INDEX_set(new_namesv, 0);
1395 if (SvPAD_OUR(new_namesv)) {
1396 NOOP; /* do nothing */
1398 else if (CvLATE(cv)) {
1399 /* delayed creation - just note the offset within parent pad */
1400 PARENT_PAD_INDEX_set(new_namesv, offset);
1404 /* immediate creation - capture outer value right now */
1405 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1406 /* But also note the offset, as newMYSUB needs it */
1407 PARENT_PAD_INDEX_set(new_namesv, offset);
1408 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1409 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1410 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1412 *out_name_sv = new_namesv;
1413 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1415 PL_comppad_name = ocomppad_name;
1416 PL_comppad = ocomppad;
1417 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1425 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1427 Get the value at offset I<po> in the current (compiling or executing) pad.
1428 Use macro PAD_SV instead of calling this function directly.
1434 Perl_pad_sv(pTHX_ PADOFFSET po)
1437 ASSERT_CURPAD_ACTIVE("pad_sv");
1440 Perl_croak(aTHX_ "panic: pad_sv po");
1441 DEBUG_X(PerlIO_printf(Perl_debug_log,
1442 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1443 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1445 return PL_curpad[po];
1449 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1451 Set the value at offset I<po> in the current (compiling or executing) pad.
1452 Use the macro PAD_SETSV() rather than calling this function directly.
1458 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1462 PERL_ARGS_ASSERT_PAD_SETSV;
1464 ASSERT_CURPAD_ACTIVE("pad_setsv");
1466 DEBUG_X(PerlIO_printf(Perl_debug_log,
1467 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1468 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1473 #endif /* DEBUGGING */
1476 =for apidoc m|void|pad_block_start|int full
1478 Update the pad compilation state variables on entry to a new block.
1483 /* XXX DAPM perhaps:
1484 * - integrate this in general state-saving routine ???
1485 * - combine with the state-saving going on in pad_new ???
1486 * - introduce a new SAVE type that does all this in one go ?
1490 Perl_pad_block_start(pTHX_ int full)
1493 ASSERT_CURPAD_ACTIVE("pad_block_start");
1494 SAVEI32(PL_comppad_name_floor);
1495 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1497 PL_comppad_name_fill = PL_comppad_name_floor;
1498 if (PL_comppad_name_floor < 0)
1499 PL_comppad_name_floor = 0;
1500 SAVEI32(PL_min_intro_pending);
1501 SAVEI32(PL_max_intro_pending);
1502 PL_min_intro_pending = 0;
1503 SAVEI32(PL_comppad_name_fill);
1504 SAVEI32(PL_padix_floor);
1505 PL_padix_floor = PL_padix;
1506 PL_pad_reset_pending = FALSE;
1510 =for apidoc m|U32|intro_my
1512 "Introduce" my variables to visible status. This is called during parsing
1513 at the end of each statement to make lexical variables visible to
1514 subsequent statements.
1527 ASSERT_CURPAD_ACTIVE("intro_my");
1528 if (! PL_min_intro_pending)
1529 return PL_cop_seqmax;
1531 svp = AvARRAY(PL_comppad_name);
1532 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1533 SV * const sv = svp[i];
1535 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1536 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1538 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1539 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1540 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1541 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1542 (long)i, SvPVX_const(sv),
1543 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1544 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1548 seq = PL_cop_seqmax;
1550 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1552 PL_min_intro_pending = 0;
1553 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1554 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1555 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1561 =for apidoc m|void|pad_leavemy
1563 Cleanup at end of scope during compilation: set the max seq number for
1564 lexicals in this scope and warn of any lexicals that never got introduced.
1570 Perl_pad_leavemy(pTHX)
1575 SV * const * const svp = AvARRAY(PL_comppad_name);
1577 PL_pad_reset_pending = FALSE;
1579 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1580 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1581 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1582 const SV * const sv = svp[off];
1583 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1584 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1585 "%"SVf" never introduced",
1589 /* "Deintroduce" my variables that are leaving with this scope. */
1590 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1591 SV * const sv = svp[off];
1592 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1593 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1595 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1596 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1597 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1598 (long)off, SvPVX_const(sv),
1599 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1600 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1602 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1603 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1604 OP *kid = newOP(OP_INTROCV, 0);
1606 o = op_prepend_elem(OP_LINESEQ, kid, o);
1611 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1613 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1614 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1619 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1621 Abandon the tmp in the current pad at offset po and replace with a
1628 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1631 ASSERT_CURPAD_LEGAL("pad_swipe");
1634 if (AvARRAY(PL_comppad) != PL_curpad)
1635 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1636 AvARRAY(PL_comppad), PL_curpad);
1637 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1638 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1639 (long)po, (long)AvFILLp(PL_comppad));
1641 DEBUG_X(PerlIO_printf(Perl_debug_log,
1642 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1643 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1646 SvREFCNT_dec(PL_curpad[po]);
1649 /* if pad tmps aren't shared between ops, then there's no need to
1650 * create a new tmp when an existing op is freed */
1651 #ifdef USE_BROKEN_PAD_RESET
1652 PL_curpad[po] = newSV(0);
1653 SvPADTMP_on(PL_curpad[po]);
1655 PL_curpad[po] = NULL;
1657 if (PadnamelistMAX(PL_comppad_name) != -1
1658 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1659 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1660 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1662 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1664 if ((I32)po < PL_padix)
1669 =for apidoc m|void|pad_reset
1671 Mark all the current temporaries for reuse
1676 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1677 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1678 * on the stack by OPs that use them, there are several ways to get an alias
1679 * to a shared TARG. Such an alias will change randomly and unpredictably.
1680 * We avoid doing this until we can think of a Better Way.
1686 #ifdef USE_BROKEN_PAD_RESET
1687 if (AvARRAY(PL_comppad) != PL_curpad)
1688 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1689 AvARRAY(PL_comppad), PL_curpad);
1691 DEBUG_X(PerlIO_printf(Perl_debug_log,
1692 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1693 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1694 (long)PL_padix, (long)PL_padix_floor
1698 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1700 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1701 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1702 SvPADTMP_off(PL_curpad[po]);
1704 PL_padix = PL_padix_floor;
1707 PL_pad_reset_pending = FALSE;
1711 =for apidoc Amx|void|pad_tidy|padtidy_type type
1713 Tidy up a pad at the end of compilation of the code to which it belongs.
1714 Jobs performed here are: remove most stuff from the pads of anonsub
1715 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1716 the kind of subroutine:
1718 padtidy_SUB ordinary subroutine
1719 padtidy_SUBCLONE prototype for lexical closure
1720 padtidy_FORMAT format
1725 /* XXX DAPM surely most of this stuff should be done properly
1726 * at the right time beforehand, rather than going around afterwards
1727 * cleaning up our mistakes ???
1731 Perl_pad_tidy(pTHX_ padtidy_type type)
1735 ASSERT_CURPAD_ACTIVE("pad_tidy");
1737 /* If this CV has had any 'eval-capable' ops planted in it:
1738 * i.e. it contains any of:
1742 * * use re 'eval'; /$var/
1745 * Then any anon prototypes in the chain of CVs should be marked as
1746 * cloneable, so that for example the eval's CV in
1750 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1751 * potentially have an eval executed within it.
1754 if (PL_cv_has_eval || PL_perldb) {
1756 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1757 if (cv != PL_compcv && CvCOMPILED(cv))
1758 break; /* no need to mark already-compiled code */
1760 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1761 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1768 /* extend namepad to match curpad */
1769 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1770 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1772 if (type == padtidy_SUBCLONE) {
1773 SV ** const namep = AvARRAY(PL_comppad_name);
1776 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1778 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1781 * The only things that a clonable function needs in its
1782 * pad are anonymous subs, constants and GVs.
1783 * The rest are created anew during cloning.
1785 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1786 || IS_PADGV(PL_curpad[ix]))
1789 if (!(PadnamePV(namesv) &&
1790 (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1792 SvREFCNT_dec(PL_curpad[ix]);
1793 PL_curpad[ix] = NULL;
1797 else if (type == padtidy_SUB) {
1798 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1799 AV * const av = newAV(); /* Will be @_ */
1800 av_store(PL_comppad, 0, MUTABLE_SV(av));
1804 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1805 SV ** const namep = AvARRAY(PL_comppad_name);
1807 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1808 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1809 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
1810 || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1812 if (!SvPADMY(PL_curpad[ix])) {
1813 SvPADTMP_on(PL_curpad[ix]);
1814 } else if (!SvFAKE(namep[ix])) {
1815 /* This is a work around for how the current implementation of
1816 ?{ } blocks in regexps interacts with lexicals.
1818 One of our lexicals.
1819 Can't do this on all lexicals, otherwise sub baz() won't
1828 because completion of compiling &bar calling pad_tidy()
1829 would cause (top level) $foo to be marked as stale, and
1830 "no longer available". */
1831 SvPADSTALE_on(PL_curpad[ix]);
1835 PL_curpad = AvARRAY(PL_comppad);
1839 =for apidoc m|void|pad_free|PADOFFSET po
1841 Free the SV at offset po in the current pad.
1846 /* XXX DAPM integrate with pad_swipe ???? */
1848 Perl_pad_free(pTHX_ PADOFFSET po)
1852 ASSERT_CURPAD_LEGAL("pad_free");
1855 if (AvARRAY(PL_comppad) != PL_curpad)
1856 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1857 AvARRAY(PL_comppad), PL_curpad);
1859 Perl_croak(aTHX_ "panic: pad_free po");
1861 DEBUG_X(PerlIO_printf(Perl_debug_log,
1862 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1863 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1868 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1869 SvFLAGS(sv) &= ~SVs_PADTMP;
1871 if ((I32)po < PL_padix)
1876 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1878 Dump the contents of a padlist
1884 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1893 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1898 pad_name = *PadlistARRAY(padlist);
1899 pad = PadlistARRAY(padlist)[1];
1900 pname = AvARRAY(pad_name);
1901 ppad = AvARRAY(pad);
1902 Perl_dump_indent(aTHX_ level, file,
1903 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1904 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1907 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1908 const SV *namesv = pname[ix];
1909 if (namesv && !PadnameLEN(namesv)) {
1914 Perl_dump_indent(aTHX_ level+1, file,
1915 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1918 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1919 SvPVX_const(namesv),
1920 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1921 (unsigned long)PARENT_PAD_INDEX(namesv)
1925 Perl_dump_indent(aTHX_ level+1, file,
1926 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1929 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1930 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1931 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1936 Perl_dump_indent(aTHX_ level+1, file,
1937 "%2d. 0x%"UVxf"<%lu>\n",
1940 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1949 =for apidoc m|void|cv_dump|CV *cv|const char *title
1951 dump the contents of a CV
1957 S_cv_dump(pTHX_ const CV *cv, const char *title)
1960 const CV * const outside = CvOUTSIDE(cv);
1961 PADLIST* const padlist = CvPADLIST(cv);
1963 PERL_ARGS_ASSERT_CV_DUMP;
1965 PerlIO_printf(Perl_debug_log,
1966 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1969 (CvANON(cv) ? "ANON"
1970 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1971 : (cv == PL_main_cv) ? "MAIN"
1972 : CvUNIQUE(cv) ? "UNIQUE"
1973 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1976 : CvANON(outside) ? "ANON"
1977 : (outside == PL_main_cv) ? "MAIN"
1978 : CvUNIQUE(outside) ? "UNIQUE"
1979 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1981 PerlIO_printf(Perl_debug_log,
1982 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1983 do_dump_pad(1, Perl_debug_log, padlist, 1);
1986 #endif /* DEBUGGING */
1989 =for apidoc Am|CV *|cv_clone|CV *proto
1991 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1992 of the function: its code, pad structure, and other attributes.
1993 The prototype is combined with a capture of outer lexicals to which the
1994 code refers, which are taken from the currently-executing instance of
1995 the immediately surrounding code.
2000 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
2003 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
2007 PADLIST* const protopadlist = CvPADLIST(proto);
2008 PAD *const protopad_name = *PadlistARRAY(protopadlist);
2009 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
2010 SV** const pname = AvARRAY(protopad_name);
2011 SV** const ppad = AvARRAY(protopad);
2012 const I32 fname = AvFILLp(protopad_name);
2013 const I32 fpad = AvFILLp(protopad);
2016 bool subclones = FALSE;
2018 assert(!CvUNIQUE(proto));
2020 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2021 * reliable. The currently-running sub is always the one we need to
2023 * For my subs, the currently-running sub may not be the one we want.
2024 * We have to check whether it is a clone of CvOUTSIDE.
2025 * Note that in general for formats, CvOUTSIDE != find_runcv.
2026 * Since formats may be nested inside closures, CvOUTSIDE may point
2027 * to a prototype; we instead want the cloned parent who called us.
2031 if (CvWEAKOUTSIDE(proto))
2032 outside = find_runcv(NULL);
2034 outside = CvOUTSIDE(proto);
2035 if ((CvCLONE(outside) && ! CvCLONED(outside))
2036 || !CvPADLIST(outside)
2037 || PadlistNAMES(CvPADLIST(outside))
2038 != protopadlist->xpadl_outid) {
2039 outside = find_runcv_where(
2040 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2042 /* outside could be null */
2046 depth = outside ? CvDEPTH(outside) : 0;
2051 SAVESPTR(PL_compcv);
2053 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2056 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2058 SAVESPTR(PL_comppad_name);
2059 PL_comppad_name = protopad_name;
2060 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2062 av_fill(PL_comppad, fpad);
2064 PL_curpad = AvARRAY(PL_comppad);
2066 outpad = outside && CvPADLIST(outside)
2067 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2070 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2072 for (ix = fpad; ix > 0; ix--) {
2073 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2075 if (namesv && PadnameLEN(namesv)) { /* lexical */
2076 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2080 if (SvFAKE(namesv)) { /* lexical from outside? */
2081 /* formats may have an inactive, or even undefined, parent;
2082 but state vars are always available. */
2083 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2084 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2085 && (!outside || !CvDEPTH(outside))) ) {
2086 S_unavailable(aTHX_ namesv);
2090 SvREFCNT_inc_simple_void_NN(sv);
2093 const char sigil = SvPVX_const(namesv)[0];
2095 /* If there are state subs, we need to clone them, too.
2096 But they may need to close over variables we have
2097 not cloned yet. So we will have to do a second
2098 pass. Furthermore, there may be state subs clos-
2099 ing over other state subs’ entries, so we have
2100 to put a stub here and then clone into it on the
2102 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2103 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2105 sv = newSV_type(SVt_PVCV);
2107 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2110 /* Just provide a stub, but name it. It will be
2111 upgrade to the real thing on scope entry. */
2112 sv = newSV_type(SVt_PVCV);
2115 share_hek(SvPVX_const(namesv)+1,
2117 * (SvUTF8(namesv) ? -1 : 1),
2121 else sv = SvREFCNT_inc(ppad[ix]);
2122 else if (sigil == '@')
2123 sv = MUTABLE_SV(newAV());
2124 else if (sigil == '%')
2125 sv = MUTABLE_SV(newHV());
2129 /* reset the 'assign only once' flag on each state var */
2130 if (sigil != '&' && SvPAD_STATE(namesv))
2135 else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
2136 sv = SvREFCNT_inc_NN(ppad[ix]);
2146 for (ix = fpad; ix > 0; ix--) {
2147 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2148 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2149 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2150 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2153 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2158 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2161 const bool newcv = !cv;
2163 assert(!CvUNIQUE(proto));
2165 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2166 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2170 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2173 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2174 else CvGV_set(cv,CvGV(proto));
2175 CvSTASH_set(cv, CvSTASH(proto));
2177 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2179 CvSTART(cv) = CvSTART(proto);
2180 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2183 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2185 SvUTF8_on(MUTABLE_SV(cv));
2188 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2190 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2193 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2194 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2195 cv_dump(proto, "Proto");
2203 Perl_cv_clone(pTHX_ CV *proto)
2205 PERL_ARGS_ASSERT_CV_CLONE;
2207 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2208 return S_cv_clone(aTHX_ proto, NULL, NULL);
2211 /* Called only by pp_clonecv */
2213 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2215 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2217 return S_cv_clone(aTHX_ proto, target, NULL);
2221 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2223 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2224 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2225 moved to a pre-existing CV struct.
2231 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2235 AV * const comppad_name = PadlistARRAY(padlist)[0];
2236 AV * const comppad = PadlistARRAY(padlist)[1];
2237 SV ** const namepad = AvARRAY(comppad_name);
2238 SV ** const curpad = AvARRAY(comppad);
2240 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2241 PERL_UNUSED_ARG(old_cv);
2243 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2244 const SV * const namesv = namepad[ix];
2245 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2246 && *SvPVX_const(namesv) == '&')
2248 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2250 SvMAGICAL(curpad[ix])
2251 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2253 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2254 if (CvOUTSIDE(innercv) == old_cv) {
2255 if (!CvWEAKOUTSIDE(innercv)) {
2256 SvREFCNT_dec(old_cv);
2257 SvREFCNT_inc_simple_void_NN(new_cv);
2259 CvOUTSIDE(innercv) = new_cv;
2262 else { /* format reference */
2263 SV * const rv = curpad[ix];
2265 if (!SvOK(rv)) continue;
2267 assert(SvWEAKREF(rv));
2268 innercv = (CV *)SvRV(rv);
2269 assert(!CvWEAKOUTSIDE(innercv));
2270 SvREFCNT_dec(CvOUTSIDE(innercv));
2271 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2278 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2280 Push a new pad frame onto the padlist, unless there's already a pad at
2281 this depth, in which case don't bother creating a new one. Then give
2282 the new pad an @_ in slot zero.
2288 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2292 PERL_ARGS_ASSERT_PAD_PUSH;
2294 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2295 PAD** const svp = PadlistARRAY(padlist);
2296 AV* const newpad = newAV();
2297 SV** const oldpad = AvARRAY(svp[depth-1]);
2298 I32 ix = AvFILLp((const AV *)svp[1]);
2299 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2300 SV** const names = AvARRAY(svp[0]);
2303 for ( ;ix > 0; ix--) {
2304 if (names_fill >= ix && PadnameLEN(names[ix])) {
2305 const char sigil = SvPVX_const(names[ix])[0];
2306 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2307 || (SvFLAGS(names[ix]) & SVpad_STATE)
2310 /* outer lexical or anon code */
2311 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2313 else { /* our own lexical */
2316 sv = MUTABLE_SV(newAV());
2317 else if (sigil == '%')
2318 sv = MUTABLE_SV(newHV());
2321 av_store(newpad, ix, sv);
2325 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2326 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2329 /* save temporaries on recursion? */
2330 SV * const sv = newSV(0);
2331 av_store(newpad, ix, sv);
2336 av_store(newpad, 0, MUTABLE_SV(av));
2339 padlist_store(padlist, depth, newpad);
2344 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2346 Looks up the type of the lexical variable at position I<po> in the
2347 currently-compiling pad. If the variable is typed, the stash of the
2348 class to which it is typed is returned. If not, C<NULL> is returned.
2354 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2357 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2358 if ( SvPAD_TYPED(*av) ) {
2359 return SvSTASH(*av);
2364 #if defined(USE_ITHREADS)
2366 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2369 =for apidoc padlist_dup
2377 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2383 PERL_ARGS_ASSERT_PADLIST_DUP;
2388 cloneall = param->flags & CLONEf_COPY_STACKS
2389 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2390 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2392 max = cloneall ? PadlistMAX(srcpad) : 1;
2394 Newx(dstpad, 1, PADLIST);
2395 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2396 PadlistMAX(dstpad) = max;
2397 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2401 for (depth = 0; depth <= max; ++depth)
2402 PadlistARRAY(dstpad)[depth] =
2403 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2405 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2406 to build anything other than the first level of pads. */
2407 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2409 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2410 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2411 SV **oldpad = AvARRAY(srcpad1);
2416 PadlistARRAY(dstpad)[0] =
2417 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2418 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2422 av_extend(pad1, ix);
2423 PadlistARRAY(dstpad)[1] = pad1;
2424 pad1a = AvARRAY(pad1);
2429 for ( ;ix > 0; ix--) {
2432 } else if (names_fill >= ix && names[ix] &&
2433 PadnameLEN(names[ix])) {
2434 const char sigil = SvPVX_const(names[ix])[0];
2435 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2436 || (SvFLAGS(names[ix]) & SVpad_STATE)
2439 /* outer lexical or anon code */
2440 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2442 else { /* our own lexical */
2443 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2444 /* This is a work around for how the current
2445 implementation of ?{ } blocks in regexps
2446 interacts with lexicals. */
2447 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2452 sv = MUTABLE_SV(newAV());
2453 else if (sigil == '%')
2454 sv = MUTABLE_SV(newHV());
2462 else if (IS_PADGV(oldpad[ix])
2463 || ( names_fill >= ix && names[ix]
2464 && PadnamePV(names[ix]) )) {
2465 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2468 /* save temporaries on recursion? */
2469 SV * const sv = newSV(0);
2472 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2473 FIXTHAT before merging this branch.
2474 (And I know how to) */
2475 if (SvPADMY(oldpad[ix]))
2483 args = newAV(); /* Will be @_ */
2485 pad1a[0] = (SV *)args;
2493 #endif /* USE_ITHREADS */
2496 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2500 SSize_t const oldmax = PadlistMAX(padlist);
2502 PERL_ARGS_ASSERT_PADLIST_STORE;
2506 if (key > PadlistMAX(padlist)) {
2507 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2508 (SV ***)&PadlistARRAY(padlist),
2509 (SV ***)&PadlistARRAY(padlist));
2510 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2513 ary = PadlistARRAY(padlist);
2514 SvREFCNT_dec(ary[key]);
2521 * c-indentation-style: bsd
2523 * indent-tabs-mode: nil
2526 * ex: set ts=8 sts=4 sw=4 et: