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 (which is actually just an
50 AV, but that may change) which represents the "names" or rather
51 the "static type information" for lexicals. The individual elements of a
52 PADNAMELIST are PADNAMEs (just SVs; but, again, that may change). 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_sv_undef
63 "names", while slots for constants have &PL_sv_no "names" (see
64 pad_alloc()). That &PL_sv_no is used is an implementation detail subject
65 to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
67 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
68 The rest are op targets/GVs/constants which are statically allocated
69 or resolved at compile time. These don't have names by which they
70 can be looked up from Perl code at run time through eval"" the way
71 my/our variables can be. Since they can't be looked up by "name"
72 but only by their index allocated at compile time (which is usually
73 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
75 The SVs in the names AV have their PV being the name of the variable.
76 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
77 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
78 _HIGH). During compilation, these fields may hold the special value
79 PERL_PADSEQ_INTRO to indicate various stages:
81 COP_SEQ_RANGE_LOW _HIGH
82 ----------------- -----
83 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
84 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
85 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
87 For typed lexicals name SV is SVt_PVMG and SvSTASH
88 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
89 SvOURSTASH slot pointing at the stash of the associated global (so that
90 duplicate C<our> declarations in the same package can be detected). SvUVX is
91 sometimes hijacked to store the generation number during compilation.
93 If PADNAME_OUTER (SvFAKE) is set on the
94 name SV, then that slot in the frame AV is
95 a REFCNT'ed reference to a lexical from "outside". In this case,
96 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
97 in scope throughout. Instead xhigh stores some flags containing info about
98 the real lexical (is it declared in an anon, and is it capable of being
99 instantiated multiple times?), and for fake ANONs, xlow contains the index
100 within the parent's pad where the lexical's value is stored, to make
103 If the 'name' is '&' the corresponding entry in the PAD
104 is a CV representing a possible closure.
105 (PADNAME_OUTER and name of '&' is not a
106 meaningful combination currently but could
107 become so if C<my sub foo {}> is implemented.)
109 Note that formats are treated as anon subs, and are cloned each time
110 write is called (if necessary).
112 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
113 and set on scope exit. This allows the
114 'Variable $x is not available' warning
115 to be generated in evals, such as
117 { my $x = 1; sub f { eval '$x'} } f();
119 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
121 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
123 During compilation, this points to the array containing the names part
124 of the pad for the currently-compiling code.
126 =for apidoc AmxU|PAD *|PL_comppad
128 During compilation, this points to the array containing the values
129 part of the pad for the currently-compiling code. (At runtime a CV may
130 have many such value arrays; at compile time just one is constructed.)
131 At runtime, this points to the array containing the currently-relevant
132 values for the pad for the currently-executing code.
134 =for apidoc AmxU|SV **|PL_curpad
136 Points directly to the body of the L</PL_comppad> array.
137 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
144 #define PERL_IN_PAD_C
146 #include "keywords.h"
148 #define COP_SEQ_RANGE_LOW_set(sv,val) \
149 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
150 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
151 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
153 #define PARENT_PAD_INDEX_set(sv,val) \
154 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
155 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
156 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
159 This is basically sv_eq_flags() in sv.c, but we avoid the magic
164 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
165 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
166 const char *pv1 = SvPVX_const(sv);
167 STRLEN cur1 = SvCUR(sv);
168 const char *pv2 = pv;
173 svrecode = newSVpvn(pv2, cur2);
174 sv_recode_to_utf8(svrecode, PL_encoding);
175 pv2 = SvPV_const(svrecode, cur2);
178 svrecode = newSVpvn(pv1, cur1);
179 sv_recode_to_utf8(svrecode, PL_encoding);
180 pv1 = SvPV_const(svrecode, cur1);
182 SvREFCNT_dec_NN(svrecode);
184 if (flags & SVf_UTF8)
185 return (bytes_cmp_utf8(
186 (const U8*)pv1, cur1,
187 (const U8*)pv2, cur2) == 0);
189 return (bytes_cmp_utf8(
190 (const U8*)pv2, cur2,
191 (const U8*)pv1, cur1) == 0);
194 return ((SvPVX_const(sv) == pv)
195 || memEQ(SvPVX_const(sv), pv, pvlen));
200 Perl_set_padlist(pTHX_ CV * cv, PADLIST *padlist){
201 PERL_ARGS_ASSERT_SET_PADLIST;
203 if((Size_t)padlist == UINT64_C(0xEFEFEFEFEFEFEFEF)){
207 if((Size_t)padlist == UINT64_C(0xEFEFEFEF)){
211 # error unknown pointer size
216 ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
221 =for apidoc Am|PADLIST *|pad_new|int flags
223 Create a new padlist, updating the global variables for the
224 currently-compiling padlist to point to the new padlist. The following
225 flags can be OR'ed together:
227 padnew_CLONE this pad is for a cloned CV
228 padnew_SAVE save old globals on the save stack
229 padnew_SAVESUB also save extra stuff for start of sub
235 Perl_pad_new(pTHX_ int flags)
241 ASSERT_CURPAD_LEGAL("pad_new");
243 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
244 * vars (based on flags) rather than storing vals + addresses for
245 * each individually. Also see pad_block_start.
246 * XXX DAPM Try to see whether all these conditionals are required
249 /* save existing state, ... */
251 if (flags & padnew_SAVE) {
253 if (! (flags & padnew_CLONE)) {
254 SAVESPTR(PL_comppad_name);
256 SAVEI32(PL_constpadix);
257 SAVEI32(PL_comppad_name_fill);
258 SAVEI32(PL_min_intro_pending);
259 SAVEI32(PL_max_intro_pending);
260 SAVEBOOL(PL_cv_has_eval);
261 if (flags & padnew_SAVESUB) {
262 SAVEBOOL(PL_pad_reset_pending);
266 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
267 * saved - check at some pt that this is okay */
269 /* ... create new pad ... */
271 Newxz(padlist, 1, PADLIST);
274 if (flags & padnew_CLONE) {
275 /* XXX DAPM I dont know why cv_clone needs it
276 * doing differently yet - perhaps this separate branch can be
277 * dispensed with eventually ???
280 AV * const a0 = newAV(); /* will be @_ */
281 av_store(pad, 0, MUTABLE_SV(a0));
284 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
287 av_store(pad, 0, NULL);
289 AvPAD_NAMELIST_on(padname);
290 av_store(padname, 0, &PL_sv_undef);
293 /* Most subroutines never recurse, hence only need 2 entries in the padlist
294 array - names, and depth=1. The default for av_store() is to allocate
295 0..3, and even an explicit call to av_extend() with <3 will be rounded
296 up, so we inline the allocation of the array here. */
298 PadlistMAX(padlist) = 1;
299 PadlistARRAY(padlist) = ary;
303 /* ... then update state variables */
306 PL_curpad = AvARRAY(pad);
308 if (! (flags & padnew_CLONE)) {
309 PL_comppad_name = padname;
310 PL_comppad_name_fill = 0;
311 PL_min_intro_pending = 0;
317 DEBUG_X(PerlIO_printf(Perl_debug_log,
318 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
319 " name=0x%"UVxf" flags=0x%"UVxf"\n",
320 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
321 PTR2UV(padname), (UV)flags
325 return (PADLIST*)padlist;
330 =head1 Embedding Functions
334 Clear out all the active components of a CV. This can happen either
335 by an explicit C<undef &foo>, or by the reference count going to zero.
336 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
337 children can still follow the full lexical scope chain.
343 Perl_cv_undef(pTHX_ CV *cv)
345 PERL_ARGS_ASSERT_CV_UNDEF;
346 cv_undef_flags(cv, 0);
350 Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
352 CV cvbody;/*CV body will never be realloced inside this func,
353 so dont read it more than once, use fake CV so existing macros
354 will work, the indirection and CV head struct optimized away*/
355 SvANY(&cvbody) = SvANY(cv);
357 PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
359 DEBUG_X(PerlIO_printf(Perl_debug_log,
360 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
361 PTR2UV(cv), PTR2UV(PL_comppad))
364 if (CvFILE(&cvbody)) {
365 char * file = CvFILE(&cvbody);
366 CvFILE(&cvbody) = NULL;
367 if(CvDYNFILE(&cvbody))
371 /* CvSLABBED_off(&cvbody); *//* turned off below */
372 /* release the sub's body */
373 if (!CvISXSUB(&cvbody)) {
374 if(CvROOT(&cvbody)) {
375 assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
376 if (CvDEPTHunsafe(&cvbody)) {
377 assert(SvTYPE(cv) == SVt_PVCV);
378 Perl_croak_nocontext("Can't undef active subroutine");
382 PAD_SAVE_SETNULLPAD();
384 if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
385 op_free(CvROOT(&cvbody));
386 CvROOT(&cvbody) = NULL;
387 CvSTART(&cvbody) = NULL;
390 else if (CvSLABBED(&cvbody)) {
391 if( CvSTART(&cvbody)) {
393 PAD_SAVE_SETNULLPAD();
395 /* discard any leaked ops */
397 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
398 opslab_force_free((OPSLAB *)CvSTART(&cvbody));
399 CvSTART(&cvbody) = NULL;
404 else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
408 else { /* dont bother checking if CvXSUB(cv) is true, less branching */
409 CvXSUB(&cvbody) = NULL;
411 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
412 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
413 if (!(flags & CV_UNDEF_KEEP_NAME)) {
414 if (CvNAMED(&cvbody)) {
415 CvNAME_HEK_set(&cvbody, NULL);
416 CvNAMED_off(&cvbody);
418 else CvGV_set(cv, NULL);
421 /* This statement and the subsequence if block was pad_undef(). */
422 pad_peg("pad_undef");
424 if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
426 const PADLIST *padlist = CvPADLIST(&cvbody);
428 /* Free the padlist associated with a CV.
429 If parts of it happen to be current, we null the relevant PL_*pad*
430 global vars so that we don't have any dangling references left.
431 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
432 subs to the outer of this cv. */
434 DEBUG_X(PerlIO_printf(Perl_debug_log,
435 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
436 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
439 /* detach any '&' anon children in the pad; if afterwards they
440 * are still live, fix up their CvOUTSIDEs to point to our outside,
442 /* XXX DAPM for efficiency, we should only do this if we know we have
443 * children, or integrate this loop with general cleanup */
445 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
446 CV * const outercv = CvOUTSIDE(&cvbody);
447 const U32 seq = CvOUTSIDE_SEQ(&cvbody);
448 PAD * const comppad_name = PadlistARRAY(padlist)[0];
449 SV ** const namepad = AvARRAY(comppad_name);
450 PAD * const comppad = PadlistARRAY(padlist)[1];
451 SV ** const curpad = AvARRAY(comppad);
452 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
453 SV * const namesv = namepad[ix];
454 if (namesv && namesv != &PL_sv_undef
455 && *SvPVX_const(namesv) == '&')
457 CV * const innercv = MUTABLE_CV(curpad[ix]);
458 U32 inner_rc = SvREFCNT(innercv);
460 assert(SvTYPE(innercv) != SVt_PVFM);
462 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
464 SvREFCNT_dec_NN(innercv);
468 /* in use, not just a prototype */
469 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
470 assert(CvWEAKOUTSIDE(innercv));
471 /* don't relink to grandfather if he's being freed */
472 if (outercv && SvREFCNT(outercv)) {
473 CvWEAKOUTSIDE_off(innercv);
474 CvOUTSIDE(innercv) = outercv;
475 CvOUTSIDE_SEQ(innercv) = seq;
476 SvREFCNT_inc_simple_void_NN(outercv);
479 CvOUTSIDE(innercv) = NULL;
486 ix = PadlistMAX(padlist);
488 PAD * const sv = PadlistARRAY(padlist)[ix--];
490 if (sv == PL_comppad) {
498 PAD * const sv = PadlistARRAY(padlist)[0];
499 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
500 PL_comppad_name = NULL;
503 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
505 CvPADLIST_set(&cvbody, NULL);
507 else if (CvISXSUB(&cvbody))
508 CvHSCXT(&cvbody) = NULL;
509 /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
512 /* remove CvOUTSIDE unless this is an undef rather than a free */
514 CV * outside = CvOUTSIDE(&cvbody);
516 CvOUTSIDE(&cvbody) = NULL;
517 if (!CvWEAKOUTSIDE(&cvbody))
518 SvREFCNT_dec_NN(outside);
521 if (CvCONST(&cvbody)) {
522 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
523 /* CvCONST_off(cv); *//* turned off below */
525 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
526 * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
527 * LEXICAL, which are used to determine the sub's name. */
528 CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
533 =for apidoc cv_forget_slab
535 When a CV has a reference count on its slab (CvSLABBED), it is responsible
536 for making sure it is freed. (Hence, no two CVs should ever have a
537 reference count on the same slab.) The CV only needs to reference the slab
538 during compilation. Once it is compiled and CvROOT attached, it has
539 finished its job, so it can forget the slab.
545 Perl_cv_forget_slab(pTHX_ CV *cv)
547 const bool slabbed = !!CvSLABBED(cv);
550 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
552 if (!slabbed) return;
556 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
557 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
559 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
563 #ifdef PERL_DEBUG_READONLY_OPS
564 const size_t refcnt = slab->opslab_refcnt;
566 OpslabREFCNT_dec(slab);
567 #ifdef PERL_DEBUG_READONLY_OPS
568 if (refcnt > 1) Slab_to_ro(slab);
574 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
576 Allocates a place in the currently-compiling
577 pad (via L<perlapi/pad_alloc>) and
578 then stores a name for that entry. I<namesv> is adopted and becomes the
579 name entry; it must already contain the name string and be sufficiently
580 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
581 added to I<namesv>. None of the other
582 processing of L<perlapi/pad_add_name_pvn>
583 is done. Returns the offset of the allocated pad slot.
589 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
591 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
593 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
595 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
598 assert(SvTYPE(namesv) == SVt_PVMG);
599 SvPAD_TYPED_on(namesv);
600 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
603 SvPAD_OUR_on(namesv);
604 SvOURSTASH_set(namesv, ourstash);
605 SvREFCNT_inc_simple_void_NN(ourstash);
607 else if (flags & padadd_STATE) {
608 SvPAD_STATE_on(namesv);
611 av_store(PL_comppad_name, offset, namesv);
612 PadnamelistMAXNAMED(PL_comppad_name) = offset;
617 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
619 Allocates a place in the currently-compiling pad for a named lexical
620 variable. Stores the name and other metadata in the name part of the
621 pad, and makes preparations to manage the variable's lexical scoping.
622 Returns the offset of the allocated pad slot.
624 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
625 If I<typestash> is non-null, the name is for a typed lexical, and this
626 identifies the type. If I<ourstash> is non-null, it's a lexical reference
627 to a package variable, and this identifies the package. The following
628 flags can be OR'ed together:
630 padadd_OUR redundantly specifies if it's a package var
631 padadd_STATE variable will retain value persistently
632 padadd_NO_DUP_CHECK skip check for lexical shadowing
638 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
639 U32 flags, HV *typestash, HV *ourstash)
645 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
647 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
648 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
651 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
653 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
654 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
657 sv_setpvn(namesv, namepv, namelen);
660 flags |= padadd_UTF8_NAME;
664 flags &= ~padadd_UTF8_NAME;
666 if ((flags & padadd_NO_DUP_CHECK) == 0) {
668 SAVEFREESV(namesv); /* in case of fatal warnings */
669 /* check for duplicate declaration */
670 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
671 SvREFCNT_inc_simple_void_NN(namesv);
675 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
677 /* not yet introduced */
678 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
679 COP_SEQ_RANGE_HIGH_set(namesv, 0);
681 if (!PL_min_intro_pending)
682 PL_min_intro_pending = offset;
683 PL_max_intro_pending = offset;
684 /* if it's not a simple scalar, replace with an AV or HV */
685 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
686 assert(SvREFCNT(PL_curpad[offset]) == 1);
687 if (namelen != 0 && *namepv == '@')
688 sv_upgrade(PL_curpad[offset], SVt_PVAV);
689 else if (namelen != 0 && *namepv == '%')
690 sv_upgrade(PL_curpad[offset], SVt_PVHV);
691 else if (namelen != 0 && *namepv == '&')
692 sv_upgrade(PL_curpad[offset], SVt_PVCV);
693 assert(SvPADMY(PL_curpad[offset]));
694 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
695 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
696 (long)offset, SvPVX(namesv),
697 PTR2UV(PL_curpad[offset])));
703 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
705 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
706 instead of a string/length pair.
712 Perl_pad_add_name_pv(pTHX_ const char *name,
713 const U32 flags, HV *typestash, HV *ourstash)
715 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
716 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
720 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
722 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
723 of an SV instead of a string/length pair.
729 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
733 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
734 namepv = SvPV(name, namelen);
736 flags |= padadd_UTF8_NAME;
737 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
741 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
743 Allocates a place in the currently-compiling pad,
744 returning the offset of the allocated pad slot.
745 No name is initially attached to the pad slot.
746 I<tmptype> is a set of flags indicating the kind of pad entry required,
747 which will be set in the value SV for the allocated pad entry:
749 SVs_PADMY named lexical variable ("my", "our", "state")
750 SVs_PADTMP unnamed temporary store
751 SVf_READONLY constant shared between recursion levels
753 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
754 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
755 does not cause the SV in the pad slot to be marked read-only, but simply
756 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
757 least should be treated as such.
759 I<optype> should be an opcode indicating the type of operation that the
760 pad entry is to support. This doesn't affect operational semantics,
761 but is used for debugging.
766 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
767 * or at least rationalise ??? */
770 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
775 PERL_UNUSED_ARG(optype);
776 ASSERT_CURPAD_ACTIVE("pad_alloc");
778 if (AvARRAY(PL_comppad) != PL_curpad)
779 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
780 AvARRAY(PL_comppad), PL_curpad);
781 if (PL_pad_reset_pending)
783 if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
784 /* For a my, simply push a null SV onto the end of PL_comppad. */
785 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
786 retval = AvFILLp(PL_comppad);
789 /* For a tmp, scan the pad from PL_padix upwards
790 * for a slot which has no name and no active value.
791 * For a constant, likewise, but use PL_constpadix.
793 SV * const * const names = AvARRAY(PL_comppad_name);
794 const SSize_t names_fill = AvFILLp(PL_comppad_name);
795 const bool konst = cBOOL(tmptype & SVf_READONLY);
796 retval = konst ? PL_constpadix : PL_padix;
799 * Entries that close over unavailable variables
800 * in outer subs contain values not marked PADMY.
801 * Thus we must skip, not just pad values that are
802 * marked as current pad values, but also those with names.
803 * If pad_reset is enabled, ‘current’ means different
804 * things depending on whether we are allocating a con-
805 * stant or a target. For a target, things marked PADTMP
806 * can be reused; not so for constants.
808 if (++retval <= names_fill &&
809 (sv = names[retval]) && sv != &PL_sv_undef)
811 sv = *av_fetch(PL_comppad, retval, TRUE);
814 (konst ? SVs_PADTMP : 0))
822 av_store(PL_comppad_name, retval, &PL_sv_no);
823 tmptype &= ~SVf_READONLY;
824 tmptype |= SVs_PADTMP;
826 *(konst ? &PL_constpadix : &PL_padix) = retval;
828 SvFLAGS(sv) |= tmptype;
829 PL_curpad = AvARRAY(PL_comppad);
831 DEBUG_X(PerlIO_printf(Perl_debug_log,
832 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
833 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
834 PL_op_name[optype]));
835 #ifdef DEBUG_LEAKING_SCALARS
836 sv->sv_debug_optype = optype;
837 sv->sv_debug_inpad = 1;
839 return (PADOFFSET)retval;
843 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
845 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
846 for an anonymous function that is lexically scoped inside the
847 currently-compiling function.
848 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
849 to the outer scope is weakened to avoid a reference loop.
851 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
853 I<optype> should be an opcode indicating the type of operation that the
854 pad entry is to support. This doesn't affect operational semantics,
855 but is used for debugging.
861 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
864 SV* const name = newSV_type(SVt_PVNV);
866 PERL_ARGS_ASSERT_PAD_ADD_ANON;
869 sv_setpvs(name, "&");
870 /* These two aren't used; just make sure they're not equal to
871 * PERL_PADSEQ_INTRO */
872 COP_SEQ_RANGE_LOW_set(name, 0);
873 COP_SEQ_RANGE_HIGH_set(name, 0);
874 ix = pad_alloc(optype, SVs_PADMY);
875 av_store(PL_comppad_name, ix, name);
876 /* XXX DAPM use PL_curpad[] ? */
877 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
878 av_store(PL_comppad, ix, (SV*)func);
880 SV *rv = newRV_noinc((SV *)func);
882 assert (SvTYPE(func) == SVt_PVFM);
883 av_store(PL_comppad, ix, rv);
886 /* to avoid ref loops, we never have parent + child referencing each
887 * other simultaneously */
888 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
889 assert(!CvWEAKOUTSIDE(func));
890 CvWEAKOUTSIDE_on(func);
891 SvREFCNT_dec_NN(CvOUTSIDE(func));
897 =for apidoc pad_check_dup
899 Check for duplicate declarations: report any of:
901 * a my in the current scope with the same name;
902 * an our (anywhere in the pad) with the same name and the
903 same stash as C<ourstash>
905 C<is_our> indicates that the name to check is an 'our' declaration.
911 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
915 const U32 is_our = flags & padadd_OUR;
917 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
919 ASSERT_CURPAD_ACTIVE("pad_check_dup");
921 assert((flags & ~padadd_OUR) == 0);
923 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
924 return; /* nothing to check */
926 svp = AvARRAY(PL_comppad_name);
927 top = AvFILLp(PL_comppad_name);
928 /* check the current scope */
929 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
931 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
932 SV * const sv = svp[off];
936 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
937 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
940 if (is_our && (SvPAD_OUR(sv)))
941 break; /* "our" masking "our" */
942 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
943 Perl_warner(aTHX_ packWARN(WARN_MISC),
944 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
945 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
946 *SvPVX(sv) == '&' ? "subroutine" : "variable",
948 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
949 ? "scope" : "statement"));
954 /* check the rest of the pad */
957 SV * const sv = svp[off];
961 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
962 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
963 && SvOURSTASH(sv) == ourstash
966 Perl_warner(aTHX_ packWARN(WARN_MISC),
967 "\"our\" variable %"SVf" redeclared", SVfARG(sv));
968 if ((I32)off <= PL_comppad_name_floor)
969 Perl_warner(aTHX_ packWARN(WARN_MISC),
970 "\t(Did you mean \"local\" instead of \"our\"?)\n");
980 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
982 Given the name of a lexical variable, find its position in the
983 currently-compiling pad.
984 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
985 I<flags> is reserved and must be zero.
986 If it is not in the current pad but appears in the pad of any lexically
987 enclosing scope, then a pseudo-entry for it is added in the current pad.
988 Returns the offset in the current pad,
989 or C<NOT_IN_PAD> if no such lexical is in scope.
995 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
1003 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
1005 pad_peg("pad_findmy_pvn");
1007 if (flags & ~padadd_UTF8_NAME)
1008 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
1011 if (flags & padadd_UTF8_NAME) {
1012 bool is_utf8 = TRUE;
1013 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
1016 flags |= padadd_UTF8_NAME;
1018 flags &= ~padadd_UTF8_NAME;
1021 offset = pad_findlex(namepv, namelen, flags,
1022 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
1023 if ((PADOFFSET)offset != NOT_IN_PAD)
1026 /* Skip the ‘our’ hack for subroutines, as the warning does not apply.
1028 if (*namepv == '&') return NOT_IN_PAD;
1030 /* look for an our that's being introduced; this allows
1031 * our $foo = 0 unless defined $foo;
1032 * to not give a warning. (Yes, this is a hack) */
1034 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
1035 name_svp = AvARRAY(nameav);
1036 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1037 const SV * const namesv = name_svp[offset];
1038 if (namesv && PadnameLEN(namesv) == namelen
1040 && (SvPAD_OUR(namesv))
1041 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1042 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
1043 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
1051 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
1053 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1054 instead of a string/length pair.
1060 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1062 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1063 return pad_findmy_pvn(name, strlen(name), flags);
1067 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1069 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1070 of an SV instead of a string/length pair.
1076 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1080 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1081 namepv = SvPV(name, namelen);
1083 flags |= padadd_UTF8_NAME;
1084 return pad_findmy_pvn(namepv, namelen, flags);
1088 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1090 Find the position of the lexical C<$_> in the pad of the
1091 currently-executing function. Returns the offset in the current pad,
1092 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1093 the global one should be used instead).
1094 L</find_rundefsv> is likely to be more convenient.
1100 Perl_find_rundefsvoffset(pTHX)
1104 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1105 NULL, &out_sv, &out_flags);
1109 =for apidoc Am|SV *|find_rundefsv
1111 Find and return the variable that is named C<$_> in the lexical scope
1112 of the currently-executing function. This may be a lexical C<$_>,
1113 or will otherwise be the global one.
1119 Perl_find_rundefsv(pTHX)
1125 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1126 NULL, &namesv, &flags);
1128 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1135 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1141 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1143 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1144 NULL, &namesv, &flags);
1146 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1149 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1153 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
1155 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1156 in the inner pads if it's found in an outer one.
1158 Returns the offset in the bottom pad of the lex or the fake lex.
1159 cv is the CV in which to start the search, and seq is the current cop_seq
1160 to match against. If warn is true, print appropriate warnings. The out_*
1161 vars return values, and so are pointers to where the returned values
1162 should be stored. out_capture, if non-null, requests that the innermost
1163 instance of the lexical is captured; out_name_sv is set to the innermost
1164 matched namesv or fake namesv; out_flags returns the flags normally
1165 associated with the IVX field of a fake namesv.
1167 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1168 then comes back down, adding fake entries
1169 as it goes. It has to be this way
1170 because fake namesvs in anon protoypes have to store in xlow the index into
1176 /* the CV has finished being compiled. This is not a sufficient test for
1177 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1178 #define CvCOMPILED(cv) CvROOT(cv)
1180 /* the CV does late binding of its lexicals */
1181 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1184 S_unavailable(pTHX_ SV *namesv)
1186 /* diag_listed_as: Variable "%s" is not available */
1187 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1188 "%se \"%"SVf"\" is not available",
1189 *SvPVX_const(namesv) == '&'
1196 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1197 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1199 I32 offset, new_offset;
1202 const PADLIST * const padlist = CvPADLIST(cv);
1203 const bool staleok = !!(flags & padadd_STALEOK);
1205 PERL_ARGS_ASSERT_PAD_FINDLEX;
1207 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1208 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1210 flags &= ~ padadd_STALEOK; /* one-shot flag */
1214 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1215 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1216 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1217 out_capture ? " capturing" : "" ));
1219 /* first, search this pad */
1221 if (padlist) { /* not an undef CV */
1222 I32 fake_offset = 0;
1223 const AV * const nameav = PadlistARRAY(padlist)[0];
1224 SV * const * const name_svp = AvARRAY(nameav);
1226 for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
1227 const SV * const namesv = name_svp[offset];
1228 if (namesv && PadnameLEN(namesv) == namelen
1229 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1230 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1232 if (SvFAKE(namesv)) {
1233 fake_offset = offset; /* in case we don't find a real one */
1236 if (PadnameIN_SCOPE(namesv, seq))
1241 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1242 if (offset > 0) { /* not fake */
1244 *out_name_sv = name_svp[offset]; /* return the namesv */
1246 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1247 * instances. For now, we just test !CvUNIQUE(cv), but
1248 * ideally, we should detect my's declared within loops
1249 * etc - this would allow a wider range of 'not stayed
1250 * shared' warnings. We also treated already-compiled
1251 * lexes as not multi as viewed from evals. */
1253 *out_flags = CvANON(cv) ?
1255 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1256 ? PAD_FAKELEX_MULTI : 0;
1258 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1259 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1260 PTR2UV(cv), (long)offset,
1261 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1262 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1264 else { /* fake match */
1265 offset = fake_offset;
1266 *out_name_sv = name_svp[offset]; /* return the namesv */
1267 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1268 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1269 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1270 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1271 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1275 /* return the lex? */
1280 if (SvPAD_OUR(*out_name_sv)) {
1281 *out_capture = NULL;
1285 /* trying to capture from an anon prototype? */
1287 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1288 : *out_flags & PAD_FAKELEX_ANON)
1292 newSVpvn_flags(namepv, namelen,
1294 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1296 *out_capture = NULL;
1302 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1303 && !SvPAD_STATE(name_svp[offset])
1304 && warn && ckWARN(WARN_CLOSURE)) {
1306 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1307 "Variable \"%"SVf"\" will not stay shared",
1308 SVfARG(newSVpvn_flags(namepv, namelen,
1310 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))));
1313 if (fake_offset && CvANON(cv)
1314 && CvCLONE(cv) &&!CvCLONED(cv))
1317 /* not yet caught - look further up */
1318 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1319 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1322 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1324 newwarn, out_capture, out_name_sv, out_flags);
1329 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1330 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1331 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1332 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1333 PTR2UV(cv), PTR2UV(*out_capture)));
1335 if (SvPADSTALE(*out_capture)
1336 && (!CvDEPTH(cv) || !staleok)
1337 && !SvPAD_STATE(name_svp[offset]))
1340 newSVpvn_flags(namepv, namelen,
1342 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1343 *out_capture = NULL;
1346 if (!*out_capture) {
1347 if (namelen != 0 && *namepv == '@')
1348 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1349 else if (namelen != 0 && *namepv == '%')
1350 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1351 else if (namelen != 0 && *namepv == '&')
1352 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1354 *out_capture = sv_newmortal();
1362 /* it's not in this pad - try above */
1367 /* out_capture non-null means caller wants us to capture lex; in
1368 * addition we capture ourselves unless it's an ANON/format */
1369 new_capturep = out_capture ? out_capture :
1370 CvLATE(cv) ? NULL : &new_capture;
1372 offset = pad_findlex(namepv, namelen,
1373 flags | padadd_STALEOK*(new_capturep == &new_capture),
1374 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1375 new_capturep, out_name_sv, out_flags);
1376 if ((PADOFFSET)offset == NOT_IN_PAD)
1379 /* found in an outer CV. Add appropriate fake entry to this pad */
1381 /* don't add new fake entries (via eval) to CVs that we have already
1382 * finished compiling, or to undef CVs */
1383 if (CvCOMPILED(cv) || !padlist)
1384 return 0; /* this dummy (and invalid) value isnt used by the caller */
1387 /* This relies on sv_setsv_flags() upgrading the destination to the same
1388 type as the source, independent of the flags set, and on it being
1389 "good" and only copying flag bits and pointers that it understands.
1391 SV *new_namesv = newSVsv(*out_name_sv);
1392 AV * const ocomppad_name = PL_comppad_name;
1393 PAD * const ocomppad = PL_comppad;
1394 PL_comppad_name = PadlistARRAY(padlist)[0];
1395 PL_comppad = PadlistARRAY(padlist)[1];
1396 PL_curpad = AvARRAY(PL_comppad);
1399 = pad_alloc_name(new_namesv,
1400 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1401 SvPAD_TYPED(*out_name_sv)
1402 ? SvSTASH(*out_name_sv) : NULL,
1403 SvOURSTASH(*out_name_sv)
1406 SvFAKE_on(new_namesv);
1407 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1408 "Pad addname: %ld \"%.*s\" FAKE\n",
1410 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1411 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1413 PARENT_PAD_INDEX_set(new_namesv, 0);
1414 if (SvPAD_OUR(new_namesv)) {
1415 NOOP; /* do nothing */
1417 else if (CvLATE(cv)) {
1418 /* delayed creation - just note the offset within parent pad */
1419 PARENT_PAD_INDEX_set(new_namesv, offset);
1423 /* immediate creation - capture outer value right now */
1424 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1425 /* But also note the offset, as newMYSUB needs it */
1426 PARENT_PAD_INDEX_set(new_namesv, offset);
1427 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1428 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1429 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1431 *out_name_sv = new_namesv;
1432 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1434 PL_comppad_name = ocomppad_name;
1435 PL_comppad = ocomppad;
1436 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1444 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1446 Get the value at offset I<po> in the current (compiling or executing) pad.
1447 Use macro PAD_SV instead of calling this function directly.
1453 Perl_pad_sv(pTHX_ PADOFFSET po)
1455 ASSERT_CURPAD_ACTIVE("pad_sv");
1458 Perl_croak(aTHX_ "panic: pad_sv po");
1459 DEBUG_X(PerlIO_printf(Perl_debug_log,
1460 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1461 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1463 return PL_curpad[po];
1467 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1469 Set the value at offset I<po> in the current (compiling or executing) pad.
1470 Use the macro PAD_SETSV() rather than calling this function directly.
1476 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1478 PERL_ARGS_ASSERT_PAD_SETSV;
1480 ASSERT_CURPAD_ACTIVE("pad_setsv");
1482 DEBUG_X(PerlIO_printf(Perl_debug_log,
1483 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1484 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1489 #endif /* DEBUGGING */
1492 =for apidoc m|void|pad_block_start|int full
1494 Update the pad compilation state variables on entry to a new block.
1499 /* XXX DAPM perhaps:
1500 * - integrate this in general state-saving routine ???
1501 * - combine with the state-saving going on in pad_new ???
1502 * - introduce a new SAVE type that does all this in one go ?
1506 Perl_pad_block_start(pTHX_ int full)
1508 ASSERT_CURPAD_ACTIVE("pad_block_start");
1509 SAVEI32(PL_comppad_name_floor);
1510 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1512 PL_comppad_name_fill = PL_comppad_name_floor;
1513 if (PL_comppad_name_floor < 0)
1514 PL_comppad_name_floor = 0;
1515 SAVEI32(PL_min_intro_pending);
1516 SAVEI32(PL_max_intro_pending);
1517 PL_min_intro_pending = 0;
1518 SAVEI32(PL_comppad_name_fill);
1519 SAVEI32(PL_padix_floor);
1520 /* PL_padix_floor is what PL_padix is reset to at the start of each
1521 statement, by pad_reset(). We set it when entering a new scope
1522 to keep things like this working:
1523 print "$foo$bar", do { this(); that() . "foo" };
1524 We must not let "$foo$bar" and the later concatenation share the
1526 PL_padix_floor = PL_padix;
1527 PL_pad_reset_pending = FALSE;
1531 =for apidoc Am|U32|intro_my
1533 "Introduce" C<my> variables to visible status. This is called during parsing
1534 at the end of each statement to make lexical variables visible to subsequent
1547 ASSERT_CURPAD_ACTIVE("intro_my");
1548 if (PL_compiling.cop_seq) {
1549 seq = PL_compiling.cop_seq;
1550 PL_compiling.cop_seq = 0;
1553 seq = PL_cop_seqmax;
1554 if (! PL_min_intro_pending)
1557 svp = AvARRAY(PL_comppad_name);
1558 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1559 SV * const sv = svp[i];
1561 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1562 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1564 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1565 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1566 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1567 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1568 (long)i, SvPVX_const(sv),
1569 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1570 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1575 PL_min_intro_pending = 0;
1576 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1577 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1578 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1584 =for apidoc m|void|pad_leavemy
1586 Cleanup at end of scope during compilation: set the max seq number for
1587 lexicals in this scope and warn of any lexicals that never got introduced.
1593 Perl_pad_leavemy(pTHX)
1597 SV * const * const svp = AvARRAY(PL_comppad_name);
1599 PL_pad_reset_pending = FALSE;
1601 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1602 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1603 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1604 const SV * const sv = svp[off];
1605 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1606 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1607 "%"SVf" never introduced",
1611 /* "Deintroduce" my variables that are leaving with this scope. */
1612 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1613 SV * const sv = svp[off];
1614 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1615 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1617 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1618 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1619 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1620 (long)off, SvPVX_const(sv),
1621 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1622 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1624 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1625 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1626 OP *kid = newOP(OP_INTROCV, 0);
1628 o = op_prepend_elem(OP_LINESEQ, kid, o);
1633 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1634 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1639 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1641 Abandon the tmp in the current pad at offset po and replace with a
1648 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1650 ASSERT_CURPAD_LEGAL("pad_swipe");
1653 if (AvARRAY(PL_comppad) != PL_curpad)
1654 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1655 AvARRAY(PL_comppad), PL_curpad);
1656 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1657 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1658 (long)po, (long)AvFILLp(PL_comppad));
1660 DEBUG_X(PerlIO_printf(Perl_debug_log,
1661 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1662 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1665 SvREFCNT_dec(PL_curpad[po]);
1668 /* if pad tmps aren't shared between ops, then there's no need to
1669 * create a new tmp when an existing op is freed */
1670 #ifdef USE_PAD_RESET
1671 PL_curpad[po] = newSV(0);
1672 SvPADTMP_on(PL_curpad[po]);
1674 PL_curpad[po] = NULL;
1676 if (PadnamelistMAX(PL_comppad_name) != -1
1677 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1678 if (PadnamelistARRAY(PL_comppad_name)[po]) {
1679 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1681 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1683 /* Use PL_constpadix here, not PL_padix. The latter may have been
1684 reset by pad_reset. We don’t want pad_alloc to have to scan the
1685 whole pad when allocating a constant. */
1686 if ((I32)po < PL_constpadix)
1687 PL_constpadix = po - 1;
1691 =for apidoc m|void|pad_reset
1693 Mark all the current temporaries for reuse
1698 /* pad_reset() causes pad temp TARGs (operator targets) to be shared
1699 * between OPs from different statements. During compilation, at the start
1700 * of each statement pad_reset resets PL_padix back to its previous value.
1701 * When allocating a target, pad_alloc begins its scan through the pad at
1706 #ifdef USE_PAD_RESET
1707 if (AvARRAY(PL_comppad) != PL_curpad)
1708 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1709 AvARRAY(PL_comppad), PL_curpad);
1711 DEBUG_X(PerlIO_printf(Perl_debug_log,
1712 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1713 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1714 (long)PL_padix, (long)PL_padix_floor
1718 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1719 PL_padix = PL_padix_floor;
1722 PL_pad_reset_pending = FALSE;
1726 =for apidoc Amx|void|pad_tidy|padtidy_type type
1728 Tidy up a pad at the end of compilation of the code to which it belongs.
1729 Jobs performed here are: remove most stuff from the pads of anonsub
1730 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1731 the kind of subroutine:
1733 padtidy_SUB ordinary subroutine
1734 padtidy_SUBCLONE prototype for lexical closure
1735 padtidy_FORMAT format
1740 /* XXX DAPM surely most of this stuff should be done properly
1741 * at the right time beforehand, rather than going around afterwards
1742 * cleaning up our mistakes ???
1746 Perl_pad_tidy(pTHX_ padtidy_type type)
1750 ASSERT_CURPAD_ACTIVE("pad_tidy");
1752 /* If this CV has had any 'eval-capable' ops planted in it:
1753 * i.e. it contains any of:
1757 * * use re 'eval'; /$var/
1760 * Then any anon prototypes in the chain of CVs should be marked as
1761 * cloneable, so that for example the eval's CV in
1765 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1766 * potentially have an eval executed within it.
1769 if (PL_cv_has_eval || PL_perldb) {
1771 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1772 if (cv != PL_compcv && CvCOMPILED(cv))
1773 break; /* no need to mark already-compiled code */
1775 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1776 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1783 /* extend namepad to match curpad */
1784 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1785 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1787 if (type == padtidy_SUBCLONE) {
1788 SV ** const namep = AvARRAY(PL_comppad_name);
1791 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1793 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1796 * The only things that a clonable function needs in its
1797 * pad are anonymous subs, constants and GVs.
1798 * The rest are created anew during cloning.
1800 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1803 if (!(PadnamePV(namesv) &&
1804 (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
1806 SvREFCNT_dec(PL_curpad[ix]);
1807 PL_curpad[ix] = NULL;
1811 else if (type == padtidy_SUB) {
1812 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1813 AV * const av = newAV(); /* Will be @_ */
1814 av_store(PL_comppad, 0, MUTABLE_SV(av));
1818 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1819 SV ** const namep = AvARRAY(PL_comppad_name);
1821 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1822 if (!namep[ix]) namep[ix] = &PL_sv_undef;
1823 if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
1825 if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) {
1826 /* This is a work around for how the current implementation of
1827 ?{ } blocks in regexps interacts with lexicals.
1829 One of our lexicals.
1830 Can't do this on all lexicals, otherwise sub baz() won't
1839 because completion of compiling &bar calling pad_tidy()
1840 would cause (top level) $foo to be marked as stale, and
1841 "no longer available". */
1842 SvPADSTALE_on(PL_curpad[ix]);
1846 PL_curpad = AvARRAY(PL_comppad);
1850 =for apidoc m|void|pad_free|PADOFFSET po
1852 Free the SV at offset po in the current pad.
1857 /* XXX DAPM integrate with pad_swipe ???? */
1859 Perl_pad_free(pTHX_ PADOFFSET po)
1861 #ifndef USE_PAD_RESET
1864 ASSERT_CURPAD_LEGAL("pad_free");
1867 if (AvARRAY(PL_comppad) != PL_curpad)
1868 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1869 AvARRAY(PL_comppad), PL_curpad);
1871 Perl_croak(aTHX_ "panic: pad_free po");
1873 DEBUG_X(PerlIO_printf(Perl_debug_log,
1874 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1875 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1878 #ifndef USE_PAD_RESET
1880 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1881 SvFLAGS(sv) &= ~SVs_PADTMP;
1883 if ((I32)po < PL_padix)
1889 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1891 Dump the contents of a padlist
1897 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1905 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1910 pad_name = *PadlistARRAY(padlist);
1911 pad = PadlistARRAY(padlist)[1];
1912 pname = AvARRAY(pad_name);
1913 ppad = AvARRAY(pad);
1914 Perl_dump_indent(aTHX_ level, file,
1915 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1916 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1919 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1920 const SV *namesv = pname[ix];
1921 if (namesv && !PadnameLEN(namesv)) {
1926 Perl_dump_indent(aTHX_ level+1, file,
1927 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1930 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1931 SvPVX_const(namesv),
1932 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1933 (unsigned long)PARENT_PAD_INDEX(namesv)
1937 Perl_dump_indent(aTHX_ level+1, file,
1938 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1941 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1942 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1943 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1948 Perl_dump_indent(aTHX_ level+1, file,
1949 "%2d. 0x%"UVxf"<%lu>\n",
1952 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1961 =for apidoc m|void|cv_dump|CV *cv|const char *title
1963 dump the contents of a CV
1969 S_cv_dump(pTHX_ const CV *cv, const char *title)
1971 const CV * const outside = CvOUTSIDE(cv);
1972 PADLIST* const padlist = CvPADLIST(cv);
1974 PERL_ARGS_ASSERT_CV_DUMP;
1976 PerlIO_printf(Perl_debug_log,
1977 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1980 (CvANON(cv) ? "ANON"
1981 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1982 : (cv == PL_main_cv) ? "MAIN"
1983 : CvUNIQUE(cv) ? "UNIQUE"
1984 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1987 : CvANON(outside) ? "ANON"
1988 : (outside == PL_main_cv) ? "MAIN"
1989 : CvUNIQUE(outside) ? "UNIQUE"
1990 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1992 PerlIO_printf(Perl_debug_log,
1993 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1994 do_dump_pad(1, Perl_debug_log, padlist, 1);
1997 #endif /* DEBUGGING */
2000 =for apidoc Am|CV *|cv_clone|CV *proto
2002 Clone a CV, making a lexical closure. I<proto> supplies the prototype
2003 of the function: its code, pad structure, and other attributes.
2004 The prototype is combined with a capture of outer lexicals to which the
2005 code refers, which are taken from the currently-executing instance of
2006 the immediately surrounding code.
2011 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
2014 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
2017 PADLIST* const protopadlist = CvPADLIST(proto);
2018 PAD *const protopad_name = *PadlistARRAY(protopadlist);
2019 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
2020 SV** const pname = AvARRAY(protopad_name);
2021 SV** const ppad = AvARRAY(protopad);
2022 const I32 fname = AvFILLp(protopad_name);
2023 const I32 fpad = AvFILLp(protopad);
2026 bool subclones = FALSE;
2028 assert(!CvUNIQUE(proto));
2030 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2031 * reliable. The currently-running sub is always the one we need to
2033 * For my subs, the currently-running sub may not be the one we want.
2034 * We have to check whether it is a clone of CvOUTSIDE.
2035 * Note that in general for formats, CvOUTSIDE != find_runcv.
2036 * Since formats may be nested inside closures, CvOUTSIDE may point
2037 * to a prototype; we instead want the cloned parent who called us.
2041 if (CvWEAKOUTSIDE(proto))
2042 outside = find_runcv(NULL);
2044 outside = CvOUTSIDE(proto);
2045 if ((CvCLONE(outside) && ! CvCLONED(outside))
2046 || !CvPADLIST(outside)
2047 || PadlistNAMES(CvPADLIST(outside))
2048 != protopadlist->xpadl_outid) {
2049 outside = find_runcv_where(
2050 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2052 /* outside could be null */
2056 depth = outside ? CvDEPTH(outside) : 0;
2061 SAVESPTR(PL_compcv);
2063 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2066 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2068 SAVESPTR(PL_comppad_name);
2069 PL_comppad_name = protopad_name;
2070 CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
2072 av_fill(PL_comppad, fpad);
2074 PL_curpad = AvARRAY(PL_comppad);
2076 outpad = outside && CvPADLIST(outside)
2077 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2080 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2082 for (ix = fpad; ix > 0; ix--) {
2083 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2085 if (namesv && PadnameLEN(namesv)) { /* lexical */
2086 if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
2090 if (SvFAKE(namesv)) { /* lexical from outside? */
2091 /* formats may have an inactive, or even undefined, parent;
2092 but state vars are always available. */
2093 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2094 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2095 && (!outside || !CvDEPTH(outside))) ) {
2096 S_unavailable(aTHX_ namesv);
2100 SvREFCNT_inc_simple_void_NN(sv);
2103 const char sigil = SvPVX_const(namesv)[0];
2105 /* If there are state subs, we need to clone them, too.
2106 But they may need to close over variables we have
2107 not cloned yet. So we will have to do a second
2108 pass. Furthermore, there may be state subs clos-
2109 ing over other state subs’ entries, so we have
2110 to put a stub here and then clone into it on the
2112 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2113 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2115 sv = newSV_type(SVt_PVCV);
2118 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2121 /* Just provide a stub, but name it. It will be
2122 upgrade to the real thing on scope entry. */
2125 PERL_HASH(hash, SvPVX_const(namesv)+1,
2127 sv = newSV_type(SVt_PVCV);
2130 share_hek(SvPVX_const(namesv)+1,
2132 * (SvUTF8(namesv) ? -1 : 1),
2137 else sv = SvREFCNT_inc(ppad[ix]);
2138 else if (sigil == '@')
2139 sv = MUTABLE_SV(newAV());
2140 else if (sigil == '%')
2141 sv = MUTABLE_SV(newHV());
2144 /* reset the 'assign only once' flag on each state var */
2145 if (sigil != '&' && SvPAD_STATE(namesv))
2150 else if (namesv && PadnamePV(namesv)) {
2151 sv = SvREFCNT_inc_NN(ppad[ix]);
2161 for (ix = fpad; ix > 0; ix--) {
2162 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2163 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2164 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2165 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2168 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2172 /* Constant sub () { $x } closing over $x:
2173 * The prototype was marked as a candiate for const-ization,
2174 * so try to grab the current const value, and if successful,
2175 * turn into a const sub:
2178 OP *o = CvSTART(cv);
2180 for (; o; o = o->op_next)
2181 if (o->op_type == OP_PADSV)
2183 ASSUME(o->op_type == OP_PADSV);
2184 const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
2185 /* the candidate should have 1 ref from this pad and 1 ref
2186 * from the parent */
2187 if (const_sv && SvREFCNT(const_sv) == 2) {
2188 const bool was_method = cBOOL(CvMETHOD(cv));
2189 bool copied = FALSE;
2191 PADNAME * const pn =
2192 PadlistNAMESARRAY(CvPADLIST(outside))
2193 [PARENT_PAD_INDEX(PadlistNAMESARRAY(
2194 CvPADLIST(cv))[o->op_targ])];
2195 assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
2197 if (PadnameLVALUE(pn)) {
2198 /* We have a lexical that is potentially modifiable
2199 elsewhere, so making a constant will break clo-
2200 sure behaviour. If this is a ‘simple lexical
2201 op tree’, i.e., sub(){$x}, emit a deprecation
2202 warning, but continue to exhibit the old behav-
2203 iour of making it a constant based on the ref-
2204 count of the candidate variable.
2206 A simple lexical op tree looks like this:
2214 cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
2218 Perl_ck_warner_d(aTHX_
2219 packWARN(WARN_DEPRECATED),
2220 "Constants from lexical "
2221 "variables potentially "
2222 "modified elsewhere are "
2224 /* We *copy* the lexical variable, and donate the
2225 copy to newCONSTSUB. Yes, this is ugly, and
2226 should be killed. We need to do this for the
2227 time being, however, because turning on SvPADTMP
2228 on a lexical will have observable effects
2230 const_sv = newSVsv(const_sv);
2238 SvREFCNT_inc_simple_void_NN(const_sv);
2239 /* If the lexical is not used elsewhere, it is safe to turn on
2240 SvPADTMP, since it is only when it is used in lvalue con-
2241 text that the difference is observable. */
2242 SvREADONLY_on(const_sv);
2243 SvPADTMP_on(const_sv);
2244 SvREFCNT_dec_NN(cv);
2245 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2259 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2264 const bool newcv = !cv;
2266 assert(!CvUNIQUE(proto));
2268 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2269 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2273 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2276 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2277 else CvGV_set(cv,CvGV(proto));
2278 CvSTASH_set(cv, CvSTASH(proto));
2280 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2282 CvSTART(cv) = CvSTART(proto);
2283 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2286 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2288 SvUTF8_on(MUTABLE_SV(cv));
2291 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2293 if (CvPADLIST(proto))
2294 cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2297 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2298 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2299 cv_dump(proto, "Proto");
2307 Perl_cv_clone(pTHX_ CV *proto)
2309 PERL_ARGS_ASSERT_CV_CLONE;
2311 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2312 return S_cv_clone(aTHX_ proto, NULL, NULL);
2315 /* Called only by pp_clonecv */
2317 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2319 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2321 return S_cv_clone(aTHX_ proto, target, NULL);
2327 Returns an SV containing the name of the CV, mainly for use in error
2328 reporting. The CV may actually be a GV instead, in which case the returned
2329 SV holds the GV's name. Anything other than a GV or CV is treated as a
2330 string already holding the sub name, but this could change in the future.
2332 An SV may be passed as a second argument. If so, the name will be assigned
2333 to it and it will be returned. Otherwise the returned SV will be a new
2336 If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
2337 included. If the first argument is neither a CV nor a GV, this flag is
2338 ignored (subject to change).
2344 Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
2346 PERL_ARGS_ASSERT_CV_NAME;
2347 if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
2348 if (sv) sv_setsv(sv,(SV *)cv);
2349 return sv ? (sv) : (SV *)cv;
2352 SV * const retsv = sv ? (sv) : sv_newmortal();
2353 if (SvTYPE(cv) == SVt_PVCV) {
2355 if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2356 sv_sethek(retsv, CvNAME_HEK(cv));
2358 sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
2359 sv_catpvs(retsv, "::");
2360 sv_cathek(retsv, CvNAME_HEK(cv));
2363 else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
2364 sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
2365 else gv_efullname3(retsv, CvGV(cv), NULL);
2367 else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
2368 else gv_efullname3(retsv,(GV *)cv,NULL);
2374 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2376 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2377 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2378 moved to a pre-existing CV struct.
2384 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2387 AV * const comppad_name = PadlistARRAY(padlist)[0];
2388 AV * const comppad = PadlistARRAY(padlist)[1];
2389 SV ** const namepad = AvARRAY(comppad_name);
2390 SV ** const curpad = AvARRAY(comppad);
2392 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2393 PERL_UNUSED_ARG(old_cv);
2395 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2396 const SV * const namesv = namepad[ix];
2397 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2398 && *SvPVX_const(namesv) == '&')
2400 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2402 SvMAGICAL(curpad[ix])
2403 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2405 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2406 if (CvOUTSIDE(innercv) == old_cv) {
2407 if (!CvWEAKOUTSIDE(innercv)) {
2408 SvREFCNT_dec(old_cv);
2409 SvREFCNT_inc_simple_void_NN(new_cv);
2411 CvOUTSIDE(innercv) = new_cv;
2414 else { /* format reference */
2415 SV * const rv = curpad[ix];
2417 if (!SvOK(rv)) continue;
2419 assert(SvWEAKREF(rv));
2420 innercv = (CV *)SvRV(rv);
2421 assert(!CvWEAKOUTSIDE(innercv));
2422 SvREFCNT_dec(CvOUTSIDE(innercv));
2423 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2430 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2432 Push a new pad frame onto the padlist, unless there's already a pad at
2433 this depth, in which case don't bother creating a new one. Then give
2434 the new pad an @_ in slot zero.
2440 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2442 PERL_ARGS_ASSERT_PAD_PUSH;
2444 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2445 PAD** const svp = PadlistARRAY(padlist);
2446 AV* const newpad = newAV();
2447 SV** const oldpad = AvARRAY(svp[depth-1]);
2448 I32 ix = AvFILLp((const AV *)svp[1]);
2449 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2450 SV** const names = AvARRAY(svp[0]);
2453 for ( ;ix > 0; ix--) {
2454 if (names_fill >= ix && PadnameLEN(names[ix])) {
2455 const char sigil = SvPVX_const(names[ix])[0];
2456 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2457 || (SvFLAGS(names[ix]) & SVpad_STATE)
2460 /* outer lexical or anon code */
2461 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2463 else { /* our own lexical */
2466 sv = MUTABLE_SV(newAV());
2467 else if (sigil == '%')
2468 sv = MUTABLE_SV(newHV());
2471 av_store(newpad, ix, sv);
2474 else if (PadnamePV(names[ix])) {
2475 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2478 /* save temporaries on recursion? */
2479 SV * const sv = newSV(0);
2480 av_store(newpad, ix, sv);
2485 av_store(newpad, 0, MUTABLE_SV(av));
2488 padlist_store(padlist, depth, newpad);
2493 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2495 Looks up the type of the lexical variable at position I<po> in the
2496 currently-compiling pad. If the variable is typed, the stash of the
2497 class to which it is typed is returned. If not, C<NULL> is returned.
2503 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2505 SV* const av = PAD_COMPNAME_SV(po);
2506 if ( SvPAD_TYPED(av) ) {
2512 #if defined(USE_ITHREADS)
2514 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2517 =for apidoc padlist_dup
2525 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2531 PERL_ARGS_ASSERT_PADLIST_DUP;
2533 cloneall = param->flags & CLONEf_COPY_STACKS
2534 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2535 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2537 max = cloneall ? PadlistMAX(srcpad) : 1;
2539 Newx(dstpad, 1, PADLIST);
2540 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2541 PadlistMAX(dstpad) = max;
2542 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2546 for (depth = 0; depth <= max; ++depth)
2547 PadlistARRAY(dstpad)[depth] =
2548 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2550 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2551 to build anything other than the first level of pads. */
2552 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2554 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2555 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2556 SV **oldpad = AvARRAY(srcpad1);
2561 PadlistARRAY(dstpad)[0] =
2562 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2563 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2567 av_extend(pad1, ix);
2568 PadlistARRAY(dstpad)[1] = pad1;
2569 pad1a = AvARRAY(pad1);
2574 for ( ;ix > 0; ix--) {
2577 } else if (names_fill >= ix && names[ix] &&
2578 PadnameLEN(names[ix])) {
2579 const char sigil = SvPVX_const(names[ix])[0];
2580 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2581 || (SvFLAGS(names[ix]) & SVpad_STATE)
2584 /* outer lexical or anon code */
2585 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2587 else { /* our own lexical */
2588 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2589 /* This is a work around for how the current
2590 implementation of ?{ } blocks in regexps
2591 interacts with lexicals. */
2592 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2597 sv = MUTABLE_SV(newAV());
2598 else if (sigil == '%')
2599 sv = MUTABLE_SV(newHV());
2606 else if (( names_fill >= ix && names[ix]
2607 && PadnamePV(names[ix]) )) {
2608 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2611 /* save temporaries on recursion? */
2612 SV * const sv = newSV(0);
2615 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2616 FIXTHAT before merging this branch.
2617 (And I know how to) */
2618 if (SvPADTMP(oldpad[ix]))
2624 args = newAV(); /* Will be @_ */
2626 pad1a[0] = (SV *)args;
2634 #endif /* USE_ITHREADS */
2637 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2640 SSize_t const oldmax = PadlistMAX(padlist);
2642 PERL_ARGS_ASSERT_PADLIST_STORE;
2646 if (key > PadlistMAX(padlist)) {
2647 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2648 (SV ***)&PadlistARRAY(padlist),
2649 (SV ***)&PadlistARRAY(padlist));
2650 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2653 ary = PadlistARRAY(padlist);
2654 SvREFCNT_dec(ary[key]);
2661 * c-indentation-style: bsd
2663 * indent-tabs-mode: nil
2666 * ex: set ts=8 sts=4 sw=4 et: