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 don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42 but that is really the callers pad (a slot of which is allocated by
45 The PADLIST has a C array where pads are stored.
47 The 0th entry of the PADLIST is a PADNAMELIST (which is actually just an
48 AV, but that may change) which represents the "names" or rather
49 the "static type information" for lexicals. The individual elements of a
50 PADNAMELIST are PADNAMEs (just SVs; but, again, that may change). Future
51 refactorings might stop the PADNAMELIST from being stored in the PADLIST's
52 array, so don't rely on it. See L</PadlistNAMES>.
54 The CvDEPTH'th entry of a PADLIST is a PAD (an AV) which is the stack frame
55 at that depth of recursion into the CV. The 0th slot of a frame AV is an
56 AV which is @_. Other entries are storage for variables and op targets.
58 Iterating over the PADNAMELIST iterates over all possible pad
59 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
60 &PL_sv_undef "names" (see pad_alloc()).
62 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
63 The rest are op targets/GVs/constants which are statically allocated
64 or resolved at compile time. These don't have names by which they
65 can be looked up from Perl code at run time through eval"" the way
66 my/our variables can be. Since they can't be looked up by "name"
67 but only by their index allocated at compile time (which is usually
68 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
70 The SVs in the names AV have their PV being the name of the variable.
71 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
72 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
73 _HIGH). During compilation, these fields may hold the special value
74 PERL_PADSEQ_INTRO to indicate various stages:
76 COP_SEQ_RANGE_LOW _HIGH
77 ----------------- -----
78 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
79 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
80 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
82 For typed lexicals name SV is SVt_PVMG and SvSTASH
83 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
84 SvOURSTASH slot pointing at the stash of the associated global (so that
85 duplicate C<our> declarations in the same package can be detected). SvUVX is
86 sometimes hijacked to store the generation number during compilation.
88 If PADNAME_OUTER (SvFAKE) is set on the
89 name SV, then that slot in the frame AV is
90 a REFCNT'ed reference to a lexical from "outside". In this case,
91 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
92 in scope throughout. Instead xhigh stores some flags containing info about
93 the real lexical (is it declared in an anon, and is it capable of being
94 instantiated multiple times?), and for fake ANONs, xlow contains the index
95 within the parent's pad where the lexical's value is stored, to make
98 If the 'name' is '&' the corresponding entry in the PAD
99 is a CV representing a possible closure.
100 (PADNAME_OUTER and name of '&' is not a
101 meaningful combination currently but could
102 become so if C<my sub foo {}> is implemented.)
104 Note that formats are treated as anon subs, and are cloned each time
105 write is called (if necessary).
107 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
108 and set on scope exit. This allows the
109 'Variable $x is not available' warning
110 to be generated in evals, such as
112 { my $x = 1; sub f { eval '$x'} } f();
114 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
116 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
118 During compilation, this points to the array containing the names part
119 of the pad for the currently-compiling code.
121 =for apidoc AmxU|PAD *|PL_comppad
123 During compilation, this points to the array containing the values
124 part of the pad for the currently-compiling code. (At runtime a CV may
125 have many such value arrays; at compile time just one is constructed.)
126 At runtime, this points to the array containing the currently-relevant
127 values for the pad for the currently-executing code.
129 =for apidoc AmxU|SV **|PL_curpad
131 Points directly to the body of the L</PL_comppad> array.
132 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
139 #define PERL_IN_PAD_C
141 #include "keywords.h"
143 #define COP_SEQ_RANGE_LOW_set(sv,val) \
144 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
145 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
148 #define PARENT_PAD_INDEX_set(sv,val) \
149 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
150 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
151 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
154 =for apidoc mx|void|pad_peg|const char *s
156 When PERL_MAD is enabled, this is a small no-op function that gets called
157 at the start of each pad-related function. It can be breakpointed to
158 track all pad operations. The parameter is a string indicating the type
159 of pad operation being performed.
165 void pad_peg(const char* s) {
166 static int pegcnt; /* XXX not threadsafe */
169 PERL_ARGS_ASSERT_PAD_PEG;
176 This is basically sv_eq_flags() in sv.c, but we avoid the magic
181 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
182 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
183 const char *pv1 = SvPVX_const(sv);
184 STRLEN cur1 = SvCUR(sv);
185 const char *pv2 = pv;
190 svrecode = newSVpvn(pv2, cur2);
191 sv_recode_to_utf8(svrecode, PL_encoding);
192 pv2 = SvPV_const(svrecode, cur2);
195 svrecode = newSVpvn(pv1, cur1);
196 sv_recode_to_utf8(svrecode, PL_encoding);
197 pv1 = SvPV_const(svrecode, cur1);
199 SvREFCNT_dec(svrecode);
201 if (flags & SVf_UTF8)
202 return (bytes_cmp_utf8(
203 (const U8*)pv1, cur1,
204 (const U8*)pv2, cur2) == 0);
206 return (bytes_cmp_utf8(
207 (const U8*)pv2, cur2,
208 (const U8*)pv1, cur1) == 0);
211 return ((SvPVX_const(sv) == pv)
212 || memEQ(SvPVX_const(sv), pv, pvlen));
217 =for apidoc Am|PADLIST *|pad_new|int flags
219 Create a new padlist, updating the global variables for the
220 currently-compiling padlist to point to the new padlist. The following
221 flags can be OR'ed together:
223 padnew_CLONE this pad is for a cloned CV
224 padnew_SAVE save old globals on the save stack
225 padnew_SAVESUB also save extra stuff for start of sub
231 Perl_pad_new(pTHX_ int flags)
238 ASSERT_CURPAD_LEGAL("pad_new");
240 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
241 * vars (based on flags) rather than storing vals + addresses for
242 * each individually. Also see pad_block_start.
243 * XXX DAPM Try to see whether all these conditionals are required
246 /* save existing state, ... */
248 if (flags & padnew_SAVE) {
250 if (! (flags & padnew_CLONE)) {
251 SAVESPTR(PL_comppad_name);
253 SAVEI32(PL_comppad_name_fill);
254 SAVEI32(PL_min_intro_pending);
255 SAVEI32(PL_max_intro_pending);
256 SAVEBOOL(PL_cv_has_eval);
257 if (flags & padnew_SAVESUB) {
258 SAVEBOOL(PL_pad_reset_pending);
262 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
263 * saved - check at some pt that this is okay */
265 /* ... create new pad ... */
267 Newxz(padlist, 1, PADLIST);
270 if (flags & padnew_CLONE) {
271 /* XXX DAPM I dont know why cv_clone needs it
272 * doing differently yet - perhaps this separate branch can be
273 * dispensed with eventually ???
276 AV * const a0 = newAV(); /* will be @_ */
277 av_store(pad, 0, MUTABLE_SV(a0));
280 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
283 padlist->xpadl_id = PL_padlist_generation++;
284 av_store(pad, 0, NULL);
288 /* Most subroutines never recurse, hence only need 2 entries in the padlist
289 array - names, and depth=1. The default for av_store() is to allocate
290 0..3, and even an explicit call to av_extend() with <3 will be rounded
291 up, so we inline the allocation of the array here. */
293 PadlistMAX(padlist) = 1;
294 PadlistARRAY(padlist) = ary;
298 /* ... then update state variables */
301 PL_curpad = AvARRAY(pad);
303 if (! (flags & padnew_CLONE)) {
304 PL_comppad_name = padname;
305 PL_comppad_name_fill = 0;
306 PL_min_intro_pending = 0;
311 DEBUG_X(PerlIO_printf(Perl_debug_log,
312 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
313 " name=0x%"UVxf" flags=0x%"UVxf"\n",
314 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
315 PTR2UV(padname), (UV)flags
319 return (PADLIST*)padlist;
324 =head1 Embedding Functions
328 Clear out all the active components of a CV. This can happen either
329 by an explicit C<undef &foo>, or by the reference count going to zero.
330 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
331 children can still follow the full lexical scope chain.
337 Perl_cv_undef(pTHX_ CV *cv)
340 const PADLIST *padlist = CvPADLIST(cv);
341 bool const slabbed = !!CvSLABBED(cv);
343 PERL_ARGS_ASSERT_CV_UNDEF;
345 DEBUG_X(PerlIO_printf(Perl_debug_log,
346 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
347 PTR2UV(cv), PTR2UV(PL_comppad))
350 if (CvFILE(cv) && CvDYNFILE(cv)) {
351 Safefree(CvFILE(cv));
356 if (!CvISXSUB(cv) && CvROOT(cv)) {
357 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
358 Perl_croak(aTHX_ "Can't undef active subroutine");
361 PAD_SAVE_SETNULLPAD();
363 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
369 else if (slabbed && CvSTART(cv)) {
371 PAD_SAVE_SETNULLPAD();
373 /* discard any leaked ops */
374 opslab_force_free((OPSLAB *)CvSTART(cv));
380 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
382 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
383 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
384 if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
385 else CvGV_set(cv, NULL);
387 /* This statement and the subsequence if block was pad_undef(). */
388 pad_peg("pad_undef");
393 /* Free the padlist associated with a CV.
394 If parts of it happen to be current, we null the relevant PL_*pad*
395 global vars so that we don't have any dangling references left.
396 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
397 subs to the outer of this cv. */
399 DEBUG_X(PerlIO_printf(Perl_debug_log,
400 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
401 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
404 /* detach any '&' anon children in the pad; if afterwards they
405 * are still live, fix up their CvOUTSIDEs to point to our outside,
407 /* XXX DAPM for efficiency, we should only do this if we know we have
408 * children, or integrate this loop with general cleanup */
410 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
411 CV * const outercv = CvOUTSIDE(cv);
412 const U32 seq = CvOUTSIDE_SEQ(cv);
413 PAD * const comppad_name = PadlistARRAY(padlist)[0];
414 SV ** const namepad = AvARRAY(comppad_name);
415 PAD * const comppad = PadlistARRAY(padlist)[1];
416 SV ** const curpad = AvARRAY(comppad);
417 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
418 SV * const namesv = namepad[ix];
419 if (namesv && namesv != &PL_sv_undef
420 && *SvPVX_const(namesv) == '&')
422 CV * const innercv = MUTABLE_CV(curpad[ix]);
423 U32 inner_rc = SvREFCNT(innercv);
425 assert(SvTYPE(innercv) != SVt_PVFM);
427 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
429 SvREFCNT_dec(innercv);
433 /* in use, not just a prototype */
434 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
435 assert(CvWEAKOUTSIDE(innercv));
436 /* don't relink to grandfather if he's being freed */
437 if (outercv && SvREFCNT(outercv)) {
438 CvWEAKOUTSIDE_off(innercv);
439 CvOUTSIDE(innercv) = outercv;
440 CvOUTSIDE_SEQ(innercv) = seq;
441 SvREFCNT_inc_simple_void_NN(outercv);
444 CvOUTSIDE(innercv) = NULL;
451 ix = PadlistMAX(padlist);
453 PAD * const sv = PadlistARRAY(padlist)[ix--];
455 if (sv == PL_comppad) {
463 PAD * const sv = PadlistARRAY(padlist)[0];
464 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
465 PL_comppad_name = NULL;
468 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
470 CvPADLIST(cv) = NULL;
474 /* remove CvOUTSIDE unless this is an undef rather than a free */
475 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
476 if (!CvWEAKOUTSIDE(cv))
477 SvREFCNT_dec(CvOUTSIDE(cv));
478 CvOUTSIDE(cv) = NULL;
481 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
484 if (CvISXSUB(cv) && CvXSUB(cv)) {
487 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
488 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
489 * to choose an error message */
490 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
494 =for apidoc cv_forget_slab
496 When a CV has a reference count on its slab (CvSLABBED), it is responsible
497 for making sure it is freed. (Hence, no two CVs should ever have a
498 reference count on the same slab.) The CV only needs to reference the slab
499 during compilation. Once it is compiled and CvROOT attached, it has
500 finished its job, so it can forget the slab.
506 Perl_cv_forget_slab(pTHX_ CV *cv)
508 const bool slabbed = !!CvSLABBED(cv);
511 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
513 if (!slabbed) return;
517 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
518 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
520 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
524 #ifdef PERL_DEBUG_READONLY_OPS
525 const size_t refcnt = slab->opslab_refcnt;
527 OpslabREFCNT_dec(slab);
528 #ifdef PERL_DEBUG_READONLY_OPS
529 if (refcnt > 1) Slab_to_ro(slab);
535 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
537 Allocates a place in the currently-compiling
538 pad (via L<perlapi/pad_alloc>) and
539 then stores a name for that entry. I<namesv> is adopted and becomes the
540 name entry; it must already contain the name string and be sufficiently
541 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
542 added to I<namesv>. None of the other
543 processing of L<perlapi/pad_add_name_pvn>
544 is done. Returns the offset of the allocated pad slot.
550 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
553 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
555 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
557 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
560 assert(SvTYPE(namesv) == SVt_PVMG);
561 SvPAD_TYPED_on(namesv);
562 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
565 SvPAD_OUR_on(namesv);
566 SvOURSTASH_set(namesv, ourstash);
567 SvREFCNT_inc_simple_void_NN(ourstash);
569 else if (flags & padadd_STATE) {
570 SvPAD_STATE_on(namesv);
573 av_store(PL_comppad_name, offset, namesv);
578 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
580 Allocates a place in the currently-compiling pad for a named lexical
581 variable. Stores the name and other metadata in the name part of the
582 pad, and makes preparations to manage the variable's lexical scoping.
583 Returns the offset of the allocated pad slot.
585 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
586 If I<typestash> is non-null, the name is for a typed lexical, and this
587 identifies the type. If I<ourstash> is non-null, it's a lexical reference
588 to a package variable, and this identifies the package. The following
589 flags can be OR'ed together:
591 padadd_OUR redundantly specifies if it's a package var
592 padadd_STATE variable will retain value persistently
593 padadd_NO_DUP_CHECK skip check for lexical shadowing
599 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
600 U32 flags, HV *typestash, HV *ourstash)
607 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
609 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
610 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
613 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
615 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
616 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
619 sv_setpvn(namesv, namepv, namelen);
622 flags |= padadd_UTF8_NAME;
626 flags &= ~padadd_UTF8_NAME;
628 if ((flags & padadd_NO_DUP_CHECK) == 0) {
629 /* check for duplicate declaration */
630 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
633 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
635 /* not yet introduced */
636 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
637 COP_SEQ_RANGE_HIGH_set(namesv, 0);
639 if (!PL_min_intro_pending)
640 PL_min_intro_pending = offset;
641 PL_max_intro_pending = offset;
642 /* if it's not a simple scalar, replace with an AV or HV */
643 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
644 assert(SvREFCNT(PL_curpad[offset]) == 1);
645 if (namelen != 0 && *namepv == '@')
646 sv_upgrade(PL_curpad[offset], SVt_PVAV);
647 else if (namelen != 0 && *namepv == '%')
648 sv_upgrade(PL_curpad[offset], SVt_PVHV);
649 else if (namelen != 0 && *namepv == '&')
650 sv_upgrade(PL_curpad[offset], SVt_PVCV);
651 assert(SvPADMY(PL_curpad[offset]));
652 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
653 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
654 (long)offset, SvPVX(namesv),
655 PTR2UV(PL_curpad[offset])));
661 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
663 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
664 instead of a string/length pair.
670 Perl_pad_add_name_pv(pTHX_ const char *name,
671 const U32 flags, HV *typestash, HV *ourstash)
673 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
674 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
678 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
680 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
681 of an SV instead of a string/length pair.
687 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
691 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
692 namepv = SvPV(name, namelen);
694 flags |= padadd_UTF8_NAME;
695 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
699 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
701 Allocates a place in the currently-compiling pad,
702 returning the offset of the allocated pad slot.
703 No name is initially attached to the pad slot.
704 I<tmptype> is a set of flags indicating the kind of pad entry required,
705 which will be set in the value SV for the allocated pad entry:
707 SVs_PADMY named lexical variable ("my", "our", "state")
708 SVs_PADTMP unnamed temporary store
710 I<optype> should be an opcode indicating the type of operation that the
711 pad entry is to support. This doesn't affect operational semantics,
712 but is used for debugging.
717 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
718 * or at least rationalise ??? */
721 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
727 PERL_UNUSED_ARG(optype);
728 ASSERT_CURPAD_ACTIVE("pad_alloc");
730 if (AvARRAY(PL_comppad) != PL_curpad)
731 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
732 AvARRAY(PL_comppad), PL_curpad);
733 if (PL_pad_reset_pending)
735 if (tmptype & SVs_PADMY) {
736 /* For a my, simply push a null SV onto the end of PL_comppad. */
737 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
738 retval = AvFILLp(PL_comppad);
741 /* For a tmp, scan the pad from PL_padix upwards
742 * for a slot which has no name and no active value.
744 SV * const * const names = AvARRAY(PL_comppad_name);
745 const SSize_t names_fill = AvFILLp(PL_comppad_name);
748 * "foreach" index vars temporarily become aliases to non-"my"
749 * values. Thus we must skip, not just pad values that are
750 * marked as current pad values, but also those with names.
752 /* HVDS why copy to sv here? we don't seem to use it */
753 if (++PL_padix <= names_fill &&
754 (sv = names[PL_padix]) && sv != &PL_sv_undef)
756 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
757 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
758 !IS_PADGV(sv) && !IS_PADCONST(sv))
763 SvFLAGS(sv) |= tmptype;
764 PL_curpad = AvARRAY(PL_comppad);
766 DEBUG_X(PerlIO_printf(Perl_debug_log,
767 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
768 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
769 PL_op_name[optype]));
770 #ifdef DEBUG_LEAKING_SCALARS
771 sv->sv_debug_optype = optype;
772 sv->sv_debug_inpad = 1;
774 return (PADOFFSET)retval;
778 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
780 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
781 for an anonymous function that is lexically scoped inside the
782 currently-compiling function.
783 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
784 to the outer scope is weakened to avoid a reference loop.
786 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
788 I<optype> should be an opcode indicating the type of operation that the
789 pad entry is to support. This doesn't affect operational semantics,
790 but is used for debugging.
796 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
800 SV* const name = newSV_type(SVt_PVNV);
802 PERL_ARGS_ASSERT_PAD_ADD_ANON;
805 sv_setpvs(name, "&");
806 /* These two aren't used; just make sure they're not equal to
807 * PERL_PADSEQ_INTRO */
808 COP_SEQ_RANGE_LOW_set(name, 0);
809 COP_SEQ_RANGE_HIGH_set(name, 0);
810 ix = pad_alloc(optype, SVs_PADMY);
811 av_store(PL_comppad_name, ix, name);
812 /* XXX DAPM use PL_curpad[] ? */
813 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
814 av_store(PL_comppad, ix, (SV*)func);
816 SV *rv = newRV_noinc((SV *)func);
818 assert (SvTYPE(func) == SVt_PVFM);
819 av_store(PL_comppad, ix, rv);
821 SvPADMY_on((SV*)func);
823 /* to avoid ref loops, we never have parent + child referencing each
824 * other simultaneously */
825 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
826 assert(!CvWEAKOUTSIDE(func));
827 CvWEAKOUTSIDE_on(func);
828 SvREFCNT_dec(CvOUTSIDE(func));
834 =for apidoc pad_check_dup
836 Check for duplicate declarations: report any of:
838 * a my in the current scope with the same name;
839 * an our (anywhere in the pad) with the same name and the
840 same stash as C<ourstash>
842 C<is_our> indicates that the name to check is an 'our' declaration.
848 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
853 const U32 is_our = flags & padadd_OUR;
855 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
857 ASSERT_CURPAD_ACTIVE("pad_check_dup");
859 assert((flags & ~padadd_OUR) == 0);
861 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
862 return; /* nothing to check */
864 svp = AvARRAY(PL_comppad_name);
865 top = AvFILLp(PL_comppad_name);
866 /* check the current scope */
867 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
869 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
870 SV * const sv = svp[off];
872 && sv != &PL_sv_undef
874 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
875 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
878 if (is_our && (SvPAD_OUR(sv)))
879 break; /* "our" masking "our" */
880 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
881 Perl_warner(aTHX_ packWARN(WARN_MISC),
882 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
883 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
884 *SvPVX(sv) == '&' ? "subroutine" : "variable",
886 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
887 ? "scope" : "statement"));
892 /* check the rest of the pad */
895 SV * const sv = svp[off];
897 && sv != &PL_sv_undef
899 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
900 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
901 && SvOURSTASH(sv) == ourstash
904 Perl_warner(aTHX_ packWARN(WARN_MISC),
905 "\"our\" variable %"SVf" redeclared", sv);
906 if ((I32)off <= PL_comppad_name_floor)
907 Perl_warner(aTHX_ packWARN(WARN_MISC),
908 "\t(Did you mean \"local\" instead of \"our\"?)\n");
918 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
920 Given the name of a lexical variable, find its position in the
921 currently-compiling pad.
922 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
923 I<flags> is reserved and must be zero.
924 If it is not in the current pad but appears in the pad of any lexically
925 enclosing scope, then a pseudo-entry for it is added in the current pad.
926 Returns the offset in the current pad,
927 or C<NOT_IN_PAD> if no such lexical is in scope.
933 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
942 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
944 pad_peg("pad_findmy_pvn");
946 if (flags & ~padadd_UTF8_NAME)
947 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
950 if (flags & padadd_UTF8_NAME) {
952 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
955 flags |= padadd_UTF8_NAME;
957 flags &= ~padadd_UTF8_NAME;
960 offset = pad_findlex(namepv, namelen, flags,
961 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
962 if ((PADOFFSET)offset != NOT_IN_PAD)
965 /* look for an our that's being introduced; this allows
966 * our $foo = 0 unless defined $foo;
967 * to not give a warning. (Yes, this is a hack) */
969 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
970 name_svp = AvARRAY(nameav);
971 for (offset = AvFILLp(nameav); offset > 0; offset--) {
972 const SV * const namesv = name_svp[offset];
973 if (namesv && namesv != &PL_sv_undef
975 && (SvPAD_OUR(namesv))
976 && SvCUR(namesv) == namelen
977 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
978 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
979 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
987 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
989 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
990 instead of a string/length pair.
996 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
998 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
999 return pad_findmy_pvn(name, strlen(name), flags);
1003 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1005 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1006 of an SV instead of a string/length pair.
1012 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1016 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1017 namepv = SvPV(name, namelen);
1019 flags |= padadd_UTF8_NAME;
1020 return pad_findmy_pvn(namepv, namelen, flags);
1024 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1026 Find the position of the lexical C<$_> in the pad of the
1027 currently-executing function. Returns the offset in the current pad,
1028 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1029 the global one should be used instead).
1030 L</find_rundefsv> is likely to be more convenient.
1036 Perl_find_rundefsvoffset(pTHX)
1041 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1042 NULL, &out_sv, &out_flags);
1046 =for apidoc Am|SV *|find_rundefsv
1048 Find and return the variable that is named C<$_> in the lexical scope
1049 of the currently-executing function. This may be a lexical C<$_>,
1050 or will otherwise be the global one.
1056 Perl_find_rundefsv(pTHX)
1062 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1063 NULL, &namesv, &flags);
1065 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1072 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1078 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1080 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1081 NULL, &namesv, &flags);
1083 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1086 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1090 =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
1092 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1093 in the inner pads if it's found in an outer one.
1095 Returns the offset in the bottom pad of the lex or the fake lex.
1096 cv is the CV in which to start the search, and seq is the current cop_seq
1097 to match against. If warn is true, print appropriate warnings. The out_*
1098 vars return values, and so are pointers to where the returned values
1099 should be stored. out_capture, if non-null, requests that the innermost
1100 instance of the lexical is captured; out_name_sv is set to the innermost
1101 matched namesv or fake namesv; out_flags returns the flags normally
1102 associated with the IVX field of a fake namesv.
1104 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1105 then comes back down, adding fake entries as it goes. It has to be this way
1106 because fake namesvs in anon protoypes have to store in xlow the index into
1112 /* the CV has finished being compiled. This is not a sufficient test for
1113 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1114 #define CvCOMPILED(cv) CvROOT(cv)
1116 /* the CV does late binding of its lexicals */
1117 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1120 S_unavailable(pTHX_ SV *namesv)
1122 /* diag_listed_as: Variable "%s" is not available */
1123 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1124 "%se \"%"SVf"\" is not available",
1125 *SvPVX_const(namesv) == '&'
1132 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1133 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1136 I32 offset, new_offset;
1139 const PADLIST * const padlist = CvPADLIST(cv);
1140 const bool staleok = !!(flags & padadd_STALEOK);
1142 PERL_ARGS_ASSERT_PAD_FINDLEX;
1144 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1145 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1147 flags &= ~ padadd_STALEOK; /* one-shot flag */
1151 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1152 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1153 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1154 out_capture ? " capturing" : "" ));
1156 /* first, search this pad */
1158 if (padlist) { /* not an undef CV */
1159 I32 fake_offset = 0;
1160 const AV * const nameav = PadlistARRAY(padlist)[0];
1161 SV * const * const name_svp = AvARRAY(nameav);
1163 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1164 const SV * const namesv = name_svp[offset];
1165 if (namesv && namesv != &PL_sv_undef
1166 && SvCUR(namesv) == namelen
1167 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1168 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1170 if (SvFAKE(namesv)) {
1171 fake_offset = offset; /* in case we don't find a real one */
1174 /* is seq within the range _LOW to _HIGH ?
1175 * This is complicated by the fact that PL_cop_seqmax
1176 * may have wrapped around at some point */
1177 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1178 continue; /* not yet introduced */
1180 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1181 /* in compiling scope */
1183 (seq > COP_SEQ_RANGE_LOW(namesv))
1184 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1185 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1190 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1192 ( seq > COP_SEQ_RANGE_LOW(namesv)
1193 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1195 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1196 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1202 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1203 if (offset > 0) { /* not fake */
1205 *out_name_sv = name_svp[offset]; /* return the namesv */
1207 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1208 * instances. For now, we just test !CvUNIQUE(cv), but
1209 * ideally, we should detect my's declared within loops
1210 * etc - this would allow a wider range of 'not stayed
1211 * shared' warnings. We also treated already-compiled
1212 * lexes as not multi as viewed from evals. */
1214 *out_flags = CvANON(cv) ?
1216 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1217 ? PAD_FAKELEX_MULTI : 0;
1219 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1220 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1221 PTR2UV(cv), (long)offset,
1222 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1223 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1225 else { /* fake match */
1226 offset = fake_offset;
1227 *out_name_sv = name_svp[offset]; /* return the namesv */
1228 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1229 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1230 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1231 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1232 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1236 /* return the lex? */
1241 if (SvPAD_OUR(*out_name_sv)) {
1242 *out_capture = NULL;
1246 /* trying to capture from an anon prototype? */
1248 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1249 : *out_flags & PAD_FAKELEX_ANON)
1253 newSVpvn_flags(namepv, namelen,
1255 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1257 *out_capture = NULL;
1263 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1264 && !SvPAD_STATE(name_svp[offset])
1265 && warn && ckWARN(WARN_CLOSURE)) {
1267 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1268 "Variable \"%"SVf"\" will not stay shared",
1269 newSVpvn_flags(namepv, namelen,
1271 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1274 if (fake_offset && CvANON(cv)
1275 && CvCLONE(cv) &&!CvCLONED(cv))
1278 /* not yet caught - look further up */
1279 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1280 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1283 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1285 newwarn, out_capture, out_name_sv, out_flags);
1290 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1291 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1292 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1293 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1294 PTR2UV(cv), PTR2UV(*out_capture)));
1296 if (SvPADSTALE(*out_capture)
1297 && (!CvDEPTH(cv) || !staleok)
1298 && !SvPAD_STATE(name_svp[offset]))
1301 newSVpvn_flags(namepv, namelen,
1303 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1304 *out_capture = NULL;
1307 if (!*out_capture) {
1308 if (namelen != 0 && *namepv == '@')
1309 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1310 else if (namelen != 0 && *namepv == '%')
1311 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1312 else if (namelen != 0 && *namepv == '&')
1313 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1315 *out_capture = sv_newmortal();
1323 /* it's not in this pad - try above */
1328 /* out_capture non-null means caller wants us to capture lex; in
1329 * addition we capture ourselves unless it's an ANON/format */
1330 new_capturep = out_capture ? out_capture :
1331 CvLATE(cv) ? NULL : &new_capture;
1333 offset = pad_findlex(namepv, namelen,
1334 flags | padadd_STALEOK*(new_capturep == &new_capture),
1335 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1336 new_capturep, out_name_sv, out_flags);
1337 if ((PADOFFSET)offset == NOT_IN_PAD)
1340 /* found in an outer CV. Add appropriate fake entry to this pad */
1342 /* don't add new fake entries (via eval) to CVs that we have already
1343 * finished compiling, or to undef CVs */
1344 if (CvCOMPILED(cv) || !padlist)
1345 return 0; /* this dummy (and invalid) value isnt used by the caller */
1348 /* This relies on sv_setsv_flags() upgrading the destination to the same
1349 type as the source, independent of the flags set, and on it being
1350 "good" and only copying flag bits and pointers that it understands.
1352 SV *new_namesv = newSVsv(*out_name_sv);
1353 AV * const ocomppad_name = PL_comppad_name;
1354 PAD * const ocomppad = PL_comppad;
1355 PL_comppad_name = PadlistARRAY(padlist)[0];
1356 PL_comppad = PadlistARRAY(padlist)[1];
1357 PL_curpad = AvARRAY(PL_comppad);
1360 = pad_alloc_name(new_namesv,
1361 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1362 SvPAD_TYPED(*out_name_sv)
1363 ? SvSTASH(*out_name_sv) : NULL,
1364 SvOURSTASH(*out_name_sv)
1367 SvFAKE_on(new_namesv);
1368 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1369 "Pad addname: %ld \"%.*s\" FAKE\n",
1371 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1372 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1374 PARENT_PAD_INDEX_set(new_namesv, 0);
1375 if (SvPAD_OUR(new_namesv)) {
1376 NOOP; /* do nothing */
1378 else if (CvLATE(cv)) {
1379 /* delayed creation - just note the offset within parent pad */
1380 PARENT_PAD_INDEX_set(new_namesv, offset);
1384 /* immediate creation - capture outer value right now */
1385 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1386 /* But also note the offset, as newMYSUB needs it */
1387 PARENT_PAD_INDEX_set(new_namesv, offset);
1388 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1389 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1390 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1392 *out_name_sv = new_namesv;
1393 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1395 PL_comppad_name = ocomppad_name;
1396 PL_comppad = ocomppad;
1397 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1405 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1407 Get the value at offset I<po> in the current (compiling or executing) pad.
1408 Use macro PAD_SV instead of calling this function directly.
1414 Perl_pad_sv(pTHX_ PADOFFSET po)
1417 ASSERT_CURPAD_ACTIVE("pad_sv");
1420 Perl_croak(aTHX_ "panic: pad_sv po");
1421 DEBUG_X(PerlIO_printf(Perl_debug_log,
1422 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1423 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1425 return PL_curpad[po];
1429 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1431 Set the value at offset I<po> in the current (compiling or executing) pad.
1432 Use the macro PAD_SETSV() rather than calling this function directly.
1438 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1442 PERL_ARGS_ASSERT_PAD_SETSV;
1444 ASSERT_CURPAD_ACTIVE("pad_setsv");
1446 DEBUG_X(PerlIO_printf(Perl_debug_log,
1447 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1448 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1453 #endif /* DEBUGGING */
1456 =for apidoc m|void|pad_block_start|int full
1458 Update the pad compilation state variables on entry to a new block.
1463 /* XXX DAPM perhaps:
1464 * - integrate this in general state-saving routine ???
1465 * - combine with the state-saving going on in pad_new ???
1466 * - introduce a new SAVE type that does all this in one go ?
1470 Perl_pad_block_start(pTHX_ int full)
1473 ASSERT_CURPAD_ACTIVE("pad_block_start");
1474 SAVEI32(PL_comppad_name_floor);
1475 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1477 PL_comppad_name_fill = PL_comppad_name_floor;
1478 if (PL_comppad_name_floor < 0)
1479 PL_comppad_name_floor = 0;
1480 SAVEI32(PL_min_intro_pending);
1481 SAVEI32(PL_max_intro_pending);
1482 PL_min_intro_pending = 0;
1483 SAVEI32(PL_comppad_name_fill);
1484 SAVEI32(PL_padix_floor);
1485 PL_padix_floor = PL_padix;
1486 PL_pad_reset_pending = FALSE;
1490 =for apidoc m|U32|intro_my
1492 "Introduce" my variables to visible status. This is called during parsing
1493 at the end of each statement to make lexical variables visible to
1494 subsequent statements.
1507 ASSERT_CURPAD_ACTIVE("intro_my");
1508 if (! PL_min_intro_pending)
1509 return PL_cop_seqmax;
1511 svp = AvARRAY(PL_comppad_name);
1512 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1513 SV * const sv = svp[i];
1515 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1516 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1518 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1519 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1520 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1521 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1522 (long)i, SvPVX_const(sv),
1523 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1524 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1528 seq = PL_cop_seqmax;
1530 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1532 PL_min_intro_pending = 0;
1533 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1534 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1535 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1541 =for apidoc m|void|pad_leavemy
1543 Cleanup at end of scope during compilation: set the max seq number for
1544 lexicals in this scope and warn of any lexicals that never got introduced.
1550 Perl_pad_leavemy(pTHX)
1555 SV * const * const svp = AvARRAY(PL_comppad_name);
1557 PL_pad_reset_pending = FALSE;
1559 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1560 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1561 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1562 const SV * const sv = svp[off];
1563 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1564 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1565 "%"SVf" never introduced",
1569 /* "Deintroduce" my variables that are leaving with this scope. */
1570 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1571 SV * const sv = svp[off];
1572 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1573 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1575 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1576 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1577 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1578 (long)off, SvPVX_const(sv),
1579 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1580 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1582 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1583 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1584 OP *kid = newOP(OP_INTROCV, 0);
1586 o = op_prepend_elem(OP_LINESEQ, kid, o);
1591 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1593 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1594 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1599 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1601 Abandon the tmp in the current pad at offset po and replace with a
1608 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1611 ASSERT_CURPAD_LEGAL("pad_swipe");
1614 if (AvARRAY(PL_comppad) != PL_curpad)
1615 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1616 AvARRAY(PL_comppad), PL_curpad);
1617 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1618 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1619 (long)po, (long)AvFILLp(PL_comppad));
1621 DEBUG_X(PerlIO_printf(Perl_debug_log,
1622 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1623 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1626 SvPADTMP_off(PL_curpad[po]);
1628 SvREFCNT_dec(PL_curpad[po]);
1631 /* if pad tmps aren't shared between ops, then there's no need to
1632 * create a new tmp when an existing op is freed */
1633 #ifdef USE_BROKEN_PAD_RESET
1634 PL_curpad[po] = newSV(0);
1635 SvPADTMP_on(PL_curpad[po]);
1637 PL_curpad[po] = &PL_sv_undef;
1639 if ((I32)po < PL_padix)
1644 =for apidoc m|void|pad_reset
1646 Mark all the current temporaries for reuse
1651 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1652 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1653 * on the stack by OPs that use them, there are several ways to get an alias
1654 * to a shared TARG. Such an alias will change randomly and unpredictably.
1655 * We avoid doing this until we can think of a Better Way.
1661 #ifdef USE_BROKEN_PAD_RESET
1662 if (AvARRAY(PL_comppad) != PL_curpad)
1663 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1664 AvARRAY(PL_comppad), PL_curpad);
1666 DEBUG_X(PerlIO_printf(Perl_debug_log,
1667 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1668 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1669 (long)PL_padix, (long)PL_padix_floor
1673 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1675 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1676 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1677 SvPADTMP_off(PL_curpad[po]);
1679 PL_padix = PL_padix_floor;
1682 PL_pad_reset_pending = FALSE;
1686 =for apidoc Amx|void|pad_tidy|padtidy_type type
1688 Tidy up a pad at the end of compilation of the code to which it belongs.
1689 Jobs performed here are: remove most stuff from the pads of anonsub
1690 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1691 the kind of subroutine:
1693 padtidy_SUB ordinary subroutine
1694 padtidy_SUBCLONE prototype for lexical closure
1695 padtidy_FORMAT format
1700 /* XXX DAPM surely most of this stuff should be done properly
1701 * at the right time beforehand, rather than going around afterwards
1702 * cleaning up our mistakes ???
1706 Perl_pad_tidy(pTHX_ padtidy_type type)
1710 ASSERT_CURPAD_ACTIVE("pad_tidy");
1712 /* If this CV has had any 'eval-capable' ops planted in it
1713 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1714 * anon prototypes in the chain of CVs should be marked as cloneable,
1715 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1716 * the right CvOUTSIDE.
1717 * If running with -d, *any* sub may potentially have an eval
1718 * executed within it.
1721 if (PL_cv_has_eval || PL_perldb) {
1723 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1724 if (cv != PL_compcv && CvCOMPILED(cv))
1725 break; /* no need to mark already-compiled code */
1727 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1728 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1735 /* extend curpad to match namepad */
1736 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1737 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1739 if (type == padtidy_SUBCLONE) {
1740 SV * const * const namep = AvARRAY(PL_comppad_name);
1743 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1746 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1749 * The only things that a clonable function needs in its
1750 * pad are anonymous subs.
1751 * The rest are created anew during cloning.
1753 if (!((namesv = namep[ix]) != NULL &&
1754 namesv != &PL_sv_undef &&
1755 *SvPVX_const(namesv) == '&'))
1757 SvREFCNT_dec(PL_curpad[ix]);
1758 PL_curpad[ix] = NULL;
1762 else if (type == padtidy_SUB) {
1763 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1764 AV * const av = newAV(); /* Will be @_ */
1765 av_store(PL_comppad, 0, MUTABLE_SV(av));
1769 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1770 SV * const * const namep = AvARRAY(PL_comppad_name);
1772 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1773 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1775 if (!SvPADMY(PL_curpad[ix])) {
1776 SvPADTMP_on(PL_curpad[ix]);
1777 } else if (!SvFAKE(namep[ix])) {
1778 /* This is a work around for how the current implementation of
1779 ?{ } blocks in regexps interacts with lexicals.
1781 One of our lexicals.
1782 Can't do this on all lexicals, otherwise sub baz() won't
1791 because completion of compiling &bar calling pad_tidy()
1792 would cause (top level) $foo to be marked as stale, and
1793 "no longer available". */
1794 SvPADSTALE_on(PL_curpad[ix]);
1798 PL_curpad = AvARRAY(PL_comppad);
1802 =for apidoc m|void|pad_free|PADOFFSET po
1804 Free the SV at offset po in the current pad.
1809 /* XXX DAPM integrate with pad_swipe ???? */
1811 Perl_pad_free(pTHX_ PADOFFSET po)
1814 ASSERT_CURPAD_LEGAL("pad_free");
1817 if (AvARRAY(PL_comppad) != PL_curpad)
1818 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1819 AvARRAY(PL_comppad), PL_curpad);
1821 Perl_croak(aTHX_ "panic: pad_free po");
1823 DEBUG_X(PerlIO_printf(Perl_debug_log,
1824 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1825 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1828 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1829 SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
1831 if ((I32)po < PL_padix)
1836 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1838 Dump the contents of a padlist
1844 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1853 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1858 pad_name = *PadlistARRAY(padlist);
1859 pad = PadlistARRAY(padlist)[1];
1860 pname = AvARRAY(pad_name);
1861 ppad = AvARRAY(pad);
1862 Perl_dump_indent(aTHX_ level, file,
1863 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1864 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1867 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1868 const SV *namesv = pname[ix];
1869 if (namesv && namesv == &PL_sv_undef) {
1874 Perl_dump_indent(aTHX_ level+1, file,
1875 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1878 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1879 SvPVX_const(namesv),
1880 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1881 (unsigned long)PARENT_PAD_INDEX(namesv)
1885 Perl_dump_indent(aTHX_ level+1, file,
1886 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1889 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1890 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1891 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1896 Perl_dump_indent(aTHX_ level+1, file,
1897 "%2d. 0x%"UVxf"<%lu>\n",
1900 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1909 =for apidoc m|void|cv_dump|CV *cv|const char *title
1911 dump the contents of a CV
1917 S_cv_dump(pTHX_ const CV *cv, const char *title)
1920 const CV * const outside = CvOUTSIDE(cv);
1921 PADLIST* const padlist = CvPADLIST(cv);
1923 PERL_ARGS_ASSERT_CV_DUMP;
1925 PerlIO_printf(Perl_debug_log,
1926 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1929 (CvANON(cv) ? "ANON"
1930 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1931 : (cv == PL_main_cv) ? "MAIN"
1932 : CvUNIQUE(cv) ? "UNIQUE"
1933 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1936 : CvANON(outside) ? "ANON"
1937 : (outside == PL_main_cv) ? "MAIN"
1938 : CvUNIQUE(outside) ? "UNIQUE"
1939 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1941 PerlIO_printf(Perl_debug_log,
1942 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1943 do_dump_pad(1, Perl_debug_log, padlist, 1);
1946 #endif /* DEBUGGING */
1949 =for apidoc Am|CV *|cv_clone|CV *proto
1951 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1952 of the function: its code, pad structure, and other attributes.
1953 The prototype is combined with a capture of outer lexicals to which the
1954 code refers, which are taken from the currently-executing instance of
1955 the immediately surrounding code.
1960 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1963 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
1967 PADLIST* const protopadlist = CvPADLIST(proto);
1968 PAD *const protopad_name = *PadlistARRAY(protopadlist);
1969 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1970 SV** const pname = AvARRAY(protopad_name);
1971 SV** const ppad = AvARRAY(protopad);
1972 const I32 fname = AvFILLp(protopad_name);
1973 const I32 fpad = AvFILLp(protopad);
1976 bool subclones = FALSE;
1978 assert(!CvUNIQUE(proto));
1980 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1981 * reliable. The currently-running sub is always the one we need to
1983 * For my subs, the currently-running sub may not be the one we want.
1984 * We have to check whether it is a clone of CvOUTSIDE.
1985 * Note that in general for formats, CvOUTSIDE != find_runcv.
1986 * Since formats may be nested inside closures, CvOUTSIDE may point
1987 * to a prototype; we instead want the cloned parent who called us.
1991 if (CvWEAKOUTSIDE(proto))
1992 outside = find_runcv(NULL);
1994 outside = CvOUTSIDE(proto);
1995 if ((CvCLONE(outside) && ! CvCLONED(outside))
1996 || !CvPADLIST(outside)
1997 || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) {
1998 outside = find_runcv_where(
1999 FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL
2001 /* outside could be null */
2005 depth = outside ? CvDEPTH(outside) : 0;
2010 SAVESPTR(PL_compcv);
2014 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2016 SAVESPTR(PL_comppad_name);
2017 PL_comppad_name = protopad_name;
2018 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2019 CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id;
2021 av_fill(PL_comppad, fpad);
2023 PL_curpad = AvARRAY(PL_comppad);
2025 outpad = outside && CvPADLIST(outside)
2026 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2028 if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id;
2030 for (ix = fpad; ix > 0; ix--) {
2031 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2033 if (namesv && namesv != &PL_sv_undef) { /* lexical */
2034 if (SvFAKE(namesv)) { /* lexical from outside? */
2035 /* formats may have an inactive, or even undefined, parent;
2036 but state vars are always available. */
2037 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2038 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2039 && (!outside || !CvDEPTH(outside))) ) {
2040 S_unavailable(aTHX_ namesv);
2044 SvREFCNT_inc_simple_void_NN(sv);
2047 const char sigil = SvPVX_const(namesv)[0];
2049 /* If there are state subs, we need to clone them, too.
2050 But they may need to close over variables we have
2051 not cloned yet. So we will have to do a second
2052 pass. Furthermore, there may be state subs clos-
2053 ing over other state subs’ entries, so we have
2054 to put a stub here and then clone into it on the
2056 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2057 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2059 sv = newSV_type(SVt_PVCV);
2061 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2064 /* Just provide a stub, but name it. It will be
2065 upgrade to the real thing on scope entry. */
2066 sv = newSV_type(SVt_PVCV);
2069 share_hek(SvPVX_const(namesv)+1,
2071 * (SvUTF8(namesv) ? -1 : 1),
2075 else sv = SvREFCNT_inc(ppad[ix]);
2076 else if (sigil == '@')
2077 sv = MUTABLE_SV(newAV());
2078 else if (sigil == '%')
2079 sv = MUTABLE_SV(newHV());
2083 /* reset the 'assign only once' flag on each state var */
2084 if (sigil != '&' && SvPAD_STATE(namesv))
2088 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2089 sv = SvREFCNT_inc_NN(ppad[ix]);
2099 for (ix = fpad; ix > 0; ix--) {
2100 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2101 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2102 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2103 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2110 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2114 assert(!CvUNIQUE(proto));
2116 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2117 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2121 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2124 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2125 else CvGV_set(cv,CvGV(proto));
2126 CvSTASH_set(cv, CvSTASH(proto));
2128 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2130 CvSTART(cv) = CvSTART(proto);
2131 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2134 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2136 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2138 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside);
2141 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2142 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2143 cv_dump(proto, "Proto");
2148 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2149 * The prototype was marked as a candiate for const-ization,
2150 * so try to grab the current const value, and if successful,
2151 * turn into a const sub:
2153 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2156 /* For this calling case, op_const_sv returns a *copy*, which we
2157 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2158 Need to fix how lib/constant.pm works to eliminate this. */
2159 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2170 Perl_cv_clone(pTHX_ CV *proto)
2172 PERL_ARGS_ASSERT_CV_CLONE;
2174 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2175 return S_cv_clone(aTHX_ proto, NULL, NULL);
2178 /* Called only by pp_clonecv */
2180 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2182 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2184 return S_cv_clone(aTHX_ proto, target, NULL);
2188 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2190 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2191 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2192 moved to a pre-existing CV struct.
2198 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2202 AV * const comppad_name = PadlistARRAY(padlist)[0];
2203 AV * const comppad = PadlistARRAY(padlist)[1];
2204 SV ** const namepad = AvARRAY(comppad_name);
2205 SV ** const curpad = AvARRAY(comppad);
2207 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2208 PERL_UNUSED_ARG(old_cv);
2210 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2211 const SV * const namesv = namepad[ix];
2212 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2213 && *SvPVX_const(namesv) == '&')
2215 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2217 SvMAGICAL(curpad[ix])
2218 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2220 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2221 if (CvOUTSIDE(innercv) == old_cv) {
2222 if (!CvWEAKOUTSIDE(innercv)) {
2223 SvREFCNT_dec(old_cv);
2224 SvREFCNT_inc_simple_void_NN(new_cv);
2226 CvOUTSIDE(innercv) = new_cv;
2229 else { /* format reference */
2230 SV * const rv = curpad[ix];
2232 if (!SvOK(rv)) continue;
2234 assert(SvWEAKREF(rv));
2235 innercv = (CV *)SvRV(rv);
2236 assert(!CvWEAKOUTSIDE(innercv));
2237 SvREFCNT_dec(CvOUTSIDE(innercv));
2238 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2245 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2247 Push a new pad frame onto the padlist, unless there's already a pad at
2248 this depth, in which case don't bother creating a new one. Then give
2249 the new pad an @_ in slot zero.
2255 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2259 PERL_ARGS_ASSERT_PAD_PUSH;
2261 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2262 PAD** const svp = PadlistARRAY(padlist);
2263 AV* const newpad = newAV();
2264 SV** const oldpad = AvARRAY(svp[depth-1]);
2265 I32 ix = AvFILLp((const AV *)svp[1]);
2266 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2267 SV** const names = AvARRAY(svp[0]);
2270 for ( ;ix > 0; ix--) {
2271 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2272 const char sigil = SvPVX_const(names[ix])[0];
2273 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2274 || (SvFLAGS(names[ix]) & SVpad_STATE)
2277 /* outer lexical or anon code */
2278 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2280 else { /* our own lexical */
2283 sv = MUTABLE_SV(newAV());
2284 else if (sigil == '%')
2285 sv = MUTABLE_SV(newHV());
2288 av_store(newpad, ix, sv);
2292 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2293 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2296 /* save temporaries on recursion? */
2297 SV * const sv = newSV(0);
2298 av_store(newpad, ix, sv);
2303 av_store(newpad, 0, MUTABLE_SV(av));
2306 padlist_store(padlist, depth, newpad);
2311 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2313 Looks up the type of the lexical variable at position I<po> in the
2314 currently-compiling pad. If the variable is typed, the stash of the
2315 class to which it is typed is returned. If not, C<NULL> is returned.
2321 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2324 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2325 if ( SvPAD_TYPED(*av) ) {
2326 return SvSTASH(*av);
2331 #if defined(USE_ITHREADS)
2333 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2336 =for apidoc padlist_dup
2344 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2350 PERL_ARGS_ASSERT_PADLIST_DUP;
2355 cloneall = param->flags & CLONEf_COPY_STACKS
2356 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2357 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2359 max = cloneall ? PadlistMAX(srcpad) : 1;
2361 Newx(dstpad, 1, PADLIST);
2362 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2363 PadlistMAX(dstpad) = max;
2364 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2368 for (depth = 0; depth <= max; ++depth)
2369 PadlistARRAY(dstpad)[depth] =
2370 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2372 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2373 to build anything other than the first level of pads. */
2374 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2376 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2377 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2378 SV **oldpad = AvARRAY(srcpad1);
2383 PadlistARRAY(dstpad)[0] =
2384 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2385 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2389 av_extend(pad1, ix);
2390 PadlistARRAY(dstpad)[1] = pad1;
2391 pad1a = AvARRAY(pad1);
2396 for ( ;ix > 0; ix--) {
2399 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2400 const char sigil = SvPVX_const(names[ix])[0];
2401 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2402 || (SvFLAGS(names[ix]) & SVpad_STATE)
2405 /* outer lexical or anon code */
2406 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2408 else { /* our own lexical */
2409 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2410 /* This is a work around for how the current
2411 implementation of ?{ } blocks in regexps
2412 interacts with lexicals. */
2413 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2418 sv = MUTABLE_SV(newAV());
2419 else if (sigil == '%')
2420 sv = MUTABLE_SV(newHV());
2428 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2429 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2432 /* save temporaries on recursion? */
2433 SV * const sv = newSV(0);
2436 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2437 FIXTHAT before merging this branch.
2438 (And I know how to) */
2439 if (SvPADMY(oldpad[ix]))
2447 args = newAV(); /* Will be @_ */
2449 pad1a[0] = (SV *)args;
2457 #endif /* USE_ITHREADS */
2460 Perl_padlist_store(pTHX_ register PADLIST *padlist, I32 key, PAD *val)
2464 SSize_t const oldmax = PadlistMAX(padlist);
2466 PERL_ARGS_ASSERT_PADLIST_STORE;
2470 if (key > PadlistMAX(padlist)) {
2471 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2472 (SV ***)&PadlistARRAY(padlist),
2473 (SV ***)&PadlistARRAY(padlist));
2474 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2477 ary = PadlistARRAY(padlist);
2478 SvREFCNT_dec(ary[key]);
2485 * c-indentation-style: bsd
2487 * indent-tabs-mode: nil
2490 * ex: set ts=8 sts=4 sw=4 et: