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 dont 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 { /* dont 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;
569 padnamelist_store(PL_comppad_name, offset, name);
570 if (PadnameLEN(name) > 1)
571 PadnamelistMAXNAMED(PL_comppad_name) = offset;
576 =for apidoc pad_add_name_pvn
578 Allocates a place in the currently-compiling pad for a named lexical
579 variable. Stores the name and other metadata in the name part of the
580 pad, and makes preparations to manage the variable's lexical scoping.
581 Returns the offset of the allocated pad slot.
583 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
584 If C<typestash> is non-null, the name is for a typed lexical, and this
585 identifies the type. If C<ourstash> is non-null, it's a lexical reference
586 to a package variable, and this identifies the package. The following
587 flags can be OR'ed together:
589 padadd_OUR redundantly specifies if it's a package var
590 padadd_STATE variable will retain value persistently
591 padadd_NO_DUP_CHECK skip check for lexical shadowing
597 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
598 U32 flags, HV *typestash, HV *ourstash)
603 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
605 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
606 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
609 name = newPADNAMEpvn(namepv, namelen);
611 if ((flags & padadd_NO_DUP_CHECK) == 0) {
613 SAVEFREEPADNAME(name); /* in case of fatal warnings */
614 /* check for duplicate declaration */
615 pad_check_dup(name, flags & padadd_OUR, ourstash);
616 PadnameREFCNT_inc(name);
620 offset = pad_alloc_name(name, flags, typestash, ourstash);
622 /* not yet introduced */
623 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
624 COP_SEQ_RANGE_HIGH_set(name, 0);
626 if (!PL_min_intro_pending)
627 PL_min_intro_pending = offset;
628 PL_max_intro_pending = offset;
629 /* if it's not a simple scalar, replace with an AV or HV */
630 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
631 assert(SvREFCNT(PL_curpad[offset]) == 1);
632 if (namelen != 0 && *namepv == '@')
633 sv_upgrade(PL_curpad[offset], SVt_PVAV);
634 else if (namelen != 0 && *namepv == '%')
635 sv_upgrade(PL_curpad[offset], SVt_PVHV);
636 else if (namelen != 0 && *namepv == '&')
637 sv_upgrade(PL_curpad[offset], SVt_PVCV);
638 assert(SvPADMY(PL_curpad[offset]));
639 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
640 "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n",
641 (long)offset, PadnamePV(name),
642 PTR2UV(PL_curpad[offset])));
648 =for apidoc pad_add_name_pv
650 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
651 instead of a string/length pair.
657 Perl_pad_add_name_pv(pTHX_ const char *name,
658 const U32 flags, HV *typestash, HV *ourstash)
660 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
661 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
665 =for apidoc pad_add_name_sv
667 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
668 of an SV instead of a string/length pair.
674 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
678 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
679 namepv = SvPVutf8(name, namelen);
680 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
684 =for apidoc pad_alloc
686 Allocates a place in the currently-compiling pad,
687 returning the offset of the allocated pad slot.
688 No name is initially attached to the pad slot.
689 C<tmptype> is a set of flags indicating the kind of pad entry required,
690 which will be set in the value SV for the allocated pad entry:
692 SVs_PADMY named lexical variable ("my", "our", "state")
693 SVs_PADTMP unnamed temporary store
694 SVf_READONLY constant shared between recursion levels
696 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
697 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
698 does not cause the SV in the pad slot to be marked read-only, but simply
699 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
700 least should be treated as such.
702 C<optype> should be an opcode indicating the type of operation that the
703 pad entry is to support. This doesn't affect operational semantics,
704 but is used for debugging.
710 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
715 PERL_UNUSED_ARG(optype);
716 ASSERT_CURPAD_ACTIVE("pad_alloc");
718 if (AvARRAY(PL_comppad) != PL_curpad)
719 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
720 AvARRAY(PL_comppad), PL_curpad);
721 if (PL_pad_reset_pending)
723 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
724 /* For a my, simply push a null SV onto the end of PL_comppad. */
725 sv = *av_store_simple(PL_comppad, AvFILLp(PL_comppad) + 1, newSV_type(SVt_NULL));
726 retval = (PADOFFSET)AvFILLp(PL_comppad);
729 /* For a tmp, scan the pad from PL_padix upwards
730 * for a slot which has no name and no active value.
731 * For a constant, likewise, but use PL_constpadix.
733 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
734 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
735 const bool konst = cBOOL(tmptype & SVf_READONLY);
736 retval = konst ? PL_constpadix : PL_padix;
739 * Entries that close over unavailable variables
740 * in outer subs contain values not marked PADMY.
741 * Thus we must skip, not just pad values that are
742 * marked as current pad values, but also those with names.
743 * If pad_reset is enabled, ‘current’ means different
744 * things depending on whether we are allocating a con-
745 * stant or a target. For a target, things marked PADTMP
746 * can be reused; not so for constants.
749 if (++retval <= names_fill &&
750 (pn = names[retval]) && PadnamePV(pn))
752 sv = *av_fetch_simple(PL_comppad, retval, TRUE);
755 (konst ? SVs_PADTMP : 0)
763 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
764 tmptype &= ~SVf_READONLY;
765 tmptype |= SVs_PADTMP;
767 *(konst ? &PL_constpadix : &PL_padix) = retval;
769 SvFLAGS(sv) |= tmptype;
770 PL_curpad = AvARRAY(PL_comppad);
772 DEBUG_X(PerlIO_printf(Perl_debug_log,
773 "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n",
774 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
775 PL_op_name[optype]));
776 #ifdef DEBUG_LEAKING_SCALARS
777 sv->sv_debug_optype = optype;
778 sv->sv_debug_inpad = 1;
784 =for apidoc pad_add_anon
786 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
787 for an anonymous function that is lexically scoped inside the
788 currently-compiling function.
789 The function C<func> is linked into the pad, and its C<CvOUTSIDE> link
790 to the outer scope is weakened to avoid a reference loop.
792 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
794 C<optype> should be an opcode indicating the type of operation that the
795 pad entry is to support. This doesn't affect operational semantics,
796 but is used for debugging.
802 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
805 PADNAME * const name = newPADNAMEpvn("&", 1);
807 PERL_ARGS_ASSERT_PAD_ADD_ANON;
808 assert (SvTYPE(func) == SVt_PVCV);
811 /* These two aren't used; just make sure they're not equal to
812 * PERL_PADSEQ_INTRO. They should be 0 by default. */
813 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
814 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
815 ix = pad_alloc(optype, SVs_PADMY);
816 padnamelist_store(PL_comppad_name, ix, name);
817 av_store(PL_comppad, ix, (SV*)func);
819 /* to avoid ref loops, we never have parent + child referencing each
820 * other simultaneously */
821 if (CvOUTSIDE(func)) {
822 assert(!CvWEAKOUTSIDE(func));
823 CvWEAKOUTSIDE_on(func);
824 SvREFCNT_dec_NN(CvOUTSIDE(func));
830 Perl_pad_add_weakref(pTHX_ CV* func)
832 const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY);
833 PADNAME * const name = newPADNAMEpvn("&", 1);
834 SV * const rv = newRV_inc((SV *)func);
836 PERL_ARGS_ASSERT_PAD_ADD_WEAKREF;
838 /* These two aren't used; just make sure they're not equal to
839 * PERL_PADSEQ_INTRO. They should be 0 by default. */
840 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
841 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
842 padnamelist_store(PL_comppad_name, ix, name);
844 av_store(PL_comppad, ix, rv);
848 =for apidoc pad_check_dup
850 Check for duplicate declarations: report any of:
852 * a 'my' in the current scope with the same name;
853 * an 'our' (anywhere in the pad) with the same name and the
854 same stash as 'ourstash'
856 C<is_our> indicates that the name to check is an C<"our"> declaration.
862 S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash)
866 const U32 is_our = flags & padadd_OUR;
868 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
870 ASSERT_CURPAD_ACTIVE("pad_check_dup");
872 assert((flags & ~padadd_OUR) == 0);
874 if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW))
875 return; /* nothing to check */
877 svp = PadnamelistARRAY(PL_comppad_name);
878 top = PadnamelistMAX(PL_comppad_name);
879 /* check the current scope */
880 for (off = top; off > PL_comppad_name_floor; off--) {
881 PADNAME * const pn = svp[off];
883 && PadnameLEN(pn) == PadnameLEN(name)
885 && ( COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO
886 || COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO)
887 && memEQ(PadnamePV(pn), PadnamePV(name), PadnameLEN(name)))
889 if (is_our && (PadnameIsOUR(pn)))
890 break; /* "our" masking "our" */
891 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
892 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
893 "\"%s\" %s %" PNf " masks earlier declaration in same %s",
895 PL_parser->in_my == KEY_my ? "my" :
896 PL_parser->in_my == KEY_sigvar ? "my" :
898 *PadnamePV(pn) == '&' ? "subroutine" : "variable",
900 (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO
901 ? "scope" : "statement"));
906 /* check the rest of the pad */
909 PADNAME * const pn = svp[off];
911 && PadnameLEN(pn) == PadnameLEN(name)
913 && ( COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO
914 || COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO)
915 && PadnameOURSTASH(pn) == ourstash
916 && memEQ(PadnamePV(pn), PadnamePV(name), PadnameLEN(name)))
918 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
919 "\"our\" variable %" PNf " redeclared", PNfARG(pn));
920 if (off <= PL_comppad_name_floor)
921 Perl_warner(aTHX_ packWARN(WARN_SHADOW),
922 "\t(Did you mean \"local\" instead of \"our\"?)\n");
932 =for apidoc pad_findmy_pvn
934 Given the name of a lexical variable, find its position in the
935 currently-compiling pad.
936 C<namepv>/C<namelen> specify the variable's name, including leading sigil.
937 C<flags> is reserved and must be zero.
938 If it is not in the current pad but appears in the pad of any lexically
939 enclosing scope, then a pseudo-entry for it is added in the current pad.
940 Returns the offset in the current pad,
941 or C<NOT_IN_PAD> if no such lexical is in scope.
947 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
952 const PADNAMELIST *namelist;
955 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
957 pad_peg("pad_findmy_pvn");
960 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
963 /* compilation errors can zero PL_compcv */
967 offset = pad_findlex(namepv, namelen, flags,
968 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
969 if (offset != NOT_IN_PAD)
972 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
974 if (*namepv == '&') return NOT_IN_PAD;
976 /* look for an our that's being introduced; this allows
977 * our $foo = 0 unless defined $foo;
978 * to not give a warning. (Yes, this is a hack) */
980 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
981 name_p = PadnamelistARRAY(namelist);
982 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
983 const PADNAME * const name = name_p[offset];
984 if (name && PadnameLEN(name) == namelen
985 && !PadnameOUTER(name)
986 && (PadnameIsOUR(name))
987 && ( PadnamePV(name) == namepv
988 || memEQ(PadnamePV(name), namepv, namelen) )
989 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
997 =for apidoc pad_findmy_pv
999 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1000 instead of a string/length pair.
1006 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1008 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1009 return pad_findmy_pvn(name, strlen(name), flags);
1013 =for apidoc pad_findmy_sv
1015 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1016 of an SV instead of a string/length pair.
1022 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1026 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1027 namepv = SvPVutf8(name, namelen);
1028 return pad_findmy_pvn(namepv, namelen, flags);
1032 =for apidoc find_rundefsv
1034 Returns the global variable C<$_>.
1040 Perl_find_rundefsv(pTHX)
1046 =for apidoc pad_findlex
1048 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1049 in the inner pads if it's found in an outer one.
1051 Returns the offset in the bottom pad of the lex or the fake lex.
1052 C<cv> is the CV in which to start the search, and seq is the current C<cop_seq>
1053 to match against. If C<warn> is true, print appropriate warnings. The C<out_>*
1054 vars return values, and so are pointers to where the returned values
1055 should be stored. C<out_capture>, if non-null, requests that the innermost
1056 instance of the lexical is captured; C<out_name> is set to the innermost
1057 matched pad name or fake pad name; C<out_flags> returns the flags normally
1058 associated with the C<PARENT_FAKELEX_FLAGS> field of a fake pad name.
1060 Note that C<pad_findlex()> is recursive; it recurses up the chain of CVs,
1061 then comes back down, adding fake entries
1062 as it goes. It has to be this way
1063 because fake names in anon prototypes have to store in C<xpadn_low> the
1064 index into the parent pad.
1069 /* the CV has finished being compiled. This is not a sufficient test for
1070 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1071 #define CvCOMPILED(cv) CvROOT(cv)
1073 /* the CV does late binding of its lexicals */
1074 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1077 S_unavailable(pTHX_ PADNAME *name)
1079 /* diag_listed_as: Variable "%s" is not available */
1080 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1081 "%s \"%" PNf "\" is not available",
1082 *PadnamePV(name) == '&'
1089 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1090 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1092 PADOFFSET offset, new_offset;
1095 const PADLIST * const padlist = CvPADLIST(cv);
1096 const bool staleok = cBOOL(flags & padadd_STALEOK);
1098 PERL_ARGS_ASSERT_PAD_FINDLEX;
1100 flags &= ~ padadd_STALEOK; /* one-shot flag */
1102 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1107 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1108 "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n",
1109 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1110 out_capture ? " capturing" : "" ));
1112 /* first, search this pad */
1114 if (padlist) { /* not an undef CV */
1115 PADOFFSET fake_offset = 0;
1116 const PADNAMELIST * const names = PadlistNAMES(padlist);
1117 PADNAME * const * const name_p = PadnamelistARRAY(names);
1119 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1120 const PADNAME * const name = name_p[offset];
1121 if (name && PadnameLEN(name) == namelen
1122 && ( PadnamePV(name) == namepv
1123 || memEQ(PadnamePV(name), namepv, namelen) ))
1125 if (PadnameOUTER(name)) {
1126 fake_offset = offset; /* in case we don't find a real one */
1129 if (PadnameIN_SCOPE(name, seq))
1134 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1135 if (offset > 0) { /* not fake */
1137 *out_name = name_p[offset]; /* return the name */
1139 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1140 * instances. For now, we just test !CvUNIQUE(cv), but
1141 * ideally, we should detect my's declared within loops
1142 * etc - this would allow a wider range of 'not stayed
1143 * shared' warnings. We also treated already-compiled
1144 * lexes as not multi as viewed from evals. */
1146 *out_flags = CvANON(cv) ?
1148 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1149 ? PAD_FAKELEX_MULTI : 0;
1151 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1152 "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n",
1153 PTR2UV(cv), (long)offset,
1154 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1155 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1157 else { /* fake match */
1158 offset = fake_offset;
1159 *out_name = name_p[offset]; /* return the name */
1160 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1161 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1162 "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n",
1163 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1164 (unsigned long) PARENT_PAD_INDEX(*out_name)
1168 /* return the lex? */
1173 if (PadnameIsOUR(*out_name)) {
1174 *out_capture = NULL;
1178 /* trying to capture from an anon prototype? */
1180 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1181 : *out_flags & PAD_FAKELEX_ANON)
1187 *out_capture = NULL;
1193 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1194 && !PadnameIsSTATE(name_p[offset])
1195 && warn && ckWARN(WARN_CLOSURE)) {
1197 /* diag_listed_as: Variable "%s" will not stay
1199 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1200 "%s \"%" UTF8f "\" will not stay shared",
1201 *namepv == '&' ? "Subroutine" : "Variable",
1202 UTF8fARG(1, namelen, namepv));
1205 if (fake_offset && CvANON(cv)
1206 && CvCLONE(cv) &&!CvCLONED(cv))
1209 /* not yet caught - look further up */
1210 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1211 "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n",
1214 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1216 newwarn, out_capture, out_name, out_flags);
1221 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1222 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1223 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1224 "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n",
1225 PTR2UV(cv), PTR2UV(*out_capture)));
1227 if (SvPADSTALE(*out_capture)
1228 && (!CvDEPTH(cv) || !staleok)
1229 && !PadnameIsSTATE(name_p[offset]))
1233 *out_capture = NULL;
1236 if (!*out_capture) {
1237 if (namelen != 0 && *namepv == '@')
1238 *out_capture = newSV_type_mortal(SVt_PVAV);
1239 else if (namelen != 0 && *namepv == '%')
1240 *out_capture = newSV_type_mortal(SVt_PVHV);
1241 else if (namelen != 0 && *namepv == '&')
1242 *out_capture = newSV_type_mortal(SVt_PVCV);
1244 *out_capture = newSV_type_mortal(SVt_NULL);
1252 /* it's not in this pad - try above */
1257 /* out_capture non-null means caller wants us to capture lex; in
1258 * addition we capture ourselves unless it's an ANON/format */
1259 new_capturep = out_capture ? out_capture :
1260 CvLATE(cv) ? NULL : &new_capture;
1262 offset = pad_findlex(namepv, namelen,
1263 flags | padadd_STALEOK*(new_capturep == &new_capture),
1264 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1265 new_capturep, out_name, out_flags);
1266 if (offset == NOT_IN_PAD)
1269 /* found in an outer CV. Add appropriate fake entry to this pad */
1271 /* don't add new fake entries (via eval) to CVs that we have already
1272 * finished compiling, or to undef CVs */
1273 if (CvCOMPILED(cv) || !padlist)
1274 return 0; /* this dummy (and invalid) value isnt used by the caller */
1277 PADNAME *new_name = newPADNAMEouter(*out_name);
1278 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1279 PAD * const ocomppad = PL_comppad;
1280 PL_comppad_name = PadlistNAMES(padlist);
1281 PL_comppad = PadlistARRAY(padlist)[1];
1282 PL_curpad = AvARRAY(PL_comppad);
1285 = pad_alloc_name(new_name,
1286 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1287 PadnameTYPE(*out_name),
1288 PadnameOURSTASH(*out_name)
1291 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1292 "Pad addname: %ld \"%.*s\" FAKE\n",
1294 (int) PadnameLEN(new_name),
1295 PadnamePV(new_name)));
1296 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1298 PARENT_PAD_INDEX_set(new_name, 0);
1299 if (PadnameIsOUR(new_name)) {
1300 NOOP; /* do nothing */
1302 else if (CvLATE(cv)) {
1303 /* delayed creation - just note the offset within parent pad */
1304 PARENT_PAD_INDEX_set(new_name, offset);
1308 /* immediate creation - capture outer value right now */
1309 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1310 /* But also note the offset, as newMYSUB needs it */
1311 PARENT_PAD_INDEX_set(new_name, offset);
1312 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1313 "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n",
1314 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1316 *out_name = new_name;
1317 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1319 PL_comppad_name = ocomppad_name;
1320 PL_comppad = ocomppad;
1321 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1331 Get the value at offset C<po> in the current (compiling or executing) pad.
1332 Use macro C<PAD_SV> instead of calling this function directly.
1338 Perl_pad_sv(pTHX_ PADOFFSET po)
1340 ASSERT_CURPAD_ACTIVE("pad_sv");
1343 Perl_croak(aTHX_ "panic: pad_sv po");
1344 DEBUG_X(PerlIO_printf(Perl_debug_log,
1345 "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n",
1346 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1348 return PL_curpad[po];
1352 =for apidoc pad_setsv
1354 Set the value at offset C<po> in the current (compiling or executing) pad.
1355 Use the macro C<PAD_SETSV()> rather than calling this function directly.
1361 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1363 PERL_ARGS_ASSERT_PAD_SETSV;
1365 ASSERT_CURPAD_ACTIVE("pad_setsv");
1367 DEBUG_X(PerlIO_printf(Perl_debug_log,
1368 "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n",
1369 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1374 #endif /* DEBUGGING */
1377 =for apidoc pad_block_start
1379 Update the pad compilation state variables on entry to a new block.
1385 Perl_pad_block_start(pTHX_ int full)
1387 ASSERT_CURPAD_ACTIVE("pad_block_start");
1388 SAVESTRLEN(PL_comppad_name_floor);
1389 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1391 PL_comppad_name_fill = PL_comppad_name_floor;
1392 if (PL_comppad_name_floor < 0)
1393 PL_comppad_name_floor = 0;
1394 SAVESTRLEN(PL_min_intro_pending);
1395 SAVESTRLEN(PL_max_intro_pending);
1396 PL_min_intro_pending = 0;
1397 SAVESTRLEN(PL_comppad_name_fill);
1398 SAVESTRLEN(PL_padix_floor);
1399 /* PL_padix_floor is what PL_padix is reset to at the start of each
1400 statement, by pad_reset(). We set it when entering a new scope
1401 to keep things like this working:
1402 print "$foo$bar", do { this(); that() . "foo" };
1403 We must not let "$foo$bar" and the later concatenation share the
1405 PL_padix_floor = PL_padix;
1406 PL_pad_reset_pending = FALSE;
1410 =for apidoc intro_my
1412 "Introduce" C<my> variables to visible status. This is called during parsing
1413 at the end of each statement to make lexical variables visible to subsequent
1426 ASSERT_CURPAD_ACTIVE("intro_my");
1427 if (PL_compiling.cop_seq) {
1428 seq = PL_compiling.cop_seq;
1429 PL_compiling.cop_seq = 0;
1432 seq = PL_cop_seqmax;
1433 if (! PL_min_intro_pending)
1436 svp = PadnamelistARRAY(PL_comppad_name);
1437 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1438 PADNAME * const sv = svp[i];
1440 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1441 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1443 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1444 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1445 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1446 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1447 (long)i, PadnamePV(sv),
1448 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1449 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1454 PL_min_intro_pending = 0;
1455 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1456 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1457 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1463 =for apidoc pad_leavemy
1465 Cleanup at end of scope during compilation: set the max seq number for
1466 lexicals in this scope and warn of any lexicals that never got introduced.
1472 Perl_pad_leavemy(pTHX)
1476 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1478 PL_pad_reset_pending = FALSE;
1480 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1481 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1482 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1483 const PADNAME * const name = svp[off];
1484 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1485 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1486 "%" PNf " never introduced",
1490 /* "Deintroduce" my variables that are leaving with this scope. */
1491 for (off = PadnamelistMAX(PL_comppad_name);
1492 off > PL_comppad_name_fill; off--) {
1493 PADNAME * const sv = svp[off];
1494 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1495 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1497 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1498 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1499 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1500 (long)off, PadnamePV(sv),
1501 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1502 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1504 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1505 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1506 OP *kid = newOP(OP_INTROCV, 0);
1508 o = op_prepend_elem(OP_LINESEQ, kid, o);
1513 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1514 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1519 =for apidoc pad_swipe
1521 Abandon the tmp in the current pad at offset C<po> and replace with a
1528 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1530 ASSERT_CURPAD_LEGAL("pad_swipe");
1533 if (AvARRAY(PL_comppad) != PL_curpad)
1534 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1535 AvARRAY(PL_comppad), PL_curpad);
1536 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1537 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1538 (long)po, (long)AvFILLp(PL_comppad));
1540 DEBUG_X(PerlIO_printf(Perl_debug_log,
1541 "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n",
1542 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1545 SvREFCNT_dec(PL_curpad[po]);
1548 /* if pad tmps aren't shared between ops, then there's no need to
1549 * create a new tmp when an existing op is freed */
1550 #ifdef USE_PAD_RESET
1551 PL_curpad[po] = newSV_type(SVt_NULL);
1552 SvPADTMP_on(PL_curpad[po]);
1554 PL_curpad[po] = NULL;
1556 if (PadnamelistMAX(PL_comppad_name) != -1
1557 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1558 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1559 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1561 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1563 /* Use PL_constpadix here, not PL_padix. The latter may have been
1564 reset by pad_reset. We don’t want pad_alloc to have to scan the
1565 whole pad when allocating a constant. */
1566 if (po < PL_constpadix)
1567 PL_constpadix = po - 1;
1571 =for apidoc pad_reset
1573 Mark all the current temporaries for reuse
1578 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1579 * between OPs from different statements. During compilation, at the start
1580 * of each statement pad_reset resets PL_padix back to its previous value.
1581 * When allocating a target, pad_alloc begins its scan through the pad at
1586 #ifdef USE_PAD_RESET
1587 if (AvARRAY(PL_comppad) != PL_curpad)
1588 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1589 AvARRAY(PL_comppad), PL_curpad);
1591 DEBUG_X(PerlIO_printf(Perl_debug_log,
1592 "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld",
1593 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1594 (long)PL_padix, (long)PL_padix_floor
1598 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1599 PL_padix = PL_padix_floor;
1602 PL_pad_reset_pending = FALSE;
1606 =for apidoc pad_tidy
1608 Tidy up a pad at the end of compilation of the code to which it belongs.
1609 Jobs performed here are: remove most stuff from the pads of anonsub
1610 prototypes; give it a C<@_>; mark temporaries as such. C<type> indicates
1611 the kind of subroutine:
1613 padtidy_SUB ordinary subroutine
1614 padtidy_SUBCLONE prototype for lexical closure
1615 padtidy_FORMAT format
1621 Perl_pad_tidy(pTHX_ padtidy_type type)
1624 ASSERT_CURPAD_ACTIVE("pad_tidy");
1626 /* If this CV has had any 'eval-capable' ops planted in it:
1627 * i.e. it contains any of:
1631 * * use re 'eval'; /$var/
1634 * Then any anon prototypes in the chain of CVs should be marked as
1635 * cloneable, so that for example the eval's CV in
1639 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1640 * potentially have an eval executed within it.
1643 if (PL_cv_has_eval || PL_perldb) {
1645 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1646 if (cv != PL_compcv && CvCOMPILED(cv))
1647 break; /* no need to mark already-compiled code */
1649 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1650 "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv)));
1657 /* extend namepad to match curpad */
1658 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1659 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1661 if (type == padtidy_SUBCLONE) {
1662 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1665 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1667 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1670 * The only things that a clonable function needs in its
1671 * pad are anonymous subs, constants and GVs.
1672 * The rest are created anew during cloning.
1674 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1677 if (!(PadnamePV(namesv) &&
1678 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1680 SvREFCNT_dec(PL_curpad[ix]);
1681 PL_curpad[ix] = NULL;
1685 else if (type == padtidy_SUB) {
1686 AV * const av = newAV(); /* Will be @_ */
1687 av_store(PL_comppad, 0, MUTABLE_SV(av));
1691 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1692 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1694 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1695 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1696 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1698 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1699 /* This is a work around for how the current implementation of
1700 ?{ } blocks in regexps interacts with lexicals.
1702 One of our lexicals.
1703 Can't do this on all lexicals, otherwise sub baz() won't
1712 because completion of compiling &bar calling pad_tidy()
1713 would cause (top level) $foo to be marked as stale, and
1714 "no longer available". */
1715 SvPADSTALE_on(PL_curpad[ix]);
1719 PL_curpad = AvARRAY(PL_comppad);
1723 =for apidoc pad_free
1725 Free the SV at offset po in the current pad.
1731 Perl_pad_free(pTHX_ PADOFFSET po)
1733 #ifndef USE_PAD_RESET
1736 ASSERT_CURPAD_LEGAL("pad_free");
1739 if (AvARRAY(PL_comppad) != PL_curpad)
1740 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1741 AvARRAY(PL_comppad), PL_curpad);
1743 Perl_croak(aTHX_ "panic: pad_free po");
1745 DEBUG_X(PerlIO_printf(Perl_debug_log,
1746 "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n",
1747 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1750 #ifndef USE_PAD_RESET
1752 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1753 SvFLAGS(sv) &= ~SVs_PADTMP;
1761 =for apidoc do_dump_pad
1763 Dump the contents of a padlist
1769 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1771 const PADNAMELIST *pad_name;
1777 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1782 pad_name = PadlistNAMES(padlist);
1783 pad = PadlistARRAY(padlist)[1];
1784 pname = PadnamelistARRAY(pad_name);
1785 ppad = AvARRAY(pad);
1786 Perl_dump_indent(aTHX_ level, file,
1787 "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n",
1788 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1791 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1792 const PADNAME *namesv = pname[ix];
1793 if (namesv && !PadnameLEN(namesv)) {
1797 if (PadnameOUTER(namesv))
1798 Perl_dump_indent(aTHX_ level+1, file,
1799 "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1802 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1804 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1805 (unsigned long)PARENT_PAD_INDEX(namesv)
1809 Perl_dump_indent(aTHX_ level+1, file,
1810 "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n",
1813 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1814 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1815 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1820 Perl_dump_indent(aTHX_ level+1, file,
1821 "%2d. 0x%" UVxf "<%lu>\n",
1824 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1835 dump the contents of a CV
1841 S_cv_dump(pTHX_ const CV *cv, const char *title)
1843 const CV * const outside = CvOUTSIDE(cv);
1845 PERL_ARGS_ASSERT_CV_DUMP;
1847 PerlIO_printf(Perl_debug_log,
1848 " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n",
1851 (CvANON(cv) ? "ANON"
1852 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1853 : (cv == PL_main_cv) ? "MAIN"
1854 : CvUNIQUE(cv) ? "UNIQUE"
1855 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1858 : CvANON(outside) ? "ANON"
1859 : (outside == PL_main_cv) ? "MAIN"
1860 : CvUNIQUE(outside) ? "UNIQUE"
1861 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1863 if (!CvISXSUB(cv)) {
1864 /* SVPADLIST(cv) will fail an assert if CvISXSUB(cv) is true,
1865 * and if the assert is removed this code will SEGV. XSUBs don't
1866 * have padlists I believe - Yves */
1867 PADLIST* const padlist = CvPADLIST(cv);
1868 PerlIO_printf(Perl_debug_log,
1869 " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist));
1870 do_dump_pad(1, Perl_debug_log, padlist, 1);
1874 #endif /* DEBUGGING */
1877 =for apidoc cv_clone
1879 Clone a CV, making a lexical closure. C<proto> supplies the prototype
1880 of the function: its code, pad structure, and other attributes.
1881 The prototype is combined with a capture of outer lexicals to which the
1882 code refers, which are taken from the currently-executing instance of
1883 the immediately surrounding code.
1888 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned);
1891 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned,
1895 PADLIST* const protopadlist = CvPADLIST(proto);
1896 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1897 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1898 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1899 SV** const ppad = AvARRAY(protopad);
1900 const PADOFFSET fname = PadnamelistMAX(protopad_name);
1901 const PADOFFSET fpad = AvFILLp(protopad);
1905 bool trouble = FALSE;
1907 assert(!CvUNIQUE(proto));
1909 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1910 * reliable. The currently-running sub is always the one we need to
1912 * For my subs, the currently-running sub may not be the one we want.
1913 * We have to check whether it is a clone of CvOUTSIDE.
1914 * Note that in general for formats, CvOUTSIDE != find_runcv.
1915 * Since formats may be nested inside closures, CvOUTSIDE may point
1916 * to a prototype; we instead want the cloned parent who called us.
1920 if (CvWEAKOUTSIDE(proto))
1921 outside = find_runcv(NULL);
1923 outside = CvOUTSIDE(proto);
1924 if ((CvCLONE(outside) && ! CvCLONED(outside))
1925 || !CvPADLIST(outside)
1926 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1927 outside = find_runcv_where(
1928 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1930 /* outside could be null */
1934 depth = outside ? CvDEPTH(outside) : 0;
1939 SAVESPTR(PL_compcv);
1941 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
1944 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
1946 SAVESPTR(PL_comppad_name);
1947 PL_comppad_name = protopad_name;
1948 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
1949 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
1951 av_fill(PL_comppad, fpad);
1953 PL_curpad = AvARRAY(PL_comppad);
1955 outpad = outside && CvPADLIST(outside)
1956 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
1958 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
1960 for (ix = fpad; ix > 0; ix--) {
1961 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
1963 if (namesv && PadnameLEN(namesv)) { /* lexical */
1964 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
1968 if (PadnameOUTER(namesv)) { /* lexical from outside? */
1969 /* formats may have an inactive, or even undefined, parent;
1970 but state vars are always available. */
1971 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
1972 || ( SvPADSTALE(sv) && !PadnameIsSTATE(namesv)
1973 && (!outside || !CvDEPTH(outside))) ) {
1974 S_unavailable(aTHX_ namesv);
1978 SvREFCNT_inc_simple_void_NN(sv);
1981 const char sigil = PadnamePV(namesv)[0];
1983 /* If there are state subs, we need to clone them, too.
1984 But they may need to close over variables we have
1985 not cloned yet. So we will have to do a second
1986 pass. Furthermore, there may be state subs clos-
1987 ing over other state subs’ entries, so we have
1988 to put a stub here and then clone into it on the
1990 if (PadnameIsSTATE(namesv) && !CvCLONED(ppad[ix])) {
1991 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
1993 if (CvOUTSIDE(ppad[ix]) != proto)
1995 sv = newSV_type(SVt_PVCV);
1998 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2001 /* Just provide a stub, but name it. It will be
2002 upgraded to the real thing on scope entry. */
2004 PERL_HASH(hash, PadnamePV(namesv)+1,
2005 PadnameLEN(namesv) - 1);
2006 sv = newSV_type(SVt_PVCV);
2009 share_hek(PadnamePV(namesv)+1,
2010 1 - PadnameLEN(namesv),
2015 else sv = SvREFCNT_inc(ppad[ix]);
2016 else if (sigil == '@')
2017 sv = MUTABLE_SV(newAV());
2018 else if (sigil == '%')
2019 sv = MUTABLE_SV(newHV());
2021 sv = newSV_type(SVt_NULL);
2022 /* reset the 'assign only once' flag on each state var */
2023 if (sigil != '&' && PadnameIsSTATE(namesv))
2028 else if (namesv && PadnamePV(namesv)) {
2029 sv = SvREFCNT_inc_NN(ppad[ix]);
2032 sv = newSV_type(SVt_NULL);
2040 if (trouble || cloned) {
2041 /* Uh-oh, we have trouble! At least one of the state subs here
2042 has its CvOUTSIDE pointer pointing somewhere unexpected. It
2043 could be pointing to another state protosub that we are
2044 about to clone. So we have to track which sub clones come
2045 from which protosubs. If the CvOUTSIDE pointer for a parti-
2046 cular sub points to something we have not cloned yet, we
2047 delay cloning it. We must loop through the pad entries,
2048 until we get a full pass with no cloning. If any uncloned
2049 subs remain (probably nested inside anonymous or ‘my’ subs),
2050 then they get cloned in a final pass.
2052 bool cloned_in_this_pass;
2054 cloned = (HV *)newSV_type_mortal(SVt_PVHV);
2056 cloned_in_this_pass = FALSE;
2057 for (ix = fpad; ix > 0; ix--) {
2058 PADNAME * const name =
2059 (ix <= fname) ? pname[ix] : NULL;
2060 if (name && name != &PL_padname_undef
2061 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2062 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2064 CV * const protokey = CvOUTSIDE(ppad[ix]);
2065 CV ** const cvp = protokey == proto
2067 : (CV **)hv_fetch(cloned, (char *)&protokey,
2070 S_cv_clone(aTHX_ (CV *)ppad[ix],
2071 (CV *)PL_curpad[ix],
2073 (void)hv_store(cloned, (char *)&ppad[ix],
2075 SvREFCNT_inc_simple_NN(PL_curpad[ix]),
2078 cloned_in_this_pass = TRUE;
2082 } while (cloned_in_this_pass);
2084 for (ix = fpad; ix > 0; ix--) {
2085 PADNAME * const name =
2086 (ix <= fname) ? pname[ix] : NULL;
2087 if (name && name != &PL_padname_undef
2088 && !PadnameOUTER(name) && PadnamePV(name)[0] == '&'
2089 && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix]))
2090 S_cv_clone(aTHX_ (CV *)ppad[ix],
2091 (CV *)PL_curpad[ix],
2092 CvOUTSIDE(ppad[ix]), cloned);
2095 else for (ix = fpad; ix > 0; ix--) {
2096 PADNAME * const name = (ix <= fname) ? pname[ix] : NULL;
2097 if (name && name != &PL_padname_undef && !PadnameOUTER(name)
2098 && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name))
2099 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv,
2104 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2108 /* Constant sub () { $x } closing over $x:
2109 * The prototype was marked as a candiate for const-ization,
2110 * so try to grab the current const value, and if successful,
2111 * turn into a const sub:
2114 OP *o = CvSTART(cv);
2116 for (; o; o = o->op_next)
2117 if (o->op_type == OP_PADSV)
2119 ASSUME(o->op_type == OP_PADSV);
2120 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2121 /* the candidate should have 1 ref from this pad and 1 ref
2122 * from the parent */
2123 if (const_sv && SvREFCNT(const_sv) == 2) {
2124 const bool was_method = cBOOL(CvNOWARN_AMBIGUOUS(cv));
2126 PADNAME * const pn =
2127 PadlistNAMESARRAY(CvPADLIST(outside))
2128 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2129 CvPADLIST(cv))[o->op_targ])];
2130 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2132 if (PadnameLVALUE(pn)) {
2133 /* We have a lexical that is potentially modifiable
2134 elsewhere, so making a constant will break clo-
2135 sure behaviour. If this is a ‘simple lexical
2136 op tree’, i.e., sub(){$x}, emit a deprecation
2137 warning, but continue to exhibit the old behav-
2138 iour of making it a constant based on the ref-
2139 count of the candidate variable.
2141 A simple lexical op tree looks like this:
2149 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2154 "Constants from lexical variables potentially modified "
2155 "elsewhere are no longer permitted");
2161 SvREFCNT_inc_simple_void_NN(const_sv);
2162 /* If the lexical is not used elsewhere, it is safe to turn on
2163 SvPADTMP, since it is only when it is used in lvalue con-
2164 text that the difference is observable. */
2165 SvREADONLY_on(const_sv);
2166 SvPADTMP_on(const_sv);
2167 SvREFCNT_dec_NN(cv);
2168 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2170 CvNOWARN_AMBIGUOUS_on(cv);
2182 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned)
2184 const bool newcv = !cv;
2186 assert(!CvUNIQUE(proto));
2188 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2189 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2193 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2196 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2197 else CvGV_set(cv,CvGV(proto));
2198 CvSTASH_set(cv, CvSTASH(proto));
2200 /* It is unlikely that proto is an xsub, but it could happen; e.g. if a
2201 * module has performed a lexical sub import trick on an xsub. This
2202 * happens with builtin::import, for example
2204 if (UNLIKELY(CvISXSUB(proto))) {
2205 CvXSUB(cv) = CvXSUB(proto);
2206 CvXSUBANY(cv) = CvXSUBANY(proto);
2207 if (CvREFCOUNTED_ANYSV(cv))
2208 SvREFCNT_inc(CvXSUBANY(cv).any_sv);
2212 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2214 CvSTART(cv) = CvSTART(proto);
2215 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2219 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2221 SvUTF8_on(MUTABLE_SV(cv));
2224 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2226 if (!CvISXSUB(proto) && CvPADLIST(proto))
2227 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv);
2230 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2231 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2232 cv_dump(proto, "Proto");
2240 Perl_cv_clone(pTHX_ CV *proto)
2242 PERL_ARGS_ASSERT_CV_CLONE;
2244 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2245 return S_cv_clone(aTHX_ proto, NULL, NULL, NULL);
2248 /* Called only by pp_clonecv */
2250 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2252 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2254 return S_cv_clone(aTHX_ proto, target, NULL, NULL);
2260 Returns an SV containing the name of the CV, mainly for use in error
2261 reporting. The CV may actually be a GV instead, in which case the returned
2262 SV holds the GV's name. Anything other than a GV or CV is treated as a
2263 string already holding the sub name, but this could change in the future.
2265 An SV may be passed as a second argument. If so, the name will be assigned
2266 to it and it will be returned. Otherwise the returned SV will be a new
2269 If C<flags> has the C<CV_NAME_NOTQUAL> bit set, then the package name will not be
2270 included. If the first argument is neither a CV nor a GV, this flag is
2271 ignored (subject to change).
2273 =for apidoc Amnh||CV_NAME_NOTQUAL
2279 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2281 PERL_ARGS_ASSERT_CV_NAME;
2282 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2283 if (sv) sv_setsv(sv,(SV *)cv);
2284 return sv ? (sv) : (SV *)cv;
2287 SV * const retsv = sv ? (sv) : sv_newmortal();
2288 if (SvTYPE(cv) == SVt_PVCV) {
2290 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2291 sv_sethek(retsv, CvNAME_HEK(cv));
2293 if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv)))
2294 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2296 sv_setpvs(retsv, "__ANON__");
2297 sv_catpvs(retsv, "::");
2298 sv_cathek(retsv, CvNAME_HEK(cv));
2301 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2302 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2303 else gv_efullname3(retsv, CvGV(cv), NULL);
2305 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2306 else gv_efullname3(retsv,(GV *)cv,NULL);
2312 =for apidoc pad_fixup_inner_anons
2314 For any anon CVs in the pad, change C<CvOUTSIDE> of that CV from
2315 C<old_cv> to C<new_cv> if necessary. Needed when a newly-compiled CV has to be
2316 moved to a pre-existing CV struct.
2322 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2325 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2326 AV * const comppad = PadlistARRAY(padlist)[1];
2327 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2328 SV ** const curpad = AvARRAY(comppad);
2330 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2331 PERL_UNUSED_ARG(old_cv);
2333 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2334 const PADNAME *name = namepad[ix];
2335 if (name && name != &PL_padname_undef && !PadnameIsOUR(name)
2336 && *PadnamePV(name) == '&')
2338 CV *innercv = MUTABLE_CV(curpad[ix]);
2339 if (UNLIKELY(PadnameOUTER(name))) {
2341 PADNAME **names = namepad;
2343 while (PadnameOUTER(name)) {
2344 assert(SvTYPE(cv) == SVt_PVCV);
2346 names = PadlistNAMESARRAY(CvPADLIST(cv));
2347 i = PARENT_PAD_INDEX(name);
2350 innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i];
2352 if (SvTYPE(innercv) == SVt_PVCV) {
2353 /* XXX 0afba48f added code here to check for a proto CV
2354 attached to the pad entry by magic. But shortly there-
2355 after 81df9f6f95 moved the magic to the pad name. The
2356 code here was never updated, so it wasn’t doing anything
2357 and got deleted when PADNAME became a distinct type. Is
2358 there any bug as a result? */
2359 if (CvOUTSIDE(innercv) == old_cv) {
2360 if (!CvWEAKOUTSIDE(innercv)) {
2361 SvREFCNT_dec(old_cv);
2362 SvREFCNT_inc_simple_void_NN(new_cv);
2364 CvOUTSIDE(innercv) = new_cv;
2367 else { /* format reference */
2368 SV * const rv = curpad[ix];
2370 if (!SvOK(rv)) continue;
2372 assert(SvWEAKREF(rv));
2373 innercv = (CV *)SvRV(rv);
2374 assert(!CvWEAKOUTSIDE(innercv));
2375 assert(CvOUTSIDE(innercv) == old_cv);
2376 SvREFCNT_dec(CvOUTSIDE(innercv));
2377 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2384 =for apidoc pad_push
2386 Push a new pad frame onto the padlist, unless there's already a pad at
2387 this depth, in which case don't bother creating a new one. Then give
2388 the new pad an C<@_> in slot zero.
2394 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2396 PERL_ARGS_ASSERT_PAD_PUSH;
2398 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2399 PAD** const svp = PadlistARRAY(padlist);
2400 AV* const newpad = newAV();
2401 SV** const oldpad = AvARRAY(svp[depth-1]);
2402 PADOFFSET ix = AvFILLp((const AV *)svp[1]);
2403 const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2404 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2407 Newxz( AvALLOC(newpad), ix + 1, SV *);
2408 AvARRAY(newpad) = AvALLOC(newpad);
2409 AvMAX(newpad) = AvFILLp(newpad) = ix;
2411 for ( ;ix > 0; ix--) {
2413 if (names_fill >= ix && PadnameLEN(names[ix])) {
2414 const char sigil = PadnamePV(names[ix])[0];
2415 if (PadnameOUTER(names[ix])
2416 || PadnameIsSTATE(names[ix])
2419 /* outer lexical or anon code */
2420 sv = SvREFCNT_inc(oldpad[ix]);
2422 else { /* our own lexical */
2424 sv = MUTABLE_SV(newAV());
2425 else if (sigil == '%')
2426 sv = MUTABLE_SV(newHV());
2428 sv = newSV_type(SVt_NULL);
2431 else if (PadnamePV(names[ix])) {
2432 sv = SvREFCNT_inc_NN(oldpad[ix]);
2435 /* save temporaries on recursion? */
2436 sv = newSV_type(SVt_NULL);
2439 AvARRAY(newpad)[ix] = sv;
2442 AvARRAY(newpad)[0] = MUTABLE_SV(av);
2445 padlist_store(padlist, depth, newpad);
2449 #if defined(USE_ITHREADS)
2451 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2454 =for apidoc padlist_dup
2462 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2468 PERL_ARGS_ASSERT_PADLIST_DUP;
2470 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2471 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2473 max = cloneall ? PadlistMAX(srcpad) : 1;
2475 Newx(dstpad, 1, PADLIST);
2476 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2477 PadlistMAX(dstpad) = max;
2478 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2480 PadlistARRAY(dstpad)[0] = (PAD *)
2481 padnamelist_dup(PadlistNAMES(srcpad), param);
2482 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2485 for (depth = 1; depth <= max; ++depth)
2486 PadlistARRAY(dstpad)[depth] =
2487 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2489 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2490 to build anything other than the first level of pads. */
2491 PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2493 const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2494 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2495 SV **oldpad = AvARRAY(srcpad1);
2496 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2502 av_extend(pad1, ix);
2503 PadlistARRAY(dstpad)[1] = pad1;
2504 pad1a = AvARRAY(pad1);
2509 for ( ;ix > 0; ix--) {
2512 } else if (names_fill >= ix && names[ix] &&
2513 PadnameLEN(names[ix])) {
2514 const char sigil = PadnamePV(names[ix])[0];
2515 if (PadnameOUTER(names[ix])
2516 || PadnameIsSTATE(names[ix])
2519 /* outer lexical or anon code */
2520 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2522 else { /* our own lexical */
2523 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2524 /* This is a work around for how the current
2525 implementation of ?{ } blocks in regexps
2526 interacts with lexicals. */
2527 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2532 sv = MUTABLE_SV(newAV());
2533 else if (sigil == '%')
2534 sv = MUTABLE_SV(newHV());
2536 sv = newSV_type(SVt_NULL);
2541 else if (( names_fill >= ix && names[ix]
2542 && PadnamePV(names[ix]) )) {
2543 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2546 /* save temporaries on recursion? */
2547 SV * const sv = newSV_type(SVt_NULL);
2550 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2551 FIXTHAT before merging this branch.
2552 (And I know how to) */
2553 if (SvPADTMP(oldpad[ix]))
2559 args = newAV(); /* Will be @_ */
2561 pad1a[0] = (SV *)args;
2569 #endif /* USE_ITHREADS */
2572 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2575 SSize_t const oldmax = PadlistMAX(padlist);
2577 PERL_ARGS_ASSERT_PADLIST_STORE;
2581 if (key > PadlistMAX(padlist)) {
2582 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2583 (SV ***)&PadlistARRAY(padlist),
2584 (SV ***)&PadlistARRAY(padlist));
2585 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2588 ary = PadlistARRAY(padlist);
2589 SvREFCNT_dec(ary[key]);
2595 =for apidoc newPADNAMELIST
2597 Creates a new pad name list. C<max> is the highest index for which space
2604 Perl_newPADNAMELIST(size_t max)
2607 Newx(pnl, 1, PADNAMELIST);
2608 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2609 PadnamelistMAX(pnl) = -1;
2610 PadnamelistREFCNT(pnl) = 1;
2611 PadnamelistMAXNAMED(pnl) = 0;
2612 pnl->xpadnl_max = max;
2617 =for apidoc padnamelist_store
2619 Stores the pad name (which may be null) at the given index, freeing any
2620 existing pad name in that slot.
2626 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2630 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2634 if (key > pnl->xpadnl_max)
2635 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2636 (SV ***)&PadnamelistARRAY(pnl),
2637 (SV ***)&PadnamelistARRAY(pnl));
2638 if (PadnamelistMAX(pnl) < key) {
2639 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2640 key-PadnamelistMAX(pnl), PADNAME *);
2641 PadnamelistMAX(pnl) = key;
2643 ary = PadnamelistARRAY(pnl);
2645 PadnameREFCNT_dec(ary[key]);
2651 =for apidoc padnamelist_fetch
2653 Fetches the pad name from the given index.
2659 Perl_padnamelist_fetch(PADNAMELIST *pnl, SSize_t key)
2661 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2664 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2668 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2670 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2671 if (!--PadnamelistREFCNT(pnl)) {
2672 while(PadnamelistMAX(pnl) >= 0)
2674 PADNAME * const pn =
2675 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2677 PadnameREFCNT_dec(pn);
2679 Safefree(PadnamelistARRAY(pnl));
2684 #if defined(USE_ITHREADS)
2687 =for apidoc padnamelist_dup
2689 Duplicates a pad name list.
2695 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2697 PADNAMELIST *dstpad;
2698 SSize_t max = PadnamelistMAX(srcpad);
2700 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2702 /* look for it in the table first */
2703 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2707 dstpad = newPADNAMELIST(max);
2708 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2709 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2710 PadnamelistMAX(dstpad) = max;
2712 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2713 for (; max >= 0; max--)
2714 if (PadnamelistARRAY(srcpad)[max]) {
2715 PadnamelistARRAY(dstpad)[max] =
2716 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2717 PadnameREFCNT_inc(PadnamelistARRAY(dstpad)[max]);
2723 #endif /* USE_ITHREADS */
2726 =for apidoc newPADNAMEpvn
2728 Constructs and returns a new pad name. C<s> must be a UTF-8 string. Do not
2729 use this for pad names that point to outer lexicals. See
2730 C<L</newPADNAMEouter>>.
2736 Perl_newPADNAMEpvn(const char *s, STRLEN len)
2738 struct padname_with_str *alloc;
2739 char *alloc2; /* for Newxz */
2741 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2743 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2745 alloc = (struct padname_with_str *)alloc2;
2746 pn = (PADNAME *)alloc;
2747 PadnameREFCNT(pn) = 1;
2748 PadnamePV(pn) = alloc->xpadn_str;
2749 Copy(s, PadnamePV(pn), len, char);
2750 *(PadnamePV(pn) + len) = '\0';
2751 PadnameLEN(pn) = len;
2756 =for apidoc newPADNAMEouter
2758 Constructs and returns a new pad name. Only use this function for names
2759 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) C<outer> is
2760 the outer pad name that this one mirrors. The returned pad name has the
2761 C<PADNAMEf_OUTER> flag already set.
2763 =for apidoc Amnh||PADNAMEf_OUTER
2769 Perl_newPADNAMEouter(PADNAME *outer)
2772 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2773 Newxz(pn, 1, PADNAME);
2774 PadnameREFCNT(pn) = 1;
2775 PadnamePV(pn) = PadnamePV(outer);
2776 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2777 another entry. The original pad name owns the buffer. */
2778 PadnameREFCNT_inc(PADNAME_FROM_PV(PadnamePV(outer)));
2779 PadnameFLAGS(pn) = PADNAMEf_OUTER;
2780 PadnameLEN(pn) = PadnameLEN(outer);
2785 Perl_padname_free(pTHX_ PADNAME *pn)
2787 PERL_ARGS_ASSERT_PADNAME_FREE;
2788 if (!--PadnameREFCNT(pn)) {
2789 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2790 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2793 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2794 SvREFCNT_dec(PadnameOURSTASH(pn));
2795 if (PadnameOUTER(pn))
2796 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2801 #if defined(USE_ITHREADS)
2804 =for apidoc padname_dup
2806 Duplicates a pad name.
2812 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2816 PERL_ARGS_ASSERT_PADNAME_DUP;
2818 /* look for it in the table first */
2819 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2823 if (!PadnamePV(src)) {
2824 dst = &PL_padname_undef;
2825 ptr_table_store(PL_ptr_table, src, dst);
2829 dst = PadnameOUTER(src)
2830 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2831 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2832 ptr_table_store(PL_ptr_table, src, dst);
2833 PadnameLEN(dst) = PadnameLEN(src);
2834 PadnameFLAGS(dst) = PadnameFLAGS(src);
2835 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2836 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2837 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2839 dst->xpadn_low = src->xpadn_low;
2840 dst->xpadn_high = src->xpadn_high;
2841 dst->xpadn_gen = src->xpadn_gen;
2845 #endif /* USE_ITHREADS */
2848 * ex: set ts=8 sts=4 sw=4 et: