3 * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 * by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
11 * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12 * might say, among those queer Bucklanders, being brought up anyhow in
13 * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
14 * never had fewer than a couple of hundred relations in the place.
15 * Mr. Bilbo never did a kinder deed than when he brought the lad back
16 * to live among decent folk.' --the Gaffer
18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 * As of Sept 2002, this file is new and may be in a state of flux for
23 * a while. I've marked things I intent to come back and look at further
24 * with an 'XXX DAPM' comment.
28 =head1 Pad Data Structures
30 =for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
32 CV's can have CvPADLIST(cv) set to point to a PADLIST. This is the CV's
33 scratchpad, which stores lexical variables and opcode temporary and
36 For these purposes "formats" are a kind-of CV; eval""s are too (except they're
37 not callable at will and are always thrown away after the eval"" is done
38 executing). Require'd files are simply evals without any outer lexical
41 XSUBs do not have a CvPADLIST. dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
43 every entersub). Do not get or set CvPADLIST if a CV is an XSUB (as
44 determined by C<CvISXSUB()>), CvPADLIST slot is reused for a different
45 internal purpose in XSUBs.
47 The PADLIST has a C array where pads are stored.
49 The 0th entry of the PADLIST is a PADNAMELIST
50 which represents the "names" or rather
51 the "static type information" for lexicals. The individual elements of a
52 PADNAMELIST are PADNAMEs. Future
53 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
54 array, so don't rely on it. See L</PadlistNAMES>.
56 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
57 at that depth of recursion into the CV. The 0th slot of a frame AV is an
58 AV which is @_. Other entries are storage for variables and op targets.
60 Iterating over the PADNAMELIST iterates over all possible pad
61 items. Pad slots for targets (SVs_PADTMP)
62 and GVs end up having &PL_padname_undef "names", while slots for constants
63 have &PL_padname_const "names" (see pad_alloc()). That &PL_padname_undef
64 and &PL_padname_const are used is an implementation detail subject to
65 change. To test for them, use C<!PadnamePV(name)> and C<PadnamePV(name)
66 && !PadnameLEN(name)>, respectively.
68 Only my/our variable slots get valid names.
69 The rest are op targets/GVs/constants which are statically allocated
70 or resolved at compile time. These don't have names by which they
71 can be looked up from Perl code at run time through eval"" the way
72 my/our variables can be. Since they can't be looked up by "name"
73 but only by their index allocated at compile time (which is usually
74 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
76 The pad names in the PADNAMELIST have their PV holding the name of
77 the variable. The COP_SEQ_RANGE_LOW and _HIGH fields form a range
78 (low+1..high inclusive) of cop_seq numbers for which the name is
79 valid. During compilation, these fields may hold the special value
80 PERL_PADSEQ_INTRO to indicate various stages:
82 COP_SEQ_RANGE_LOW _HIGH
83 ----------------- -----
84 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
85 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
86 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
88 For typed lexicals PadnameTYPE points at the type stash. For C<our>
89 lexicals, PadnameOURSTASH points at the stash of the associated global (so
90 that duplicate C<our> declarations in the same package can be detected).
91 PadnameGEN is sometimes used to store the generation number during
94 If PadnameOUTER is set on the pad name, then that slot in the frame AV
95 is a REFCNT'ed reference to a lexical from "outside". Such entries
96 are sometimes referred to as 'fake'. In this case, the name does not
97 use 'low' and 'high' to store a cop_seq range, since it is in scope
98 throughout. Instead 'high' stores some flags containing info about
99 the real lexical (is it declared in an anon, and is it capable of being
100 instantiated multiple times?), and for fake ANONs, 'low' contains the index
101 within the parent's pad where the lexical's value is stored, to make
104 If the 'name' is '&' the corresponding entry in the PAD
105 is a CV representing a possible closure.
107 Note that formats are treated as anon subs, and are cloned each time
108 write is called (if necessary).
110 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
111 and set on scope exit. This allows the
112 'Variable $x is not available' warning
113 to be generated in evals, such as
115 { my $x = 1; sub f { eval '$x'} } f();
117 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised',
118 but this internal state is stored in a separate pad entry.
120 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
122 During compilation, this points to the array containing the names part
123 of the pad for the currently-compiling code.
125 =for apidoc AmxU|PAD *|PL_comppad
127 During compilation, this points to the array containing the values
128 part of the pad for the currently-compiling code. (At runtime a CV may
129 have many such value arrays; at compile time just one is constructed.)
130 At runtime, this points to the array containing the currently-relevant
131 values for the pad for the currently-executing code.
133 =for apidoc AmxU|SV **|PL_curpad
135 Points directly to the body of the L</PL_comppad> array.
136 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
143 #define PERL_IN_PAD_C
145 #include "keywords.h"
147 #define COP_SEQ_RANGE_LOW_set(sv,val) \
148 STMT_START { (sv)->xpadn_low = (val); } STMT_END
149 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
150 STMT_START { (sv)->xpadn_high = (val); } STMT_END
152 #define PARENT_PAD_INDEX_set COP_SEQ_RANGE_LOW_set
153 #define PARENT_FAKELEX_FLAGS_set COP_SEQ_RANGE_HIGH_set
157 Perl_set_padlist(CV * cv, PADLIST *padlist){
158 PERL_ARGS_ASSERT_SET_PADLIST;
160 assert((Size_t)padlist != UINT64_C(0xEFEFEFEFEFEFEFEF));
162 assert((Size_t)padlist != UINT64_C(0xEFEFEFEF));
164 # error unknown pointer size
166 assert(!CvISXSUB(cv));
167 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
172 =for apidoc Am|PADLIST *|pad_new|int flags
174 Create a new padlist, updating the global variables for the
175 currently-compiling padlist to point to the new padlist. The following
176 flags can be OR'ed together:
178 padnew_CLONE this pad is for a cloned CV
179 padnew_SAVE save old globals on the save stack
180 padnew_SAVESUB also save extra stuff for start of sub
186 Perl_pad_new(pTHX_ int flags)
189 PADNAMELIST *padname;
193 ASSERT_CURPAD_LEGAL("pad_new");
195 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
196 * vars (based on flags) rather than storing vals + addresses for
197 * each individually. Also see pad_block_start.
198 * XXX DAPM Try to see whether all these conditionals are required
201 /* save existing state, ... */
203 if (flags & padnew_SAVE) {
205 if (! (flags & padnew_CLONE)) {
206 SAVESPTR(PL_comppad_name);
208 SAVEI32(PL_constpadix);
209 SAVEI32(PL_comppad_name_fill);
210 SAVEI32(PL_min_intro_pending);
211 SAVEI32(PL_max_intro_pending);
212 SAVEBOOL(PL_cv_has_eval);
213 if (flags & padnew_SAVESUB) {
214 SAVEBOOL(PL_pad_reset_pending);
218 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
219 * saved - check at some pt that this is okay */
221 /* ... create new pad ... */
223 Newxz(padlist, 1, PADLIST);
226 if (flags & padnew_CLONE) {
227 /* XXX DAPM I dont know why cv_clone needs it
228 * doing differently yet - perhaps this separate branch can be
229 * dispensed with eventually ???
232 AV * const a0 = newAV(); /* will be @_ */
233 av_store(pad, 0, MUTABLE_SV(a0));
236 PadnamelistREFCNT(padname = PL_comppad_name)++;
239 padlist->xpadl_id = PL_padlist_generation++;
240 av_store(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 =head1 Embedding Functions
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 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,
394 /* XXX DAPM for efficiency, we should only do this if we know we have
395 * children, or integrate this loop with general cleanup */
397 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
398 CV * const outercv = CvOUTSIDE(&cvbody);
399 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
400 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
401 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
402 PAD * const comppad = PadlistARRAY(padlist)[1];
403 SV ** const curpad = AvARRAY(comppad);
404 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
405 PADNAME * const name = namepad[ix];
406 if (name && PadnamePV(name) && *PadnamePV(name) == '&')
408 CV * const innercv = MUTABLE_CV(curpad[ix]);
409 U32 inner_rc = SvREFCNT(innercv);
411 assert(SvTYPE(innercv) != SVt_PVFM);
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 CvHSCXT(&cvbody) = NULL;
462 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
465 /* remove CvOUTSIDE unless this is an undef rather than a free */
467 CV * outside = CvOUTSIDE(&cvbody);
469 CvOUTSIDE(&cvbody) = NULL;
470 if (!CvWEAKOUTSIDE(&cvbody))
471 SvREFCNT_dec_NN(outside);
474 if (CvCONST(&cvbody)) {
475 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
476 /* CvCONST_off(cv); *//* turned off below */
478 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
479 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
480 * LEXICAL, which are used to determine the sub's name. */
481 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
486 =for apidoc cv_forget_slab
488 When a CV has a reference count on its slab (CvSLABBED), it is responsible
489 for making sure it is freed. (Hence, no two CVs should ever have a
490 reference count on the same slab.) The CV only needs to reference the slab
491 during compilation. Once it is compiled and CvROOT attached, it has
492 finished its job, so it can forget the slab.
498 Perl_cv_forget_slab(pTHX_ CV *cv)
500 const bool slabbed = !!CvSLABBED(cv);
503 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
505 if (!slabbed) return;
509 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
510 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
512 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
516 #ifdef PERL_DEBUG_READONLY_OPS
517 const size_t refcnt = slab->opslab_refcnt;
519 OpslabREFCNT_dec(slab);
520 #ifdef PERL_DEBUG_READONLY_OPS
521 if (refcnt > 1) Slab_to_ro(slab);
527 =for apidoc m|PADOFFSET|pad_alloc_name|PADNAME *name|U32 flags|HV *typestash|HV *ourstash
529 Allocates a place in the currently-compiling
530 pad (via L<perlapi/pad_alloc>) and
531 then stores a name for that entry. I<name> is adopted and
532 becomes the name entry; it must already contain the name
533 string. I<typestash> and I<ourstash> and the C<padadd_STATE>
534 flag get added to I<name>. None of the other
535 processing of L<perlapi/pad_add_name_pvn>
536 is done. Returns the offset of the allocated pad slot.
542 S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash,
545 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
547 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
549 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
552 SvPAD_TYPED_on(name);
554 MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)));
558 SvOURSTASH_set(name, ourstash);
559 SvREFCNT_inc_simple_void_NN(ourstash);
561 else if (flags & padadd_STATE) {
562 SvPAD_STATE_on(name);
565 padnamelist_store(PL_comppad_name, offset, name);
566 if (PadnameLEN(name) > 1)
567 PadnamelistMAXNAMED(PL_comppad_name) = offset;
572 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
574 Allocates a place in the currently-compiling pad for a named lexical
575 variable. Stores the name and other metadata in the name part of the
576 pad, and makes preparations to manage the variable's lexical scoping.
577 Returns the offset of the allocated pad slot.
579 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
580 If I<typestash> is non-null, the name is for a typed lexical, and this
581 identifies the type. If I<ourstash> is non-null, it's a lexical reference
582 to a package variable, and this identifies the package. The following
583 flags can be OR'ed together:
585 padadd_OUR redundantly specifies if it's a package var
586 padadd_STATE variable will retain value persistently
587 padadd_NO_DUP_CHECK skip check for lexical shadowing
593 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
594 U32 flags, HV *typestash, HV *ourstash)
599 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
601 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
602 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
605 name = newPADNAMEpvn(namepv, namelen);
607 if ((flags & padadd_NO_DUP_CHECK) == 0) {
609 SAVEFREEPADNAME(name); /* in case of fatal warnings */
610 /* check for duplicate declaration */
611 pad_check_dup(name, flags & padadd_OUR, ourstash);
612 PadnameREFCNT(name)++;
616 offset = pad_alloc_name(name, flags, typestash, ourstash);
618 /* not yet introduced */
619 COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
620 COP_SEQ_RANGE_HIGH_set(name, 0);
622 if (!PL_min_intro_pending)
623 PL_min_intro_pending = offset;
624 PL_max_intro_pending = offset;
625 /* if it's not a simple scalar, replace with an AV or HV */
626 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
627 assert(SvREFCNT(PL_curpad[offset]) == 1);
628 if (namelen != 0 && *namepv == '@')
629 sv_upgrade(PL_curpad[offset], SVt_PVAV);
630 else if (namelen != 0 && *namepv == '%')
631 sv_upgrade(PL_curpad[offset], SVt_PVHV);
632 else if (namelen != 0 && *namepv == '&')
633 sv_upgrade(PL_curpad[offset], SVt_PVCV);
634 assert(SvPADMY(PL_curpad[offset]));
635 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
636 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
637 (long)offset, PadnamePV(name),
638 PTR2UV(PL_curpad[offset])));
644 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
646 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
647 instead of a string/length pair.
653 Perl_pad_add_name_pv(pTHX_ const char *name,
654 const U32 flags, HV *typestash, HV *ourstash)
656 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
657 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
661 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
663 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
664 of an SV instead of a string/length pair.
670 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
674 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
675 namepv = SvPVutf8(name, namelen);
676 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
680 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
682 Allocates a place in the currently-compiling pad,
683 returning the offset of the allocated pad slot.
684 No name is initially attached to the pad slot.
685 I<tmptype> is a set of flags indicating the kind of pad entry required,
686 which will be set in the value SV for the allocated pad entry:
688 SVs_PADMY named lexical variable ("my", "our", "state")
689 SVs_PADTMP unnamed temporary store
690 SVf_READONLY constant shared between recursion levels
692 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
693 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
694 does not cause the SV in the pad slot to be marked read-only, but simply
695 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
696 least should be treated as such.
698 I<optype> should be an opcode indicating the type of operation that the
699 pad entry is to support. This doesn't affect operational semantics,
700 but is used for debugging.
705 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
706 * or at least rationalise ??? */
709 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
714 PERL_UNUSED_ARG(optype);
715 ASSERT_CURPAD_ACTIVE("pad_alloc");
717 if (AvARRAY(PL_comppad) != PL_curpad)
718 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
719 AvARRAY(PL_comppad), PL_curpad);
720 if (PL_pad_reset_pending)
722 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
723 /* For a my, simply push a null SV onto the end of PL_comppad. */
724 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
725 retval = AvFILLp(PL_comppad);
728 /* For a tmp, scan the pad from PL_padix upwards
729 * for a slot which has no name and no active value.
730 * For a constant, likewise, but use PL_constpadix.
732 PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name);
733 const SSize_t names_fill = PadnamelistMAX(PL_comppad_name);
734 const bool konst = cBOOL(tmptype & SVf_READONLY);
735 retval = konst ? PL_constpadix : PL_padix;
738 * Entries that close over unavailable variables
739 * in outer subs contain values not marked PADMY.
740 * Thus we must skip, not just pad values that are
741 * marked as current pad values, but also those with names.
742 * If pad_reset is enabled, ‘current’ means different
743 * things depending on whether we are allocating a con-
744 * stant or a target. For a target, things marked PADTMP
745 * can be reused; not so for constants.
748 if (++retval <= names_fill &&
749 (pn = names[retval]) && PadnamePV(pn))
751 sv = *av_fetch(PL_comppad, retval, TRUE);
754 (konst ? SVs_PADTMP : 0))
762 padnamelist_store(PL_comppad_name, retval, &PL_padname_const);
763 tmptype &= ~SVf_READONLY;
764 tmptype |= SVs_PADTMP;
766 *(konst ? &PL_constpadix : &PL_padix) = retval;
768 SvFLAGS(sv) |= tmptype;
769 PL_curpad = AvARRAY(PL_comppad);
771 DEBUG_X(PerlIO_printf(Perl_debug_log,
772 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
773 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
774 PL_op_name[optype]));
775 #ifdef DEBUG_LEAKING_SCALARS
776 sv->sv_debug_optype = optype;
777 sv->sv_debug_inpad = 1;
779 return (PADOFFSET)retval;
783 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
785 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
786 for an anonymous function that is lexically scoped inside the
787 currently-compiling function.
788 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
789 to the outer scope is weakened to avoid a reference loop.
791 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
793 I<optype> should be an opcode indicating the type of operation that the
794 pad entry is to support. This doesn't affect operational semantics,
795 but is used for debugging.
801 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
804 PADNAME * const name = newPADNAMEpvn("&", 1);
806 PERL_ARGS_ASSERT_PAD_ADD_ANON;
807 assert (SvTYPE(func) == SVt_PVCV);
810 /* These two aren't used; just make sure they're not equal to
811 * PERL_PADSEQ_INTRO. They should be 0 by default. */
812 assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO);
813 assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO);
814 ix = pad_alloc(optype, SVs_PADMY);
815 padnamelist_store(PL_comppad_name, ix, name);
816 /* XXX DAPM use PL_curpad[] ? */
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 C<ourstash>
856 C<is_our> indicates that the name to check is an '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_MISC))
875 return; /* nothing to check */
877 svp = PadnamelistARRAY(PL_comppad_name);
878 top = PadnamelistMAX(PL_comppad_name);
879 /* check the current scope */
880 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
882 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
883 PADNAME * const sv = svp[off];
885 && PadnameLEN(sv) == PadnameLEN(name)
887 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
888 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
889 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
891 if (is_our && (SvPAD_OUR(sv)))
892 break; /* "our" masking "our" */
893 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
894 Perl_warner(aTHX_ packWARN(WARN_MISC),
895 "\"%s\" %s %"PNf" masks earlier declaration in same %s",
896 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
897 *PadnamePV(sv) == '&' ? "subroutine" : "variable",
899 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
900 ? "scope" : "statement"));
905 /* check the rest of the pad */
908 PADNAME * const sv = svp[off];
910 && PadnameLEN(sv) == PadnameLEN(name)
912 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
913 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
914 && SvOURSTASH(sv) == ourstash
915 && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name)))
917 Perl_warner(aTHX_ packWARN(WARN_MISC),
918 "\"our\" variable %"PNf" redeclared", PNfARG(sv));
919 if ((I32)off <= PL_comppad_name_floor)
920 Perl_warner(aTHX_ packWARN(WARN_MISC),
921 "\t(Did you mean \"local\" instead of \"our\"?)\n");
931 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
933 Given the name of a lexical variable, find its position in the
934 currently-compiling pad.
935 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
936 I<flags> is reserved and must be zero.
937 If it is not in the current pad but appears in the pad of any lexically
938 enclosing scope, then a pseudo-entry for it is added in the current pad.
939 Returns the offset in the current pad,
940 or C<NOT_IN_PAD> if no such lexical is in scope.
946 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
951 const PADNAMELIST *namelist;
954 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
956 pad_peg("pad_findmy_pvn");
959 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
962 offset = pad_findlex(namepv, namelen, flags,
963 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
964 if ((PADOFFSET)offset != NOT_IN_PAD)
967 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
969 if (*namepv == '&') return NOT_IN_PAD;
971 /* look for an our that's being introduced; this allows
972 * our $foo = 0 unless defined $foo;
973 * to not give a warning. (Yes, this is a hack) */
975 namelist = PadlistNAMES(CvPADLIST(PL_compcv));
976 name_p = PadnamelistARRAY(namelist);
977 for (offset = PadnamelistMAXNAMED(namelist); offset > 0; offset--) {
978 const PADNAME * const name = name_p[offset];
979 if (name && PadnameLEN(name) == namelen
980 && !PadnameOUTER(name)
981 && (PadnameIsOUR(name))
982 && ( PadnamePV(name) == namepv
983 || memEQ(PadnamePV(name), namepv, namelen) )
984 && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
992 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
994 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
995 instead of a string/length pair.
1001 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1003 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1004 return pad_findmy_pvn(name, strlen(name), flags);
1008 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1010 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1011 of an SV instead of a string/length pair.
1017 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1021 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1022 namepv = SvPVutf8(name, namelen);
1023 return pad_findmy_pvn(namepv, namelen, flags);
1027 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1029 Find the position of the lexical C<$_> in the pad of the
1030 currently-executing function. Returns the offset in the current pad,
1031 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1032 the global one should be used instead).
1033 L</find_rundefsv> is likely to be more convenient.
1039 Perl_find_rundefsvoffset(pTHX)
1043 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1044 NULL, &out_pn, &out_flags);
1048 =for apidoc Am|SV *|find_rundefsv
1050 Find and return the variable that is named C<$_> in the lexical scope
1051 of the currently-executing function. This may be a lexical C<$_>,
1052 or will otherwise be the global one.
1058 Perl_find_rundefsv(pTHX)
1064 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1065 NULL, &name, &flags);
1067 if (po == NOT_IN_PAD || PadnameIsOUR(name))
1074 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1080 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1082 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1083 NULL, &name, &flags);
1085 if (po == NOT_IN_PAD || PadnameIsOUR(name))
1088 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1092 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|PADNAME** out_name|int *out_flags
1094 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1095 in the inner pads if it's found in an outer one.
1097 Returns the offset in the bottom pad of the lex or the fake lex.
1098 cv is the CV in which to start the search, and seq is the current cop_seq
1099 to match against. If warn is true, print appropriate warnings. The out_*
1100 vars return values, and so are pointers to where the returned values
1101 should be stored. out_capture, if non-null, requests that the innermost
1102 instance of the lexical is captured; out_name is set to the innermost
1103 matched pad name or fake pad name; out_flags returns the flags normally
1104 associated with the PARENT_FAKELEX_FLAGS field of a fake pad name.
1106 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1107 then comes back down, adding fake entries
1108 as it goes. It has to be this way
1109 because fake names in anon protoypes have to store in xlow the index into
1115 /* the CV has finished being compiled. This is not a sufficient test for
1116 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1117 #define CvCOMPILED(cv) CvROOT(cv)
1119 /* the CV does late binding of its lexicals */
1120 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1123 S_unavailable(pTHX_ PADNAME *name)
1125 /* diag_listed_as: Variable "%s" is not available */
1126 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1127 "%se \"%"PNf"\" is not available",
1128 *PadnamePV(name) == '&'
1135 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1136 int warn, SV** out_capture, PADNAME** out_name, int *out_flags)
1138 I32 offset, new_offset;
1141 const PADLIST * const padlist = CvPADLIST(cv);
1142 const bool staleok = !!(flags & padadd_STALEOK);
1144 PERL_ARGS_ASSERT_PAD_FINDLEX;
1146 flags &= ~ padadd_STALEOK; /* one-shot flag */
1148 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1153 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1154 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1155 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1156 out_capture ? " capturing" : "" ));
1158 /* first, search this pad */
1160 if (padlist) { /* not an undef CV */
1161 I32 fake_offset = 0;
1162 const PADNAMELIST * const names = PadlistNAMES(padlist);
1163 PADNAME * const * const name_p = PadnamelistARRAY(names);
1165 for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
1166 const PADNAME * const name = name_p[offset];
1167 if (name && PadnameLEN(name) == namelen
1168 && ( PadnamePV(name) == namepv
1169 || memEQ(PadnamePV(name), namepv, namelen) ))
1171 if (PadnameOUTER(name)) {
1172 fake_offset = offset; /* in case we don't find a real one */
1175 if (PadnameIN_SCOPE(name, seq))
1180 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1181 if (offset > 0) { /* not fake */
1183 *out_name = name_p[offset]; /* return the name */
1185 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1186 * instances. For now, we just test !CvUNIQUE(cv), but
1187 * ideally, we should detect my's declared within loops
1188 * etc - this would allow a wider range of 'not stayed
1189 * shared' warnings. We also treated already-compiled
1190 * lexes as not multi as viewed from evals. */
1192 *out_flags = CvANON(cv) ?
1194 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1195 ? PAD_FAKELEX_MULTI : 0;
1197 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1198 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1199 PTR2UV(cv), (long)offset,
1200 (unsigned long)COP_SEQ_RANGE_LOW(*out_name),
1201 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name)));
1203 else { /* fake match */
1204 offset = fake_offset;
1205 *out_name = name_p[offset]; /* return the name */
1206 *out_flags = PARENT_FAKELEX_FLAGS(*out_name);
1207 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1208 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1209 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1210 (unsigned long) PARENT_PAD_INDEX(*out_name)
1214 /* return the lex? */
1219 if (PadnameIsOUR(*out_name)) {
1220 *out_capture = NULL;
1224 /* trying to capture from an anon prototype? */
1226 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1227 : *out_flags & PAD_FAKELEX_ANON)
1233 *out_capture = NULL;
1239 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1240 && !PadnameIsSTATE(name_p[offset])
1241 && warn && ckWARN(WARN_CLOSURE)) {
1243 /* diag_listed_as: Variable "%s" will not stay
1245 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1246 "%se \"%"UTF8f"\" will not stay shared",
1247 *namepv == '&' ? "Subroutin" : "Variabl",
1248 UTF8fARG(1, namelen, namepv));
1251 if (fake_offset && CvANON(cv)
1252 && CvCLONE(cv) &&!CvCLONED(cv))
1255 /* not yet caught - look further up */
1256 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1257 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1260 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1262 newwarn, out_capture, out_name, out_flags);
1267 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1268 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1269 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1270 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1271 PTR2UV(cv), PTR2UV(*out_capture)));
1273 if (SvPADSTALE(*out_capture)
1274 && (!CvDEPTH(cv) || !staleok)
1275 && !PadnameIsSTATE(name_p[offset]))
1279 *out_capture = NULL;
1282 if (!*out_capture) {
1283 if (namelen != 0 && *namepv == '@')
1284 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1285 else if (namelen != 0 && *namepv == '%')
1286 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1287 else if (namelen != 0 && *namepv == '&')
1288 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1290 *out_capture = sv_newmortal();
1298 /* it's not in this pad - try above */
1303 /* out_capture non-null means caller wants us to capture lex; in
1304 * addition we capture ourselves unless it's an ANON/format */
1305 new_capturep = out_capture ? out_capture :
1306 CvLATE(cv) ? NULL : &new_capture;
1308 offset = pad_findlex(namepv, namelen,
1309 flags | padadd_STALEOK*(new_capturep == &new_capture),
1310 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1311 new_capturep, out_name, out_flags);
1312 if ((PADOFFSET)offset == NOT_IN_PAD)
1315 /* found in an outer CV. Add appropriate fake entry to this pad */
1317 /* don't add new fake entries (via eval) to CVs that we have already
1318 * finished compiling, or to undef CVs */
1319 if (CvCOMPILED(cv) || !padlist)
1320 return 0; /* this dummy (and invalid) value isnt used by the caller */
1323 /* This relies on sv_setsv_flags() upgrading the destination to the same
1324 type as the source, independent of the flags set, and on it being
1325 "good" and only copying flag bits and pointers that it understands.
1327 PADNAME *new_name = newPADNAMEouter(*out_name);
1328 PADNAMELIST * const ocomppad_name = PL_comppad_name;
1329 PAD * const ocomppad = PL_comppad;
1330 PL_comppad_name = PadlistNAMES(padlist);
1331 PL_comppad = PadlistARRAY(padlist)[1];
1332 PL_curpad = AvARRAY(PL_comppad);
1335 = pad_alloc_name(new_name,
1336 PadnameIsSTATE(*out_name) ? padadd_STATE : 0,
1337 PadnameTYPE(*out_name),
1338 PadnameOURSTASH(*out_name)
1341 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1342 "Pad addname: %ld \"%.*s\" FAKE\n",
1344 (int) PadnameLEN(new_name),
1345 PadnamePV(new_name)));
1346 PARENT_FAKELEX_FLAGS_set(new_name, *out_flags);
1348 PARENT_PAD_INDEX_set(new_name, 0);
1349 if (PadnameIsOUR(new_name)) {
1350 NOOP; /* do nothing */
1352 else if (CvLATE(cv)) {
1353 /* delayed creation - just note the offset within parent pad */
1354 PARENT_PAD_INDEX_set(new_name, offset);
1358 /* immediate creation - capture outer value right now */
1359 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1360 /* But also note the offset, as newMYSUB needs it */
1361 PARENT_PAD_INDEX_set(new_name, offset);
1362 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1363 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1364 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1366 *out_name = new_name;
1367 *out_flags = PARENT_FAKELEX_FLAGS(new_name);
1369 PL_comppad_name = ocomppad_name;
1370 PL_comppad = ocomppad;
1371 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1379 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1381 Get the value at offset I<po> in the current (compiling or executing) pad.
1382 Use macro PAD_SV instead of calling this function directly.
1388 Perl_pad_sv(pTHX_ PADOFFSET po)
1390 ASSERT_CURPAD_ACTIVE("pad_sv");
1393 Perl_croak(aTHX_ "panic: pad_sv po");
1394 DEBUG_X(PerlIO_printf(Perl_debug_log,
1395 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1396 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1398 return PL_curpad[po];
1402 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1404 Set the value at offset I<po> in the current (compiling or executing) pad.
1405 Use the macro PAD_SETSV() rather than calling this function directly.
1411 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1413 PERL_ARGS_ASSERT_PAD_SETSV;
1415 ASSERT_CURPAD_ACTIVE("pad_setsv");
1417 DEBUG_X(PerlIO_printf(Perl_debug_log,
1418 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1419 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1424 #endif /* DEBUGGING */
1427 =for apidoc m|void|pad_block_start|int full
1429 Update the pad compilation state variables on entry to a new block.
1434 /* XXX DAPM perhaps:
1435 * - integrate this in general state-saving routine ???
1436 * - combine with the state-saving going on in pad_new ???
1437 * - introduce a new SAVE type that does all this in one go ?
1441 Perl_pad_block_start(pTHX_ int full)
1443 ASSERT_CURPAD_ACTIVE("pad_block_start");
1444 SAVEI32(PL_comppad_name_floor);
1445 PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name);
1447 PL_comppad_name_fill = PL_comppad_name_floor;
1448 if (PL_comppad_name_floor < 0)
1449 PL_comppad_name_floor = 0;
1450 SAVEI32(PL_min_intro_pending);
1451 SAVEI32(PL_max_intro_pending);
1452 PL_min_intro_pending = 0;
1453 SAVEI32(PL_comppad_name_fill);
1454 SAVEI32(PL_padix_floor);
1455 /* PL_padix_floor is what PL_padix is reset to at the start of each
1456 statement, by pad_reset(). We set it when entering a new scope
1457 to keep things like this working:
1458 print "$foo$bar", do { this(); that() . "foo" };
1459 We must not let "$foo$bar" and the later concatenation share the
1461 PL_padix_floor = PL_padix;
1462 PL_pad_reset_pending = FALSE;
1466 =for apidoc Am|U32|intro_my
1468 "Introduce" C<my> variables to visible status. This is called during parsing
1469 at the end of each statement to make lexical variables visible to subsequent
1482 ASSERT_CURPAD_ACTIVE("intro_my");
1483 if (PL_compiling.cop_seq) {
1484 seq = PL_compiling.cop_seq;
1485 PL_compiling.cop_seq = 0;
1488 seq = PL_cop_seqmax;
1489 if (! PL_min_intro_pending)
1492 svp = PadnamelistARRAY(PL_comppad_name);
1493 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1494 PADNAME * const sv = svp[i];
1496 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1497 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1499 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1500 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1501 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1502 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1503 (long)i, PadnamePV(sv),
1504 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1505 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1510 PL_min_intro_pending = 0;
1511 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1512 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1513 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1519 =for apidoc m|void|pad_leavemy
1521 Cleanup at end of scope during compilation: set the max seq number for
1522 lexicals in this scope and warn of any lexicals that never got introduced.
1528 Perl_pad_leavemy(pTHX)
1532 PADNAME * const * const svp = PadnamelistARRAY(PL_comppad_name);
1534 PL_pad_reset_pending = FALSE;
1536 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1537 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1538 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1539 const PADNAME * const name = svp[off];
1540 if (name && PadnameLEN(name) && !PadnameOUTER(name))
1541 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1542 "%"PNf" never introduced",
1546 /* "Deintroduce" my variables that are leaving with this scope. */
1547 for (off = PadnamelistMAX(PL_comppad_name);
1548 off > PL_comppad_name_fill; off--) {
1549 PADNAME * const sv = svp[off];
1550 if (sv && PadnameLEN(sv) && !PadnameOUTER(sv)
1551 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1553 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1554 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1555 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1556 (long)off, PadnamePV(sv),
1557 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1558 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1560 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1561 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1562 OP *kid = newOP(OP_INTROCV, 0);
1564 o = op_prepend_elem(OP_LINESEQ, kid, o);
1569 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1570 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1575 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1577 Abandon the tmp in the current pad at offset po and replace with a
1584 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1586 ASSERT_CURPAD_LEGAL("pad_swipe");
1589 if (AvARRAY(PL_comppad) != PL_curpad)
1590 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1591 AvARRAY(PL_comppad), PL_curpad);
1592 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1593 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1594 (long)po, (long)AvFILLp(PL_comppad));
1596 DEBUG_X(PerlIO_printf(Perl_debug_log,
1597 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1598 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1601 SvREFCNT_dec(PL_curpad[po]);
1604 /* if pad tmps aren't shared between ops, then there's no need to
1605 * create a new tmp when an existing op is freed */
1606 #ifdef USE_PAD_RESET
1607 PL_curpad[po] = newSV(0);
1608 SvPADTMP_on(PL_curpad[po]);
1610 PL_curpad[po] = NULL;
1612 if (PadnamelistMAX(PL_comppad_name) != -1
1613 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1614 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1615 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1617 PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef;
1619 /* Use PL_constpadix here, not PL_padix. The latter may have been
1620 reset by pad_reset. We don’t want pad_alloc to have to scan the
1621 whole pad when allocating a constant. */
1622 if ((I32)po < PL_constpadix)
1623 PL_constpadix = po - 1;
1627 =for apidoc m|void|pad_reset
1629 Mark all the current temporaries for reuse
1634 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1635 * between OPs from different statements. During compilation, at the start
1636 * of each statement pad_reset resets PL_padix back to its previous value.
1637 * When allocating a target, pad_alloc begins its scan through the pad at
1642 #ifdef USE_PAD_RESET
1643 if (AvARRAY(PL_comppad) != PL_curpad)
1644 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1645 AvARRAY(PL_comppad), PL_curpad);
1647 DEBUG_X(PerlIO_printf(Perl_debug_log,
1648 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1649 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1650 (long)PL_padix, (long)PL_padix_floor
1654 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1655 PL_padix = PL_padix_floor;
1658 PL_pad_reset_pending = FALSE;
1662 =for apidoc Amx|void|pad_tidy|padtidy_type type
1664 Tidy up a pad at the end of compilation of the code to which it belongs.
1665 Jobs performed here are: remove most stuff from the pads of anonsub
1666 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1667 the kind of subroutine:
1669 padtidy_SUB ordinary subroutine
1670 padtidy_SUBCLONE prototype for lexical closure
1671 padtidy_FORMAT format
1676 /* XXX DAPM surely most of this stuff should be done properly
1677 * at the right time beforehand, rather than going around afterwards
1678 * cleaning up our mistakes ???
1682 Perl_pad_tidy(pTHX_ padtidy_type type)
1686 ASSERT_CURPAD_ACTIVE("pad_tidy");
1688 /* If this CV has had any 'eval-capable' ops planted in it:
1689 * i.e. it contains any of:
1693 * * use re 'eval'; /$var/
1696 * Then any anon prototypes in the chain of CVs should be marked as
1697 * cloneable, so that for example the eval's CV in
1701 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1702 * potentially have an eval executed within it.
1705 if (PL_cv_has_eval || PL_perldb) {
1707 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1708 if (cv != PL_compcv && CvCOMPILED(cv))
1709 break; /* no need to mark already-compiled code */
1711 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1712 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1719 /* extend namepad to match curpad */
1720 if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad))
1721 padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1723 if (type == padtidy_SUBCLONE) {
1724 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1727 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1729 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1732 * The only things that a clonable function needs in its
1733 * pad are anonymous subs, constants and GVs.
1734 * The rest are created anew during cloning.
1736 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1739 if (!(PadnamePV(namesv) &&
1740 (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&')))
1742 SvREFCNT_dec(PL_curpad[ix]);
1743 PL_curpad[ix] = NULL;
1747 else if (type == padtidy_SUB) {
1748 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1749 AV * const av = newAV(); /* Will be @_ */
1750 av_store(PL_comppad, 0, MUTABLE_SV(av));
1754 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1755 PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name);
1757 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1758 if (!namep[ix]) namep[ix] = &PL_padname_undef;
1759 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1761 if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) {
1762 /* This is a work around for how the current implementation of
1763 ?{ } blocks in regexps interacts with lexicals.
1765 One of our lexicals.
1766 Can't do this on all lexicals, otherwise sub baz() won't
1775 because completion of compiling &bar calling pad_tidy()
1776 would cause (top level) $foo to be marked as stale, and
1777 "no longer available". */
1778 SvPADSTALE_on(PL_curpad[ix]);
1782 PL_curpad = AvARRAY(PL_comppad);
1786 =for apidoc m|void|pad_free|PADOFFSET po
1788 Free the SV at offset po in the current pad.
1793 /* XXX DAPM integrate with pad_swipe ???? */
1795 Perl_pad_free(pTHX_ PADOFFSET po)
1797 #ifndef USE_PAD_RESET
1800 ASSERT_CURPAD_LEGAL("pad_free");
1803 if (AvARRAY(PL_comppad) != PL_curpad)
1804 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1805 AvARRAY(PL_comppad), PL_curpad);
1807 Perl_croak(aTHX_ "panic: pad_free po");
1809 DEBUG_X(PerlIO_printf(Perl_debug_log,
1810 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1811 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1814 #ifndef USE_PAD_RESET
1816 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1817 SvFLAGS(sv) &= ~SVs_PADTMP;
1819 if ((I32)po < PL_padix)
1825 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1827 Dump the contents of a padlist
1833 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1835 const PADNAMELIST *pad_name;
1841 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1846 pad_name = PadlistNAMES(padlist);
1847 pad = PadlistARRAY(padlist)[1];
1848 pname = PadnamelistARRAY(pad_name);
1849 ppad = AvARRAY(pad);
1850 Perl_dump_indent(aTHX_ level, file,
1851 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1852 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1855 for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) {
1856 const PADNAME *namesv = pname[ix];
1857 if (namesv && !PadnameLEN(namesv)) {
1861 if (PadnameOUTER(namesv))
1862 Perl_dump_indent(aTHX_ level+1, file,
1863 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1866 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1868 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1869 (unsigned long)PARENT_PAD_INDEX(namesv)
1873 Perl_dump_indent(aTHX_ level+1, file,
1874 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1877 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1878 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1879 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1884 Perl_dump_indent(aTHX_ level+1, file,
1885 "%2d. 0x%"UVxf"<%lu>\n",
1888 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1897 =for apidoc m|void|cv_dump|CV *cv|const char *title
1899 dump the contents of a CV
1905 S_cv_dump(pTHX_ const CV *cv, const char *title)
1907 const CV * const outside = CvOUTSIDE(cv);
1908 PADLIST* const padlist = CvPADLIST(cv);
1910 PERL_ARGS_ASSERT_CV_DUMP;
1912 PerlIO_printf(Perl_debug_log,
1913 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1916 (CvANON(cv) ? "ANON"
1917 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1918 : (cv == PL_main_cv) ? "MAIN"
1919 : CvUNIQUE(cv) ? "UNIQUE"
1920 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1923 : CvANON(outside) ? "ANON"
1924 : (outside == PL_main_cv) ? "MAIN"
1925 : CvUNIQUE(outside) ? "UNIQUE"
1926 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1928 PerlIO_printf(Perl_debug_log,
1929 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1930 do_dump_pad(1, Perl_debug_log, padlist, 1);
1933 #endif /* DEBUGGING */
1936 =for apidoc Am|CV *|cv_clone|CV *proto
1938 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1939 of the function: its code, pad structure, and other attributes.
1940 The prototype is combined with a capture of outer lexicals to which the
1941 code refers, which are taken from the currently-executing instance of
1942 the immediately surrounding code.
1947 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1950 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1953 PADLIST* const protopadlist = CvPADLIST(proto);
1954 PADNAMELIST *const protopad_name = PadlistNAMES(protopadlist);
1955 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1956 PADNAME** const pname = PadnamelistARRAY(protopad_name);
1957 SV** const ppad = AvARRAY(protopad);
1958 const I32 fname = PadnamelistMAX(protopad_name);
1959 const I32 fpad = AvFILLp(protopad);
1962 bool subclones = FALSE;
1964 assert(!CvUNIQUE(proto));
1966 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1967 * reliable. The currently-running sub is always the one we need to
1969 * For my subs, the currently-running sub may not be the one we want.
1970 * We have to check whether it is a clone of CvOUTSIDE.
1971 * Note that in general for formats, CvOUTSIDE != find_runcv.
1972 * Since formats may be nested inside closures, CvOUTSIDE may point
1973 * to a prototype; we instead want the cloned parent who called us.
1977 if (CvWEAKOUTSIDE(proto))
1978 outside = find_runcv(NULL);
1980 outside = CvOUTSIDE(proto);
1981 if ((CvCLONE(outside) && ! CvCLONED(outside))
1982 || !CvPADLIST(outside)
1983 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1984 outside = find_runcv_where(
1985 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
1987 /* outside could be null */
1991 depth = outside ? CvDEPTH(outside) : 0;
1996 SAVESPTR(PL_compcv);
1998 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2001 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2003 SAVESPTR(PL_comppad_name);
2004 PL_comppad_name = protopad_name;
2005 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
2006 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
2008 av_fill(PL_comppad, fpad);
2010 PL_curpad = AvARRAY(PL_comppad);
2012 outpad = outside && CvPADLIST(outside)
2013 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2015 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
2017 for (ix = fpad; ix > 0; ix--) {
2018 PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL;
2020 if (namesv && PadnameLEN(namesv)) { /* lexical */
2021 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2025 if (PadnameOUTER(namesv)) { /* lexical from outside? */
2026 /* formats may have an inactive, or even undefined, parent;
2027 but state vars are always available. */
2028 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2029 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2030 && (!outside || !CvDEPTH(outside))) ) {
2031 S_unavailable(aTHX_ namesv);
2035 SvREFCNT_inc_simple_void_NN(sv);
2038 const char sigil = PadnamePV(namesv)[0];
2040 /* If there are state subs, we need to clone them, too.
2041 But they may need to close over variables we have
2042 not cloned yet. So we will have to do a second
2043 pass. Furthermore, there may be state subs clos-
2044 ing over other state subs’ entries, so we have
2045 to put a stub here and then clone into it on the
2047 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2048 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2050 sv = newSV_type(SVt_PVCV);
2053 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2056 /* Just provide a stub, but name it. It will be
2057 upgrade to the real thing on scope entry. */
2060 PERL_HASH(hash, PadnamePV(namesv)+1,
2061 PadnameLEN(namesv) - 1);
2062 sv = newSV_type(SVt_PVCV);
2065 share_hek(PadnamePV(namesv)+1,
2066 1 - PadnameLEN(namesv),
2071 else sv = SvREFCNT_inc(ppad[ix]);
2072 else if (sigil == '@')
2073 sv = MUTABLE_SV(newAV());
2074 else if (sigil == '%')
2075 sv = MUTABLE_SV(newHV());
2078 /* reset the 'assign only once' flag on each state var */
2079 if (sigil != '&' && SvPAD_STATE(namesv))
2084 else if (namesv && PadnamePV(namesv)) {
2085 sv = SvREFCNT_inc_NN(ppad[ix]);
2095 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);
2102 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2106 /* Constant sub () { $x } closing over $x:
2107 * The prototype was marked as a candiate for const-ization,
2108 * so try to grab the current const value, and if successful,
2109 * turn into a const sub:
2112 OP *o = CvSTART(cv);
2114 for (; o; o = o->op_next)
2115 if (o->op_type == OP_PADSV)
2117 ASSUME(o->op_type == OP_PADSV);
2118 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2119 /* the candidate should have 1 ref from this pad and 1 ref
2120 * from the parent */
2121 if (const_sv && SvREFCNT(const_sv) == 2) {
2122 const bool was_method = cBOOL(CvMETHOD(cv));
2123 bool copied = FALSE;
2125 PADNAME * const pn =
2126 PadlistNAMESARRAY(CvPADLIST(outside))
2127 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2128 CvPADLIST(cv))[o->op_targ])];
2129 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2131 if (PadnameLVALUE(pn)) {
2132 /* We have a lexical that is potentially modifiable
2133 elsewhere, so making a constant will break clo-
2134 sure behaviour. If this is a ‘simple lexical
2135 op tree’, i.e., sub(){$x}, emit a deprecation
2136 warning, but continue to exhibit the old behav-
2137 iour of making it a constant based on the ref-
2138 count of the candidate variable.
2140 A simple lexical op tree looks like this:
2148 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2152 Perl_ck_warner_d(aTHX_
2153 packWARN(WARN_DEPRECATED),
2154 "Constants from lexical "
2155 "variables potentially "
2156 "modified elsewhere are "
2158 /* We *copy* the lexical variable, and donate the
2159 copy to newCONSTSUB. Yes, this is ugly, and
2160 should be killed. We need to do this for the
2161 time being, however, because turning on SvPADTMP
2162 on a lexical will have observable effects
2164 const_sv = newSVsv(const_sv);
2172 SvREFCNT_inc_simple_void_NN(const_sv);
2173 /* If the lexical is not used elsewhere, it is safe to turn on
2174 SvPADTMP, since it is only when it is used in lvalue con-
2175 text that the difference is observable. */
2176 SvREADONLY_on(const_sv);
2177 SvPADTMP_on(const_sv);
2178 SvREFCNT_dec_NN(cv);
2179 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2193 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2198 const bool newcv = !cv;
2200 assert(!CvUNIQUE(proto));
2202 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2203 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2207 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2210 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2211 else CvGV_set(cv,CvGV(proto));
2212 CvSTASH_set(cv, CvSTASH(proto));
2214 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2216 CvSTART(cv) = CvSTART(proto);
2217 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2220 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2222 SvUTF8_on(MUTABLE_SV(cv));
2225 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2227 if (CvPADLIST(proto))
2228 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2231 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2232 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2233 cv_dump(proto, "Proto");
2241 Perl_cv_clone(pTHX_ CV *proto)
2243 PERL_ARGS_ASSERT_CV_CLONE;
2245 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2246 return S_cv_clone(aTHX_ proto, NULL, NULL);
2249 /* Called only by pp_clonecv */
2251 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2253 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2255 return S_cv_clone(aTHX_ proto, target, NULL);
2261 Returns an SV containing the name of the CV, mainly for use in error
2262 reporting. The CV may actually be a GV instead, in which case the returned
2263 SV holds the GV's name. Anything other than a GV or CV is treated as a
2264 string already holding the sub name, but this could change in the future.
2266 An SV may be passed as a second argument. If so, the name will be assigned
2267 to it and it will be returned. Otherwise the returned SV will be a new
2270 If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
2271 included. If the first argument is neither a CV nor a GV, this flag is
2272 ignored (subject to change).
2278 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2280 PERL_ARGS_ASSERT_CV_NAME;
2281 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2282 if (sv) sv_setsv(sv,(SV *)cv);
2283 return sv ? (sv) : (SV *)cv;
2286 SV * const retsv = sv ? (sv) : sv_newmortal();
2287 if (SvTYPE(cv) == SVt_PVCV) {
2289 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2290 sv_sethek(retsv, CvNAME_HEK(cv));
2292 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2293 sv_catpvs(retsv, "::");
2294 sv_cathek(retsv, CvNAME_HEK(cv));
2297 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2298 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2299 else gv_efullname3(retsv, CvGV(cv), NULL);
2301 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2302 else gv_efullname3(retsv,(GV *)cv,NULL);
2308 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2310 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2311 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2312 moved to a pre-existing CV struct.
2318 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2321 PADNAMELIST * const comppad_name = PadlistNAMES(padlist);
2322 AV * const comppad = PadlistARRAY(padlist)[1];
2323 PADNAME ** const namepad = PadnamelistARRAY(comppad_name);
2324 SV ** const curpad = AvARRAY(comppad);
2326 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2327 PERL_UNUSED_ARG(old_cv);
2329 for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) {
2330 const PADNAME * const name = namepad[ix];
2331 if (name && name != &PL_padname_undef && !PadnameIsSTATE(name)
2332 && *PadnamePV(name) == '&')
2334 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2335 /* XXX 0afba48f added code here to check for a proto CV
2336 attached to the pad entry by magic. But shortly there-
2337 after 81df9f6f95 moved the magic to the pad name. The
2338 code here was never updated, so it wasn’t doing anything
2339 and got deleted when PADNAME became a distinct type. Is
2340 there any bug as a result? */
2341 CV * const innercv = MUTABLE_CV(curpad[ix]);
2342 if (CvOUTSIDE(innercv) == old_cv) {
2343 if (!CvWEAKOUTSIDE(innercv)) {
2344 SvREFCNT_dec(old_cv);
2345 SvREFCNT_inc_simple_void_NN(new_cv);
2347 CvOUTSIDE(innercv) = new_cv;
2350 else { /* format reference */
2351 SV * const rv = curpad[ix];
2353 if (!SvOK(rv)) continue;
2355 assert(SvWEAKREF(rv));
2356 innercv = (CV *)SvRV(rv);
2357 assert(!CvWEAKOUTSIDE(innercv));
2358 SvREFCNT_dec(CvOUTSIDE(innercv));
2359 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2366 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2368 Push a new pad frame onto the padlist, unless there's already a pad at
2369 this depth, in which case don't bother creating a new one. Then give
2370 the new pad an @_ in slot zero.
2376 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2378 PERL_ARGS_ASSERT_PAD_PUSH;
2380 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2381 PAD** const svp = PadlistARRAY(padlist);
2382 AV* const newpad = newAV();
2383 SV** const oldpad = AvARRAY(svp[depth-1]);
2384 I32 ix = AvFILLp((const AV *)svp[1]);
2385 const I32 names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]);
2386 PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]);
2389 for ( ;ix > 0; ix--) {
2390 if (names_fill >= ix && PadnameLEN(names[ix])) {
2391 const char sigil = PadnamePV(names[ix])[0];
2392 if (PadnameOUTER(names[ix])
2393 || PadnameIsSTATE(names[ix])
2396 /* outer lexical or anon code */
2397 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2399 else { /* our own lexical */
2402 sv = MUTABLE_SV(newAV());
2403 else if (sigil == '%')
2404 sv = MUTABLE_SV(newHV());
2407 av_store(newpad, ix, sv);
2410 else if (PadnamePV(names[ix])) {
2411 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2414 /* save temporaries on recursion? */
2415 SV * const sv = newSV(0);
2416 av_store(newpad, ix, sv);
2421 av_store(newpad, 0, MUTABLE_SV(av));
2424 padlist_store(padlist, depth, newpad);
2428 #if defined(USE_ITHREADS)
2430 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2433 =for apidoc padlist_dup
2441 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2447 PERL_ARGS_ASSERT_PADLIST_DUP;
2449 cloneall = cBOOL(param->flags & CLONEf_COPY_STACKS);
2450 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2452 max = cloneall ? PadlistMAX(srcpad) : 1;
2454 Newx(dstpad, 1, PADLIST);
2455 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2456 PadlistMAX(dstpad) = max;
2457 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2459 PadlistARRAY(dstpad)[0] = (PAD *)
2460 padnamelist_dup(PadlistNAMES(srcpad), param);
2461 PadnamelistREFCNT(PadlistNAMES(dstpad))++;
2464 for (depth = 1; depth <= max; ++depth)
2465 PadlistARRAY(dstpad)[depth] =
2466 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2468 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2469 to build anything other than the first level of pads. */
2470 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2472 const I32 names_fill = PadnamelistMAX(PadlistNAMES(srcpad));
2473 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2474 SV **oldpad = AvARRAY(srcpad1);
2475 PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad));
2481 av_extend(pad1, ix);
2482 PadlistARRAY(dstpad)[1] = pad1;
2483 pad1a = AvARRAY(pad1);
2488 for ( ;ix > 0; ix--) {
2491 } else if (names_fill >= ix && names[ix] &&
2492 PadnameLEN(names[ix])) {
2493 const char sigil = PadnamePV(names[ix])[0];
2494 if (PadnameOUTER(names[ix])
2495 || PadnameIsSTATE(names[ix])
2498 /* outer lexical or anon code */
2499 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2501 else { /* our own lexical */
2502 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2503 /* This is a work around for how the current
2504 implementation of ?{ } blocks in regexps
2505 interacts with lexicals. */
2506 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2511 sv = MUTABLE_SV(newAV());
2512 else if (sigil == '%')
2513 sv = MUTABLE_SV(newHV());
2520 else if (( names_fill >= ix && names[ix]
2521 && PadnamePV(names[ix]) )) {
2522 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2525 /* save temporaries on recursion? */
2526 SV * const sv = newSV(0);
2529 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2530 FIXTHAT before merging this branch.
2531 (And I know how to) */
2532 if (SvPADTMP(oldpad[ix]))
2538 args = newAV(); /* Will be @_ */
2540 pad1a[0] = (SV *)args;
2548 #endif /* USE_ITHREADS */
2551 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2554 SSize_t const oldmax = PadlistMAX(padlist);
2556 PERL_ARGS_ASSERT_PADLIST_STORE;
2560 if (key > PadlistMAX(padlist)) {
2561 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2562 (SV ***)&PadlistARRAY(padlist),
2563 (SV ***)&PadlistARRAY(padlist));
2564 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2567 ary = PadlistARRAY(padlist);
2568 SvREFCNT_dec(ary[key]);
2574 =for apidoc newPADNAMELIST
2576 Creates a new pad name list. C<max> is the highest index for which space
2583 Perl_newPADNAMELIST(pTHX_ size_t max)
2586 Newx(pnl, 1, PADNAMELIST);
2587 Newxz(PadnamelistARRAY(pnl), max+1, PADNAME *);
2588 PadnamelistMAX(pnl) = -1;
2589 PadnamelistREFCNT(pnl) = 1;
2590 PadnamelistMAXNAMED(pnl) = 0;
2591 pnl->xpadnl_max = max;
2596 =for apidoc padnamelist_store
2598 Stores the pad name (which may be null) at the given index, freeing any
2599 existing pad name in that slot.
2605 Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val)
2609 PERL_ARGS_ASSERT_PADNAMELIST_STORE;
2613 if (key > pnl->xpadnl_max)
2614 av_extend_guts(NULL,key,&pnl->xpadnl_max,
2615 (SV ***)&PadnamelistARRAY(pnl),
2616 (SV ***)&PadnamelistARRAY(pnl));
2617 if (PadnamelistMAX(pnl) < key) {
2618 Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1,
2619 key-PadnamelistMAX(pnl), PADNAME *);
2620 PadnamelistMAX(pnl) = key;
2622 ary = PadnamelistARRAY(pnl);
2624 PadnameREFCNT_dec(ary[key]);
2630 =for apidoc padnamelist_fetch
2632 Fetches the pad name from the given index.
2638 Perl_padnamelist_fetch(pTHX_ PADNAMELIST *pnl, SSize_t key)
2640 PERL_ARGS_ASSERT_PADNAMELIST_FETCH;
2643 return key > PadnamelistMAX(pnl) ? NULL : PadnamelistARRAY(pnl)[key];
2647 Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl)
2649 PERL_ARGS_ASSERT_PADNAMELIST_FREE;
2650 if (!--PadnamelistREFCNT(pnl)) {
2651 while(PadnamelistMAX(pnl) >= 0)
2653 PADNAME * const pn =
2654 PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--];
2656 PadnameREFCNT_dec(pn);
2658 Safefree(PadnamelistARRAY(pnl));
2663 #if defined(USE_ITHREADS)
2666 =for apidoc padnamelist_dup
2668 Duplicates a pad name list.
2674 Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param)
2676 PADNAMELIST *dstpad;
2677 SSize_t max = PadnamelistMAX(srcpad);
2679 PERL_ARGS_ASSERT_PADNAMELIST_DUP;
2681 /* look for it in the table first */
2682 dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad);
2686 dstpad = newPADNAMELIST(max);
2687 PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */
2688 PadnamelistMAXNAMED(dstpad) = PadnamelistMAXNAMED(srcpad);
2689 PadnamelistMAX(dstpad) = max;
2691 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2692 for (; max >= 0; max--)
2693 if (PadnamelistARRAY(srcpad)[max]) {
2694 PadnamelistARRAY(dstpad)[max] =
2695 padname_dup(PadnamelistARRAY(srcpad)[max], param);
2696 PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++;
2702 #endif /* USE_ITHREADS */
2705 =for apidoc newPADNAMEpvn
2707 Constructs and returns a new pad name. I<s> must be a UTF8 string. Do not
2708 use this for pad names that point to outer lexicals. See
2709 L</newPADNAMEouter>.
2715 Perl_newPADNAMEpvn(pTHX_ const char *s, STRLEN len)
2717 struct padname_with_str *alloc;
2718 char *alloc2; /* for Newxz */
2720 PERL_ARGS_ASSERT_NEWPADNAMEPVN;
2722 STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1,
2724 alloc = (struct padname_with_str *)alloc2;
2725 pn = (PADNAME *)alloc;
2726 PadnameREFCNT(pn) = 1;
2727 PadnamePV(pn) = alloc->xpadn_str;
2728 Copy(s, PadnamePV(pn), len, char);
2729 *(PadnamePV(pn) + len) = '\0';
2730 PadnameLEN(pn) = len;
2735 =for apidoc newPADNAMEouter
2737 Constructs and returns a new pad name. Only use this function for names
2738 that refer to outer lexicals. (See also L</newPADNAMEpvn>.) I<outer> is
2739 the outer pad name that this one mirrors. The returned pad name has the
2740 PADNAMEt_OUTER flag already set.
2746 Perl_newPADNAMEouter(pTHX_ PADNAME *outer)
2749 PERL_ARGS_ASSERT_NEWPADNAMEOUTER;
2750 Newxz(pn, 1, PADNAME);
2751 PadnameREFCNT(pn) = 1;
2752 PadnamePV(pn) = PadnamePV(outer);
2753 /* Not PadnameREFCNT(outer), because ‘outer’ may itself close over
2754 another entry. The original pad name owns the buffer. */
2755 PadnameREFCNT(PADNAME_FROM_PV(PadnamePV(outer)))++;
2756 PadnameFLAGS(pn) = PADNAMEt_OUTER;
2757 PadnameLEN(pn) = PadnameLEN(outer);
2762 Perl_padname_free(pTHX_ PADNAME *pn)
2764 PERL_ARGS_ASSERT_PADNAME_FREE;
2765 if (!--PadnameREFCNT(pn)) {
2766 if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) {
2767 PadnameREFCNT(pn) = SvREFCNT_IMMORTAL;
2770 SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */
2771 SvREFCNT_dec(PadnameOURSTASH(pn));
2772 if (PadnameOUTER(pn))
2773 PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn)));
2778 #if defined(USE_ITHREADS)
2781 =for apidoc padname_dup
2783 Duplicates a pad name.
2789 Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param)
2793 PERL_ARGS_ASSERT_PADNAME_DUP;
2795 /* look for it in the table first */
2796 dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src);
2800 if (!PadnamePV(src)) {
2801 dst = &PL_padname_undef;
2802 ptr_table_store(PL_ptr_table, src, dst);
2806 dst = PadnameOUTER(src)
2807 ? newPADNAMEouter(padname_dup(PADNAME_FROM_PV(PadnamePV(src)), param))
2808 : newPADNAMEpvn(PadnamePV(src), PadnameLEN(src));
2809 ptr_table_store(PL_ptr_table, src, dst);
2810 PadnameLEN(dst) = PadnameLEN(src);
2811 PadnameFLAGS(dst) = PadnameFLAGS(src);
2812 PadnameREFCNT(dst) = 0; /* The caller will increment it. */
2813 PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param);
2814 PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src),
2816 dst->xpadn_low = src->xpadn_low;
2817 dst->xpadn_high = src->xpadn_high;
2818 dst->xpadn_gen = src->xpadn_gen;
2822 #endif /* USE_ITHREADS */
2826 * c-indentation-style: bsd
2828 * indent-tabs-mode: nil
2831 * ex: set ts=8 sts=4 sw=4 et: