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 for targets (SVs_PADTMP) and GVs end up having &PL_sv_no
60 "names", while slots for constants have &PL_sv_no "names" (see
61 pad_alloc()). That &PL_sv_no is used is an implementation detail subject
62 to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
64 Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
65 The rest are op targets/GVs/constants which are statically allocated
66 or resolved at compile time. These don't have names by which they
67 can be looked up from Perl code at run time through eval"" the way
68 my/our variables can be. Since they can't be looked up by "name"
69 but only by their index allocated at compile time (which is usually
70 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
72 The SVs in the names AV have their PV being the name of the variable.
73 xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
74 which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
75 _HIGH). During compilation, these fields may hold the special value
76 PERL_PADSEQ_INTRO to indicate various stages:
78 COP_SEQ_RANGE_LOW _HIGH
79 ----------------- -----
80 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
81 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
82 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
84 For typed lexicals name SV is SVt_PVMG and SvSTASH
85 points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
86 SvOURSTASH slot pointing at the stash of the associated global (so that
87 duplicate C<our> declarations in the same package can be detected). SvUVX is
88 sometimes hijacked to store the generation number during compilation.
90 If PADNAME_OUTER (SvFAKE) is set on the
91 name SV, then that slot in the frame AV is
92 a REFCNT'ed reference to a lexical from "outside". In this case,
93 the name SV does not use xlow and xhigh to store a cop_seq range, since it is
94 in scope throughout. Instead xhigh stores some flags containing info about
95 the real lexical (is it declared in an anon, and is it capable of being
96 instantiated multiple times?), and for fake ANONs, xlow contains the index
97 within the parent's pad where the lexical's value is stored, to make
100 If the 'name' is '&' the corresponding entry in the PAD
101 is a CV representing a possible closure.
102 (PADNAME_OUTER and name of '&' is not a
103 meaningful combination currently but could
104 become so if C<my sub foo {}> is implemented.)
106 Note that formats are treated as anon subs, and are cloned each time
107 write is called (if necessary).
109 The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
110 and set on scope exit. This allows the
111 'Variable $x is not available' warning
112 to be generated in evals, such as
114 { my $x = 1; sub f { eval '$x'} } f();
116 For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'.
118 =for apidoc AmxU|PADNAMELIST *|PL_comppad_name
120 During compilation, this points to the array containing the names part
121 of the pad for the currently-compiling code.
123 =for apidoc AmxU|PAD *|PL_comppad
125 During compilation, this points to the array containing the values
126 part of the pad for the currently-compiling code. (At runtime a CV may
127 have many such value arrays; at compile time just one is constructed.)
128 At runtime, this points to the array containing the currently-relevant
129 values for the pad for the currently-executing code.
131 =for apidoc AmxU|SV **|PL_curpad
133 Points directly to the body of the L</PL_comppad> array.
134 (I.e., this is C<PAD_ARRAY(PL_comppad)>.)
141 #define PERL_IN_PAD_C
143 #include "keywords.h"
145 #define COP_SEQ_RANGE_LOW_set(sv,val) \
146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
147 #define COP_SEQ_RANGE_HIGH_set(sv,val) \
148 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
150 #define PARENT_PAD_INDEX_set(sv,val) \
151 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
152 #define PARENT_FAKELEX_FLAGS_set(sv,val) \
153 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
156 =for apidoc mx|void|pad_peg|const char *s
158 When PERL_MAD is enabled, this is a small no-op function that gets called
159 at the start of each pad-related function. It can be breakpointed to
160 track all pad operations. The parameter is a string indicating the type
161 of pad operation being performed.
167 void pad_peg(const char* s) {
168 static int pegcnt; /* XXX not threadsafe */
171 PERL_ARGS_ASSERT_PAD_PEG;
178 This is basically sv_eq_flags() in sv.c, but we avoid the magic
183 sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
184 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
185 const char *pv1 = SvPVX_const(sv);
186 STRLEN cur1 = SvCUR(sv);
187 const char *pv2 = pv;
192 svrecode = newSVpvn(pv2, cur2);
193 sv_recode_to_utf8(svrecode, PL_encoding);
194 pv2 = SvPV_const(svrecode, cur2);
197 svrecode = newSVpvn(pv1, cur1);
198 sv_recode_to_utf8(svrecode, PL_encoding);
199 pv1 = SvPV_const(svrecode, cur1);
201 SvREFCNT_dec_NN(svrecode);
203 if (flags & SVf_UTF8)
204 return (bytes_cmp_utf8(
205 (const U8*)pv1, cur1,
206 (const U8*)pv2, cur2) == 0);
208 return (bytes_cmp_utf8(
209 (const U8*)pv2, cur2,
210 (const U8*)pv1, cur1) == 0);
213 return ((SvPVX_const(sv) == pv)
214 || memEQ(SvPVX_const(sv), pv, pvlen));
219 =for apidoc Am|PADLIST *|pad_new|int flags
221 Create a new padlist, updating the global variables for the
222 currently-compiling padlist to point to the new padlist. The following
223 flags can be OR'ed together:
225 padnew_CLONE this pad is for a cloned CV
226 padnew_SAVE save old globals on the save stack
227 padnew_SAVESUB also save extra stuff for start of sub
233 Perl_pad_new(pTHX_ int flags)
240 ASSERT_CURPAD_LEGAL("pad_new");
242 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
243 * vars (based on flags) rather than storing vals + addresses for
244 * each individually. Also see pad_block_start.
245 * XXX DAPM Try to see whether all these conditionals are required
248 /* save existing state, ... */
250 if (flags & padnew_SAVE) {
252 if (! (flags & padnew_CLONE)) {
253 SAVESPTR(PL_comppad_name);
255 SAVEI32(PL_comppad_name_fill);
256 SAVEI32(PL_min_intro_pending);
257 SAVEI32(PL_max_intro_pending);
258 SAVEBOOL(PL_cv_has_eval);
259 if (flags & padnew_SAVESUB) {
260 SAVEBOOL(PL_pad_reset_pending);
264 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
265 * saved - check at some pt that this is okay */
267 /* ... create new pad ... */
269 Newxz(padlist, 1, PADLIST);
272 if (flags & padnew_CLONE) {
273 /* XXX DAPM I dont know why cv_clone needs it
274 * doing differently yet - perhaps this separate branch can be
275 * dispensed with eventually ???
278 AV * const a0 = newAV(); /* will be @_ */
279 av_store(pad, 0, MUTABLE_SV(a0));
282 padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
285 av_store(pad, 0, NULL);
289 /* Most subroutines never recurse, hence only need 2 entries in the padlist
290 array - names, and depth=1. The default for av_store() is to allocate
291 0..3, and even an explicit call to av_extend() with <3 will be rounded
292 up, so we inline the allocation of the array here. */
294 PadlistMAX(padlist) = 1;
295 PadlistARRAY(padlist) = ary;
299 /* ... then update state variables */
302 PL_curpad = AvARRAY(pad);
304 if (! (flags & padnew_CLONE)) {
305 PL_comppad_name = padname;
306 PL_comppad_name_fill = 0;
307 PL_min_intro_pending = 0;
312 DEBUG_X(PerlIO_printf(Perl_debug_log,
313 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
314 " name=0x%"UVxf" flags=0x%"UVxf"\n",
315 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
316 PTR2UV(padname), (UV)flags
320 return (PADLIST*)padlist;
325 =head1 Embedding Functions
329 Clear out all the active components of a CV. This can happen either
330 by an explicit C<undef &foo>, or by the reference count going to zero.
331 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
332 children can still follow the full lexical scope chain.
338 Perl_cv_undef(pTHX_ CV *cv)
341 const PADLIST *padlist = CvPADLIST(cv);
342 bool const slabbed = !!CvSLABBED(cv);
344 PERL_ARGS_ASSERT_CV_UNDEF;
346 DEBUG_X(PerlIO_printf(Perl_debug_log,
347 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
348 PTR2UV(cv), PTR2UV(PL_comppad))
351 if (CvFILE(cv) && CvDYNFILE(cv)) {
352 Safefree(CvFILE(cv));
357 if (!CvISXSUB(cv) && CvROOT(cv)) {
358 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
359 Perl_croak(aTHX_ "Can't undef active subroutine");
362 PAD_SAVE_SETNULLPAD();
364 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
370 else if (slabbed && CvSTART(cv)) {
372 PAD_SAVE_SETNULLPAD();
374 /* discard any leaked ops */
376 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
377 opslab_force_free((OPSLAB *)CvSTART(cv));
383 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
385 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
386 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
387 if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
388 else CvGV_set(cv, NULL);
390 /* This statement and the subsequence if block was pad_undef(). */
391 pad_peg("pad_undef");
396 /* Free the padlist associated with a CV.
397 If parts of it happen to be current, we null the relevant PL_*pad*
398 global vars so that we don't have any dangling references left.
399 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
400 subs to the outer of this cv. */
402 DEBUG_X(PerlIO_printf(Perl_debug_log,
403 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
404 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
407 /* detach any '&' anon children in the pad; if afterwards they
408 * are still live, fix up their CvOUTSIDEs to point to our outside,
410 /* XXX DAPM for efficiency, we should only do this if we know we have
411 * children, or integrate this loop with general cleanup */
413 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
414 CV * const outercv = CvOUTSIDE(cv);
415 const U32 seq = CvOUTSIDE_SEQ(cv);
416 PAD * const comppad_name = PadlistARRAY(padlist)[0];
417 SV ** const namepad = AvARRAY(comppad_name);
418 PAD * const comppad = PadlistARRAY(padlist)[1];
419 SV ** const curpad = AvARRAY(comppad);
420 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
421 SV * const namesv = namepad[ix];
422 if (namesv && namesv != &PL_sv_undef
423 && *SvPVX_const(namesv) == '&')
425 CV * const innercv = MUTABLE_CV(curpad[ix]);
426 U32 inner_rc = SvREFCNT(innercv);
428 assert(SvTYPE(innercv) != SVt_PVFM);
430 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
432 SvREFCNT_dec_NN(innercv);
436 /* in use, not just a prototype */
437 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
438 assert(CvWEAKOUTSIDE(innercv));
439 /* don't relink to grandfather if he's being freed */
440 if (outercv && SvREFCNT(outercv)) {
441 CvWEAKOUTSIDE_off(innercv);
442 CvOUTSIDE(innercv) = outercv;
443 CvOUTSIDE_SEQ(innercv) = seq;
444 SvREFCNT_inc_simple_void_NN(outercv);
447 CvOUTSIDE(innercv) = NULL;
454 ix = PadlistMAX(padlist);
456 PAD * const sv = PadlistARRAY(padlist)[ix--];
458 if (sv == PL_comppad) {
466 PAD * const sv = PadlistARRAY(padlist)[0];
467 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
468 PL_comppad_name = NULL;
471 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
473 CvPADLIST(cv) = NULL;
477 /* remove CvOUTSIDE unless this is an undef rather than a free */
478 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
479 if (!CvWEAKOUTSIDE(cv))
480 SvREFCNT_dec(CvOUTSIDE(cv));
481 CvOUTSIDE(cv) = NULL;
484 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
487 if (CvISXSUB(cv) && CvXSUB(cv)) {
490 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
491 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
492 * to choose an error message */
493 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
497 =for apidoc cv_forget_slab
499 When a CV has a reference count on its slab (CvSLABBED), it is responsible
500 for making sure it is freed. (Hence, no two CVs should ever have a
501 reference count on the same slab.) The CV only needs to reference the slab
502 during compilation. Once it is compiled and CvROOT attached, it has
503 finished its job, so it can forget the slab.
509 Perl_cv_forget_slab(pTHX_ CV *cv)
511 const bool slabbed = !!CvSLABBED(cv);
514 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
516 if (!slabbed) return;
520 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
521 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
523 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
527 #ifdef PERL_DEBUG_READONLY_OPS
528 const size_t refcnt = slab->opslab_refcnt;
530 OpslabREFCNT_dec(slab);
531 #ifdef PERL_DEBUG_READONLY_OPS
532 if (refcnt > 1) Slab_to_ro(slab);
538 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
540 Allocates a place in the currently-compiling
541 pad (via L<perlapi/pad_alloc>) and
542 then stores a name for that entry. I<namesv> is adopted and becomes the
543 name entry; it must already contain the name string and be sufficiently
544 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
545 added to I<namesv>. None of the other
546 processing of L<perlapi/pad_add_name_pvn>
547 is done. Returns the offset of the allocated pad slot.
553 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
556 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
558 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
560 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
563 assert(SvTYPE(namesv) == SVt_PVMG);
564 SvPAD_TYPED_on(namesv);
565 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
568 SvPAD_OUR_on(namesv);
569 SvOURSTASH_set(namesv, ourstash);
570 SvREFCNT_inc_simple_void_NN(ourstash);
572 else if (flags & padadd_STATE) {
573 SvPAD_STATE_on(namesv);
576 av_store(PL_comppad_name, offset, namesv);
581 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
583 Allocates a place in the currently-compiling pad for a named lexical
584 variable. Stores the name and other metadata in the name part of the
585 pad, and makes preparations to manage the variable's lexical scoping.
586 Returns the offset of the allocated pad slot.
588 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
589 If I<typestash> is non-null, the name is for a typed lexical, and this
590 identifies the type. If I<ourstash> is non-null, it's a lexical reference
591 to a package variable, and this identifies the package. The following
592 flags can be OR'ed together:
594 padadd_OUR redundantly specifies if it's a package var
595 padadd_STATE variable will retain value persistently
596 padadd_NO_DUP_CHECK skip check for lexical shadowing
602 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
603 U32 flags, HV *typestash, HV *ourstash)
610 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
612 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
613 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
616 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
618 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
619 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
622 sv_setpvn(namesv, namepv, namelen);
625 flags |= padadd_UTF8_NAME;
629 flags &= ~padadd_UTF8_NAME;
631 if ((flags & padadd_NO_DUP_CHECK) == 0) {
633 SAVEFREESV(namesv); /* in case of fatal warnings */
634 /* check for duplicate declaration */
635 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
636 SvREFCNT_inc_simple_void_NN(namesv);
640 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
642 /* not yet introduced */
643 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
644 COP_SEQ_RANGE_HIGH_set(namesv, 0);
646 if (!PL_min_intro_pending)
647 PL_min_intro_pending = offset;
648 PL_max_intro_pending = offset;
649 /* if it's not a simple scalar, replace with an AV or HV */
650 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
651 assert(SvREFCNT(PL_curpad[offset]) == 1);
652 if (namelen != 0 && *namepv == '@')
653 sv_upgrade(PL_curpad[offset], SVt_PVAV);
654 else if (namelen != 0 && *namepv == '%')
655 sv_upgrade(PL_curpad[offset], SVt_PVHV);
656 else if (namelen != 0 && *namepv == '&')
657 sv_upgrade(PL_curpad[offset], SVt_PVCV);
658 assert(SvPADMY(PL_curpad[offset]));
659 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
660 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
661 (long)offset, SvPVX(namesv),
662 PTR2UV(PL_curpad[offset])));
668 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
670 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
671 instead of a string/length pair.
677 Perl_pad_add_name_pv(pTHX_ const char *name,
678 const U32 flags, HV *typestash, HV *ourstash)
680 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
681 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
685 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
687 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
688 of an SV instead of a string/length pair.
694 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
698 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
699 namepv = SvPV(name, namelen);
701 flags |= padadd_UTF8_NAME;
702 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
706 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
708 Allocates a place in the currently-compiling pad,
709 returning the offset of the allocated pad slot.
710 No name is initially attached to the pad slot.
711 I<tmptype> is a set of flags indicating the kind of pad entry required,
712 which will be set in the value SV for the allocated pad entry:
714 SVs_PADMY named lexical variable ("my", "our", "state")
715 SVs_PADTMP unnamed temporary store
716 SVf_READONLY constant shared between recursion levels
718 C<SVf_READONLY> has been supported here only since perl 5.20. To work with
719 earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
720 does not cause the SV in the pad slot to be marked read-only, but simply
721 tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
722 least should be treated as such.
724 I<optype> should be an opcode indicating the type of operation that the
725 pad entry is to support. This doesn't affect operational semantics,
726 but is used for debugging.
731 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
732 * or at least rationalise ??? */
735 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
741 PERL_UNUSED_ARG(optype);
742 ASSERT_CURPAD_ACTIVE("pad_alloc");
744 if (AvARRAY(PL_comppad) != PL_curpad)
745 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
746 AvARRAY(PL_comppad), PL_curpad);
747 if (PL_pad_reset_pending)
749 if (tmptype & SVs_PADMY) {
750 /* For a my, simply push a null SV onto the end of PL_comppad. */
751 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
752 retval = AvFILLp(PL_comppad);
755 /* For a tmp, scan the pad from PL_padix upwards
756 * for a slot which has no name and no active value.
758 SV * const * const names = AvARRAY(PL_comppad_name);
759 const SSize_t names_fill = AvFILLp(PL_comppad_name);
762 * Entries that close over unavailable variables
763 * in outer subs contain values not marked PADMY.
764 * Thus we must skip, not just pad values that are
765 * marked as current pad values, but also those with names.
767 if (++PL_padix <= names_fill &&
768 (sv = names[PL_padix]) && sv != &PL_sv_undef)
770 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
771 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
775 if (tmptype & SVf_READONLY) {
776 av_store(PL_comppad_name, PL_padix, &PL_sv_no);
777 tmptype &= ~SVf_READONLY;
778 tmptype |= SVs_PADTMP;
782 SvFLAGS(sv) |= tmptype;
783 PL_curpad = AvARRAY(PL_comppad);
785 DEBUG_X(PerlIO_printf(Perl_debug_log,
786 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
787 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
788 PL_op_name[optype]));
789 #ifdef DEBUG_LEAKING_SCALARS
790 sv->sv_debug_optype = optype;
791 sv->sv_debug_inpad = 1;
793 return (PADOFFSET)retval;
797 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
799 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
800 for an anonymous function that is lexically scoped inside the
801 currently-compiling function.
802 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
803 to the outer scope is weakened to avoid a reference loop.
805 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
807 I<optype> should be an opcode indicating the type of operation that the
808 pad entry is to support. This doesn't affect operational semantics,
809 but is used for debugging.
815 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
819 SV* const name = newSV_type(SVt_PVNV);
821 PERL_ARGS_ASSERT_PAD_ADD_ANON;
824 sv_setpvs(name, "&");
825 /* These two aren't used; just make sure they're not equal to
826 * PERL_PADSEQ_INTRO */
827 COP_SEQ_RANGE_LOW_set(name, 0);
828 COP_SEQ_RANGE_HIGH_set(name, 0);
829 ix = pad_alloc(optype, SVs_PADMY);
830 av_store(PL_comppad_name, ix, name);
831 /* XXX DAPM use PL_curpad[] ? */
832 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
833 av_store(PL_comppad, ix, (SV*)func);
835 SV *rv = newRV_noinc((SV *)func);
837 assert (SvTYPE(func) == SVt_PVFM);
838 av_store(PL_comppad, ix, rv);
840 SvPADMY_on((SV*)func);
842 /* to avoid ref loops, we never have parent + child referencing each
843 * other simultaneously */
844 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
845 assert(!CvWEAKOUTSIDE(func));
846 CvWEAKOUTSIDE_on(func);
847 SvREFCNT_dec_NN(CvOUTSIDE(func));
853 =for apidoc pad_check_dup
855 Check for duplicate declarations: report any of:
857 * a my in the current scope with the same name;
858 * an our (anywhere in the pad) with the same name and the
859 same stash as C<ourstash>
861 C<is_our> indicates that the name to check is an 'our' declaration.
867 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
872 const U32 is_our = flags & padadd_OUR;
874 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
876 ASSERT_CURPAD_ACTIVE("pad_check_dup");
878 assert((flags & ~padadd_OUR) == 0);
880 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
881 return; /* nothing to check */
883 svp = AvARRAY(PL_comppad_name);
884 top = AvFILLp(PL_comppad_name);
885 /* check the current scope */
886 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
888 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
889 SV * const sv = svp[off];
893 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
894 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
897 if (is_our && (SvPAD_OUR(sv)))
898 break; /* "our" masking "our" */
899 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
900 Perl_warner(aTHX_ packWARN(WARN_MISC),
901 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
902 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
903 *SvPVX(sv) == '&' ? "subroutine" : "variable",
905 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
906 ? "scope" : "statement"));
911 /* check the rest of the pad */
914 SV * const sv = svp[off];
918 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
919 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
920 && SvOURSTASH(sv) == ourstash
923 Perl_warner(aTHX_ packWARN(WARN_MISC),
924 "\"our\" variable %"SVf" redeclared", sv);
925 if ((I32)off <= PL_comppad_name_floor)
926 Perl_warner(aTHX_ packWARN(WARN_MISC),
927 "\t(Did you mean \"local\" instead of \"our\"?)\n");
937 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
939 Given the name of a lexical variable, find its position in the
940 currently-compiling pad.
941 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
942 I<flags> is reserved and must be zero.
943 If it is not in the current pad but appears in the pad of any lexically
944 enclosing scope, then a pseudo-entry for it is added in the current pad.
945 Returns the offset in the current pad,
946 or C<NOT_IN_PAD> if no such lexical is in scope.
952 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
961 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
963 pad_peg("pad_findmy_pvn");
965 if (flags & ~padadd_UTF8_NAME)
966 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
969 if (flags & padadd_UTF8_NAME) {
971 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
974 flags |= padadd_UTF8_NAME;
976 flags &= ~padadd_UTF8_NAME;
979 offset = pad_findlex(namepv, namelen, flags,
980 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
981 if ((PADOFFSET)offset != NOT_IN_PAD)
984 /* look for an our that's being introduced; this allows
985 * our $foo = 0 unless defined $foo;
986 * to not give a warning. (Yes, this is a hack) */
988 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
989 name_svp = AvARRAY(nameav);
990 for (offset = AvFILLp(nameav); offset > 0; offset--) {
991 const SV * const namesv = name_svp[offset];
992 if (namesv && PadnameLEN(namesv) == namelen
994 && (SvPAD_OUR(namesv))
995 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
996 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
997 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
1005 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
1007 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
1008 instead of a string/length pair.
1014 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1016 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1017 return pad_findmy_pvn(name, strlen(name), flags);
1021 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1023 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1024 of an SV instead of a string/length pair.
1030 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1034 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1035 namepv = SvPV(name, namelen);
1037 flags |= padadd_UTF8_NAME;
1038 return pad_findmy_pvn(namepv, namelen, flags);
1042 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1044 Find the position of the lexical C<$_> in the pad of the
1045 currently-executing function. Returns the offset in the current pad,
1046 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1047 the global one should be used instead).
1048 L</find_rundefsv> is likely to be more convenient.
1054 Perl_find_rundefsvoffset(pTHX)
1059 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1060 NULL, &out_sv, &out_flags);
1064 =for apidoc Am|SV *|find_rundefsv
1066 Find and return the variable that is named C<$_> in the lexical scope
1067 of the currently-executing function. This may be a lexical C<$_>,
1068 or will otherwise be the global one.
1074 Perl_find_rundefsv(pTHX)
1080 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1081 NULL, &namesv, &flags);
1083 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1090 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1096 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1098 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1099 NULL, &namesv, &flags);
1101 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1104 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1108 =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
1110 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1111 in the inner pads if it's found in an outer one.
1113 Returns the offset in the bottom pad of the lex or the fake lex.
1114 cv is the CV in which to start the search, and seq is the current cop_seq
1115 to match against. If warn is true, print appropriate warnings. The out_*
1116 vars return values, and so are pointers to where the returned values
1117 should be stored. out_capture, if non-null, requests that the innermost
1118 instance of the lexical is captured; out_name_sv is set to the innermost
1119 matched namesv or fake namesv; out_flags returns the flags normally
1120 associated with the IVX field of a fake namesv.
1122 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1123 then comes back down, adding fake entries as it goes. It has to be this way
1124 because fake namesvs in anon protoypes have to store in xlow the index into
1130 /* the CV has finished being compiled. This is not a sufficient test for
1131 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1132 #define CvCOMPILED(cv) CvROOT(cv)
1134 /* the CV does late binding of its lexicals */
1135 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1138 S_unavailable(pTHX_ SV *namesv)
1140 /* diag_listed_as: Variable "%s" is not available */
1141 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1142 "%se \"%"SVf"\" is not available",
1143 *SvPVX_const(namesv) == '&'
1150 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1151 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1154 I32 offset, new_offset;
1157 const PADLIST * const padlist = CvPADLIST(cv);
1158 const bool staleok = !!(flags & padadd_STALEOK);
1160 PERL_ARGS_ASSERT_PAD_FINDLEX;
1162 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1163 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1165 flags &= ~ padadd_STALEOK; /* one-shot flag */
1169 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1170 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1171 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1172 out_capture ? " capturing" : "" ));
1174 /* first, search this pad */
1176 if (padlist) { /* not an undef CV */
1177 I32 fake_offset = 0;
1178 const AV * const nameav = PadlistARRAY(padlist)[0];
1179 SV * const * const name_svp = AvARRAY(nameav);
1181 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1182 const SV * const namesv = name_svp[offset];
1183 if (namesv && PadnameLEN(namesv) == namelen
1184 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1185 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1187 if (SvFAKE(namesv)) {
1188 fake_offset = offset; /* in case we don't find a real one */
1191 /* is seq within the range _LOW to _HIGH ?
1192 * This is complicated by the fact that PL_cop_seqmax
1193 * may have wrapped around at some point */
1194 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1195 continue; /* not yet introduced */
1197 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1198 /* in compiling scope */
1200 (seq > COP_SEQ_RANGE_LOW(namesv))
1201 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1202 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1207 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1209 ( seq > COP_SEQ_RANGE_LOW(namesv)
1210 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1212 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1213 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1219 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1220 if (offset > 0) { /* not fake */
1222 *out_name_sv = name_svp[offset]; /* return the namesv */
1224 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1225 * instances. For now, we just test !CvUNIQUE(cv), but
1226 * ideally, we should detect my's declared within loops
1227 * etc - this would allow a wider range of 'not stayed
1228 * shared' warnings. We also treated already-compiled
1229 * lexes as not multi as viewed from evals. */
1231 *out_flags = CvANON(cv) ?
1233 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1234 ? PAD_FAKELEX_MULTI : 0;
1236 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1237 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1238 PTR2UV(cv), (long)offset,
1239 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1240 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1242 else { /* fake match */
1243 offset = fake_offset;
1244 *out_name_sv = name_svp[offset]; /* return the namesv */
1245 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1246 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1247 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1248 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1249 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1253 /* return the lex? */
1258 if (SvPAD_OUR(*out_name_sv)) {
1259 *out_capture = NULL;
1263 /* trying to capture from an anon prototype? */
1265 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1266 : *out_flags & PAD_FAKELEX_ANON)
1270 newSVpvn_flags(namepv, namelen,
1272 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1274 *out_capture = NULL;
1280 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1281 && !SvPAD_STATE(name_svp[offset])
1282 && warn && ckWARN(WARN_CLOSURE)) {
1284 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1285 "Variable \"%"SVf"\" will not stay shared",
1286 newSVpvn_flags(namepv, namelen,
1288 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1291 if (fake_offset && CvANON(cv)
1292 && CvCLONE(cv) &&!CvCLONED(cv))
1295 /* not yet caught - look further up */
1296 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1297 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1300 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1302 newwarn, out_capture, out_name_sv, out_flags);
1307 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1308 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1309 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1310 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1311 PTR2UV(cv), PTR2UV(*out_capture)));
1313 if (SvPADSTALE(*out_capture)
1314 && (!CvDEPTH(cv) || !staleok)
1315 && !SvPAD_STATE(name_svp[offset]))
1318 newSVpvn_flags(namepv, namelen,
1320 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1321 *out_capture = NULL;
1324 if (!*out_capture) {
1325 if (namelen != 0 && *namepv == '@')
1326 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1327 else if (namelen != 0 && *namepv == '%')
1328 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1329 else if (namelen != 0 && *namepv == '&')
1330 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1332 *out_capture = sv_newmortal();
1340 /* it's not in this pad - try above */
1345 /* out_capture non-null means caller wants us to capture lex; in
1346 * addition we capture ourselves unless it's an ANON/format */
1347 new_capturep = out_capture ? out_capture :
1348 CvLATE(cv) ? NULL : &new_capture;
1350 offset = pad_findlex(namepv, namelen,
1351 flags | padadd_STALEOK*(new_capturep == &new_capture),
1352 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1353 new_capturep, out_name_sv, out_flags);
1354 if ((PADOFFSET)offset == NOT_IN_PAD)
1357 /* found in an outer CV. Add appropriate fake entry to this pad */
1359 /* don't add new fake entries (via eval) to CVs that we have already
1360 * finished compiling, or to undef CVs */
1361 if (CvCOMPILED(cv) || !padlist)
1362 return 0; /* this dummy (and invalid) value isnt used by the caller */
1365 /* This relies on sv_setsv_flags() upgrading the destination to the same
1366 type as the source, independent of the flags set, and on it being
1367 "good" and only copying flag bits and pointers that it understands.
1369 SV *new_namesv = newSVsv(*out_name_sv);
1370 AV * const ocomppad_name = PL_comppad_name;
1371 PAD * const ocomppad = PL_comppad;
1372 PL_comppad_name = PadlistARRAY(padlist)[0];
1373 PL_comppad = PadlistARRAY(padlist)[1];
1374 PL_curpad = AvARRAY(PL_comppad);
1377 = pad_alloc_name(new_namesv,
1378 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1379 SvPAD_TYPED(*out_name_sv)
1380 ? SvSTASH(*out_name_sv) : NULL,
1381 SvOURSTASH(*out_name_sv)
1384 SvFAKE_on(new_namesv);
1385 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1386 "Pad addname: %ld \"%.*s\" FAKE\n",
1388 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1389 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1391 PARENT_PAD_INDEX_set(new_namesv, 0);
1392 if (SvPAD_OUR(new_namesv)) {
1393 NOOP; /* do nothing */
1395 else if (CvLATE(cv)) {
1396 /* delayed creation - just note the offset within parent pad */
1397 PARENT_PAD_INDEX_set(new_namesv, offset);
1401 /* immediate creation - capture outer value right now */
1402 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1403 /* But also note the offset, as newMYSUB needs it */
1404 PARENT_PAD_INDEX_set(new_namesv, offset);
1405 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1406 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1407 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1409 *out_name_sv = new_namesv;
1410 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1412 PL_comppad_name = ocomppad_name;
1413 PL_comppad = ocomppad;
1414 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1422 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1424 Get the value at offset I<po> in the current (compiling or executing) pad.
1425 Use macro PAD_SV instead of calling this function directly.
1431 Perl_pad_sv(pTHX_ PADOFFSET po)
1434 ASSERT_CURPAD_ACTIVE("pad_sv");
1437 Perl_croak(aTHX_ "panic: pad_sv po");
1438 DEBUG_X(PerlIO_printf(Perl_debug_log,
1439 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1440 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1442 return PL_curpad[po];
1446 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1448 Set the value at offset I<po> in the current (compiling or executing) pad.
1449 Use the macro PAD_SETSV() rather than calling this function directly.
1455 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1459 PERL_ARGS_ASSERT_PAD_SETSV;
1461 ASSERT_CURPAD_ACTIVE("pad_setsv");
1463 DEBUG_X(PerlIO_printf(Perl_debug_log,
1464 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1465 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1470 #endif /* DEBUGGING */
1473 =for apidoc m|void|pad_block_start|int full
1475 Update the pad compilation state variables on entry to a new block.
1480 /* XXX DAPM perhaps:
1481 * - integrate this in general state-saving routine ???
1482 * - combine with the state-saving going on in pad_new ???
1483 * - introduce a new SAVE type that does all this in one go ?
1487 Perl_pad_block_start(pTHX_ int full)
1490 ASSERT_CURPAD_ACTIVE("pad_block_start");
1491 SAVEI32(PL_comppad_name_floor);
1492 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1494 PL_comppad_name_fill = PL_comppad_name_floor;
1495 if (PL_comppad_name_floor < 0)
1496 PL_comppad_name_floor = 0;
1497 SAVEI32(PL_min_intro_pending);
1498 SAVEI32(PL_max_intro_pending);
1499 PL_min_intro_pending = 0;
1500 SAVEI32(PL_comppad_name_fill);
1501 SAVEI32(PL_padix_floor);
1502 PL_padix_floor = PL_padix;
1503 PL_pad_reset_pending = FALSE;
1507 =for apidoc m|U32|intro_my
1509 "Introduce" my variables to visible status. This is called during parsing
1510 at the end of each statement to make lexical variables visible to
1511 subsequent statements.
1524 ASSERT_CURPAD_ACTIVE("intro_my");
1525 if (! PL_min_intro_pending)
1526 return PL_cop_seqmax;
1528 svp = AvARRAY(PL_comppad_name);
1529 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1530 SV * const sv = svp[i];
1532 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1533 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1535 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1536 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1537 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1538 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1539 (long)i, SvPVX_const(sv),
1540 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1541 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1545 seq = PL_cop_seqmax;
1547 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1549 PL_min_intro_pending = 0;
1550 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1551 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1552 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1558 =for apidoc m|void|pad_leavemy
1560 Cleanup at end of scope during compilation: set the max seq number for
1561 lexicals in this scope and warn of any lexicals that never got introduced.
1567 Perl_pad_leavemy(pTHX)
1572 SV * const * const svp = AvARRAY(PL_comppad_name);
1574 PL_pad_reset_pending = FALSE;
1576 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1577 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1578 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1579 const SV * const sv = svp[off];
1580 if (sv && PadnameLEN(sv) && !SvFAKE(sv))
1581 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1582 "%"SVf" never introduced",
1586 /* "Deintroduce" my variables that are leaving with this scope. */
1587 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1588 SV * const sv = svp[off];
1589 if (sv && PadnameLEN(sv) && !SvFAKE(sv)
1590 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1592 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1593 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1594 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1595 (long)off, SvPVX_const(sv),
1596 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1597 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1599 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1600 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1601 OP *kid = newOP(OP_INTROCV, 0);
1603 o = op_prepend_elem(OP_LINESEQ, kid, o);
1608 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1610 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1611 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1616 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1618 Abandon the tmp in the current pad at offset po and replace with a
1625 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1628 ASSERT_CURPAD_LEGAL("pad_swipe");
1631 if (AvARRAY(PL_comppad) != PL_curpad)
1632 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1633 AvARRAY(PL_comppad), PL_curpad);
1634 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1635 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1636 (long)po, (long)AvFILLp(PL_comppad));
1638 DEBUG_X(PerlIO_printf(Perl_debug_log,
1639 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1640 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1643 SvREFCNT_dec(PL_curpad[po]);
1646 /* if pad tmps aren't shared between ops, then there's no need to
1647 * create a new tmp when an existing op is freed */
1648 #ifdef USE_BROKEN_PAD_RESET
1649 PL_curpad[po] = newSV(0);
1650 SvPADTMP_on(PL_curpad[po]);
1652 PL_curpad[po] = &PL_sv_undef;
1654 if (PadnamelistMAX(PL_comppad_name) != -1
1655 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
1656 assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
1657 PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
1659 if ((I32)po < PL_padix)
1664 =for apidoc m|void|pad_reset
1666 Mark all the current temporaries for reuse
1671 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1672 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1673 * on the stack by OPs that use them, there are several ways to get an alias
1674 * to a shared TARG. Such an alias will change randomly and unpredictably.
1675 * We avoid doing this until we can think of a Better Way.
1681 #ifdef USE_BROKEN_PAD_RESET
1682 if (AvARRAY(PL_comppad) != PL_curpad)
1683 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1684 AvARRAY(PL_comppad), PL_curpad);
1686 DEBUG_X(PerlIO_printf(Perl_debug_log,
1687 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1688 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1689 (long)PL_padix, (long)PL_padix_floor
1693 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1695 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1696 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1697 SvPADTMP_off(PL_curpad[po]);
1699 PL_padix = PL_padix_floor;
1702 PL_pad_reset_pending = FALSE;
1706 =for apidoc Amx|void|pad_tidy|padtidy_type type
1708 Tidy up a pad at the end of compilation of the code to which it belongs.
1709 Jobs performed here are: remove most stuff from the pads of anonsub
1710 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1711 the kind of subroutine:
1713 padtidy_SUB ordinary subroutine
1714 padtidy_SUBCLONE prototype for lexical closure
1715 padtidy_FORMAT format
1720 /* XXX DAPM surely most of this stuff should be done properly
1721 * at the right time beforehand, rather than going around afterwards
1722 * cleaning up our mistakes ???
1726 Perl_pad_tidy(pTHX_ padtidy_type type)
1730 ASSERT_CURPAD_ACTIVE("pad_tidy");
1732 /* If this CV has had any 'eval-capable' ops planted in it:
1733 * i.e. it contains any of:
1737 * * use re 'eval'; /$var/
1740 * Then any anon prototypes in the chain of CVs should be marked as
1741 * cloneable, so that for example the eval's CV in
1745 * gets the right CvOUTSIDE. If running with -d, *any* sub may
1746 * potentially have an eval executed within it.
1749 if (PL_cv_has_eval || PL_perldb) {
1751 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1752 if (cv != PL_compcv && CvCOMPILED(cv))
1753 break; /* no need to mark already-compiled code */
1755 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1756 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1763 /* extend namepad to match curpad */
1764 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1765 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1767 if (type == padtidy_SUBCLONE) {
1768 SV * const * const namep = AvARRAY(PL_comppad_name);
1771 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1774 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1777 * The only things that a clonable function needs in its
1778 * pad are anonymous subs.
1779 * The rest are created anew during cloning.
1781 if (!((namesv = namep[ix]) != NULL &&
1782 namesv != &PL_sv_undef &&
1783 *SvPVX_const(namesv) == '&'))
1785 SvREFCNT_dec(PL_curpad[ix]);
1786 PL_curpad[ix] = NULL;
1790 else if (type == padtidy_SUB) {
1791 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1792 AV * const av = newAV(); /* Will be @_ */
1793 av_store(PL_comppad, 0, MUTABLE_SV(av));
1797 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1798 SV * const * const namep = AvARRAY(PL_comppad_name);
1800 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1801 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1803 if (!SvPADMY(PL_curpad[ix])) {
1804 SvPADTMP_on(PL_curpad[ix]);
1805 } else if (!SvFAKE(namep[ix])) {
1806 /* This is a work around for how the current implementation of
1807 ?{ } blocks in regexps interacts with lexicals.
1809 One of our lexicals.
1810 Can't do this on all lexicals, otherwise sub baz() won't
1819 because completion of compiling &bar calling pad_tidy()
1820 would cause (top level) $foo to be marked as stale, and
1821 "no longer available". */
1822 SvPADSTALE_on(PL_curpad[ix]);
1826 PL_curpad = AvARRAY(PL_comppad);
1830 =for apidoc m|void|pad_free|PADOFFSET po
1832 Free the SV at offset po in the current pad.
1837 /* XXX DAPM integrate with pad_swipe ???? */
1839 Perl_pad_free(pTHX_ PADOFFSET po)
1843 ASSERT_CURPAD_LEGAL("pad_free");
1846 if (AvARRAY(PL_comppad) != PL_curpad)
1847 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1848 AvARRAY(PL_comppad), PL_curpad);
1850 Perl_croak(aTHX_ "panic: pad_free po");
1852 DEBUG_X(PerlIO_printf(Perl_debug_log,
1853 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1854 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1859 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1860 SvFLAGS(sv) &= ~SVs_PADTMP;
1862 if ((I32)po < PL_padix)
1867 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1869 Dump the contents of a padlist
1875 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1884 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1889 pad_name = *PadlistARRAY(padlist);
1890 pad = PadlistARRAY(padlist)[1];
1891 pname = AvARRAY(pad_name);
1892 ppad = AvARRAY(pad);
1893 Perl_dump_indent(aTHX_ level, file,
1894 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1895 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1898 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1899 const SV *namesv = pname[ix];
1900 if (namesv && !PadnameLEN(namesv)) {
1905 Perl_dump_indent(aTHX_ level+1, file,
1906 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1909 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1910 SvPVX_const(namesv),
1911 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1912 (unsigned long)PARENT_PAD_INDEX(namesv)
1916 Perl_dump_indent(aTHX_ level+1, file,
1917 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1920 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1921 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1922 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1927 Perl_dump_indent(aTHX_ level+1, file,
1928 "%2d. 0x%"UVxf"<%lu>\n",
1931 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1940 =for apidoc m|void|cv_dump|CV *cv|const char *title
1942 dump the contents of a CV
1948 S_cv_dump(pTHX_ const CV *cv, const char *title)
1951 const CV * const outside = CvOUTSIDE(cv);
1952 PADLIST* const padlist = CvPADLIST(cv);
1954 PERL_ARGS_ASSERT_CV_DUMP;
1956 PerlIO_printf(Perl_debug_log,
1957 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1960 (CvANON(cv) ? "ANON"
1961 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1962 : (cv == PL_main_cv) ? "MAIN"
1963 : CvUNIQUE(cv) ? "UNIQUE"
1964 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1967 : CvANON(outside) ? "ANON"
1968 : (outside == PL_main_cv) ? "MAIN"
1969 : CvUNIQUE(outside) ? "UNIQUE"
1970 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1972 PerlIO_printf(Perl_debug_log,
1973 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1974 do_dump_pad(1, Perl_debug_log, padlist, 1);
1977 #endif /* DEBUGGING */
1980 =for apidoc Am|CV *|cv_clone|CV *proto
1982 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1983 of the function: its code, pad structure, and other attributes.
1984 The prototype is combined with a capture of outer lexicals to which the
1985 code refers, which are taken from the currently-executing instance of
1986 the immediately surrounding code.
1991 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1994 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1998 PADLIST* const protopadlist = CvPADLIST(proto);
1999 PAD *const protopad_name = *PadlistARRAY(protopadlist);
2000 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
2001 SV** const pname = AvARRAY(protopad_name);
2002 SV** const ppad = AvARRAY(protopad);
2003 const I32 fname = AvFILLp(protopad_name);
2004 const I32 fpad = AvFILLp(protopad);
2007 bool subclones = FALSE;
2009 assert(!CvUNIQUE(proto));
2011 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
2012 * reliable. The currently-running sub is always the one we need to
2014 * For my subs, the currently-running sub may not be the one we want.
2015 * We have to check whether it is a clone of CvOUTSIDE.
2016 * Note that in general for formats, CvOUTSIDE != find_runcv.
2017 * Since formats may be nested inside closures, CvOUTSIDE may point
2018 * to a prototype; we instead want the cloned parent who called us.
2022 if (CvWEAKOUTSIDE(proto))
2023 outside = find_runcv(NULL);
2025 outside = CvOUTSIDE(proto);
2026 if ((CvCLONE(outside) && ! CvCLONED(outside))
2027 || !CvPADLIST(outside)
2028 || PadlistNAMES(CvPADLIST(outside))
2029 != protopadlist->xpadl_outid) {
2030 outside = find_runcv_where(
2031 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2033 /* outside could be null */
2037 depth = outside ? CvDEPTH(outside) : 0;
2042 SAVESPTR(PL_compcv);
2044 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2047 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2049 SAVESPTR(PL_comppad_name);
2050 PL_comppad_name = protopad_name;
2051 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2053 av_fill(PL_comppad, fpad);
2055 PL_curpad = AvARRAY(PL_comppad);
2057 outpad = outside && CvPADLIST(outside)
2058 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2061 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2063 for (ix = fpad; ix > 0; ix--) {
2064 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2066 if (namesv && PadnameLEN(namesv)) { /* lexical */
2067 if (SvFAKE(namesv)) { /* lexical from outside? */
2068 /* formats may have an inactive, or even undefined, parent;
2069 but state vars are always available. */
2070 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2071 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2072 && (!outside || !CvDEPTH(outside))) ) {
2073 S_unavailable(aTHX_ namesv);
2077 SvREFCNT_inc_simple_void_NN(sv);
2080 const char sigil = SvPVX_const(namesv)[0];
2082 /* If there are state subs, we need to clone them, too.
2083 But they may need to close over variables we have
2084 not cloned yet. So we will have to do a second
2085 pass. Furthermore, there may be state subs clos-
2086 ing over other state subs’ entries, so we have
2087 to put a stub here and then clone into it on the
2089 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2090 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2092 sv = newSV_type(SVt_PVCV);
2094 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2097 /* Just provide a stub, but name it. It will be
2098 upgrade to the real thing on scope entry. */
2099 sv = newSV_type(SVt_PVCV);
2102 share_hek(SvPVX_const(namesv)+1,
2104 * (SvUTF8(namesv) ? -1 : 1),
2108 else sv = SvREFCNT_inc(ppad[ix]);
2109 else if (sigil == '@')
2110 sv = MUTABLE_SV(newAV());
2111 else if (sigil == '%')
2112 sv = MUTABLE_SV(newHV());
2116 /* reset the 'assign only once' flag on each state var */
2117 if (sigil != '&' && SvPAD_STATE(namesv))
2121 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2122 sv = SvREFCNT_inc_NN(ppad[ix]);
2132 for (ix = fpad; ix > 0; ix--) {
2133 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2134 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2135 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2136 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2139 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2144 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2147 const bool newcv = !cv;
2149 assert(!CvUNIQUE(proto));
2151 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2152 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2156 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2159 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2160 else CvGV_set(cv,CvGV(proto));
2161 CvSTASH_set(cv, CvSTASH(proto));
2163 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2165 CvSTART(cv) = CvSTART(proto);
2166 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2169 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2171 SvUTF8_on(MUTABLE_SV(cv));
2174 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2176 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2179 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2180 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2181 cv_dump(proto, "Proto");
2189 Perl_cv_clone(pTHX_ CV *proto)
2191 PERL_ARGS_ASSERT_CV_CLONE;
2193 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2194 return S_cv_clone(aTHX_ proto, NULL, NULL);
2197 /* Called only by pp_clonecv */
2199 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2201 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2203 return S_cv_clone(aTHX_ proto, target, NULL);
2207 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2209 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2210 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2211 moved to a pre-existing CV struct.
2217 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2221 AV * const comppad_name = PadlistARRAY(padlist)[0];
2222 AV * const comppad = PadlistARRAY(padlist)[1];
2223 SV ** const namepad = AvARRAY(comppad_name);
2224 SV ** const curpad = AvARRAY(comppad);
2226 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2227 PERL_UNUSED_ARG(old_cv);
2229 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2230 const SV * const namesv = namepad[ix];
2231 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2232 && *SvPVX_const(namesv) == '&')
2234 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2236 SvMAGICAL(curpad[ix])
2237 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2239 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2240 if (CvOUTSIDE(innercv) == old_cv) {
2241 if (!CvWEAKOUTSIDE(innercv)) {
2242 SvREFCNT_dec(old_cv);
2243 SvREFCNT_inc_simple_void_NN(new_cv);
2245 CvOUTSIDE(innercv) = new_cv;
2248 else { /* format reference */
2249 SV * const rv = curpad[ix];
2251 if (!SvOK(rv)) continue;
2253 assert(SvWEAKREF(rv));
2254 innercv = (CV *)SvRV(rv);
2255 assert(!CvWEAKOUTSIDE(innercv));
2256 SvREFCNT_dec(CvOUTSIDE(innercv));
2257 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2264 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2266 Push a new pad frame onto the padlist, unless there's already a pad at
2267 this depth, in which case don't bother creating a new one. Then give
2268 the new pad an @_ in slot zero.
2274 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2278 PERL_ARGS_ASSERT_PAD_PUSH;
2280 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2281 PAD** const svp = PadlistARRAY(padlist);
2282 AV* const newpad = newAV();
2283 SV** const oldpad = AvARRAY(svp[depth-1]);
2284 I32 ix = AvFILLp((const AV *)svp[1]);
2285 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2286 SV** const names = AvARRAY(svp[0]);
2289 for ( ;ix > 0; ix--) {
2290 if (names_fill >= ix && PadnameLEN(names[ix])) {
2291 const char sigil = SvPVX_const(names[ix])[0];
2292 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2293 || (SvFLAGS(names[ix]) & SVpad_STATE)
2296 /* outer lexical or anon code */
2297 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2299 else { /* our own lexical */
2302 sv = MUTABLE_SV(newAV());
2303 else if (sigil == '%')
2304 sv = MUTABLE_SV(newHV());
2307 av_store(newpad, ix, sv);
2311 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2312 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2315 /* save temporaries on recursion? */
2316 SV * const sv = newSV(0);
2317 av_store(newpad, ix, sv);
2322 av_store(newpad, 0, MUTABLE_SV(av));
2325 padlist_store(padlist, depth, newpad);
2330 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2332 Looks up the type of the lexical variable at position I<po> in the
2333 currently-compiling pad. If the variable is typed, the stash of the
2334 class to which it is typed is returned. If not, C<NULL> is returned.
2340 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2343 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2344 if ( SvPAD_TYPED(*av) ) {
2345 return SvSTASH(*av);
2350 #if defined(USE_ITHREADS)
2352 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2355 =for apidoc padlist_dup
2363 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2369 PERL_ARGS_ASSERT_PADLIST_DUP;
2374 cloneall = param->flags & CLONEf_COPY_STACKS
2375 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2376 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2378 max = cloneall ? PadlistMAX(srcpad) : 1;
2380 Newx(dstpad, 1, PADLIST);
2381 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2382 PadlistMAX(dstpad) = max;
2383 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2387 for (depth = 0; depth <= max; ++depth)
2388 PadlistARRAY(dstpad)[depth] =
2389 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2391 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2392 to build anything other than the first level of pads. */
2393 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2395 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2396 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2397 SV **oldpad = AvARRAY(srcpad1);
2402 PadlistARRAY(dstpad)[0] =
2403 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2404 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2408 av_extend(pad1, ix);
2409 PadlistARRAY(dstpad)[1] = pad1;
2410 pad1a = AvARRAY(pad1);
2415 for ( ;ix > 0; ix--) {
2418 } else if (names_fill >= ix && PadnameLEN(names[ix])) {
2419 const char sigil = SvPVX_const(names[ix])[0];
2420 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2421 || (SvFLAGS(names[ix]) & SVpad_STATE)
2424 /* outer lexical or anon code */
2425 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2427 else { /* our own lexical */
2428 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2429 /* This is a work around for how the current
2430 implementation of ?{ } blocks in regexps
2431 interacts with lexicals. */
2432 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2437 sv = MUTABLE_SV(newAV());
2438 else if (sigil == '%')
2439 sv = MUTABLE_SV(newHV());
2447 else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
2448 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2451 /* save temporaries on recursion? */
2452 SV * const sv = newSV(0);
2455 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2456 FIXTHAT before merging this branch.
2457 (And I know how to) */
2458 if (SvPADMY(oldpad[ix]))
2466 args = newAV(); /* Will be @_ */
2468 pad1a[0] = (SV *)args;
2476 #endif /* USE_ITHREADS */
2479 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2483 SSize_t const oldmax = PadlistMAX(padlist);
2485 PERL_ARGS_ASSERT_PADLIST_STORE;
2489 if (key > PadlistMAX(padlist)) {
2490 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2491 (SV ***)&PadlistARRAY(padlist),
2492 (SV ***)&PadlistARRAY(padlist));
2493 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2496 ary = PadlistARRAY(padlist);
2497 SvREFCNT_dec(ary[key]);
2504 * c-indentation-style: bsd
2506 * indent-tabs-mode: nil
2509 * ex: set ts=8 sts=4 sw=4 et: