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 =for apidoc_section $pad
24 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
26 CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
27 scratchpad, which stores lexical variables and opcode temporary and
30 For these purposes "formats" are a kind-of CV; eval""s are too (except they're
31 not callable at will and are always thrown away after the eval"" is done
32 executing). Require'd files are simply evals without any outer lexical
35 XSUBs do not have a C<CvPADLIST>. C<dXSTARG> fetches values from C<PL_curpad>,
36 but that is really the callers pad (a slot of which is allocated by
37 every entersub). Do not get or set C<CvPADLIST> if a CV is an XSUB (as
38 determined by C<CvISXSUB()>), C<CvPADLIST> slot is reused for a different
39 internal purpose in XSUBs.
41 The PADLIST has a C array where pads are stored.
43 The 0th entry of the PADLIST is a PADNAMELIST
44 which represents the "names" or rather
45 the "static type information" for lexicals. The individual elements of a
46 PADNAMELIST are PADNAMEs. Future
47 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
48 array, so don't rely on it. See L</PadlistNAMES>.
50 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
51 at that depth of recursion into the CV. The 0th slot of a frame AV is an
52 AV which is C<@_>. Other entries are storage for variables and op targets.
54 Iterating over the PADNAMELIST iterates over all possible pad
55 items. Pad slots for targets (C<SVs_PADTMP>)
56 and GVs end up having &PL_padname_undef "names", while slots for constants
57 have C<&PL_padname_const> "names" (see C<L</pad_alloc>>). That
59 and C<&PL_padname_const> are used is an implementation detail subject to
60 change. To test for them, use C<!PadnamePV(name)> and
61 S<C<PadnamePV(name) && !PadnameLEN(name)>>, respectively.
63 Only C<my>/C<our> variable slots get valid names.
64 The rest are op targets/GVs/constants which are statically allocated
65 or resolved at compile time. These don't have names by which they
66 can be looked up from Perl code at run time through eval"" the way
67 C<my>/C<our> variables can be. Since they can't be looked up by "name"
68 but only by their index allocated at compile time (which is usually
69 in C<< PL_op->op_targ >>), wasting a name SV for them doesn't make sense.
71 The pad names in the PADNAMELIST have their PV holding the name of
72 the variable. The C<COP_SEQ_RANGE_LOW> and C<_HIGH> fields form a range
73 (low+1..high inclusive) of cop_seq numbers for which the name is
74 valid. During compilation, these fields may hold the special value
75 PERL_PADSEQ_INTRO to indicate various stages:
77 COP_SEQ_RANGE_LOW _HIGH
78 ----------------- -----
79 PERL_PADSEQ_INTRO 0 variable not yet introduced:
81 valid-seq# PERL_PADSEQ_INTRO variable in scope:
83 valid-seq# valid-seq# compilation of scope complete:
86 When a lexical var hasn't yet been introduced, it already exists from the
87 perspective of duplicate declarations, but not for variable lookups, e.g.
89 my ($x, $x); # '"my" variable $x masks earlier declaration'
90 my $x = $x; # equal to my $x = $::x;
92 For typed lexicals C<PadnameTYPE> points at the type stash. For C<our>
93 lexicals, C<PadnameOURSTASH> points at the stash of the associated global (so
94 that duplicate C<our> declarations in the same package can be detected).
95 C<PadnameGEN> is sometimes used to store the generation number during
98 If C<PadnameOUTER> is set on the pad name, then that slot in the frame AV
99 is a REFCNT'ed reference to a lexical from "outside". Such entries
100 are sometimes referred to as 'fake'. In this case, the name does not
101 use 'low' and 'high' to store a cop_seq range, since it is in scope
102 throughout. Instead 'high' stores some flags containing info about
103 the real lexical (is it declared in an anon, and is it capable of being
104 instantiated multiple times?), and for fake ANONs, 'low' contains the index
105 within the parent's pad where the lexical's value is stored, to make
108 If the 'name' is C<&> the corresponding entry in the PAD
109 is a CV representing a possible closure.
111 Note that formats are treated as anon subs, and are cloned each time
112 write is called (if necessary).
114 The flag C<SVs_PADSTALE> is cleared on lexicals each time the C<my()> is executed,
115 and set on scope exit. This allows the
116 C<"Variable $x is not available"> warning
117 to be generated in evals, such as
119 { my $x = 1; sub f { eval '$x'} } f();
121 For state vars, C<SVs_PADSTALE> is overloaded to mean 'not yet initialised',
122 but this internal state is stored in a separate pad entry.
124 =for apidoc Amnh||SVs_PADSTALE
126 =for apidoc AmnxU|PADNAMELIST *|PL_comppad_name
128 During compilation, this points to the array containing the names part
129 of the pad for the currently-compiling code.
131 =for apidoc AmnxU|PAD *|PL_comppad
133 During compilation, this points to the array containing the values
134 part of the pad for the currently-compiling code. (At runtime a CV may
135 have many such value arrays; at compile time just one is constructed.)
136 At runtime, this points to the array containing the currently-relevant
137 values for the pad for the currently-executing code.
139 =for apidoc AmnxU|SV **|PL_curpad
141 Points directly to the body of the L</PL_comppad> array.
142 (I.e., this is C<PadARRAY(PL_comppad)>.)
149 #define PERL_IN_PAD_C
151 #include "keywords.h"
153 #define COP_SEQ_RANGE_LOW_set(sv,val) \
154 STMT_START { (sv)->xpadn_low = (val); } STMT_END
155 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
156 STMT_START { (sv)->xpadn_high = (val); } STMT_END
158 #define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set
159 #define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set
163 Perl_set_padlist(CV * cv, PADLIST *padlist){
164 PERL_ARGS_ASSERT_SET_PADLIST;
166 assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
168 assert((Size_t)padlist != 0xEFEFEFEF);
170 # error unknown pointer size
172 assert(!CvISXSUB(cv));
173 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
180 Create a new padlist, updating the global variables for the
181 currently-compiling padlist to point to the new padlist. The following
182 flags can be OR'ed together:
184 padnew_CLONE this pad is for a cloned CV
185 padnew_SAVE save old globals on the save stack
186 padnew_SAVESUB also save extra stuff for start of sub
192 Perl_pad_new(pTHX_ int flags)
195 PADNAMELIST *padname;
199 ASSERT_CURPAD_LEGAL("pad_new");
201 /* save existing state, ... */
203 if (flags & padnew_SAVE) {
205 if (! (flags & padnew_CLONE)) {
206 SAVESPTR(PL_comppad_name);
207 SAVESTRLEN(PL_padix);
208 SAVESTRLEN(PL_constpadix);
209 SAVESTRLEN(PL_comppad_name_fill);
210 SAVESTRLEN(PL_min_intro_pending);
211 SAVESTRLEN(PL_max_intro_pending);
212 SAVEBOOL(PL_cv_has_eval);
213 if (flags & padnew_SAVESUB) {
214 SAVEBOOL(PL_pad_reset_pending);
219 /* ... create new pad ... */
221 Newxz(padlist, 1, PADLIST);
223 Newxz(AvALLOC(pad), 4, SV *); /* Originally sized to
224 match av_extend default */
225 AvARRAY(pad) = AvALLOC(pad);
227 AvFILLp(pad) = 0; /* @_ or NULL, set below. */
229 if (flags & padnew_CLONE) {
230 AV * const a0 = newAV(); /* will be @_ */
231 AvARRAY(pad)[0] = MUTABLE_SV(a0);
232 #ifndef PERL_RC_STACK
236 PadnamelistREFCNT(padname = PL_comppad_name)++;
239 padlist->xpadl_id = PL_padlist_generation++;
240 /* Set implicitly through use of Newxz above
241 AvARRAY(pad)[0] = NULL;
243 padname = newPADNAMELIST(0);
244 padnamelist_store(padname, 0, &PL_padname_undef);
247 /* Most subroutines never recurse, hence only need 2 entries in the padlist
248 array - names, and depth=1. The default for av_store() is to allocate
249 0..3, and even an explicit call to av_extend() with <3 will be rounded
250 up, so we inline the allocation of the array here. */
252 PadlistMAX(padlist) = 1;
253 PadlistARRAY(padlist) = ary;
254 ary[0] = (PAD *)padname;
257 /* ... then update state variables */
260 PL_curpad = AvARRAY(pad);
262 if (! (flags & padnew_CLONE)) {
263 PL_comppad_name = padname;
264 PL_comppad_name_fill = 0;
265 PL_min_intro_pending = 0;
271 DEBUG_X(PerlIO_printf(Perl_debug_log,
272 "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf
273 " name=0x%" UVxf " flags=0x%" UVxf "\n",
274 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
275 PTR2UV(padname), (UV)flags
279 return (PADLIST*)padlist;
284 =for apidoc_section $embedding
288 Clear out all the active components of a CV. This can happen either
289 by an explicit C<undef &foo>, or by the reference count going to zero.
290 In the former case, we keep the C<CvOUTSIDE> pointer, so that any anonymous
291 children can still follow the full lexical scope chain.
297 Perl_cv_undef(pTHX_ CV *cv)
299 PERL_ARGS_ASSERT_CV_UNDEF;
300 cv_undef_flags(cv, 0);
304 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
306 CV cvbody;/*CV body will never be realloced inside this func,
307 so don't read it more than once, use fake CV so existing macros
308 will work, the indirection and CV head struct optimized away*/
309 SvANY(&cvbody) = SvANY(cv);
311 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
313 DEBUG_X(PerlIO_printf(Perl_debug_log,
314 "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n",
315 PTR2UV(cv), PTR2UV(PL_comppad))
318 if (CvFILE(&cvbody)) {
319 char * file = CvFILE(&cvbody);
320 CvFILE(&cvbody) = NULL;
321 if(CvDYNFILE(&cvbody))
325 /* CvSLABBED_off(&cvbody); *//* turned off below */
326 /* release the sub's body */
327 if (!CvISXSUB(&cvbody)) {
328 if(CvROOT(&cvbody)) {
329 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
330 if (CvDEPTHunsafe(&cvbody)) {
331 assert(SvTYPE(cv) == SVt_PVCV);
332 Perl_croak_nocontext("Can't undef active subroutine");
336 PAD_SAVE_SETNULLPAD();
338 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
339 op_free(CvROOT(&cvbody));
340 CvROOT(&cvbody) = NULL;
341 CvSTART(&cvbody) = NULL;
344 else if (CvSLABBED(&cvbody)) {
345 if( CvSTART(&cvbody)) {
347 PAD_SAVE_SETNULLPAD();
349 /* discard any leaked ops */
351 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
352 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
353 CvSTART(&cvbody) = NULL;
358 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
362 else { /* don't bother checking if CvXSUB(cv) is true, less branching */
363 CvXSUB(&cvbody) = NULL;
365 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
366 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
367 if (!(flags & CV_UNDEF_KEEP_NAME)) {
368 if (CvNAMED(&cvbody)) {
369 CvNAME_HEK_set(&cvbody, NULL);
370 CvNAMED_off(&cvbody);
372 else CvGV_set(cv, NULL);
375 /* This statement and the subsequence if block was pad_undef(). */
376 pad_peg("pad_undef");
378 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
380 const PADLIST *padlist = CvPADLIST(&cvbody);
382 /* Free the padlist associated with a CV.
383 If parts of it happen to be current, we null the relevant PL_*pad*
384 global vars so that we don't have any dangling references left.
385 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
386 subs to the outer of this cv. */
388 DEBUG_X(PerlIO_printf(Perl_debug_log,
389 "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n",
390 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
393 /* detach any '&' anon children in the pad; if afterwards they
394 * are still live, fix up their CvOUTSIDEs to point to our outside,
397 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
398 CV * const outercv = CvOUTSIDE(&cvbody);
399 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
400 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
401 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
402 PAD * const comppad = PadlistARRAY(padlist)[1];
403 SV ** const curpad = AvARRAY(comppad);
404 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
405 PADNAME * const name = namepad[ix];
406 if (name && PadnamePV(name) && *PadnamePV(name) == '&') {
407 CV * const innercv = MUTABLE_CV(curpad[ix]);
408 if (PadnameIsOUR(name) && CvCLONED(&cvbody)) {
414 assert(SvTYPE(innercv) != SVt_PVFM);
415 inner_rc = SvREFCNT(innercv);
418 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
420 SvREFCNT_dec_NN(innercv);
424 /* in use, not just a prototype */
425 if (inner_rc && SvTYPE(innercv) == SVt_PVCV
426 && (CvOUTSIDE(innercv) == cv))
428 assert(CvWEAKOUTSIDE(innercv));
429 /* don't relink to grandfather if he's being freed */
430 if (outercv && SvREFCNT(outercv)) {
431 CvWEAKOUTSIDE_off(innercv);
432 CvOUTSIDE(innercv) = outercv;
433 CvOUTSIDE_SEQ(innercv) = seq;
434 SvREFCNT_inc_simple_void_NN(outercv);
437 CvOUTSIDE(innercv) = NULL;
445 ix = PadlistMAX(padlist);
447 PAD * const sv = PadlistARRAY(padlist)[ix--];
449 if (sv == PL_comppad) {
457 PADNAMELIST * const names = PadlistNAMES(padlist);
458 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
459 PL_comppad_name = NULL;
460 PadnamelistREFCNT_dec(names);
462 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
464 CvPADLIST_set(&cvbody, NULL);
466 else if (CvISXSUB(&cvbody)) {
467 if (CvREFCOUNTED_ANYSV(&cvbody))
468 SvREFCNT_dec(CvXSUBANY(&cvbody).any_sv);
469 CvHSCXT(&cvbody) = NULL;
471 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
474 /* remove CvOUTSIDE unless this is an undef rather than a free */
476 CV * outside = CvOUTSIDE(&cvbody);
478 CvOUTSIDE(&cvbody) = NULL;
479 if (!CvWEAKOUTSIDE(&cvbody))
480 SvREFCNT_dec_NN(outside);
483 if (CvCONST(&cvbody)) {
484 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
485 /* CvCONST_off(cv); *//* turned off below */
487 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
488 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
489 * LEXICAL, which are used to determine the sub's name. */
490 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
495 =for apidoc cv_forget_slab
497 When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
498 for making sure it is freed. (Hence, no two CVs should ever have a
499 reference count on the same slab.) The CV only needs to reference the slab
500 during compilation. Once it is compiled and C<CvROOT> attached, it has
501 finished its job, so it can forget the slab.
507 Perl_cv_forget_slab(pTHX_ CV *cv)
514 slabbed = cBOOL(CvSLABBED(cv));
515 if (!slabbed) return;
519 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
520 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
522 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
526 #ifdef PERL_DEBUG_READONLY_OPS
527 const size_t refcnt = slab->opslab_refcnt;
529 OpslabREFCNT_dec(slab);
530 #ifdef PERL_DEBUG_READONLY_OPS
531 if (refcnt > 1) Slab_to_ro(slab);
537 =for apidoc pad_alloc_name
539 Allocates a place in the currently-compiling
540 pad (via L<perlapi/pad_alloc>) and
541 then stores a name for that entry. C<name> is adopted and
542 becomes the name entry; it must already contain the name
543 string. C<typestash> and C<ourstash> and the C<padadd_STATE>
544 and C<padadd_TOMBSTONE> flags get added to C<name>.
545 None of the other processing of L<perlapi/pad_add_name_pvn>
546 is done. Returns the offset of the allocated pad slot.
552 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
555 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
557 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
559 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
562 PadnameFLAGS(name) |= PADNAMEf_TYPED;
564 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
567 PadnameFLAGS(name) |= PADNAMEf_OUR;
568 PadnameOURSTASH_set(name, ourstash);
569 SvREFCNT_inc_simple_void_NN(ourstash);
571 else if (flags & padadd_STATE) {
572 PadnameFLAGS(name) |= PADNAMEf_STATE;
574 if (flags & padadd_FIELD) {
575 assert(HvSTASH_IS_CLASS(PL_curstash));
576 class_add_field(PL_curstash, name);
578 if (flags & padadd_TOMBSTONE) {
579 PadnameFLAGS(name) |= PADNAMEf_TOMBSTONE;
582 padnamelist_store(PL_comppad_name, offset, name);
583 if (PadnameLEN(name) > 1)
584 PadnamelistMAXNAMED(PL_comppad_name) = offset;
589 =for apidoc pad_add_name_pvn
591 Allocates a place in the currently-compiling pad for a named lexical
592 variable. Stores the name and other metadata in the name part of the
593 pad, and makes preparations to manage the variable's lexical scoping.
594 Returns the offset of the allocated pad slot.
596 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
597 If C<typestash> is non-null, the name is for a typed lexical, and this
598 identifies the type. If C<ourstash> is non-null, it's a lexical reference
599 to a package variable, and this identifies the package. The following
600 flags can be OR'ed together:
602 padadd_OUR redundantly specifies if it's a package var
603 padadd_STATE variable will retain value persistently
604 padadd_NO_DUP_CHECK skip check for lexical shadowing
605 padadd_FIELD specifies that the lexical is a field for a class
606 padadd_TOMBSTONE sets the PadnameIsTOMBSTONE flag on the new name
612 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
613 U32 flags, HV *typestash, HV *ourstash)
618 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
620 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_FIELD|padadd_TOMBSTONE))
621 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
624 name = newPADNAMEpvn(namepv, namelen);
626 if ((flags & (padadd_NO_DUP_CHECK|padadd_TOMBSTONE)) == 0) {
628 SAVEFREEPADNAME(name); /* in case of fatal warnings */
629 /* check for duplicate declaration */
630 pad_check_dup(name, flags & (padadd_OUR|padadd_FIELD), ourstash);
631 PadnameREFCNT_inc(name);
635 offset = pad_alloc_name(name, flags, typestash, ourstash);
637 /* not yet introduced */
638 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
639 COP_SEQ_RANGE_HIGH_set(name, 0);
641 if (!PL_min_intro_pending)
642 PL_min_intro_pending = offset;
643 PL_max_intro_pending = offset;
644 /* if it's not a simple scalar, replace with an AV or HV */
645 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
646 assert(SvREFCNT(PL_curpad[offset]) == 1);
647 if (namelen != 0 && *namepv == '@')
648 sv_upgrade(PL_curpad[offset], SVt_PVAV);
649 else if (namelen != 0 && *namepv == '%')
650 sv_upgrade(PL_curpad[offset], SVt_PVHV);
651 else if (namelen != 0 && *namepv == '&')
652 sv_upgrade(PL_curpad[offset], SVt_PVCV);
653 assert(SvPADMY(PL_curpad[offset]));
654 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
655 "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n",
656 (long)offset, PadnamePV(name),
657 PTR2UV(PL_curpad[offset])));
663 =for apidoc pad_add_name_pv
665 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
666 instead of a string/length pair.
672 Perl_pad_add_name_pv(pTHX_ const char *name,
673 const U32 flags, HV *typestash, HV *ourstash)
675 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
676 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
680 =for apidoc pad_add_name_sv
682 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
683 of an SV instead of a string/length pair.
689 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
693 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
694 namepv = SvPVutf8(name, namelen);
695 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
699 =for apidoc pad_alloc
701 Allocates a place in the currently-compiling pad,
702 returning the offset of the allocated pad slot.
703 No name is initially attached to the pad slot.
704 C<tmptype> is a set of flags indicating the kind of pad entry required,
705 which will be set in the value SV for the allocated pad entry:
707 SVs_PADMY named lexical variable ("my", "our", "state")
708 SVs_PADTMP unnamed temporary store
709 SVf_READONLY constant shared between recursion levels
711 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
712 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
713 does not cause the SV in the pad slot to be marked read-only, but simply
714 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
715 least should be treated as such.
717 C<optype> should be an opcode indicating the type of operation that the
718 pad entry is to support. This doesn't affect operational semantics,
719 but is used for debugging.
725 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
730 PERL_UNUSED_ARG(optype);
731 ASSERT_CURPAD_ACTIVE("pad_alloc");
733 if (AvARRAY(PL_comppad) != PL_curpad)
734 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
735 AvARRAY(PL_comppad), PL_curpad);
736 if (PL_pad_reset_pending)
738 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
739 /* For a my, simply push a null SV onto the end of PL_comppad. */
740 sv = *av_store_simple(PL_comppad, AvFILLp(PL_comppad) + 1, newSV_type(SVt_NULL));
741 retval = (PADOFFSET)AvFILLp(PL_comppad);
744 /* For a tmp, scan the pad from PL_padix upwards
745 * for a slot which has no name and no active value.
746 * For a constant, likewise, but use PL_constpadix.
748 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
749 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
750 const bool konst = cBOOL(tmptype & SVf_READONLY);
751 retval = konst ? PL_constpadix : PL_padix;
754 * Entries that close over unavailable variables
755 * in outer subs contain values not marked PADMY.
756 * Thus we must skip, not just pad values that are
757 * marked as current pad values, but also those with names.
758 * If pad_reset is enabled, ‘current’ means different
759 * things depending on whether we are allocating a con-
760 * stant or a target. For a target, things marked PADTMP
761 * can be reused; not so for constants.
764 if (++retval <= names_fill &&
765 (pn = names[retval]) && PadnamePV(pn))
767 sv = *av_fetch_simple(PL_comppad, retval, TRUE);
770 (konst ? SVs_PADTMP : 0)
778 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
779 tmptype &= ~SVf_READONLY;
780 tmptype |= SVs_PADTMP;
782 *(konst ? &PL_constpadix : &PL_padix) = retval;
784 SvFLAGS(sv) |= tmptype;
785 PL_curpad = AvARRAY(PL_comppad);
787 DEBUG_X(PerlIO_printf(Perl_debug_log,
788 "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n",
789 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
790 PL_op_name[optype]));
791 #ifdef DEBUG_LEAKING_SCALARS
792 sv->sv_debug_optype = optype;
793 sv->sv_debug_inpad = 1;
799 =for apidoc pad_add_anon
801 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
802 for an anonymous function that is lexically scoped inside the
803 currently-compiling function.
804 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
805 to the outer scope is weakened to avoid a reference loop.
807 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
809 C<optype> should be an opcode indicating the type of operation that the
810 pad entry is to support. This doesn't affect operational semantics,
811 but is used for debugging.
817 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
820 PADNAME * const name = newPADNAMEpvn("&", 1);
822 PERL_ARGS_ASSERT_PAD_ADD_ANON;
823 assert (SvTYPE(func) == SVt_PVCV);
826 /* These two aren't used; just make sure they're not equal to
827 * PERL_PADSEQ_INTRO. They should be 0 by default. */
828 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
829 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
830 ix = pad_alloc(optype, SVs_PADMY);
831 padnamelist_store(PL_comppad_name, ix, name);
832 av_store(PL_comppad, ix, (SV*)func);
834 /* to avoid ref loops, we never have parent + child referencing each
835 * other simultaneously */
836 if (CvOUTSIDE(func)) {
837 assert(!CvWEAKOUTSIDE(func));
838 CvWEAKOUTSIDE_on(func);
839 SvREFCNT_dec_NN(CvOUTSIDE(func));
845 Perl_pad_add_weakref(pTHX_ CV* func)
847 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
848 PADNAME * const name = newPADNAMEpvn("&", 1);
849 SV * const rv = newRV_inc((SV *)func);
851 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
853 /* These two aren't used; just make sure they're not equal to
854 * PERL_PADSEQ_INTRO. They should be 0 by default. */
855 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
856 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
857 padnamelist_store(PL_comppad_name, ix, name);
859 av_store(PL_comppad, ix, rv);
863 =for apidoc pad_check_dup
865 Check for duplicate declarations: report any of:
867 * a 'my' in the current scope with the same name;
868 * an 'our' (anywhere in the pad) with the same name and the
869 same stash as 'ourstash'
871 C<is_our> indicates that the name to check is an C<"our"> declaration.
877 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
881 const U32 is_our = flags & padadd_OUR;
882 bool is_field = flags & padadd_FIELD;
884 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
886 ASSERT_CURPAD_ACTIVE("pad_check_dup");
888 assert((flags & ~(padadd_OUR|padadd_FIELD)) == 0);
890 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW))
891 return; /* nothing to check */
893 svp = PadnamelistARRAY(PL_comppad_name);
894 top = PadnamelistMAX(PL_comppad_name);
895 /* check the current scope */
896 for (off = top; off > PL_comppad_name_floor; off--) {
897 PADNAME * const pn = svp[off];
899 && PadnameLEN(pn) == PadnameLEN(name)
901 && !PadnameIsTOMBSTONE(pn)
902 && ( COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO
903 || COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO)
904 && memEQ(PadnamePV(pn), PadnamePV(name), PadnameLEN(name)))
906 if (is_our && (PadnameIsOUR(pn)))
907 break; /* "our" masking "our" */
908 if (is_field && PadnameIsFIELD(pn) &&
909 PadnameFIELDINFO(pn)->fieldstash != PL_curstash)
910 break; /* field of a different class */
911 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
912 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
913 "\"%s\" %s %" PNf " masks earlier declaration in same %s",
915 PL_parser->in_my == KEY_my ? "my" :
916 PL_parser->in_my == KEY_sigvar ? "my" :
917 PL_parser->in_my == KEY_field ? "field" :
919 *PadnamePV(pn) == '&' ? "subroutine" : "variable",
921 (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO
922 ? "scope" : "statement"));
927 /* check the rest of the pad */
930 PADNAME * const pn = svp[off];
932 && PadnameLEN(pn) == PadnameLEN(name)
934 && ( COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO
935 || COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO)
936 && PadnameOURSTASH(pn) == ourstash
937 && memEQ(PadnamePV(pn), PadnamePV(name), PadnameLEN(name)))
939 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
940 "\"our\" variable %" PNf " redeclared", PNfARG(pn));
941 if (off <= PL_comppad_name_floor)
942 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
943 "\t(Did you mean \"local\" instead of \"our\"?)\n");
953 =for apidoc pad_findmy_pvn
955 Given the name of a lexical variable, find its position in the
956 currently-compiling pad.
957 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
958 C<flags> is reserved and must be zero.
959 If it is not in the current pad but appears in the pad of any lexically
960 enclosing scope, then a pseudo-entry for it is added in the current pad.
961 Returns the offset in the current pad,
962 or C<NOT_IN_PAD> if no such lexical is in scope.
968 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
973 const PADNAMELIST *namelist;
976 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
978 pad_peg("pad_findmy_pvn");
981 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
984 /* compilation errors can zero PL_compcv */
988 offset = pad_findlex(namepv, namelen, flags,
989 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
990 if (offset != NOT_IN_PAD)
993 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
995 if (*namepv == '&') return NOT_IN_PAD;
997 /* look for an our that's being introduced; this allows
998 * our $foo = 0 unless defined $foo;
999 * to not give a warning. (Yes, this is a hack) */
1001 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
1002 name_p = PadnamelistARRAY(namelist);
1003 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
1004 const PADNAME * const name = name_p[offset];
1005 if (name && PadnameLEN(name) == namelen
1006 && !PadnameOUTER(name)
1007 && (PadnameIsOUR(name))
1008 && ( PadnamePV(name) == namepv
1009 || memEQ(PadnamePV(name), namepv, namelen) )
1010 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
1018 =for apidoc pad_findmy_pv
1020 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1021 instead of a string/length pair.
1027 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1029 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1030 return pad_findmy_pvn(name, strlen(name), flags);
1034 =for apidoc pad_findmy_sv
1036 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1037 of an SV instead of a string/length pair.
1043 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1047 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1048 namepv = SvPVutf8(name, namelen);
1049 return pad_findmy_pvn(namepv, namelen, flags);
1053 =for apidoc find_rundefsv
1055 Returns the global variable C<$_>.
1061 Perl_find_rundefsv(pTHX)
1067 =for apidoc pad_findlex
1069 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1070 in the inner pads if it's found in an outer one.
1072 Returns the offset in the bottom pad of the lex or the fake lex.
1073 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1074 to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
1075 vars return values, and so are pointers to where the returned values
1076 should be stored. C<out_capture>, if non-null, requests that the innermost
1077 instance of the lexical is captured; C<out_name> is set to the innermost
1078 matched pad name or fake pad name; C<out_flags> returns the flags normally
1079 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1081 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
1082 then comes back down, adding fake entries
1083 as it goes. It has to be this way
1084 because fake names in anon prototypes have to store in C<xpadn_low> the
1085 index into the parent pad.
1090 /* the CV has finished being compiled. This is not a sufficient test for
1091 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1092 #define CvCOMPILED(cv) CvROOT(cv)
1094 /* the CV does late binding of its lexicals */
1095 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1098 S_unavailable(pTHX_ PADNAME *name)
1100 /* diag_listed_as: Variable "%s" is not available */
1101 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1102 "%s \"%" PNf "\" is not available",
1103 *PadnamePV(name) == '&'
1110 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1111 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1113 PADOFFSET offset, new_offset;
1116 const PADLIST * const padlist = CvPADLIST(cv);
1117 const bool staleok = cBOOL(flags & padadd_STALEOK);
1118 const bool fieldok = cBOOL(flags & padfind_FIELD_OK);
1120 PERL_ARGS_ASSERT_PAD_FINDLEX;
1122 flags &= ~(padadd_STALEOK|padfind_FIELD_OK); /* one-shot flags */
1124 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1129 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1130 "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n",
1131 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1132 out_capture ? " capturing" : "" ));
1134 /* first, search this pad */
1136 if (padlist) { /* not an undef CV */
1137 PADOFFSET fake_offset = 0;
1138 const PADNAMELIST * const names = PadlistNAMES(padlist);
1139 PADNAME * const * const name_p = PadnamelistARRAY(names);
1141 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1142 const PADNAME * const name = name_p[offset];
1143 if (name && PadnameLEN(name) == namelen
1144 && ( PadnamePV(name) == namepv
1145 || memEQ(PadnamePV(name), namepv, namelen) ))
1147 if (PadnameOUTER(name)) {
1148 fake_offset = offset; /* in case we don't find a real one */
1151 if (PadnameIN_SCOPE(name, seq))
1156 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1157 if (offset > 0) { /* not fake */
1159 *out_name = name_p[offset]; /* return the name */
1161 if (PadnameIsTOMBSTONE(*out_name))
1162 /* is this a lexical import that has been deleted? */
1165 if (PadnameIsFIELD(*out_name) && !fieldok)
1166 croak("Field %" SVf " is not accessible outside a method",
1167 SVfARG(PadnameSV(*out_name)));
1169 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1170 * instances. For now, we just test !CvUNIQUE(cv), but
1171 * ideally, we should detect my's declared within loops
1172 * etc - this would allow a wider range of 'not stayed
1173 * shared' warnings. We also treated already-compiled
1174 * lexes as not multi as viewed from evals. */
1176 *out_flags = CvANON(cv) ?
1178 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1179 ? PAD_FAKELEX_MULTI : 0;
1181 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1182 "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n",
1183 PTR2UV(cv), (long)offset,
1184 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1185 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1187 else { /* fake match */
1188 offset = fake_offset;
1189 *out_name = name_p[offset]; /* return the name */
1190 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1191 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1192 "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n",
1193 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1194 (unsigned long) PARENT_PAD_INDEX(*out_name)
1198 /* return the lex? */
1203 if (PadnameIsOUR(*out_name)) {
1204 *out_capture = NULL;
1208 /* trying to capture from an anon prototype? */
1210 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1211 : *out_flags & PAD_FAKELEX_ANON)
1217 *out_capture = NULL;
1223 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1224 && !PadnameIsSTATE(name_p[offset])
1225 && warn && ckWARN(WARN_CLOSURE)) {
1227 /* diag_listed_as: Variable "%s" will not stay
1229 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1230 "%s \"%" UTF8f "\" will not stay shared",
1231 *namepv == '&' ? "Subroutine" : "Variable",
1232 UTF8fARG(1, namelen, namepv));
1235 if (fake_offset && CvANON(cv)
1236 && CvCLONE(cv) &&!CvCLONED(cv))
1239 /* not yet caught - look further up */
1240 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1241 "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n",
1244 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1246 newwarn, out_capture, out_name, out_flags);
1251 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1252 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1253 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1254 "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n",
1255 PTR2UV(cv), PTR2UV(*out_capture)));
1257 if (SvPADSTALE(*out_capture)
1258 && (!CvDEPTH(cv) || !staleok)
1259 && !PadnameIsSTATE(name_p[offset]))
1263 *out_capture = NULL;
1266 if (!*out_capture) {
1267 if (namelen != 0 && *namepv == '@')
1268 *out_capture = newSV_type_mortal(SVt_PVAV);
1269 else if (namelen != 0 && *namepv == '%')
1270 *out_capture = newSV_type_mortal(SVt_PVHV);
1271 else if (namelen != 0 && *namepv == '&')
1272 *out_capture = newSV_type_mortal(SVt_PVCV);
1274 *out_capture = newSV_type_mortal(SVt_NULL);
1282 /* it's not in this pad - try above */
1287 /* out_capture non-null means caller wants us to capture lex; in
1288 * addition we capture ourselves unless it's an ANON/format */
1289 new_capturep = out_capture ? out_capture :
1290 CvLATE(cv) ? NULL : &new_capture;
1292 U32 recurse_flags = flags;
1293 if(new_capturep == &new_capture)
1294 recurse_flags |= padadd_STALEOK;
1296 recurse_flags |= padfind_FIELD_OK;
1298 offset = pad_findlex(namepv, namelen, recurse_flags,
1299 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1300 new_capturep, out_name, out_flags);
1301 if (offset == NOT_IN_PAD)
1304 if (PadnameIsFIELD(*out_name)) {
1305 HV *fieldstash = PadnameFIELDINFO(*out_name)->fieldstash;
1307 /* fields are only visible to the class that declared them */
1308 if(fieldstash != PL_curstash)
1309 croak("Field %" SVf " of %" HvNAMEf_QUOTEDPREFIX " is not accessible in a method of %" HvNAMEf_QUOTEDPREFIX,
1310 SVfARG(PadnameSV(*out_name)), HvNAMEfARG(fieldstash), HvNAMEfARG(PL_curstash));
1313 /* found in an outer CV. Add appropriate fake entry to this pad */
1315 /* don't add new fake entries (via eval) to CVs that we have already
1316 * finished compiling, or to undef CVs */
1317 if (CvCOMPILED(cv) || !padlist)
1318 return 0; /* this dummy (and invalid) value isnt used by the caller */
1321 PADNAME *new_name = newPADNAMEouter(*out_name);
1322 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1323 PAD * const ocomppad = PL_comppad;
1324 PL_comppad_name = PadlistNAMES(padlist);
1325 PL_comppad = PadlistARRAY(padlist)[1];
1326 PL_curpad = AvARRAY(PL_comppad);
1329 = pad_alloc_name(new_name,
1330 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1331 PadnameTYPE(*out_name),
1332 PadnameOURSTASH(*out_name)
1335 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1336 "Pad addname: %ld \"%.*s\" FAKE\n",
1338 (int) PadnameLEN(new_name),
1339 PadnamePV(new_name)));
1340 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1342 PARENT_PAD_INDEX_set(new_name, 0);
1343 if (PadnameIsOUR(new_name)) {
1344 NOOP; /* do nothing */
1346 else if (CvLATE(cv)) {
1347 /* delayed creation - just note the offset within parent pad */
1348 PARENT_PAD_INDEX_set(new_name, offset);
1352 /* immediate creation - capture outer value right now */
1353 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1354 /* But also note the offset, as newMYSUB needs it */
1355 PARENT_PAD_INDEX_set(new_name, offset);
1356 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1357 "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n",
1358 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1360 *out_name = new_name;
1361 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1363 PL_comppad_name = ocomppad_name;
1364 PL_comppad = ocomppad;
1365 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1375 Get the value at offset C<po> in the current (compiling or executing) pad.
1376 Use macro C<PAD_SV> instead of calling this function directly.
1382 Perl_pad_sv(pTHX_ PADOFFSET po)
1384 ASSERT_CURPAD_ACTIVE("pad_sv");
1387 Perl_croak(aTHX_ "panic: pad_sv po");
1388 DEBUG_X(PerlIO_printf(Perl_debug_log,
1389 "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n",
1390 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1392 return PL_curpad[po];
1396 =for apidoc pad_setsv
1398 Set the value at offset C<po> in the current (compiling or executing) pad.
1399 Use the macro C<PAD_SETSV()> rather than calling this function directly.
1405 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1407 PERL_ARGS_ASSERT_PAD_SETSV;
1409 ASSERT_CURPAD_ACTIVE("pad_setsv");
1411 DEBUG_X(PerlIO_printf(Perl_debug_log,
1412 "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n",
1413 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1418 #endif /* DEBUGGING */
1421 =for apidoc pad_block_start
1423 Update the pad compilation state variables on entry to a new block.
1429 Perl_pad_block_start(pTHX_ int full)
1431 ASSERT_CURPAD_ACTIVE("pad_block_start");
1432 SAVESTRLEN(PL_comppad_name_floor);
1433 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1435 PL_comppad_name_fill = PL_comppad_name_floor;
1436 if (PL_comppad_name_floor < 0)
1437 PL_comppad_name_floor = 0;
1438 SAVESTRLEN(PL_min_intro_pending);
1439 SAVESTRLEN(PL_max_intro_pending);
1440 PL_min_intro_pending = 0;
1441 SAVESTRLEN(PL_comppad_name_fill);
1442 SAVESTRLEN(PL_padix_floor);
1443 /* PL_padix_floor is what PL_padix is reset to at the start of each
1444 statement, by pad_reset(). We set it when entering a new scope
1445 to keep things like this working:
1446 print "$foo$bar", do { this(); that() . "foo" };
1447 We must not let "$foo$bar" and the later concatenation share the
1449 PL_padix_floor = PL_padix;
1450 PL_pad_reset_pending = FALSE;
1454 =for apidoc intro_my
1456 "Introduce" C<my> variables to visible status. This is called during parsing
1457 at the end of each statement to make lexical variables visible to subsequent
1470 ASSERT_CURPAD_ACTIVE("intro_my");
1471 if (PL_compiling.cop_seq) {
1472 seq = PL_compiling.cop_seq;
1473 PL_compiling.cop_seq = 0;
1476 seq = PL_cop_seqmax;
1477 if (! PL_min_intro_pending)
1480 svp = PadnamelistARRAY(PL_comppad_name);
1481 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1482 PADNAME * const sv = svp[i];
1484 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1485 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1487 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1488 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1489 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1490 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1491 (long)i, PadnamePV(sv),
1492 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1493 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1498 PL_min_intro_pending = 0;
1499 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1500 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1501 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1507 =for apidoc pad_leavemy
1509 Cleanup at end of scope during compilation: set the max seq number for
1510 lexicals in this scope and warn of any lexicals that never got introduced.
1516 Perl_pad_leavemy(pTHX)
1520 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1522 PL_pad_reset_pending = FALSE;
1524 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1525 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1526 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1527 const PADNAME * const name = svp[off];
1528 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1529 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1530 "%" PNf " never introduced",
1534 /* "Deintroduce" my variables that are leaving with this scope. */
1535 for (off = PadnamelistMAX(PL_comppad_name);
1536 off > PL_comppad_name_fill; off--) {
1537 PADNAME * const sv = svp[off];
1538 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1539 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1541 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1542 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1543 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1544 (long)off, PadnamePV(sv),
1545 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1546 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1548 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1549 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1550 OP *kid = newOP(OP_INTROCV, 0);
1552 o = op_prepend_elem(OP_LINESEQ, kid, o);
1557 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1558 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1563 =for apidoc pad_swipe
1565 Abandon the tmp in the current pad at offset C<po> and replace with a
1572 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1574 ASSERT_CURPAD_LEGAL("pad_swipe");
1577 if (AvARRAY(PL_comppad) != PL_curpad)
1578 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1579 AvARRAY(PL_comppad), PL_curpad);
1580 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1581 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1582 (long)po, (long)AvFILLp(PL_comppad));
1584 DEBUG_X(PerlIO_printf(Perl_debug_log,
1585 "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n",
1586 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1589 SvREFCNT_dec(PL_curpad[po]);
1592 /* if pad tmps aren't shared between ops, then there's no need to
1593 * create a new tmp when an existing op is freed */
1594 #ifdef USE_PAD_RESET
1595 PL_curpad[po] = newSV_type(SVt_NULL);
1596 SvPADTMP_on(PL_curpad[po]);
1598 PL_curpad[po] = NULL;
1600 if (PadnamelistMAX(PL_comppad_name) != -1
1601 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1602 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1603 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1605 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1607 /* Use PL_constpadix here, not PL_padix. The latter may have been
1608 reset by pad_reset. We don’t want pad_alloc to have to scan the
1609 whole pad when allocating a constant. */
1610 if (po < PL_constpadix)
1611 PL_constpadix = po - 1;
1615 =for apidoc pad_reset
1617 Mark all the current temporaries for reuse
1622 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1623 * between OPs from different statements. During compilation, at the start
1624 * of each statement pad_reset resets PL_padix back to its previous value.
1625 * When allocating a target, pad_alloc begins its scan through the pad at
1630 #ifdef USE_PAD_RESET
1631 if (AvARRAY(PL_comppad) != PL_curpad)
1632 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1633 AvARRAY(PL_comppad), PL_curpad);
1635 DEBUG_X(PerlIO_printf(Perl_debug_log,
1636 "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld",
1637 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1638 (long)PL_padix, (long)PL_padix_floor
1642 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1643 PL_padix = PL_padix_floor;
1646 PL_pad_reset_pending = FALSE;
1650 =for apidoc pad_tidy
1652 Tidy up a pad at the end of compilation of the code to which it belongs.
1653 Jobs performed here are: remove most stuff from the pads of anonsub
1654 prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
1655 the kind of subroutine:
1657 padtidy_SUB ordinary subroutine
1658 padtidy_SUBCLONE prototype for lexical closure
1659 padtidy_FORMAT format
1665 Perl_pad_tidy(pTHX_ padtidy_type type)
1668 ASSERT_CURPAD_ACTIVE("pad_tidy");
1670 /* If this CV has had any 'eval-capable' ops planted in it:
1671 * i.e. it contains any of:
1675 * * use re 'eval'; /$var/
1678 * Then any anon prototypes in the chain of CVs should be marked as
1679 * cloneable, so that for example the eval's CV in
1683 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1684 * potentially have an eval executed within it.
1687 if (PL_cv_has_eval || PL_perldb) {
1689 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1690 if (cv != PL_compcv && CvCOMPILED(cv))
1691 break; /* no need to mark already-compiled code */
1693 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1694 "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
1700 /* extend namepad to match curpad */
1701 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1702 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1704 if (type == padtidy_SUBCLONE) {
1705 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1708 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1710 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1713 * The only things that a clonable function needs in its
1714 * pad are anonymous subs, constants and GVs.
1715 * The rest are created anew during cloning.
1717 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1720 if (!(PadnamePV(namesv) &&
1721 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1723 SvREFCNT_dec(PL_curpad[ix]);
1724 PL_curpad[ix] = NULL;
1728 else if (type == padtidy_SUB) {
1729 AV * const av = newAV(); /* Will be @_ */
1730 av_store(PL_comppad, 0, MUTABLE_SV(av));
1731 #ifndef PERL_RC_STACK
1736 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1737 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1739 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1740 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1741 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1743 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1744 /* This is a work around for how the current implementation of
1745 ?{ } blocks in regexps interacts with lexicals.
1747 One of our lexicals.
1748 Can't do this on all lexicals, otherwise sub baz() won't
1757 because completion of compiling &bar calling pad_tidy()
1758 would cause (top level) $foo to be marked as stale, and
1759 "no longer available". */
1760 SvPADSTALE_on(PL_curpad[ix]);
1764 PL_curpad = AvARRAY(PL_comppad);
1768 =for apidoc pad_free
1770 Free the SV at offset po in the current pad.
1776 Perl_pad_free(pTHX_ PADOFFSET po)
1778 #ifndef USE_PAD_RESET
1781 ASSERT_CURPAD_LEGAL("pad_free");
1784 if (AvARRAY(PL_comppad) != PL_curpad)
1785 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1786 AvARRAY(PL_comppad), PL_curpad);
1788 Perl_croak(aTHX_ "panic: pad_free po");
1790 DEBUG_X(PerlIO_printf(Perl_debug_log,
1791 "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
1792 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1795 #ifndef USE_PAD_RESET
1797 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1798 SvFLAGS(sv) &= ~SVs_PADTMP;
1806 =for apidoc do_dump_pad
1808 Dump the contents of a padlist
1814 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1816 const PADNAMELIST *pad_name;
1822 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1827 pad_name = PadlistNAMES(padlist);
1828 pad = PadlistARRAY(padlist)[1];
1829 pname = PadnamelistARRAY(pad_name);
1830 ppad = AvARRAY(pad);
1831 Perl_dump_indent(aTHX_ level, file,
1832 "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
1833 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1836 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1837 const PADNAME *namesv = pname[ix];
1838 if (namesv && !PadnameLEN(namesv)) {
1842 if (PadnameOUTER(namesv))
1843 Perl_dump_indent(aTHX_ level+1, file,
1844 "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1847 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1849 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1850 (unsigned long)PARENT_PAD_INDEX(namesv)
1854 Perl_dump_indent(aTHX_ level+1, file,
1855 "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
1858 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1859 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1860 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1865 Perl_dump_indent(aTHX_ level+1, file,
1866 "%2d. 0x%" UVxf "<%lu>\n",
1869 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1880 dump the contents of a CV
1886 S_cv_dump(pTHX_ const CV *cv, const char *title)
1888 const CV * const outside = CvOUTSIDE(cv);
1890 PERL_ARGS_ASSERT_CV_DUMP;
1892 PerlIO_printf(Perl_debug_log,
1893 " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
1896 (CvANON(cv) ? "ANON"
1897 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1898 : (cv == PL_main_cv) ? "MAIN"
1899 : CvUNIQUE(cv) ? "UNIQUE"
1900 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1903 : CvANON(outside) ? "ANON"
1904 : (outside == PL_main_cv) ? "MAIN"
1905 : CvUNIQUE(outside) ? "UNIQUE"
1906 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1908 if (!CvISXSUB(cv)) {
1909 /* SVPADLIST(cv) will fail an assert if CvISXSUB(cv) is true,
1910 * and if the assert is removed this code will SEGV. XSUBs don't
1911 * have padlists I believe - Yves */
1912 PADLIST* const padlist = CvPADLIST(cv);
1913 PerlIO_printf(Perl_debug_log,
1914 " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
1915 do_dump_pad(1, Perl_debug_log, padlist, 1);
1919 #endif /* DEBUGGING */
1922 =for apidoc cv_clone
1924 Clone a CV, making a lexical closure. C<proto> supplies the prototype
1925 of the function: its code, pad structure, and other attributes.
1926 The prototype is combined with a capture of outer lexicals to which the
1927 code refers, which are taken from the currently-executing instance of
1928 the immediately surrounding code.
1933 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1936 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1940 PADLIST* const protopadlist = CvPADLIST(proto);
1941 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1942 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1943 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1944 SV** const ppad = AvARRAY(protopad);
1945 const PADOFFSET fname = PadnamelistMAX(protopad_name);
1946 const PADOFFSET fpad = AvFILLp(protopad);
1950 bool trouble = FALSE;
1952 assert(!CvUNIQUE(proto));
1954 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1955 * reliable. The currently-running sub is always the one we need to
1957 * For my subs, the currently-running sub may not be the one we want.
1958 * We have to check whether it is a clone of CvOUTSIDE.
1959 * Note that in general for formats, CvOUTSIDE != find_runcv.
1960 * Since formats may be nested inside closures, CvOUTSIDE may point
1961 * to a prototype; we instead want the cloned parent who called us.
1965 if (CvWEAKOUTSIDE(proto))
1966 outside = find_runcv(NULL);
1968 outside = CvOUTSIDE(proto);
1969 if ((CvCLONE(outside) && ! CvCLONED(outside))
1970 || !CvPADLIST(outside)
1971 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1972 outside = find_runcv_where(
1973 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1975 /* outside could be null */
1979 depth = outside ? CvDEPTH(outside) : 0;
1984 SAVESPTR(PL_compcv);
1986 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1988 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1990 SAVESPTR(PL_comppad_name);
1991 PL_comppad_name = protopad_name;
1992 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1993 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1995 av_fill(PL_comppad, fpad);
1997 PL_curpad = AvARRAY(PL_comppad);
1999 outpad = outside && CvPADLIST(outside)
2000 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2002 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
2004 for (ix = fpad; ix > 0; ix--) {
2005 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
2007 if (namesv && PadnameLEN(namesv)) { /* lexical */
2008 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2012 if (PadnameOUTER(namesv)) { /* lexical from outside? */
2013 /* formats may have an inactive, or even undefined, parent;
2014 but state vars are always available. */
2015 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2016 || ( SvPADSTALE(sv) && !PadnameIsSTATE(namesv)
2017 && (!outside || !CvDEPTH(outside))) ) {
2018 S_unavailable(aTHX_ namesv);
2022 SvREFCNT_inc_simple_void_NN(sv);
2025 const char sigil = PadnamePV(namesv)[0];
2027 /* If there are state subs, we need to clone them, too.
2028 But they may need to close over variables we have
2029 not cloned yet. So we will have to do a second
2030 pass. Furthermore, there may be state subs clos-
2031 ing over other state subs’ entries, so we have
2032 to put a stub here and then clone into it on the
2034 if (PadnameIsSTATE(namesv) && !CvCLONED(ppad[ix])) {
2035 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2037 if (CvOUTSIDE(ppad[ix]) != proto)
2039 sv = newSV_type(SVt_PVCV);
2042 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2045 /* Just provide a stub, but name it. It will be
2046 upgraded to the real thing on scope entry. */
2048 PERL_HASH(hash, PadnamePV(namesv)+1,
2049 PadnameLEN(namesv) - 1);
2050 sv = newSV_type(SVt_PVCV);
2053 share_hek(PadnamePV(namesv)+1,
2054 1 - PadnameLEN(namesv),
2059 else sv = SvREFCNT_inc(ppad[ix]);
2060 else if (sigil == '@')
2061 sv = MUTABLE_SV(newAV());
2062 else if (sigil == '%')
2063 sv = MUTABLE_SV(newHV());
2065 sv = newSV_type(SVt_NULL);
2066 /* reset the 'assign only once' flag on each state var */
2067 if (sigil != '&' && PadnameIsSTATE(namesv))
2072 else if (namesv && PadnamePV(namesv)) {
2073 sv = SvREFCNT_inc_NN(ppad[ix]);
2076 sv = newSV_type(SVt_NULL);
2084 if (trouble || cloned) {
2085 /* Uh-oh, we have trouble! At least one of the state subs here
2086 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2087 could be pointing to another state protosub that we are
2088 about to clone. So we have to track which sub clones come
2089 from which protosubs. If the CvOUTSIDE pointer for a parti-
2090 cular sub points to something we have not cloned yet, we
2091 delay cloning it. We must loop through the pad entries,
2092 until we get a full pass with no cloning. If any uncloned
2093 subs remain (probably nested inside anonymous or ‘my’ subs),
2094 then they get cloned in a final pass.
2096 bool cloned_in_this_pass;
2098 cloned = (HV *)newSV_type_mortal(SVt_PVHV);
2100 cloned_in_this_pass = FALSE;
2101 for (ix = fpad; ix > 0; ix--) {
2102 PADNAME * const name =
2103 (ix <= fname) ? pname[ix] : NULL;
2104 if (name && name != &PL_padname_undef
2105 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2106 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2108 CV * const protokey = CvOUTSIDE(ppad[ix]);
2109 CV ** const cvp = protokey == proto
2111 : (CV **)hv_fetch(cloned, (char *)&protokey,
2114 S_cv_clone(aTHX_ (CV *)ppad[ix],
2115 (CV *)PL_curpad[ix],
2117 (void)hv_store(cloned, (char *)&ppad[ix],
2119 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2122 cloned_in_this_pass = TRUE;
2126 } while (cloned_in_this_pass);
2128 for (ix = fpad; ix > 0; ix--) {
2129 PADNAME * const name =
2130 (ix <= fname) ? pname[ix] : NULL;
2131 if (name && name != &PL_padname_undef
2132 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2133 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2134 S_cv_clone(aTHX_ (CV *)ppad[ix],
2135 (CV *)PL_curpad[ix],
2136 CvOUTSIDE(ppad[ix]), cloned);
2139 else for (ix = fpad; ix > 0; ix--) {
2140 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2141 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2142 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2143 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2148 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2152 /* Constant sub () { $x } closing over $x:
2153 * The prototype was marked as a candidate for const-ization,
2154 * so try to grab the current const value, and if successful,
2155 * turn into a const sub:
2158 OP *o = CvSTART(cv);
2160 for (; o; o = o->op_next)
2161 if (o->op_type == OP_PADSV)
2163 ASSUME(o->op_type == OP_PADSV);
2164 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2165 /* the candidate should have 1 ref from this pad and 1 ref
2166 * from the parent */
2167 if (const_sv && SvREFCNT(const_sv) == 2) {
2168 const bool was_method = cBOOL(CvNOWARN_AMBIGUOUS(cv));
2170 PADNAME * const pn =
2171 PadlistNAMESARRAY(CvPADLIST(outside))
2172 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2173 CvPADLIST(cv))[o->op_targ])];
2174 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2176 if (PadnameLVALUE(pn)) {
2177 /* We have a lexical that is potentially modifiable
2178 elsewhere, so making a constant will break clo-
2179 sure behaviour. If this is a ‘simple lexical
2180 op tree’, i.e., sub(){$x}, emit a deprecation
2181 warning, but continue to exhibit the old behav-
2182 iour of making it a constant based on the ref-
2183 count of the candidate variable.
2185 A simple lexical op tree looks like this:
2193 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2198 "Constants from lexical variables potentially modified "
2199 "elsewhere are no longer permitted");
2205 SvREFCNT_inc_simple_void_NN(const_sv);
2206 /* If the lexical is not used elsewhere, it is safe to turn on
2207 SvPADTMP, since it is only when it is used in lvalue con-
2208 text that the difference is observable. */
2209 SvREADONLY_on(const_sv);
2210 SvPADTMP_on(const_sv);
2211 SvREFCNT_dec_NN(cv);
2212 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2214 CvNOWARN_AMBIGUOUS_on(cv);
2226 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2228 const bool newcv = !cv;
2230 assert(!CvUNIQUE(proto));
2232 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2233 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2237 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2240 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2241 else CvGV_set(cv,CvGV(proto));
2242 CvSTASH_set(cv, CvSTASH(proto));
2244 /* It is unlikely that proto is an xsub, but it could happen; e.g. if a
2245 * module has performed a lexical sub import trick on an xsub. This
2246 * happens with builtin::import, for example
2248 if (UNLIKELY(CvISXSUB(proto))) {
2249 CvXSUB(cv) = CvXSUB(proto);
2250 CvXSUBANY(cv) = CvXSUBANY(proto);
2251 if (CvREFCOUNTED_ANYSV(cv))
2252 SvREFCNT_inc(CvXSUBANY(cv).any_sv);
2256 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2258 CvSTART(cv) = CvSTART(proto);
2259 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2263 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2265 SvUTF8_on(MUTABLE_SV(cv));
2268 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2270 if (!CvISXSUB(proto) && CvPADLIST(proto))
2271 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2274 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2275 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2276 cv_dump(proto, "Proto");
2284 Perl_cv_clone(pTHX_ CV *proto)
2286 PERL_ARGS_ASSERT_CV_CLONE;
2288 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2289 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2292 /* Called only by pp_clonecv */
2294 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2296 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2298 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2304 Returns an SV containing the name of the CV, mainly for use in error
2305 reporting. The CV may actually be a GV instead, in which case the returned
2306 SV holds the GV's name. Anything other than a GV or CV is treated as a
2307 string already holding the sub name, but this could change in the future.
2309 An SV may be passed as a second argument. If so, the name will be assigned
2310 to it and it will be returned. Otherwise the returned SV will be a new
2313 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2314 included. If the first argument is neither a CV nor a GV, this flag is
2315 ignored (subject to change).
2317 =for apidoc Amnh||CV_NAME_NOTQUAL
2323 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2325 PERL_ARGS_ASSERT_CV_NAME;
2326 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2327 if (sv) sv_setsv(sv,(SV *)cv);
2328 return sv ? (sv) : (SV *)cv;
2331 SV * const retsv = sv ? (sv) : sv_newmortal();
2332 if (SvTYPE(cv) == SVt_PVCV) {
2334 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2335 sv_sethek(retsv, CvNAME_HEK(cv));
2337 if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
2338 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2340 sv_setpvs(retsv, "__ANON__");
2341 sv_catpvs(retsv, "::");
2342 sv_cathek(retsv, CvNAME_HEK(cv));
2345 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2346 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2347 else gv_efullname3(retsv, CvGV(cv), NULL);
2349 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2350 else gv_efullname3(retsv,(GV *)cv,NULL);
2356 =for apidoc pad_fixup_inner_anons
2358 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2359 C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
2360 moved to a pre-existing CV struct.
2366 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2369 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2370 AV * const comppad = PadlistARRAY(padlist)[1];
2371 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2372 SV ** const curpad = AvARRAY(comppad);
2374 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2375 PERL_UNUSED_ARG(old_cv);
2377 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2378 const PADNAME *name = namepad[ix];
2379 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2380 && *PadnamePV(name) == '&')
2382 CV *innercv = MUTABLE_CV(curpad[ix]);
2383 if (UNLIKELY(PadnameOUTER(name))) {
2385 PADNAME **names = namepad;
2387 while (PadnameOUTER(name)) {
2388 assert(SvTYPE(cv) == SVt_PVCV);
2390 names = PadlistNAMESARRAY(CvPADLIST(cv));
2391 i = PARENT_PAD_INDEX(name);
2394 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2396 if (SvTYPE(innercv) == SVt_PVCV) {
2397 /* XXX 0afba48f added code here to check for a proto CV
2398 attached to the pad entry by magic. But shortly there-
2399 after 81df9f6f95 moved the magic to the pad name. The
2400 code here was never updated, so it wasn’t doing anything
2401 and got deleted when PADNAME became a distinct type. Is
2402 there any bug as a result? */
2403 if (CvOUTSIDE(innercv) == old_cv) {
2404 if (!CvWEAKOUTSIDE(innercv)) {
2405 SvREFCNT_dec(old_cv);
2406 SvREFCNT_inc_simple_void_NN(new_cv);
2408 CvOUTSIDE(innercv) = new_cv;
2411 else { /* format reference */
2412 SV * const rv = curpad[ix];
2414 if (!SvOK(rv)) continue;
2416 assert(SvWEAKREF(rv));
2417 innercv = (CV *)SvRV(rv);
2418 assert(!CvWEAKOUTSIDE(innercv));
2419 assert(CvOUTSIDE(innercv) == old_cv);
2420 SvREFCNT_dec(CvOUTSIDE(innercv));
2421 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2428 =for apidoc pad_push
2430 Push a new pad frame onto the padlist, unless there's already a pad at
2431 this depth, in which case don't bother creating a new one. Then give
2432 the new pad an C<@_> in slot zero.
2438 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2440 PERL_ARGS_ASSERT_PAD_PUSH;
2442 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2443 PAD** const svp = PadlistARRAY(padlist);
2444 AV* const newpad = newAV();
2445 SV** const oldpad = AvARRAY(svp[depth-1]);
2446 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
2447 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2448 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2451 Newxz( AvALLOC(newpad), ix + 1, SV *);
2452 AvARRAY(newpad) = AvALLOC(newpad);
2453 AvMAX(newpad) = AvFILLp(newpad) = ix;
2455 for ( ;ix > 0; ix--) {
2457 if (names_fill >= ix && PadnameLEN(names[ix])) {
2458 const char sigil = PadnamePV(names[ix])[0];
2459 if (PadnameOUTER(names[ix])
2460 || PadnameIsSTATE(names[ix])
2463 /* outer lexical or anon code */
2464 sv = SvREFCNT_inc(oldpad[ix]);
2466 else { /* our own lexical */
2468 sv = MUTABLE_SV(newAV());
2469 else if (sigil == '%')
2470 sv = MUTABLE_SV(newHV());
2472 sv = newSV_type(SVt_NULL);
2475 else if (PadnamePV(names[ix])) {
2476 sv = SvREFCNT_inc_NN(oldpad[ix]);
2479 /* save temporaries on recursion? */
2480 sv = newSV_type(SVt_NULL);
2483 AvARRAY(newpad)[ix] = sv;
2486 AvARRAY(newpad)[0] = MUTABLE_SV(av);
2487 #ifndef PERL_RC_STACK
2491 padlist_store(padlist, depth, newpad);
2495 #if defined(USE_ITHREADS)
2498 =for apidoc padlist_dup
2506 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2512 PERL_ARGS_ASSERT_PADLIST_DUP;
2514 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2515 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2517 max = cloneall ? PadlistMAX(srcpad) : 1;
2519 Newx(dstpad, 1, PADLIST);
2520 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2521 PadlistMAX(dstpad) = max;
2522 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2524 PadlistARRAY(dstpad)[0] = (PAD *)padnamelist_dup_inc(PadlistNAMES(srcpad), param);
2527 for (depth = 1; depth <= max; ++depth)
2528 PadlistARRAY(dstpad)[depth] =
2529 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2531 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2532 to build anything other than the first level of pads. */
2533 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2535 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2536 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2537 SV **oldpad = AvARRAY(srcpad1);
2538 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2544 av_extend(pad1, ix);
2545 PadlistARRAY(dstpad)[1] = pad1;
2546 pad1a = AvARRAY(pad1);
2551 for ( ;ix > 0; ix--) {
2554 } else if (names_fill >= ix && names[ix] &&
2555 PadnameLEN(names[ix])) {
2556 const char sigil = PadnamePV(names[ix])[0];
2557 if (PadnameOUTER(names[ix])
2558 || PadnameIsSTATE(names[ix])
2561 /* outer lexical or anon code */
2562 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2564 else { /* our own lexical */
2565 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2566 /* This is a work around for how the current
2567 implementation of ?{ } blocks in regexps
2568 interacts with lexicals. */
2569 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2574 sv = MUTABLE_SV(newAV());
2575 else if (sigil == '%')
2576 sv = MUTABLE_SV(newHV());
2578 sv = newSV_type(SVt_NULL);
2583 else if (( names_fill >= ix && names[ix]
2584 && PadnamePV(names[ix]) )) {
2585 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2588 /* save temporaries on recursion? */
2589 SV * const sv = newSV_type(SVt_NULL);
2592 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2593 FIXTHAT before merging this branch.
2594 (And I know how to) */
2595 if (SvPADTMP(oldpad[ix]))
2601 args = newAV(); /* Will be @_ */
2602 #ifndef PERL_RC_STACK
2605 pad1a[0] = (SV *)args;
2613 #endif /* USE_ITHREADS */
2616 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2619 SSize_t const oldmax = PadlistMAX(padlist);
2621 PERL_ARGS_ASSERT_PADLIST_STORE;
2625 if (key > PadlistMAX(padlist)) {
2626 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2627 (SV ***)&PadlistARRAY(padlist),
2628 (SV ***)&PadlistARRAY(padlist));
2629 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2632 ary = PadlistARRAY(padlist);
2633 SvREFCNT_dec(ary[key]);
2639 =for apidoc newPADNAMELIST
2641 Creates a new pad name list. C<max> is the highest index for which space
2648 Perl_newPADNAMELIST(size_t max)
2651 Newx(pnl, 1, PADNAMELIST);
2652 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2653 PadnamelistMAX(pnl) = -1;
2654 PadnamelistREFCNT(pnl) = 1;
2655 PadnamelistMAXNAMED(pnl) = 0;
2656 pnl->xpadnl_max = max;
2661 =for apidoc padnamelist_store
2663 Stores the pad name (which may be null) at the given index, freeing any
2664 existing pad name in that slot.
2670 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2674 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2678 if (key > pnl->xpadnl_max)
2679 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2680 (SV ***)&PadnamelistARRAY(pnl),
2681 (SV ***)&PadnamelistARRAY(pnl));
2682 if (PadnamelistMAX(pnl) < key) {
2683 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2684 key-PadnamelistMAX(pnl), PADNAME *);
2685 PadnamelistMAX(pnl) = key;
2687 ary = PadnamelistARRAY(pnl);
2689 PadnameREFCNT_dec(ary[key]);
2695 =for apidoc padnamelist_fetch
2697 Fetches the pad name from the given index.
2703 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2705 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2708 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2712 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2714 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2715 if (!--PadnamelistREFCNT(pnl)) {
2716 while(PadnamelistMAX(pnl) >= 0)
2718 PADNAME * const pn =
2719 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2721 PadnameREFCNT_dec(pn);
2723 Safefree(PadnamelistARRAY(pnl));
2728 #if defined(USE_ITHREADS)
2731 =for apidoc padnamelist_dup
2733 Duplicates a pad name list.
2739 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2741 PADNAMELIST *dstpad;
2742 SSize_t max = PadnamelistMAX(srcpad);
2744 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2746 /* look for it in the table first */
2747 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2751 dstpad = newPADNAMELIST(max);
2752 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2753 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2754 PadnamelistMAX(dstpad) = max;
2756 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2757 for (; max >= 0; max--)
2758 if (PadnamelistARRAY(srcpad)[max]) {
2759 PadnamelistARRAY(dstpad)[max] =
2760 padname_dup_inc(PadnamelistARRAY(srcpad)[max], param);
2766 #endif /* USE_ITHREADS */
2769 =for apidoc newPADNAMEpvn
2771 Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
2772 use this for pad names that point to outer lexicals. See
2773 C<L</newPADNAMEouter>>.
2779 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2781 struct padname_with_str *alloc;
2782 char *alloc2; /* for Newxz */
2784 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2786 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2788 alloc = (struct padname_with_str *)alloc2;
2789 pn = (PADNAME *)alloc;
2790 PadnameREFCNT(pn) = 1;
2791 PadnamePV(pn) = alloc->xpadn_str;
2792 Copy(s, PadnamePV(pn), len, char);
2793 *(PadnamePV(pn) + len) = '\0';
2794 PadnameLEN(pn) = len;
2799 =for apidoc newPADNAMEouter
2801 Constructs and returns a new pad name. Only use this function for names
2802 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
2803 the outer pad name that this one mirrors. The returned pad name has the
2804 C<PADNAMEf_OUTER> flag already set.
2806 =for apidoc Amnh||PADNAMEf_OUTER
2812 Perl_newPADNAMEouter(PADNAME *outer)
2815 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2816 Newxz(pn, 1, PADNAME);
2817 PadnameREFCNT(pn) = 1;
2818 PadnamePV(pn) = PadnamePV(outer);
2819 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2820 another entry. The original pad name owns the buffer. */
2821 PadnameREFCNT_inc(PADNAME_FROM_PV(PadnamePV(outer)));
2822 PadnameFLAGS(pn) = PADNAMEf_OUTER;
2823 if(PadnameIsFIELD(outer)) {
2824 PadnameFIELDINFO(pn) = PadnameFIELDINFO(outer);
2825 PadnameFIELDINFO(pn)->refcount++;
2826 PadnameFLAGS(pn) |= PADNAMEf_FIELD;
2828 PadnameLEN(pn) = PadnameLEN(outer);
2833 Perl_padname_free(pTHX_ PADNAME *pn)
2835 PERL_ARGS_ASSERT_PADNAME_FREE;
2836 if (!--PadnameREFCNT(pn)) {
2837 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2838 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2841 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2842 SvREFCNT_dec(PadnameOURSTASH(pn));
2843 if (PadnameOUTER(pn))
2844 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2845 if (PadnameIsFIELD(pn)) {
2846 struct padname_fieldinfo *info = PadnameFIELDINFO(pn);
2847 if(!--info->refcount) {
2848 SvREFCNT_dec(info->fieldstash);
2849 /* todo: something about defop */
2850 SvREFCNT_dec(info->paramname);
2859 #if defined(USE_ITHREADS)
2862 =for apidoc padname_dup
2864 Duplicates a pad name.
2870 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2874 PERL_ARGS_ASSERT_PADNAME_DUP;
2876 /* look for it in the table first */
2877 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2881 if (!PadnamePV(src)) {
2882 dst = &PL_padname_undef;
2883 ptr_table_store(PL_ptr_table, src, dst);
2887 dst = PadnameOUTER(src)
2888 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2889 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2890 ptr_table_store(PL_ptr_table, src, dst);
2891 PadnameLEN(dst) = PadnameLEN(src);
2892 PadnameFLAGS(dst) = PadnameFLAGS(src);
2893 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2894 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2895 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2897 if(PadnameIsFIELD(src) && !PadnameOUTER(src)) {
2898 struct padname_fieldinfo *sinfo = PadnameFIELDINFO(src);
2899 struct padname_fieldinfo *dinfo;
2900 Newxz(dinfo, 1, struct padname_fieldinfo);
2902 dinfo->refcount = 1;
2903 dinfo->fieldix = sinfo->fieldix;
2904 dinfo->fieldstash = hv_dup_inc(sinfo->fieldstash, param);
2905 dinfo->paramname = sv_dup_inc(sinfo->paramname, param);
2907 PadnameFIELDINFO(dst) = dinfo;
2909 dst->xpadn_low = src->xpadn_low;
2910 dst->xpadn_high = src->xpadn_high;
2911 dst->xpadn_gen = src->xpadn_gen;
2915 #endif /* USE_ITHREADS */
2918 =for apidoc_section $lexer
2919 =for apidoc suspend_compcv
2921 Implements part of the concept of a "suspended compilation CV", which can be
2922 used to pause the parser and compiler during parsing a CV in order to come
2923 back to it later on.
2925 This function saves the current state of the subroutine under compilation
2926 (C<PL_compcv>) into the supplied buffer. This should be used initially to
2927 create the state in the buffer, as the final thing before a C<LEAVE> within a
2934 suspend_compcv(&buffer);
2937 Once suspended, the C<resume_compcv_final> or C<resume_compcv_and_save>
2938 function can later be used to continue the parsing from the point this stopped.
2944 Perl_suspend_compcv(pTHX_ struct suspended_compcv *buffer)
2946 PERL_ARGS_ASSERT_SUSPEND_COMPCV;
2948 buffer->compcv = PL_compcv;
2950 buffer->padix = PL_padix;
2951 buffer->constpadix = PL_constpadix;
2953 buffer->comppad_name_fill = PL_comppad_name_fill;
2954 buffer->min_intro_pending = PL_min_intro_pending;
2955 buffer->max_intro_pending = PL_max_intro_pending;
2957 buffer->cv_has_eval = PL_cv_has_eval;
2958 buffer->pad_reset_pending = PL_pad_reset_pending;
2962 =for apidoc resume_compcv_final
2964 Resumes the parser state previously saved using the C<suspend_compcv> function
2965 for a final time before being compiled into a full CV. This should be used
2966 within an C<ENTER>/C<LEAVE> scoped pair.
2968 =for apidoc resume_compcv_and_save
2970 Resumes a buffer previously suspended by the C<suspend_compcv> function, in a
2971 way that will be re-suspended at the end of the scope so it can be used again
2972 later. This should be used within an C<ENTER>/C<LEAVE> scoped pair.
2978 Perl_resume_compcv(pTHX_ struct suspended_compcv *buffer, bool save)
2980 PERL_ARGS_ASSERT_RESUME_COMPCV;
2982 SAVESPTR(PL_compcv);
2983 PL_compcv = buffer->compcv;
2984 PAD_SET_CUR(CvPADLIST(PL_compcv), 1);
2986 SAVESPTR(PL_comppad_name);
2987 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
2989 SAVESTRLEN(PL_padix); PL_padix = buffer->padix;
2990 SAVESTRLEN(PL_constpadix); PL_constpadix = buffer->constpadix;
2991 SAVESTRLEN(PL_comppad_name_fill); PL_comppad_name_fill = buffer->comppad_name_fill;
2992 SAVESTRLEN(PL_min_intro_pending); PL_min_intro_pending = buffer->min_intro_pending;
2993 SAVESTRLEN(PL_max_intro_pending); PL_max_intro_pending = buffer->max_intro_pending;
2995 SAVEBOOL(PL_cv_has_eval); PL_cv_has_eval = buffer->cv_has_eval;
2996 SAVEBOOL(PL_pad_reset_pending); PL_pad_reset_pending = buffer->pad_reset_pending;
2999 SAVEDESTRUCTOR_X(&Perl_suspend_compcv, buffer);
3003 * ex: set ts=8 sts=4 sw=4 et: