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);
234 PadnamelistREFCNT(padname = PL_comppad_name)++;
237 padlist->xpadl_id = PL_padlist_generation++;
238 /* Set implicitly through use of Newxz above
239 AvARRAY(pad)[0] = NULL;
241 padname = newPADNAMELIST(0);
242 padnamelist_store(padname, 0, &PL_padname_undef);
245 /* Most subroutines never recurse, hence only need 2 entries in the padlist
246 array - names, and depth=1. The default for av_store() is to allocate
247 0..3, and even an explicit call to av_extend() with <3 will be rounded
248 up, so we inline the allocation of the array here. */
250 PadlistMAX(padlist) = 1;
251 PadlistARRAY(padlist) = ary;
252 ary[0] = (PAD *)padname;
255 /* ... then update state variables */
258 PL_curpad = AvARRAY(pad);
260 if (! (flags & padnew_CLONE)) {
261 PL_comppad_name = padname;
262 PL_comppad_name_fill = 0;
263 PL_min_intro_pending = 0;
269 DEBUG_X(PerlIO_printf(Perl_debug_log,
270 "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf
271 " name=0x%" UVxf " flags=0x%" UVxf "\n",
272 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
273 PTR2UV(padname), (UV)flags
277 return (PADLIST*)padlist;
282 =for apidoc_section $embedding
286 Clear out all the active components of a CV. This can happen either
287 by an explicit C<undef &foo>, or by the reference count going to zero.
288 In the former case, we keep the C<CvOUTSIDE> pointer, so that any anonymous
289 children can still follow the full lexical scope chain.
295 Perl_cv_undef(pTHX_ CV *cv)
297 PERL_ARGS_ASSERT_CV_UNDEF;
298 cv_undef_flags(cv, 0);
302 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
304 CV cvbody;/*CV body will never be realloced inside this func,
305 so don't read it more than once, use fake CV so existing macros
306 will work, the indirection and CV head struct optimized away*/
307 SvANY(&cvbody) = SvANY(cv);
309 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
311 DEBUG_X(PerlIO_printf(Perl_debug_log,
312 "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n",
313 PTR2UV(cv), PTR2UV(PL_comppad))
316 if (CvFILE(&cvbody)) {
317 char * file = CvFILE(&cvbody);
318 CvFILE(&cvbody) = NULL;
319 if(CvDYNFILE(&cvbody))
323 /* CvSLABBED_off(&cvbody); *//* turned off below */
324 /* release the sub's body */
325 if (!CvISXSUB(&cvbody)) {
326 if(CvROOT(&cvbody)) {
327 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
328 if (CvDEPTHunsafe(&cvbody)) {
329 assert(SvTYPE(cv) == SVt_PVCV);
330 Perl_croak_nocontext("Can't undef active subroutine");
334 PAD_SAVE_SETNULLPAD();
336 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
337 op_free(CvROOT(&cvbody));
338 CvROOT(&cvbody) = NULL;
339 CvSTART(&cvbody) = NULL;
342 else if (CvSLABBED(&cvbody)) {
343 if( CvSTART(&cvbody)) {
345 PAD_SAVE_SETNULLPAD();
347 /* discard any leaked ops */
349 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
350 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
351 CvSTART(&cvbody) = NULL;
356 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
360 else { /* don't bother checking if CvXSUB(cv) is true, less branching */
361 CvXSUB(&cvbody) = NULL;
363 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
364 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
365 if (!(flags & CV_UNDEF_KEEP_NAME)) {
366 if (CvNAMED(&cvbody)) {
367 CvNAME_HEK_set(&cvbody, NULL);
368 CvNAMED_off(&cvbody);
370 else CvGV_set(cv, NULL);
373 /* This statement and the subsequence if block was pad_undef(). */
374 pad_peg("pad_undef");
376 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
378 const PADLIST *padlist = CvPADLIST(&cvbody);
380 /* Free the padlist associated with a CV.
381 If parts of it happen to be current, we null the relevant PL_*pad*
382 global vars so that we don't have any dangling references left.
383 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
384 subs to the outer of this cv. */
386 DEBUG_X(PerlIO_printf(Perl_debug_log,
387 "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n",
388 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
391 /* detach any '&' anon children in the pad; if afterwards they
392 * are still live, fix up their CvOUTSIDEs to point to our outside,
395 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
396 CV * const outercv = CvOUTSIDE(&cvbody);
397 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
398 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
399 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
400 PAD * const comppad = PadlistARRAY(padlist)[1];
401 SV ** const curpad = AvARRAY(comppad);
402 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
403 PADNAME * const name = namepad[ix];
404 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
406 CV * const innercv = MUTABLE_CV(curpad[ix]);
409 assert(SvTYPE(innercv) != SVt_PVFM);
410 inner_rc = SvREFCNT(innercv);
413 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
415 SvREFCNT_dec_NN(innercv);
419 /* in use, not just a prototype */
420 if (inner_rc && SvTYPE(innercv) == SVt_PVCV
421 && (CvOUTSIDE(innercv) == cv))
423 assert(CvWEAKOUTSIDE(innercv));
424 /* don't relink to grandfather if he's being freed */
425 if (outercv && SvREFCNT(outercv)) {
426 CvWEAKOUTSIDE_off(innercv);
427 CvOUTSIDE(innercv) = outercv;
428 CvOUTSIDE_SEQ(innercv) = seq;
429 SvREFCNT_inc_simple_void_NN(outercv);
432 CvOUTSIDE(innercv) = NULL;
439 ix = PadlistMAX(padlist);
441 PAD * const sv = PadlistARRAY(padlist)[ix--];
443 if (sv == PL_comppad) {
451 PADNAMELIST * const names = PadlistNAMES(padlist);
452 if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1)
453 PL_comppad_name = NULL;
454 PadnamelistREFCNT_dec(names);
456 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
458 CvPADLIST_set(&cvbody, NULL);
460 else if (CvISXSUB(&cvbody)) {
461 if (CvREFCOUNTED_ANYSV(&cvbody))
462 SvREFCNT_dec(CvXSUBANY(&cvbody).any_sv);
463 CvHSCXT(&cvbody) = NULL;
465 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
468 /* remove CvOUTSIDE unless this is an undef rather than a free */
470 CV * outside = CvOUTSIDE(&cvbody);
472 CvOUTSIDE(&cvbody) = NULL;
473 if (!CvWEAKOUTSIDE(&cvbody))
474 SvREFCNT_dec_NN(outside);
477 if (CvCONST(&cvbody)) {
478 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
479 /* CvCONST_off(cv); *//* turned off below */
481 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
482 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
483 * LEXICAL, which are used to determine the sub's name. */
484 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
489 =for apidoc cv_forget_slab
491 When a CV has a reference count on its slab (C<CvSLABBED>), it is responsible
492 for making sure it is freed. (Hence, no two CVs should ever have a
493 reference count on the same slab.) The CV only needs to reference the slab
494 during compilation. Once it is compiled and C<CvROOT> attached, it has
495 finished its job, so it can forget the slab.
501 Perl_cv_forget_slab(pTHX_ CV *cv)
508 slabbed = cBOOL(CvSLABBED(cv));
509 if (!slabbed) return;
513 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
514 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
516 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
520 #ifdef PERL_DEBUG_READONLY_OPS
521 const size_t refcnt = slab->opslab_refcnt;
523 OpslabREFCNT_dec(slab);
524 #ifdef PERL_DEBUG_READONLY_OPS
525 if (refcnt > 1) Slab_to_ro(slab);
531 =for apidoc pad_alloc_name
533 Allocates a place in the currently-compiling
534 pad (via L<perlapi/pad_alloc>) and
535 then stores a name for that entry. C<name> is adopted and
536 becomes the name entry; it must already contain the name
537 string. C<typestash> and C<ourstash> and the C<padadd_STATE>
538 flag get added to C<name>. None of the other
539 processing of L<perlapi/pad_add_name_pvn>
540 is done. Returns the offset of the allocated pad slot.
546 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
549 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
551 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
553 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
556 PadnameFLAGS(name) |= PADNAMEf_TYPED;
558 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
561 PadnameFLAGS(name) |= PADNAMEf_OUR;
562 PadnameOURSTASH_set(name, ourstash);
563 SvREFCNT_inc_simple_void_NN(ourstash);
565 else if (flags & padadd_STATE) {
566 PadnameFLAGS(name) |= PADNAMEf_STATE;
568 if (flags & padadd_FIELD) {
569 assert(HvSTASH_IS_CLASS(PL_curstash));
570 class_add_field(PL_curstash, name);
573 padnamelist_store(PL_comppad_name, offset, name);
574 if (PadnameLEN(name) > 1)
575 PadnamelistMAXNAMED(PL_comppad_name) = offset;
580 =for apidoc pad_add_name_pvn
582 Allocates a place in the currently-compiling pad for a named lexical
583 variable. Stores the name and other metadata in the name part of the
584 pad, and makes preparations to manage the variable's lexical scoping.
585 Returns the offset of the allocated pad slot.
587 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
588 If C<typestash> is non-null, the name is for a typed lexical, and this
589 identifies the type. If C<ourstash> is non-null, it's a lexical reference
590 to a package variable, and this identifies the package. The following
591 flags can be OR'ed together:
593 padadd_OUR redundantly specifies if it's a package var
594 padadd_STATE variable will retain value persistently
595 padadd_NO_DUP_CHECK skip check for lexical shadowing
596 padadd_FIELD specifies that the lexical is a field for a class
602 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
603 U32 flags, HV *typestash, HV *ourstash)
608 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
610 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_FIELD))
611 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
614 name = newPADNAMEpvn(namepv, namelen);
616 if ((flags & padadd_NO_DUP_CHECK) == 0) {
618 SAVEFREEPADNAME(name); /* in case of fatal warnings */
619 /* check for duplicate declaration */
620 pad_check_dup(name, flags & (padadd_OUR|padadd_FIELD), ourstash);
621 PadnameREFCNT_inc(name);
625 offset = pad_alloc_name(name, flags, typestash, ourstash);
627 /* not yet introduced */
628 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
629 COP_SEQ_RANGE_HIGH_set(name, 0);
631 if (!PL_min_intro_pending)
632 PL_min_intro_pending = offset;
633 PL_max_intro_pending = offset;
634 /* if it's not a simple scalar, replace with an AV or HV */
635 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
636 assert(SvREFCNT(PL_curpad[offset]) == 1);
637 if (namelen != 0 && *namepv == '@')
638 sv_upgrade(PL_curpad[offset], SVt_PVAV);
639 else if (namelen != 0 && *namepv == '%')
640 sv_upgrade(PL_curpad[offset], SVt_PVHV);
641 else if (namelen != 0 && *namepv == '&')
642 sv_upgrade(PL_curpad[offset], SVt_PVCV);
643 assert(SvPADMY(PL_curpad[offset]));
644 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
645 "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n",
646 (long)offset, PadnamePV(name),
647 PTR2UV(PL_curpad[offset])));
653 =for apidoc pad_add_name_pv
655 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
656 instead of a string/length pair.
662 Perl_pad_add_name_pv(pTHX_ const char *name,
663 const U32 flags, HV *typestash, HV *ourstash)
665 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
666 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
670 =for apidoc pad_add_name_sv
672 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
673 of an SV instead of a string/length pair.
679 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
683 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
684 namepv = SvPVutf8(name, namelen);
685 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
689 =for apidoc pad_alloc
691 Allocates a place in the currently-compiling pad,
692 returning the offset of the allocated pad slot.
693 No name is initially attached to the pad slot.
694 C<tmptype> is a set of flags indicating the kind of pad entry required,
695 which will be set in the value SV for the allocated pad entry:
697 SVs_PADMY named lexical variable ("my", "our", "state")
698 SVs_PADTMP unnamed temporary store
699 SVf_READONLY constant shared between recursion levels
701 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
702 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
703 does not cause the SV in the pad slot to be marked read-only, but simply
704 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
705 least should be treated as such.
707 C<optype> should be an opcode indicating the type of operation that the
708 pad entry is to support. This doesn't affect operational semantics,
709 but is used for debugging.
715 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
720 PERL_UNUSED_ARG(optype);
721 ASSERT_CURPAD_ACTIVE("pad_alloc");
723 if (AvARRAY(PL_comppad) != PL_curpad)
724 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
725 AvARRAY(PL_comppad), PL_curpad);
726 if (PL_pad_reset_pending)
728 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
729 /* For a my, simply push a null SV onto the end of PL_comppad. */
730 sv = *av_store_simple(PL_comppad, AvFILLp(PL_comppad) + 1, newSV_type(SVt_NULL));
731 retval = (PADOFFSET)AvFILLp(PL_comppad);
734 /* For a tmp, scan the pad from PL_padix upwards
735 * for a slot which has no name and no active value.
736 * For a constant, likewise, but use PL_constpadix.
738 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
739 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
740 const bool konst = cBOOL(tmptype & SVf_READONLY);
741 retval = konst ? PL_constpadix : PL_padix;
744 * Entries that close over unavailable variables
745 * in outer subs contain values not marked PADMY.
746 * Thus we must skip, not just pad values that are
747 * marked as current pad values, but also those with names.
748 * If pad_reset is enabled, ‘current’ means different
749 * things depending on whether we are allocating a con-
750 * stant or a target. For a target, things marked PADTMP
751 * can be reused; not so for constants.
754 if (++retval <= names_fill &&
755 (pn = names[retval]) && PadnamePV(pn))
757 sv = *av_fetch_simple(PL_comppad, retval, TRUE);
760 (konst ? SVs_PADTMP : 0)
768 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
769 tmptype &= ~SVf_READONLY;
770 tmptype |= SVs_PADTMP;
772 *(konst ? &PL_constpadix : &PL_padix) = retval;
774 SvFLAGS(sv) |= tmptype;
775 PL_curpad = AvARRAY(PL_comppad);
777 DEBUG_X(PerlIO_printf(Perl_debug_log,
778 "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n",
779 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
780 PL_op_name[optype]));
781 #ifdef DEBUG_LEAKING_SCALARS
782 sv->sv_debug_optype = optype;
783 sv->sv_debug_inpad = 1;
789 =for apidoc pad_add_anon
791 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
792 for an anonymous function that is lexically scoped inside the
793 currently-compiling function.
794 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
795 to the outer scope is weakened to avoid a reference loop.
797 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
799 C<optype> should be an opcode indicating the type of operation that the
800 pad entry is to support. This doesn't affect operational semantics,
801 but is used for debugging.
807 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
810 PADNAME * const name = newPADNAMEpvn("&", 1);
812 PERL_ARGS_ASSERT_PAD_ADD_ANON;
813 assert (SvTYPE(func) == SVt_PVCV);
816 /* These two aren't used; just make sure they're not equal to
817 * PERL_PADSEQ_INTRO. They should be 0 by default. */
818 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
819 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
820 ix = pad_alloc(optype, SVs_PADMY);
821 padnamelist_store(PL_comppad_name, ix, name);
822 av_store(PL_comppad, ix, (SV*)func);
824 /* to avoid ref loops, we never have parent + child referencing each
825 * other simultaneously */
826 if (CvOUTSIDE(func)) {
827 assert(!CvWEAKOUTSIDE(func));
828 CvWEAKOUTSIDE_on(func);
829 SvREFCNT_dec_NN(CvOUTSIDE(func));
835 Perl_pad_add_weakref(pTHX_ CV* func)
837 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
838 PADNAME * const name = newPADNAMEpvn("&", 1);
839 SV * const rv = newRV_inc((SV *)func);
841 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
843 /* These two aren't used; just make sure they're not equal to
844 * PERL_PADSEQ_INTRO. They should be 0 by default. */
845 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
846 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
847 padnamelist_store(PL_comppad_name, ix, name);
849 av_store(PL_comppad, ix, rv);
853 =for apidoc pad_check_dup
855 Check for duplicate declarations: report any of:
857 * a 'my' in the current scope with the same name;
858 * an 'our' (anywhere in the pad) with the same name and the
859 same stash as 'ourstash'
861 C<is_our> indicates that the name to check is an C<"our"> declaration.
867 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
871 const U32 is_our = flags & padadd_OUR;
872 bool is_field = flags & padadd_FIELD;
874 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
876 ASSERT_CURPAD_ACTIVE("pad_check_dup");
878 assert((flags & ~(padadd_OUR|padadd_FIELD)) == 0);
880 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW))
881 return; /* nothing to check */
883 svp = PadnamelistARRAY(PL_comppad_name);
884 top = PadnamelistMAX(PL_comppad_name);
885 /* check the current scope */
886 for (off = top; off > PL_comppad_name_floor; off--) {
887 PADNAME * const pn = svp[off];
889 && PadnameLEN(pn) == PadnameLEN(name)
891 && ( COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO
892 || COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO)
893 && memEQ(PadnamePV(pn), PadnamePV(name), PadnameLEN(name)))
895 if (is_our && (PadnameIsOUR(pn)))
896 break; /* "our" masking "our" */
897 if (is_field && PadnameIsFIELD(pn) &&
898 PadnameFIELDINFO(pn)->fieldstash != PL_curstash)
899 break; /* field of a different class */
900 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
901 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
902 "\"%s\" %s %" PNf " masks earlier declaration in same %s",
904 PL_parser->in_my == KEY_my ? "my" :
905 PL_parser->in_my == KEY_sigvar ? "my" :
906 PL_parser->in_my == KEY_field ? "field" :
908 *PadnamePV(pn) == '&' ? "subroutine" : "variable",
910 (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO
911 ? "scope" : "statement"));
916 /* check the rest of the pad */
919 PADNAME * const pn = svp[off];
921 && PadnameLEN(pn) == PadnameLEN(name)
923 && ( COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO
924 || COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO)
925 && PadnameOURSTASH(pn) == ourstash
926 && memEQ(PadnamePV(pn), PadnamePV(name), PadnameLEN(name)))
928 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
929 "\"our\" variable %" PNf " redeclared", PNfARG(pn));
930 if (off <= PL_comppad_name_floor)
931 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
932 "\t(Did you mean \"local\" instead of \"our\"?)\n");
942 =for apidoc pad_findmy_pvn
944 Given the name of a lexical variable, find its position in the
945 currently-compiling pad.
946 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
947 C<flags> is reserved and must be zero.
948 If it is not in the current pad but appears in the pad of any lexically
949 enclosing scope, then a pseudo-entry for it is added in the current pad.
950 Returns the offset in the current pad,
951 or C<NOT_IN_PAD> if no such lexical is in scope.
957 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
962 const PADNAMELIST *namelist;
965 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
967 pad_peg("pad_findmy_pvn");
970 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
973 /* compilation errors can zero PL_compcv */
977 offset = pad_findlex(namepv, namelen, flags,
978 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
979 if (offset != NOT_IN_PAD)
982 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
984 if (*namepv == '&') return NOT_IN_PAD;
986 /* look for an our that's being introduced; this allows
987 * our $foo = 0 unless defined $foo;
988 * to not give a warning. (Yes, this is a hack) */
990 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
991 name_p = PadnamelistARRAY(namelist);
992 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
993 const PADNAME * const name = name_p[offset];
994 if (name && PadnameLEN(name) == namelen
995 && !PadnameOUTER(name)
996 && (PadnameIsOUR(name))
997 && ( PadnamePV(name) == namepv
998 || memEQ(PadnamePV(name), namepv, namelen) )
999 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
1007 =for apidoc pad_findmy_pv
1009 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1010 instead of a string/length pair.
1016 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1018 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1019 return pad_findmy_pvn(name, strlen(name), flags);
1023 =for apidoc pad_findmy_sv
1025 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1026 of an SV instead of a string/length pair.
1032 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1036 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1037 namepv = SvPVutf8(name, namelen);
1038 return pad_findmy_pvn(namepv, namelen, flags);
1042 =for apidoc find_rundefsv
1044 Returns the global variable C<$_>.
1050 Perl_find_rundefsv(pTHX)
1056 =for apidoc pad_findlex
1058 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1059 in the inner pads if it's found in an outer one.
1061 Returns the offset in the bottom pad of the lex or the fake lex.
1062 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1063 to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
1064 vars return values, and so are pointers to where the returned values
1065 should be stored. C<out_capture>, if non-null, requests that the innermost
1066 instance of the lexical is captured; C<out_name> is set to the innermost
1067 matched pad name or fake pad name; C<out_flags> returns the flags normally
1068 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1070 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
1071 then comes back down, adding fake entries
1072 as it goes. It has to be this way
1073 because fake names in anon prototypes have to store in C<xpadn_low> the
1074 index into the parent pad.
1079 /* the CV has finished being compiled. This is not a sufficient test for
1080 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1081 #define CvCOMPILED(cv) CvROOT(cv)
1083 /* the CV does late binding of its lexicals */
1084 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1087 S_unavailable(pTHX_ PADNAME *name)
1089 /* diag_listed_as: Variable "%s" is not available */
1090 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1091 "%s \"%" PNf "\" is not available",
1092 *PadnamePV(name) == '&'
1099 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1100 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1102 PADOFFSET offset, new_offset;
1105 const PADLIST * const padlist = CvPADLIST(cv);
1106 const bool staleok = cBOOL(flags & padadd_STALEOK);
1107 const bool fieldok = cBOOL(flags & padfind_FIELD_OK);
1109 PERL_ARGS_ASSERT_PAD_FINDLEX;
1111 flags &= ~(padadd_STALEOK|padfind_FIELD_OK); /* one-shot flags */
1113 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1118 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1119 "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n",
1120 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1121 out_capture ? " capturing" : "" ));
1123 /* first, search this pad */
1125 if (padlist) { /* not an undef CV */
1126 PADOFFSET fake_offset = 0;
1127 const PADNAMELIST * const names = PadlistNAMES(padlist);
1128 PADNAME * const * const name_p = PadnamelistARRAY(names);
1130 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1131 const PADNAME * const name = name_p[offset];
1132 if (name && PadnameLEN(name) == namelen
1133 && ( PadnamePV(name) == namepv
1134 || memEQ(PadnamePV(name), namepv, namelen) ))
1136 if (PadnameOUTER(name)) {
1137 fake_offset = offset; /* in case we don't find a real one */
1140 if (PadnameIN_SCOPE(name, seq))
1145 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1146 if (offset > 0) { /* not fake */
1148 *out_name = name_p[offset]; /* return the name */
1150 if (PadnameIsFIELD(*out_name) && !fieldok)
1151 croak("Field %" SVf " is not accessible outside a method",
1152 SVfARG(PadnameSV(*out_name)));
1154 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1155 * instances. For now, we just test !CvUNIQUE(cv), but
1156 * ideally, we should detect my's declared within loops
1157 * etc - this would allow a wider range of 'not stayed
1158 * shared' warnings. We also treated already-compiled
1159 * lexes as not multi as viewed from evals. */
1161 *out_flags = CvANON(cv) ?
1163 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1164 ? PAD_FAKELEX_MULTI : 0;
1166 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1167 "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n",
1168 PTR2UV(cv), (long)offset,
1169 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1170 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1172 else { /* fake match */
1173 offset = fake_offset;
1174 *out_name = name_p[offset]; /* return the name */
1175 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1176 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1177 "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n",
1178 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1179 (unsigned long) PARENT_PAD_INDEX(*out_name)
1183 /* return the lex? */
1188 if (PadnameIsOUR(*out_name)) {
1189 *out_capture = NULL;
1193 /* trying to capture from an anon prototype? */
1195 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1196 : *out_flags & PAD_FAKELEX_ANON)
1202 *out_capture = NULL;
1208 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1209 && !PadnameIsSTATE(name_p[offset])
1210 && warn && ckWARN(WARN_CLOSURE)) {
1212 /* diag_listed_as: Variable "%s" will not stay
1214 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1215 "%s \"%" UTF8f "\" will not stay shared",
1216 *namepv == '&' ? "Subroutine" : "Variable",
1217 UTF8fARG(1, namelen, namepv));
1220 if (fake_offset && CvANON(cv)
1221 && CvCLONE(cv) &&!CvCLONED(cv))
1224 /* not yet caught - look further up */
1225 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1226 "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n",
1229 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1231 newwarn, out_capture, out_name, out_flags);
1236 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1237 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1238 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1239 "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n",
1240 PTR2UV(cv), PTR2UV(*out_capture)));
1242 if (SvPADSTALE(*out_capture)
1243 && (!CvDEPTH(cv) || !staleok)
1244 && !PadnameIsSTATE(name_p[offset]))
1248 *out_capture = NULL;
1251 if (!*out_capture) {
1252 if (namelen != 0 && *namepv == '@')
1253 *out_capture = newSV_type_mortal(SVt_PVAV);
1254 else if (namelen != 0 && *namepv == '%')
1255 *out_capture = newSV_type_mortal(SVt_PVHV);
1256 else if (namelen != 0 && *namepv == '&')
1257 *out_capture = newSV_type_mortal(SVt_PVCV);
1259 *out_capture = newSV_type_mortal(SVt_NULL);
1267 /* it's not in this pad - try above */
1272 /* out_capture non-null means caller wants us to capture lex; in
1273 * addition we capture ourselves unless it's an ANON/format */
1274 new_capturep = out_capture ? out_capture :
1275 CvLATE(cv) ? NULL : &new_capture;
1277 U32 recurse_flags = flags;
1278 if(new_capturep == &new_capture)
1279 recurse_flags |= padadd_STALEOK;
1281 recurse_flags |= padfind_FIELD_OK;
1283 offset = pad_findlex(namepv, namelen, recurse_flags,
1284 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1285 new_capturep, out_name, out_flags);
1286 if (offset == NOT_IN_PAD)
1289 if (PadnameIsFIELD(*out_name)) {
1290 HV *fieldstash = PadnameFIELDINFO(*out_name)->fieldstash;
1292 /* fields are only visible to the class that declared them */
1293 if(fieldstash != PL_curstash)
1294 croak("Field %" SVf " of %" HvNAMEf_QUOTEDPREFIX " is not accessible in a method of %" HvNAMEf_QUOTEDPREFIX,
1295 SVfARG(PadnameSV(*out_name)), HvNAMEfARG(fieldstash), HvNAMEfARG(PL_curstash));
1298 /* found in an outer CV. Add appropriate fake entry to this pad */
1300 /* don't add new fake entries (via eval) to CVs that we have already
1301 * finished compiling, or to undef CVs */
1302 if (CvCOMPILED(cv) || !padlist)
1303 return 0; /* this dummy (and invalid) value isnt used by the caller */
1306 PADNAME *new_name = newPADNAMEouter(*out_name);
1307 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1308 PAD * const ocomppad = PL_comppad;
1309 PL_comppad_name = PadlistNAMES(padlist);
1310 PL_comppad = PadlistARRAY(padlist)[1];
1311 PL_curpad = AvARRAY(PL_comppad);
1314 = pad_alloc_name(new_name,
1315 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1316 PadnameTYPE(*out_name),
1317 PadnameOURSTASH(*out_name)
1320 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1321 "Pad addname: %ld \"%.*s\" FAKE\n",
1323 (int) PadnameLEN(new_name),
1324 PadnamePV(new_name)));
1325 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1327 PARENT_PAD_INDEX_set(new_name, 0);
1328 if (PadnameIsOUR(new_name)) {
1329 NOOP; /* do nothing */
1331 else if (CvLATE(cv)) {
1332 /* delayed creation - just note the offset within parent pad */
1333 PARENT_PAD_INDEX_set(new_name, offset);
1337 /* immediate creation - capture outer value right now */
1338 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1339 /* But also note the offset, as newMYSUB needs it */
1340 PARENT_PAD_INDEX_set(new_name, offset);
1341 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1342 "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n",
1343 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1345 *out_name = new_name;
1346 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1348 PL_comppad_name = ocomppad_name;
1349 PL_comppad = ocomppad;
1350 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1360 Get the value at offset C<po> in the current (compiling or executing) pad.
1361 Use macro C<PAD_SV> instead of calling this function directly.
1367 Perl_pad_sv(pTHX_ PADOFFSET po)
1369 ASSERT_CURPAD_ACTIVE("pad_sv");
1372 Perl_croak(aTHX_ "panic: pad_sv po");
1373 DEBUG_X(PerlIO_printf(Perl_debug_log,
1374 "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n",
1375 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1377 return PL_curpad[po];
1381 =for apidoc pad_setsv
1383 Set the value at offset C<po> in the current (compiling or executing) pad.
1384 Use the macro C<PAD_SETSV()> rather than calling this function directly.
1390 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1392 PERL_ARGS_ASSERT_PAD_SETSV;
1394 ASSERT_CURPAD_ACTIVE("pad_setsv");
1396 DEBUG_X(PerlIO_printf(Perl_debug_log,
1397 "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n",
1398 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1403 #endif /* DEBUGGING */
1406 =for apidoc pad_block_start
1408 Update the pad compilation state variables on entry to a new block.
1414 Perl_pad_block_start(pTHX_ int full)
1416 ASSERT_CURPAD_ACTIVE("pad_block_start");
1417 SAVESTRLEN(PL_comppad_name_floor);
1418 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1420 PL_comppad_name_fill = PL_comppad_name_floor;
1421 if (PL_comppad_name_floor < 0)
1422 PL_comppad_name_floor = 0;
1423 SAVESTRLEN(PL_min_intro_pending);
1424 SAVESTRLEN(PL_max_intro_pending);
1425 PL_min_intro_pending = 0;
1426 SAVESTRLEN(PL_comppad_name_fill);
1427 SAVESTRLEN(PL_padix_floor);
1428 /* PL_padix_floor is what PL_padix is reset to at the start of each
1429 statement, by pad_reset(). We set it when entering a new scope
1430 to keep things like this working:
1431 print "$foo$bar", do { this(); that() . "foo" };
1432 We must not let "$foo$bar" and the later concatenation share the
1434 PL_padix_floor = PL_padix;
1435 PL_pad_reset_pending = FALSE;
1439 =for apidoc intro_my
1441 "Introduce" C<my> variables to visible status. This is called during parsing
1442 at the end of each statement to make lexical variables visible to subsequent
1455 ASSERT_CURPAD_ACTIVE("intro_my");
1456 if (PL_compiling.cop_seq) {
1457 seq = PL_compiling.cop_seq;
1458 PL_compiling.cop_seq = 0;
1461 seq = PL_cop_seqmax;
1462 if (! PL_min_intro_pending)
1465 svp = PadnamelistARRAY(PL_comppad_name);
1466 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1467 PADNAME * const sv = svp[i];
1469 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1470 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1472 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1473 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1474 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1475 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1476 (long)i, PadnamePV(sv),
1477 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1478 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1483 PL_min_intro_pending = 0;
1484 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1485 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1486 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1492 =for apidoc pad_leavemy
1494 Cleanup at end of scope during compilation: set the max seq number for
1495 lexicals in this scope and warn of any lexicals that never got introduced.
1501 Perl_pad_leavemy(pTHX)
1505 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1507 PL_pad_reset_pending = FALSE;
1509 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1510 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1511 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1512 const PADNAME * const name = svp[off];
1513 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1514 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1515 "%" PNf " never introduced",
1519 /* "Deintroduce" my variables that are leaving with this scope. */
1520 for (off = PadnamelistMAX(PL_comppad_name);
1521 off > PL_comppad_name_fill; off--) {
1522 PADNAME * const sv = svp[off];
1523 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1524 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1526 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1527 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1528 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1529 (long)off, PadnamePV(sv),
1530 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1531 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1533 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1534 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1535 OP *kid = newOP(OP_INTROCV, 0);
1537 o = op_prepend_elem(OP_LINESEQ, kid, o);
1542 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1543 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1548 =for apidoc pad_swipe
1550 Abandon the tmp in the current pad at offset C<po> and replace with a
1557 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1559 ASSERT_CURPAD_LEGAL("pad_swipe");
1562 if (AvARRAY(PL_comppad) != PL_curpad)
1563 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1564 AvARRAY(PL_comppad), PL_curpad);
1565 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1566 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1567 (long)po, (long)AvFILLp(PL_comppad));
1569 DEBUG_X(PerlIO_printf(Perl_debug_log,
1570 "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n",
1571 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1574 SvREFCNT_dec(PL_curpad[po]);
1577 /* if pad tmps aren't shared between ops, then there's no need to
1578 * create a new tmp when an existing op is freed */
1579 #ifdef USE_PAD_RESET
1580 PL_curpad[po] = newSV_type(SVt_NULL);
1581 SvPADTMP_on(PL_curpad[po]);
1583 PL_curpad[po] = NULL;
1585 if (PadnamelistMAX(PL_comppad_name) != -1
1586 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1587 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1588 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1590 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1592 /* Use PL_constpadix here, not PL_padix. The latter may have been
1593 reset by pad_reset. We don’t want pad_alloc to have to scan the
1594 whole pad when allocating a constant. */
1595 if (po < PL_constpadix)
1596 PL_constpadix = po - 1;
1600 =for apidoc pad_reset
1602 Mark all the current temporaries for reuse
1607 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1608 * between OPs from different statements. During compilation, at the start
1609 * of each statement pad_reset resets PL_padix back to its previous value.
1610 * When allocating a target, pad_alloc begins its scan through the pad at
1615 #ifdef USE_PAD_RESET
1616 if (AvARRAY(PL_comppad) != PL_curpad)
1617 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1618 AvARRAY(PL_comppad), PL_curpad);
1620 DEBUG_X(PerlIO_printf(Perl_debug_log,
1621 "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld",
1622 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1623 (long)PL_padix, (long)PL_padix_floor
1627 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1628 PL_padix = PL_padix_floor;
1631 PL_pad_reset_pending = FALSE;
1635 =for apidoc pad_tidy
1637 Tidy up a pad at the end of compilation of the code to which it belongs.
1638 Jobs performed here are: remove most stuff from the pads of anonsub
1639 prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
1640 the kind of subroutine:
1642 padtidy_SUB ordinary subroutine
1643 padtidy_SUBCLONE prototype for lexical closure
1644 padtidy_FORMAT format
1650 Perl_pad_tidy(pTHX_ padtidy_type type)
1653 ASSERT_CURPAD_ACTIVE("pad_tidy");
1655 /* If this CV has had any 'eval-capable' ops planted in it:
1656 * i.e. it contains any of:
1660 * * use re 'eval'; /$var/
1663 * Then any anon prototypes in the chain of CVs should be marked as
1664 * cloneable, so that for example the eval's CV in
1668 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1669 * potentially have an eval executed within it.
1672 if (PL_cv_has_eval || PL_perldb) {
1674 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1675 if (cv != PL_compcv && CvCOMPILED(cv))
1676 break; /* no need to mark already-compiled code */
1678 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1679 "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
1686 /* extend namepad to match curpad */
1687 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1688 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1690 if (type == padtidy_SUBCLONE) {
1691 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1694 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1696 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1699 * The only things that a clonable function needs in its
1700 * pad are anonymous subs, constants and GVs.
1701 * The rest are created anew during cloning.
1703 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1706 if (!(PadnamePV(namesv) &&
1707 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1709 SvREFCNT_dec(PL_curpad[ix]);
1710 PL_curpad[ix] = NULL;
1714 else if (type == padtidy_SUB) {
1715 AV * const av = newAV(); /* Will be @_ */
1716 av_store(PL_comppad, 0, MUTABLE_SV(av));
1720 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1721 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1723 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1724 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1725 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1727 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1728 /* This is a work around for how the current implementation of
1729 ?{ } blocks in regexps interacts with lexicals.
1731 One of our lexicals.
1732 Can't do this on all lexicals, otherwise sub baz() won't
1741 because completion of compiling &bar calling pad_tidy()
1742 would cause (top level) $foo to be marked as stale, and
1743 "no longer available". */
1744 SvPADSTALE_on(PL_curpad[ix]);
1748 PL_curpad = AvARRAY(PL_comppad);
1752 =for apidoc pad_free
1754 Free the SV at offset po in the current pad.
1760 Perl_pad_free(pTHX_ PADOFFSET po)
1762 #ifndef USE_PAD_RESET
1765 ASSERT_CURPAD_LEGAL("pad_free");
1768 if (AvARRAY(PL_comppad) != PL_curpad)
1769 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1770 AvARRAY(PL_comppad), PL_curpad);
1772 Perl_croak(aTHX_ "panic: pad_free po");
1774 DEBUG_X(PerlIO_printf(Perl_debug_log,
1775 "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
1776 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1779 #ifndef USE_PAD_RESET
1781 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1782 SvFLAGS(sv) &= ~SVs_PADTMP;
1790 =for apidoc do_dump_pad
1792 Dump the contents of a padlist
1798 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1800 const PADNAMELIST *pad_name;
1806 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1811 pad_name = PadlistNAMES(padlist);
1812 pad = PadlistARRAY(padlist)[1];
1813 pname = PadnamelistARRAY(pad_name);
1814 ppad = AvARRAY(pad);
1815 Perl_dump_indent(aTHX_ level, file,
1816 "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
1817 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1820 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1821 const PADNAME *namesv = pname[ix];
1822 if (namesv && !PadnameLEN(namesv)) {
1826 if (PadnameOUTER(namesv))
1827 Perl_dump_indent(aTHX_ level+1, file,
1828 "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1831 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1833 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1834 (unsigned long)PARENT_PAD_INDEX(namesv)
1838 Perl_dump_indent(aTHX_ level+1, file,
1839 "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
1842 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1843 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1844 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1849 Perl_dump_indent(aTHX_ level+1, file,
1850 "%2d. 0x%" UVxf "<%lu>\n",
1853 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1864 dump the contents of a CV
1870 S_cv_dump(pTHX_ const CV *cv, const char *title)
1872 const CV * const outside = CvOUTSIDE(cv);
1874 PERL_ARGS_ASSERT_CV_DUMP;
1876 PerlIO_printf(Perl_debug_log,
1877 " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
1880 (CvANON(cv) ? "ANON"
1881 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1882 : (cv == PL_main_cv) ? "MAIN"
1883 : CvUNIQUE(cv) ? "UNIQUE"
1884 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1887 : CvANON(outside) ? "ANON"
1888 : (outside == PL_main_cv) ? "MAIN"
1889 : CvUNIQUE(outside) ? "UNIQUE"
1890 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1892 if (!CvISXSUB(cv)) {
1893 /* SVPADLIST(cv) will fail an assert if CvISXSUB(cv) is true,
1894 * and if the assert is removed this code will SEGV. XSUBs don't
1895 * have padlists I believe - Yves */
1896 PADLIST* const padlist = CvPADLIST(cv);
1897 PerlIO_printf(Perl_debug_log,
1898 " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
1899 do_dump_pad(1, Perl_debug_log, padlist, 1);
1903 #endif /* DEBUGGING */
1906 =for apidoc cv_clone
1908 Clone a CV, making a lexical closure. C<proto> supplies the prototype
1909 of the function: its code, pad structure, and other attributes.
1910 The prototype is combined with a capture of outer lexicals to which the
1911 code refers, which are taken from the currently-executing instance of
1912 the immediately surrounding code.
1917 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1920 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1924 PADLIST* const protopadlist = CvPADLIST(proto);
1925 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1926 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1927 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1928 SV** const ppad = AvARRAY(protopad);
1929 const PADOFFSET fname = PadnamelistMAX(protopad_name);
1930 const PADOFFSET fpad = AvFILLp(protopad);
1934 bool trouble = FALSE;
1936 assert(!CvUNIQUE(proto));
1938 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1939 * reliable. The currently-running sub is always the one we need to
1941 * For my subs, the currently-running sub may not be the one we want.
1942 * We have to check whether it is a clone of CvOUTSIDE.
1943 * Note that in general for formats, CvOUTSIDE != find_runcv.
1944 * Since formats may be nested inside closures, CvOUTSIDE may point
1945 * to a prototype; we instead want the cloned parent who called us.
1949 if (CvWEAKOUTSIDE(proto))
1950 outside = find_runcv(NULL);
1952 outside = CvOUTSIDE(proto);
1953 if ((CvCLONE(outside) && ! CvCLONED(outside))
1954 || !CvPADLIST(outside)
1955 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1956 outside = find_runcv_where(
1957 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1959 /* outside could be null */
1963 depth = outside ? CvDEPTH(outside) : 0;
1968 SAVESPTR(PL_compcv);
1970 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1973 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1975 SAVESPTR(PL_comppad_name);
1976 PL_comppad_name = protopad_name;
1977 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1978 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1980 av_fill(PL_comppad, fpad);
1982 PL_curpad = AvARRAY(PL_comppad);
1984 outpad = outside && CvPADLIST(outside)
1985 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
1987 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
1989 for (ix = fpad; ix > 0; ix--) {
1990 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
1992 if (namesv && PadnameLEN(namesv)) { /* lexical */
1993 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
1997 if (PadnameOUTER(namesv)) { /* lexical from outside? */
1998 /* formats may have an inactive, or even undefined, parent;
1999 but state vars are always available. */
2000 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2001 || ( SvPADSTALE(sv) && !PadnameIsSTATE(namesv)
2002 && (!outside || !CvDEPTH(outside))) ) {
2003 S_unavailable(aTHX_ namesv);
2007 SvREFCNT_inc_simple_void_NN(sv);
2010 const char sigil = PadnamePV(namesv)[0];
2012 /* If there are state subs, we need to clone them, too.
2013 But they may need to close over variables we have
2014 not cloned yet. So we will have to do a second
2015 pass. Furthermore, there may be state subs clos-
2016 ing over other state subs’ entries, so we have
2017 to put a stub here and then clone into it on the
2019 if (PadnameIsSTATE(namesv) && !CvCLONED(ppad[ix])) {
2020 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2022 if (CvOUTSIDE(ppad[ix]) != proto)
2024 sv = newSV_type(SVt_PVCV);
2027 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2030 /* Just provide a stub, but name it. It will be
2031 upgraded to the real thing on scope entry. */
2033 PERL_HASH(hash, PadnamePV(namesv)+1,
2034 PadnameLEN(namesv) - 1);
2035 sv = newSV_type(SVt_PVCV);
2038 share_hek(PadnamePV(namesv)+1,
2039 1 - PadnameLEN(namesv),
2044 else sv = SvREFCNT_inc(ppad[ix]);
2045 else if (sigil == '@')
2046 sv = MUTABLE_SV(newAV());
2047 else if (sigil == '%')
2048 sv = MUTABLE_SV(newHV());
2050 sv = newSV_type(SVt_NULL);
2051 /* reset the 'assign only once' flag on each state var */
2052 if (sigil != '&' && PadnameIsSTATE(namesv))
2057 else if (namesv && PadnamePV(namesv)) {
2058 sv = SvREFCNT_inc_NN(ppad[ix]);
2061 sv = newSV_type(SVt_NULL);
2069 if (trouble || cloned) {
2070 /* Uh-oh, we have trouble! At least one of the state subs here
2071 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2072 could be pointing to another state protosub that we are
2073 about to clone. So we have to track which sub clones come
2074 from which protosubs. If the CvOUTSIDE pointer for a parti-
2075 cular sub points to something we have not cloned yet, we
2076 delay cloning it. We must loop through the pad entries,
2077 until we get a full pass with no cloning. If any uncloned
2078 subs remain (probably nested inside anonymous or ‘my’ subs),
2079 then they get cloned in a final pass.
2081 bool cloned_in_this_pass;
2083 cloned = (HV *)newSV_type_mortal(SVt_PVHV);
2085 cloned_in_this_pass = FALSE;
2086 for (ix = fpad; ix > 0; ix--) {
2087 PADNAME * const name =
2088 (ix <= fname) ? pname[ix] : NULL;
2089 if (name && name != &PL_padname_undef
2090 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2091 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2093 CV * const protokey = CvOUTSIDE(ppad[ix]);
2094 CV ** const cvp = protokey == proto
2096 : (CV **)hv_fetch(cloned, (char *)&protokey,
2099 S_cv_clone(aTHX_ (CV *)ppad[ix],
2100 (CV *)PL_curpad[ix],
2102 (void)hv_store(cloned, (char *)&ppad[ix],
2104 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2107 cloned_in_this_pass = TRUE;
2111 } while (cloned_in_this_pass);
2113 for (ix = fpad; ix > 0; ix--) {
2114 PADNAME * const name =
2115 (ix <= fname) ? pname[ix] : NULL;
2116 if (name && name != &PL_padname_undef
2117 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2118 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2119 S_cv_clone(aTHX_ (CV *)ppad[ix],
2120 (CV *)PL_curpad[ix],
2121 CvOUTSIDE(ppad[ix]), cloned);
2124 else for (ix = fpad; ix > 0; ix--) {
2125 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2126 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2127 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2128 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2133 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2137 /* Constant sub () { $x } closing over $x:
2138 * The prototype was marked as a candidate for const-ization,
2139 * so try to grab the current const value, and if successful,
2140 * turn into a const sub:
2143 OP *o = CvSTART(cv);
2145 for (; o; o = o->op_next)
2146 if (o->op_type == OP_PADSV)
2148 ASSUME(o->op_type == OP_PADSV);
2149 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2150 /* the candidate should have 1 ref from this pad and 1 ref
2151 * from the parent */
2152 if (const_sv && SvREFCNT(const_sv) == 2) {
2153 const bool was_method = cBOOL(CvNOWARN_AMBIGUOUS(cv));
2155 PADNAME * const pn =
2156 PadlistNAMESARRAY(CvPADLIST(outside))
2157 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2158 CvPADLIST(cv))[o->op_targ])];
2159 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2161 if (PadnameLVALUE(pn)) {
2162 /* We have a lexical that is potentially modifiable
2163 elsewhere, so making a constant will break clo-
2164 sure behaviour. If this is a ‘simple lexical
2165 op tree’, i.e., sub(){$x}, emit a deprecation
2166 warning, but continue to exhibit the old behav-
2167 iour of making it a constant based on the ref-
2168 count of the candidate variable.
2170 A simple lexical op tree looks like this:
2178 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2183 "Constants from lexical variables potentially modified "
2184 "elsewhere are no longer permitted");
2190 SvREFCNT_inc_simple_void_NN(const_sv);
2191 /* If the lexical is not used elsewhere, it is safe to turn on
2192 SvPADTMP, since it is only when it is used in lvalue con-
2193 text that the difference is observable. */
2194 SvREADONLY_on(const_sv);
2195 SvPADTMP_on(const_sv);
2196 SvREFCNT_dec_NN(cv);
2197 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2199 CvNOWARN_AMBIGUOUS_on(cv);
2211 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2213 const bool newcv = !cv;
2215 assert(!CvUNIQUE(proto));
2217 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2218 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2222 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2225 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2226 else CvGV_set(cv,CvGV(proto));
2227 CvSTASH_set(cv, CvSTASH(proto));
2229 /* It is unlikely that proto is an xsub, but it could happen; e.g. if a
2230 * module has performed a lexical sub import trick on an xsub. This
2231 * happens with builtin::import, for example
2233 if (UNLIKELY(CvISXSUB(proto))) {
2234 CvXSUB(cv) = CvXSUB(proto);
2235 CvXSUBANY(cv) = CvXSUBANY(proto);
2236 if (CvREFCOUNTED_ANYSV(cv))
2237 SvREFCNT_inc(CvXSUBANY(cv).any_sv);
2241 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2243 CvSTART(cv) = CvSTART(proto);
2244 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2248 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2250 SvUTF8_on(MUTABLE_SV(cv));
2253 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2255 if (!CvISXSUB(proto) && CvPADLIST(proto))
2256 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2259 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2260 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2261 cv_dump(proto, "Proto");
2269 Perl_cv_clone(pTHX_ CV *proto)
2271 PERL_ARGS_ASSERT_CV_CLONE;
2273 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2274 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2277 /* Called only by pp_clonecv */
2279 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2281 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2283 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2289 Returns an SV containing the name of the CV, mainly for use in error
2290 reporting. The CV may actually be a GV instead, in which case the returned
2291 SV holds the GV's name. Anything other than a GV or CV is treated as a
2292 string already holding the sub name, but this could change in the future.
2294 An SV may be passed as a second argument. If so, the name will be assigned
2295 to it and it will be returned. Otherwise the returned SV will be a new
2298 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2299 included. If the first argument is neither a CV nor a GV, this flag is
2300 ignored (subject to change).
2302 =for apidoc Amnh||CV_NAME_NOTQUAL
2308 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2310 PERL_ARGS_ASSERT_CV_NAME;
2311 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2312 if (sv) sv_setsv(sv,(SV *)cv);
2313 return sv ? (sv) : (SV *)cv;
2316 SV * const retsv = sv ? (sv) : sv_newmortal();
2317 if (SvTYPE(cv) == SVt_PVCV) {
2319 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2320 sv_sethek(retsv, CvNAME_HEK(cv));
2322 if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
2323 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2325 sv_setpvs(retsv, "__ANON__");
2326 sv_catpvs(retsv, "::");
2327 sv_cathek(retsv, CvNAME_HEK(cv));
2330 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2331 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2332 else gv_efullname3(retsv, CvGV(cv), NULL);
2334 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2335 else gv_efullname3(retsv,(GV *)cv,NULL);
2341 =for apidoc pad_fixup_inner_anons
2343 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2344 C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
2345 moved to a pre-existing CV struct.
2351 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2354 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2355 AV * const comppad = PadlistARRAY(padlist)[1];
2356 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2357 SV ** const curpad = AvARRAY(comppad);
2359 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2360 PERL_UNUSED_ARG(old_cv);
2362 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2363 const PADNAME *name = namepad[ix];
2364 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2365 && *PadnamePV(name) == '&')
2367 CV *innercv = MUTABLE_CV(curpad[ix]);
2368 if (UNLIKELY(PadnameOUTER(name))) {
2370 PADNAME **names = namepad;
2372 while (PadnameOUTER(name)) {
2373 assert(SvTYPE(cv) == SVt_PVCV);
2375 names = PadlistNAMESARRAY(CvPADLIST(cv));
2376 i = PARENT_PAD_INDEX(name);
2379 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2381 if (SvTYPE(innercv) == SVt_PVCV) {
2382 /* XXX 0afba48f added code here to check for a proto CV
2383 attached to the pad entry by magic. But shortly there-
2384 after 81df9f6f95 moved the magic to the pad name. The
2385 code here was never updated, so it wasn’t doing anything
2386 and got deleted when PADNAME became a distinct type. Is
2387 there any bug as a result? */
2388 if (CvOUTSIDE(innercv) == old_cv) {
2389 if (!CvWEAKOUTSIDE(innercv)) {
2390 SvREFCNT_dec(old_cv);
2391 SvREFCNT_inc_simple_void_NN(new_cv);
2393 CvOUTSIDE(innercv) = new_cv;
2396 else { /* format reference */
2397 SV * const rv = curpad[ix];
2399 if (!SvOK(rv)) continue;
2401 assert(SvWEAKREF(rv));
2402 innercv = (CV *)SvRV(rv);
2403 assert(!CvWEAKOUTSIDE(innercv));
2404 assert(CvOUTSIDE(innercv) == old_cv);
2405 SvREFCNT_dec(CvOUTSIDE(innercv));
2406 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2413 =for apidoc pad_push
2415 Push a new pad frame onto the padlist, unless there's already a pad at
2416 this depth, in which case don't bother creating a new one. Then give
2417 the new pad an C<@_> in slot zero.
2423 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2425 PERL_ARGS_ASSERT_PAD_PUSH;
2427 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2428 PAD** const svp = PadlistARRAY(padlist);
2429 AV* const newpad = newAV();
2430 SV** const oldpad = AvARRAY(svp[depth-1]);
2431 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
2432 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2433 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2436 Newxz( AvALLOC(newpad), ix + 1, SV *);
2437 AvARRAY(newpad) = AvALLOC(newpad);
2438 AvMAX(newpad) = AvFILLp(newpad) = ix;
2440 for ( ;ix > 0; ix--) {
2442 if (names_fill >= ix && PadnameLEN(names[ix])) {
2443 const char sigil = PadnamePV(names[ix])[0];
2444 if (PadnameOUTER(names[ix])
2445 || PadnameIsSTATE(names[ix])
2448 /* outer lexical or anon code */
2449 sv = SvREFCNT_inc(oldpad[ix]);
2451 else { /* our own lexical */
2453 sv = MUTABLE_SV(newAV());
2454 else if (sigil == '%')
2455 sv = MUTABLE_SV(newHV());
2457 sv = newSV_type(SVt_NULL);
2460 else if (PadnamePV(names[ix])) {
2461 sv = SvREFCNT_inc_NN(oldpad[ix]);
2464 /* save temporaries on recursion? */
2465 sv = newSV_type(SVt_NULL);
2468 AvARRAY(newpad)[ix] = sv;
2471 AvARRAY(newpad)[0] = MUTABLE_SV(av);
2474 padlist_store(padlist, depth, newpad);
2478 #if defined(USE_ITHREADS)
2481 =for apidoc padlist_dup
2489 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2495 PERL_ARGS_ASSERT_PADLIST_DUP;
2497 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2498 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2500 max = cloneall ? PadlistMAX(srcpad) : 1;
2502 Newx(dstpad, 1, PADLIST);
2503 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2504 PadlistMAX(dstpad) = max;
2505 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2507 PadlistARRAY(dstpad)[0] = (PAD *)padnamelist_dup_inc(PadlistNAMES(srcpad), param);
2510 for (depth = 1; depth <= max; ++depth)
2511 PadlistARRAY(dstpad)[depth] =
2512 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2514 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2515 to build anything other than the first level of pads. */
2516 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2518 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2519 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2520 SV **oldpad = AvARRAY(srcpad1);
2521 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2527 av_extend(pad1, ix);
2528 PadlistARRAY(dstpad)[1] = pad1;
2529 pad1a = AvARRAY(pad1);
2534 for ( ;ix > 0; ix--) {
2537 } else if (names_fill >= ix && names[ix] &&
2538 PadnameLEN(names[ix])) {
2539 const char sigil = PadnamePV(names[ix])[0];
2540 if (PadnameOUTER(names[ix])
2541 || PadnameIsSTATE(names[ix])
2544 /* outer lexical or anon code */
2545 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2547 else { /* our own lexical */
2548 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2549 /* This is a work around for how the current
2550 implementation of ?{ } blocks in regexps
2551 interacts with lexicals. */
2552 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2557 sv = MUTABLE_SV(newAV());
2558 else if (sigil == '%')
2559 sv = MUTABLE_SV(newHV());
2561 sv = newSV_type(SVt_NULL);
2566 else if (( names_fill >= ix && names[ix]
2567 && PadnamePV(names[ix]) )) {
2568 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2571 /* save temporaries on recursion? */
2572 SV * const sv = newSV_type(SVt_NULL);
2575 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2576 FIXTHAT before merging this branch.
2577 (And I know how to) */
2578 if (SvPADTMP(oldpad[ix]))
2584 args = newAV(); /* Will be @_ */
2586 pad1a[0] = (SV *)args;
2594 #endif /* USE_ITHREADS */
2597 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2600 SSize_t const oldmax = PadlistMAX(padlist);
2602 PERL_ARGS_ASSERT_PADLIST_STORE;
2606 if (key > PadlistMAX(padlist)) {
2607 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2608 (SV ***)&PadlistARRAY(padlist),
2609 (SV ***)&PadlistARRAY(padlist));
2610 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2613 ary = PadlistARRAY(padlist);
2614 SvREFCNT_dec(ary[key]);
2620 =for apidoc newPADNAMELIST
2622 Creates a new pad name list. C<max> is the highest index for which space
2629 Perl_newPADNAMELIST(size_t max)
2632 Newx(pnl, 1, PADNAMELIST);
2633 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2634 PadnamelistMAX(pnl) = -1;
2635 PadnamelistREFCNT(pnl) = 1;
2636 PadnamelistMAXNAMED(pnl) = 0;
2637 pnl->xpadnl_max = max;
2642 =for apidoc padnamelist_store
2644 Stores the pad name (which may be null) at the given index, freeing any
2645 existing pad name in that slot.
2651 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2655 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2659 if (key > pnl->xpadnl_max)
2660 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2661 (SV ***)&PadnamelistARRAY(pnl),
2662 (SV ***)&PadnamelistARRAY(pnl));
2663 if (PadnamelistMAX(pnl) < key) {
2664 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2665 key-PadnamelistMAX(pnl), PADNAME *);
2666 PadnamelistMAX(pnl) = key;
2668 ary = PadnamelistARRAY(pnl);
2670 PadnameREFCNT_dec(ary[key]);
2676 =for apidoc padnamelist_fetch
2678 Fetches the pad name from the given index.
2684 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2686 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2689 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2693 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2695 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2696 if (!--PadnamelistREFCNT(pnl)) {
2697 while(PadnamelistMAX(pnl) >= 0)
2699 PADNAME * const pn =
2700 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2702 PadnameREFCNT_dec(pn);
2704 Safefree(PadnamelistARRAY(pnl));
2709 #if defined(USE_ITHREADS)
2712 =for apidoc padnamelist_dup
2714 Duplicates a pad name list.
2720 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2722 PADNAMELIST *dstpad;
2723 SSize_t max = PadnamelistMAX(srcpad);
2725 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2727 /* look for it in the table first */
2728 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2732 dstpad = newPADNAMELIST(max);
2733 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2734 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2735 PadnamelistMAX(dstpad) = max;
2737 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2738 for (; max >= 0; max--)
2739 if (PadnamelistARRAY(srcpad)[max]) {
2740 PadnamelistARRAY(dstpad)[max] =
2741 padname_dup_inc(PadnamelistARRAY(srcpad)[max], param);
2747 #endif /* USE_ITHREADS */
2750 =for apidoc newPADNAMEpvn
2752 Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
2753 use this for pad names that point to outer lexicals. See
2754 C<L</newPADNAMEouter>>.
2760 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2762 struct padname_with_str *alloc;
2763 char *alloc2; /* for Newxz */
2765 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2767 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2769 alloc = (struct padname_with_str *)alloc2;
2770 pn = (PADNAME *)alloc;
2771 PadnameREFCNT(pn) = 1;
2772 PadnamePV(pn) = alloc->xpadn_str;
2773 Copy(s, PadnamePV(pn), len, char);
2774 *(PadnamePV(pn) + len) = '\0';
2775 PadnameLEN(pn) = len;
2780 =for apidoc newPADNAMEouter
2782 Constructs and returns a new pad name. Only use this function for names
2783 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
2784 the outer pad name that this one mirrors. The returned pad name has the
2785 C<PADNAMEf_OUTER> flag already set.
2787 =for apidoc Amnh||PADNAMEf_OUTER
2793 Perl_newPADNAMEouter(PADNAME *outer)
2796 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2797 Newxz(pn, 1, PADNAME);
2798 PadnameREFCNT(pn) = 1;
2799 PadnamePV(pn) = PadnamePV(outer);
2800 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2801 another entry. The original pad name owns the buffer. */
2802 PadnameREFCNT_inc(PADNAME_FROM_PV(PadnamePV(outer)));
2803 PadnameFLAGS(pn) = PADNAMEf_OUTER;
2804 if(PadnameIsFIELD(outer)) {
2805 PadnameFIELDINFO(pn) = PadnameFIELDINFO(outer);
2806 PadnameFIELDINFO(pn)->refcount++;
2807 PadnameFLAGS(pn) |= PADNAMEf_FIELD;
2809 PadnameLEN(pn) = PadnameLEN(outer);
2814 Perl_padname_free(pTHX_ PADNAME *pn)
2816 PERL_ARGS_ASSERT_PADNAME_FREE;
2817 if (!--PadnameREFCNT(pn)) {
2818 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2819 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2822 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2823 SvREFCNT_dec(PadnameOURSTASH(pn));
2824 if (PadnameOUTER(pn))
2825 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2826 if (PadnameIsFIELD(pn)) {
2827 struct padname_fieldinfo *info = PadnameFIELDINFO(pn);
2828 if(!--info->refcount) {
2829 SvREFCNT_dec(info->fieldstash);
2830 /* todo: something about defop */
2831 SvREFCNT_dec(info->paramname);
2840 #if defined(USE_ITHREADS)
2843 =for apidoc padname_dup
2845 Duplicates a pad name.
2851 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2855 PERL_ARGS_ASSERT_PADNAME_DUP;
2857 /* look for it in the table first */
2858 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2862 if (!PadnamePV(src)) {
2863 dst = &PL_padname_undef;
2864 ptr_table_store(PL_ptr_table, src, dst);
2868 dst = PadnameOUTER(src)
2869 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2870 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2871 ptr_table_store(PL_ptr_table, src, dst);
2872 PadnameLEN(dst) = PadnameLEN(src);
2873 PadnameFLAGS(dst) = PadnameFLAGS(src);
2874 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2875 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2876 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2878 if(PadnameIsFIELD(src) && !PadnameOUTER(src)) {
2879 struct padname_fieldinfo *sinfo = PadnameFIELDINFO(src);
2880 struct padname_fieldinfo *dinfo;
2881 Newxz(dinfo, 1, struct padname_fieldinfo);
2883 dinfo->refcount = 1;
2884 dinfo->fieldix = sinfo->fieldix;
2885 dinfo->fieldstash = hv_dup_inc(sinfo->fieldstash, param);
2886 dinfo->paramname = sv_dup_inc(sinfo->paramname, param);
2888 PadnameFIELDINFO(dst) = dinfo;
2890 dst->xpadn_low = src->xpadn_low;
2891 dst->xpadn_high = src->xpadn_high;
2892 dst->xpadn_gen = src->xpadn_gen;
2896 #endif /* USE_ITHREADS */
2899 =for apidoc_section $lexer
2900 =for apidoc suspend_compcv
2902 Implements part of the concept of a "suspended compilation CV", which can be
2903 used to pause the parser and compiler during parsing a CV in order to come
2904 back to it later on.
2906 This function saves the current state of the subroutine under compilation
2907 (C<PL_compcv>) into the supplied buffer. This should be used initially to
2908 create the state in the buffer, as the final thing before a C<LEAVE> within a
2915 suspend_compcv(&buffer);
2918 Once suspended, the C<resume_compcv> or C<resume_compcv_and_save> function can
2919 later be used to continue the parsing from the point this stopped.
2925 Perl_suspend_compcv(pTHX_ struct suspended_compcv *buffer)
2927 PERL_ARGS_ASSERT_SUSPEND_COMPCV;
2929 buffer->compcv = PL_compcv;
2931 buffer->padix = PL_padix;
2932 buffer->constpadix = PL_constpadix;
2934 buffer->comppad_name_fill = PL_comppad_name_fill;
2935 buffer->min_intro_pending = PL_min_intro_pending;
2936 buffer->max_intro_pending = PL_max_intro_pending;
2938 buffer->cv_has_eval = PL_cv_has_eval;
2939 buffer->pad_reset_pending = PL_pad_reset_pending;
2943 =for apidoc resume_compcv_final
2945 Resumes the parser state previously saved using the C<suspend_compcv> function
2946 for a final time before being compiled into a full CV. This should be used
2947 within an C<ENTER>/C<LEAVE> scoped pair.
2949 =for apidoc resume_compcv_and_save
2951 Resumes a buffer previously suspended by the C<suspend_compcv> function, in a
2952 way that will be re-suspended at the end of the scope so it can be used again
2953 later. This should be used within an C<ENTER>/C<LEAVE> scoped pair.
2959 Perl_resume_compcv(pTHX_ struct suspended_compcv *buffer, bool save)
2961 PERL_ARGS_ASSERT_RESUME_COMPCV;
2963 SAVESPTR(PL_compcv);
2964 PL_compcv = buffer->compcv;
2965 PAD_SET_CUR(CvPADLIST(PL_compcv), 1);
2967 SAVESPTR(PL_comppad_name);
2968 PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv));
2970 SAVESTRLEN(PL_padix); PL_padix = buffer->padix;
2971 SAVESTRLEN(PL_constpadix); PL_constpadix = buffer->constpadix;
2972 SAVESTRLEN(PL_comppad_name_fill); PL_comppad_name_fill = buffer->comppad_name_fill;
2973 SAVESTRLEN(PL_min_intro_pending); PL_min_intro_pending = buffer->min_intro_pending;
2974 SAVESTRLEN(PL_max_intro_pending); PL_max_intro_pending = buffer->max_intro_pending;
2976 SAVEBOOL(PL_cv_has_eval); PL_cv_has_eval = buffer->cv_has_eval;
2977 SAVEBOOL(PL_pad_reset_pending); PL_pad_reset_pending = buffer->pad_reset_pending;
2980 SAVEDESTRUCTOR_X(&Perl_suspend_compcv, buffer);
2984 * ex: set ts=8 sts=4 sw=4 et: