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 av_store(pad, 0, NULL);
287 /* Most subroutines never recurse, hence only need 2 entries in the padlist
288 array - names, and depth=1. The default for av_store() is to allocate
289 0..3, and even an explicit call to av_extend() with <3 will be rounded
290 up, so we inline the allocation of the array here. */
292 PadlistMAX(padlist) = 1;
293 PadlistARRAY(padlist) = ary;
297 /* ... then update state variables */
300 PL_curpad = AvARRAY(pad);
302 if (! (flags & padnew_CLONE)) {
303 PL_comppad_name = padname;
304 PL_comppad_name_fill = 0;
305 PL_min_intro_pending = 0;
310 DEBUG_X(PerlIO_printf(Perl_debug_log,
311 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
312 " name=0x%"UVxf" flags=0x%"UVxf"\n",
313 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
314 PTR2UV(padname), (UV)flags
318 return (PADLIST*)padlist;
323 =head1 Embedding Functions
327 Clear out all the active components of a CV. This can happen either
328 by an explicit C<undef &foo>, or by the reference count going to zero.
329 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
330 children can still follow the full lexical scope chain.
336 Perl_cv_undef(pTHX_ CV *cv)
339 const PADLIST *padlist = CvPADLIST(cv);
340 bool const slabbed = !!CvSLABBED(cv);
342 PERL_ARGS_ASSERT_CV_UNDEF;
344 DEBUG_X(PerlIO_printf(Perl_debug_log,
345 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
346 PTR2UV(cv), PTR2UV(PL_comppad))
349 if (CvFILE(cv) && CvDYNFILE(cv)) {
350 Safefree(CvFILE(cv));
355 if (!CvISXSUB(cv) && CvROOT(cv)) {
356 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
357 Perl_croak(aTHX_ "Can't undef active subroutine");
360 PAD_SAVE_SETNULLPAD();
362 if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
368 else if (slabbed && CvSTART(cv)) {
370 PAD_SAVE_SETNULLPAD();
372 /* discard any leaked ops */
374 parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv));
375 opslab_force_free((OPSLAB *)CvSTART(cv));
381 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
383 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
384 sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
385 if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
386 else CvGV_set(cv, NULL);
388 /* This statement and the subsequence if block was pad_undef(). */
389 pad_peg("pad_undef");
394 /* Free the padlist associated with a CV.
395 If parts of it happen to be current, we null the relevant PL_*pad*
396 global vars so that we don't have any dangling references left.
397 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
398 subs to the outer of this cv. */
400 DEBUG_X(PerlIO_printf(Perl_debug_log,
401 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
402 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
405 /* detach any '&' anon children in the pad; if afterwards they
406 * are still live, fix up their CvOUTSIDEs to point to our outside,
408 /* XXX DAPM for efficiency, we should only do this if we know we have
409 * children, or integrate this loop with general cleanup */
411 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
412 CV * const outercv = CvOUTSIDE(cv);
413 const U32 seq = CvOUTSIDE_SEQ(cv);
414 PAD * const comppad_name = PadlistARRAY(padlist)[0];
415 SV ** const namepad = AvARRAY(comppad_name);
416 PAD * const comppad = PadlistARRAY(padlist)[1];
417 SV ** const curpad = AvARRAY(comppad);
418 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
419 SV * const namesv = namepad[ix];
420 if (namesv && namesv != &PL_sv_undef
421 && *SvPVX_const(namesv) == '&')
423 CV * const innercv = MUTABLE_CV(curpad[ix]);
424 U32 inner_rc = SvREFCNT(innercv);
426 assert(SvTYPE(innercv) != SVt_PVFM);
428 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
430 SvREFCNT_dec(innercv);
434 /* in use, not just a prototype */
435 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
436 assert(CvWEAKOUTSIDE(innercv));
437 /* don't relink to grandfather if he's being freed */
438 if (outercv && SvREFCNT(outercv)) {
439 CvWEAKOUTSIDE_off(innercv);
440 CvOUTSIDE(innercv) = outercv;
441 CvOUTSIDE_SEQ(innercv) = seq;
442 SvREFCNT_inc_simple_void_NN(outercv);
445 CvOUTSIDE(innercv) = NULL;
452 ix = PadlistMAX(padlist);
454 PAD * const sv = PadlistARRAY(padlist)[ix--];
456 if (sv == PL_comppad) {
464 PAD * const sv = PadlistARRAY(padlist)[0];
465 if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
466 PL_comppad_name = NULL;
469 if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
471 CvPADLIST(cv) = NULL;
475 /* remove CvOUTSIDE unless this is an undef rather than a free */
476 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
477 if (!CvWEAKOUTSIDE(cv))
478 SvREFCNT_dec(CvOUTSIDE(cv));
479 CvOUTSIDE(cv) = NULL;
482 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
485 if (CvISXSUB(cv) && CvXSUB(cv)) {
488 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
489 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
490 * to choose an error message */
491 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
495 =for apidoc cv_forget_slab
497 When a CV has a reference count on its slab (CvSLABBED), it is responsible
498 for making sure it is freed. (Hence, no two CVs should ever have a
499 reference count on the same slab.) The CV only needs to reference the slab
500 during compilation. Once it is compiled and CvROOT attached, it has
501 finished its job, so it can forget the slab.
507 Perl_cv_forget_slab(pTHX_ CV *cv)
509 const bool slabbed = !!CvSLABBED(cv);
512 PERL_ARGS_ASSERT_CV_FORGET_SLAB;
514 if (!slabbed) return;
518 if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
519 else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
521 else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
525 #ifdef PERL_DEBUG_READONLY_OPS
526 const size_t refcnt = slab->opslab_refcnt;
528 OpslabREFCNT_dec(slab);
529 #ifdef PERL_DEBUG_READONLY_OPS
530 if (refcnt > 1) Slab_to_ro(slab);
536 =for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
538 Allocates a place in the currently-compiling
539 pad (via L<perlapi/pad_alloc>) and
540 then stores a name for that entry. I<namesv> is adopted and becomes the
541 name entry; it must already contain the name string and be sufficiently
542 upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
543 added to I<namesv>. None of the other
544 processing of L<perlapi/pad_add_name_pvn>
545 is done. Returns the offset of the allocated pad slot.
551 S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
554 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
556 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
558 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
561 assert(SvTYPE(namesv) == SVt_PVMG);
562 SvPAD_TYPED_on(namesv);
563 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
566 SvPAD_OUR_on(namesv);
567 SvOURSTASH_set(namesv, ourstash);
568 SvREFCNT_inc_simple_void_NN(ourstash);
570 else if (flags & padadd_STATE) {
571 SvPAD_STATE_on(namesv);
574 av_store(PL_comppad_name, offset, namesv);
579 =for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
581 Allocates a place in the currently-compiling pad for a named lexical
582 variable. Stores the name and other metadata in the name part of the
583 pad, and makes preparations to manage the variable's lexical scoping.
584 Returns the offset of the allocated pad slot.
586 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
587 If I<typestash> is non-null, the name is for a typed lexical, and this
588 identifies the type. If I<ourstash> is non-null, it's a lexical reference
589 to a package variable, and this identifies the package. The following
590 flags can be OR'ed together:
592 padadd_OUR redundantly specifies if it's a package var
593 padadd_STATE variable will retain value persistently
594 padadd_NO_DUP_CHECK skip check for lexical shadowing
600 Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
601 U32 flags, HV *typestash, HV *ourstash)
608 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
610 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
611 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
614 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
616 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
617 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
620 sv_setpvn(namesv, namepv, namelen);
623 flags |= padadd_UTF8_NAME;
627 flags &= ~padadd_UTF8_NAME;
629 if ((flags & padadd_NO_DUP_CHECK) == 0) {
631 SAVEFREESV(namesv); /* in case of fatal warnings */
632 /* check for duplicate declaration */
633 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
634 SvREFCNT_inc_simple_void_NN(namesv);
638 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
640 /* not yet introduced */
641 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
642 COP_SEQ_RANGE_HIGH_set(namesv, 0);
644 if (!PL_min_intro_pending)
645 PL_min_intro_pending = offset;
646 PL_max_intro_pending = offset;
647 /* if it's not a simple scalar, replace with an AV or HV */
648 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
649 assert(SvREFCNT(PL_curpad[offset]) == 1);
650 if (namelen != 0 && *namepv == '@')
651 sv_upgrade(PL_curpad[offset], SVt_PVAV);
652 else if (namelen != 0 && *namepv == '%')
653 sv_upgrade(PL_curpad[offset], SVt_PVHV);
654 else if (namelen != 0 && *namepv == '&')
655 sv_upgrade(PL_curpad[offset], SVt_PVCV);
656 assert(SvPADMY(PL_curpad[offset]));
657 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
658 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
659 (long)offset, SvPVX(namesv),
660 PTR2UV(PL_curpad[offset])));
666 =for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
668 Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
669 instead of a string/length pair.
675 Perl_pad_add_name_pv(pTHX_ const char *name,
676 const U32 flags, HV *typestash, HV *ourstash)
678 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
679 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
683 =for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
685 Exactly like L</pad_add_name_pvn>, but takes the name string in the form
686 of an SV instead of a string/length pair.
692 Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
696 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
697 namepv = SvPV(name, namelen);
699 flags |= padadd_UTF8_NAME;
700 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
704 =for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
706 Allocates a place in the currently-compiling pad,
707 returning the offset of the allocated pad slot.
708 No name is initially attached to the pad slot.
709 I<tmptype> is a set of flags indicating the kind of pad entry required,
710 which will be set in the value SV for the allocated pad entry:
712 SVs_PADMY named lexical variable ("my", "our", "state")
713 SVs_PADTMP unnamed temporary store
715 I<optype> should be an opcode indicating the type of operation that the
716 pad entry is to support. This doesn't affect operational semantics,
717 but is used for debugging.
722 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
723 * or at least rationalise ??? */
726 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
732 PERL_UNUSED_ARG(optype);
733 ASSERT_CURPAD_ACTIVE("pad_alloc");
735 if (AvARRAY(PL_comppad) != PL_curpad)
736 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
737 AvARRAY(PL_comppad), PL_curpad);
738 if (PL_pad_reset_pending)
740 if (tmptype & SVs_PADMY) {
741 /* For a my, simply push a null SV onto the end of PL_comppad. */
742 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
743 retval = AvFILLp(PL_comppad);
746 /* For a tmp, scan the pad from PL_padix upwards
747 * for a slot which has no name and no active value.
749 SV * const * const names = AvARRAY(PL_comppad_name);
750 const SSize_t names_fill = AvFILLp(PL_comppad_name);
753 * "foreach" index vars temporarily become aliases to non-"my"
754 * values. Thus we must skip, not just pad values that are
755 * marked as current pad values, but also those with names.
757 /* HVDS why copy to sv here? we don't seem to use it */
758 if (++PL_padix <= names_fill &&
759 (sv = names[PL_padix]) && sv != &PL_sv_undef)
761 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
762 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
763 !IS_PADGV(sv) && !IS_PADCONST(sv))
768 SvFLAGS(sv) |= tmptype;
769 PL_curpad = AvARRAY(PL_comppad);
771 DEBUG_X(PerlIO_printf(Perl_debug_log,
772 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
773 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
774 PL_op_name[optype]));
775 #ifdef DEBUG_LEAKING_SCALARS
776 sv->sv_debug_optype = optype;
777 sv->sv_debug_inpad = 1;
779 return (PADOFFSET)retval;
783 =for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
785 Allocates a place in the currently-compiling pad (via L</pad_alloc>)
786 for an anonymous function that is lexically scoped inside the
787 currently-compiling function.
788 The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
789 to the outer scope is weakened to avoid a reference loop.
791 One reference count is stolen, so you may need to do C<SvREFCNT_inc(func)>.
793 I<optype> should be an opcode indicating the type of operation that the
794 pad entry is to support. This doesn't affect operational semantics,
795 but is used for debugging.
801 Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
805 SV* const name = newSV_type(SVt_PVNV);
807 PERL_ARGS_ASSERT_PAD_ADD_ANON;
810 sv_setpvs(name, "&");
811 /* These two aren't used; just make sure they're not equal to
812 * PERL_PADSEQ_INTRO */
813 COP_SEQ_RANGE_LOW_set(name, 0);
814 COP_SEQ_RANGE_HIGH_set(name, 0);
815 ix = pad_alloc(optype, SVs_PADMY);
816 av_store(PL_comppad_name, ix, name);
817 /* XXX DAPM use PL_curpad[] ? */
818 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
819 av_store(PL_comppad, ix, (SV*)func);
821 SV *rv = newRV_noinc((SV *)func);
823 assert (SvTYPE(func) == SVt_PVFM);
824 av_store(PL_comppad, ix, rv);
826 SvPADMY_on((SV*)func);
828 /* to avoid ref loops, we never have parent + child referencing each
829 * other simultaneously */
830 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
831 assert(!CvWEAKOUTSIDE(func));
832 CvWEAKOUTSIDE_on(func);
833 SvREFCNT_dec(CvOUTSIDE(func));
839 =for apidoc pad_check_dup
841 Check for duplicate declarations: report any of:
843 * a my in the current scope with the same name;
844 * an our (anywhere in the pad) with the same name and the
845 same stash as C<ourstash>
847 C<is_our> indicates that the name to check is an 'our' declaration.
853 S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
858 const U32 is_our = flags & padadd_OUR;
860 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
862 ASSERT_CURPAD_ACTIVE("pad_check_dup");
864 assert((flags & ~padadd_OUR) == 0);
866 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
867 return; /* nothing to check */
869 svp = AvARRAY(PL_comppad_name);
870 top = AvFILLp(PL_comppad_name);
871 /* check the current scope */
872 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
874 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
875 SV * const sv = svp[off];
877 && sv != &PL_sv_undef
879 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
880 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
883 if (is_our && (SvPAD_OUR(sv)))
884 break; /* "our" masking "our" */
885 /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
886 Perl_warner(aTHX_ packWARN(WARN_MISC),
887 "\"%s\" %s %"SVf" masks earlier declaration in same %s",
888 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
889 *SvPVX(sv) == '&' ? "subroutine" : "variable",
891 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
892 ? "scope" : "statement"));
897 /* check the rest of the pad */
900 SV * const sv = svp[off];
902 && sv != &PL_sv_undef
904 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
905 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
906 && SvOURSTASH(sv) == ourstash
909 Perl_warner(aTHX_ packWARN(WARN_MISC),
910 "\"our\" variable %"SVf" redeclared", sv);
911 if ((I32)off <= PL_comppad_name_floor)
912 Perl_warner(aTHX_ packWARN(WARN_MISC),
913 "\t(Did you mean \"local\" instead of \"our\"?)\n");
923 =for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
925 Given the name of a lexical variable, find its position in the
926 currently-compiling pad.
927 I<namepv>/I<namelen> specify the variable's name, including leading sigil.
928 I<flags> is reserved and must be zero.
929 If it is not in the current pad but appears in the pad of any lexically
930 enclosing scope, then a pseudo-entry for it is added in the current pad.
931 Returns the offset in the current pad,
932 or C<NOT_IN_PAD> if no such lexical is in scope.
938 Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
947 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
949 pad_peg("pad_findmy_pvn");
951 if (flags & ~padadd_UTF8_NAME)
952 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
955 if (flags & padadd_UTF8_NAME) {
957 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
960 flags |= padadd_UTF8_NAME;
962 flags &= ~padadd_UTF8_NAME;
965 offset = pad_findlex(namepv, namelen, flags,
966 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
967 if ((PADOFFSET)offset != NOT_IN_PAD)
970 /* look for an our that's being introduced; this allows
971 * our $foo = 0 unless defined $foo;
972 * to not give a warning. (Yes, this is a hack) */
974 nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0];
975 name_svp = AvARRAY(nameav);
976 for (offset = AvFILLp(nameav); offset > 0; offset--) {
977 const SV * const namesv = name_svp[offset];
978 if (namesv && namesv != &PL_sv_undef
980 && (SvPAD_OUR(namesv))
981 && SvCUR(namesv) == namelen
982 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
983 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
984 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
992 =for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
994 Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
995 instead of a string/length pair.
1001 Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
1003 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
1004 return pad_findmy_pvn(name, strlen(name), flags);
1008 =for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
1010 Exactly like L</pad_findmy_pvn>, but takes the name string in the form
1011 of an SV instead of a string/length pair.
1017 Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
1021 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
1022 namepv = SvPV(name, namelen);
1024 flags |= padadd_UTF8_NAME;
1025 return pad_findmy_pvn(namepv, namelen, flags);
1029 =for apidoc Amp|PADOFFSET|find_rundefsvoffset
1031 Find the position of the lexical C<$_> in the pad of the
1032 currently-executing function. Returns the offset in the current pad,
1033 or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
1034 the global one should be used instead).
1035 L</find_rundefsv> is likely to be more convenient.
1041 Perl_find_rundefsvoffset(pTHX)
1046 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1047 NULL, &out_sv, &out_flags);
1051 =for apidoc Am|SV *|find_rundefsv
1053 Find and return the variable that is named C<$_> in the lexical scope
1054 of the currently-executing function. This may be a lexical C<$_>,
1055 or will otherwise be the global one.
1061 Perl_find_rundefsv(pTHX)
1067 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
1068 NULL, &namesv, &flags);
1070 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1077 Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1083 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1085 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1086 NULL, &namesv, &flags);
1088 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1091 return AvARRAY(PadlistARRAY(CvPADLIST(cv))[CvDEPTH(cv)])[po];
1095 =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
1097 Find a named lexical anywhere in a chain of nested pads. Add fake entries
1098 in the inner pads if it's found in an outer one.
1100 Returns the offset in the bottom pad of the lex or the fake lex.
1101 cv is the CV in which to start the search, and seq is the current cop_seq
1102 to match against. If warn is true, print appropriate warnings. The out_*
1103 vars return values, and so are pointers to where the returned values
1104 should be stored. out_capture, if non-null, requests that the innermost
1105 instance of the lexical is captured; out_name_sv is set to the innermost
1106 matched namesv or fake namesv; out_flags returns the flags normally
1107 associated with the IVX field of a fake namesv.
1109 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1110 then comes back down, adding fake entries as it goes. It has to be this way
1111 because fake namesvs in anon protoypes have to store in xlow the index into
1117 /* the CV has finished being compiled. This is not a sufficient test for
1118 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1119 #define CvCOMPILED(cv) CvROOT(cv)
1121 /* the CV does late binding of its lexicals */
1122 #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM)
1125 S_unavailable(pTHX_ SV *namesv)
1127 /* diag_listed_as: Variable "%s" is not available */
1128 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
1129 "%se \"%"SVf"\" is not available",
1130 *SvPVX_const(namesv) == '&'
1137 S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
1138 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
1141 I32 offset, new_offset;
1144 const PADLIST * const padlist = CvPADLIST(cv);
1145 const bool staleok = !!(flags & padadd_STALEOK);
1147 PERL_ARGS_ASSERT_PAD_FINDLEX;
1149 if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
1150 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1152 flags &= ~ padadd_STALEOK; /* one-shot flag */
1156 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1157 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
1158 PTR2UV(cv), (int)namelen, namepv, (int)seq,
1159 out_capture ? " capturing" : "" ));
1161 /* first, search this pad */
1163 if (padlist) { /* not an undef CV */
1164 I32 fake_offset = 0;
1165 const AV * const nameav = PadlistARRAY(padlist)[0];
1166 SV * const * const name_svp = AvARRAY(nameav);
1168 for (offset = AvFILLp(nameav); offset > 0; offset--) {
1169 const SV * const namesv = name_svp[offset];
1170 if (namesv && namesv != &PL_sv_undef
1171 && SvCUR(namesv) == namelen
1172 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1173 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
1175 if (SvFAKE(namesv)) {
1176 fake_offset = offset; /* in case we don't find a real one */
1179 /* is seq within the range _LOW to _HIGH ?
1180 * This is complicated by the fact that PL_cop_seqmax
1181 * may have wrapped around at some point */
1182 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1183 continue; /* not yet introduced */
1185 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1186 /* in compiling scope */
1188 (seq > COP_SEQ_RANGE_LOW(namesv))
1189 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1190 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1195 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1197 ( seq > COP_SEQ_RANGE_LOW(namesv)
1198 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1200 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1201 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1207 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1208 if (offset > 0) { /* not fake */
1210 *out_name_sv = name_svp[offset]; /* return the namesv */
1212 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1213 * instances. For now, we just test !CvUNIQUE(cv), but
1214 * ideally, we should detect my's declared within loops
1215 * etc - this would allow a wider range of 'not stayed
1216 * shared' warnings. We also treated already-compiled
1217 * lexes as not multi as viewed from evals. */
1219 *out_flags = CvANON(cv) ?
1221 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1222 ? PAD_FAKELEX_MULTI : 0;
1224 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1225 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1226 PTR2UV(cv), (long)offset,
1227 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1228 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
1230 else { /* fake match */
1231 offset = fake_offset;
1232 *out_name_sv = name_svp[offset]; /* return the namesv */
1233 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
1234 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1235 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
1236 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
1237 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
1241 /* return the lex? */
1246 if (SvPAD_OUR(*out_name_sv)) {
1247 *out_capture = NULL;
1251 /* trying to capture from an anon prototype? */
1253 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1254 : *out_flags & PAD_FAKELEX_ANON)
1258 newSVpvn_flags(namepv, namelen,
1260 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1262 *out_capture = NULL;
1268 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
1269 && !SvPAD_STATE(name_svp[offset])
1270 && warn && ckWARN(WARN_CLOSURE)) {
1272 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1273 "Variable \"%"SVf"\" will not stay shared",
1274 newSVpvn_flags(namepv, namelen,
1276 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1279 if (fake_offset && CvANON(cv)
1280 && CvCLONE(cv) &&!CvCLONED(cv))
1283 /* not yet caught - look further up */
1284 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1285 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1288 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
1290 newwarn, out_capture, out_name_sv, out_flags);
1295 *out_capture = AvARRAY(PadlistARRAY(padlist)[
1296 CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
1297 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1298 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
1299 PTR2UV(cv), PTR2UV(*out_capture)));
1301 if (SvPADSTALE(*out_capture)
1302 && (!CvDEPTH(cv) || !staleok)
1303 && !SvPAD_STATE(name_svp[offset]))
1306 newSVpvn_flags(namepv, namelen,
1308 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1309 *out_capture = NULL;
1312 if (!*out_capture) {
1313 if (namelen != 0 && *namepv == '@')
1314 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
1315 else if (namelen != 0 && *namepv == '%')
1316 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
1317 else if (namelen != 0 && *namepv == '&')
1318 *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
1320 *out_capture = sv_newmortal();
1328 /* it's not in this pad - try above */
1333 /* out_capture non-null means caller wants us to capture lex; in
1334 * addition we capture ourselves unless it's an ANON/format */
1335 new_capturep = out_capture ? out_capture :
1336 CvLATE(cv) ? NULL : &new_capture;
1338 offset = pad_findlex(namepv, namelen,
1339 flags | padadd_STALEOK*(new_capturep == &new_capture),
1340 CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
1341 new_capturep, out_name_sv, out_flags);
1342 if ((PADOFFSET)offset == NOT_IN_PAD)
1345 /* found in an outer CV. Add appropriate fake entry to this pad */
1347 /* don't add new fake entries (via eval) to CVs that we have already
1348 * finished compiling, or to undef CVs */
1349 if (CvCOMPILED(cv) || !padlist)
1350 return 0; /* this dummy (and invalid) value isnt used by the caller */
1353 /* This relies on sv_setsv_flags() upgrading the destination to the same
1354 type as the source, independent of the flags set, and on it being
1355 "good" and only copying flag bits and pointers that it understands.
1357 SV *new_namesv = newSVsv(*out_name_sv);
1358 AV * const ocomppad_name = PL_comppad_name;
1359 PAD * const ocomppad = PL_comppad;
1360 PL_comppad_name = PadlistARRAY(padlist)[0];
1361 PL_comppad = PadlistARRAY(padlist)[1];
1362 PL_curpad = AvARRAY(PL_comppad);
1365 = pad_alloc_name(new_namesv,
1366 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
1367 SvPAD_TYPED(*out_name_sv)
1368 ? SvSTASH(*out_name_sv) : NULL,
1369 SvOURSTASH(*out_name_sv)
1372 SvFAKE_on(new_namesv);
1373 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1374 "Pad addname: %ld \"%.*s\" FAKE\n",
1376 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
1377 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
1379 PARENT_PAD_INDEX_set(new_namesv, 0);
1380 if (SvPAD_OUR(new_namesv)) {
1381 NOOP; /* do nothing */
1383 else if (CvLATE(cv)) {
1384 /* delayed creation - just note the offset within parent pad */
1385 PARENT_PAD_INDEX_set(new_namesv, offset);
1389 /* immediate creation - capture outer value right now */
1390 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1391 /* But also note the offset, as newMYSUB needs it */
1392 PARENT_PAD_INDEX_set(new_namesv, offset);
1393 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1394 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1395 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1397 *out_name_sv = new_namesv;
1398 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1400 PL_comppad_name = ocomppad_name;
1401 PL_comppad = ocomppad;
1402 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1410 =for apidoc Am|SV *|pad_sv|PADOFFSET po
1412 Get the value at offset I<po> in the current (compiling or executing) pad.
1413 Use macro PAD_SV instead of calling this function directly.
1419 Perl_pad_sv(pTHX_ PADOFFSET po)
1422 ASSERT_CURPAD_ACTIVE("pad_sv");
1425 Perl_croak(aTHX_ "panic: pad_sv po");
1426 DEBUG_X(PerlIO_printf(Perl_debug_log,
1427 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
1428 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
1430 return PL_curpad[po];
1434 =for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
1436 Set the value at offset I<po> in the current (compiling or executing) pad.
1437 Use the macro PAD_SETSV() rather than calling this function directly.
1443 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1447 PERL_ARGS_ASSERT_PAD_SETSV;
1449 ASSERT_CURPAD_ACTIVE("pad_setsv");
1451 DEBUG_X(PerlIO_printf(Perl_debug_log,
1452 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
1453 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
1458 #endif /* DEBUGGING */
1461 =for apidoc m|void|pad_block_start|int full
1463 Update the pad compilation state variables on entry to a new block.
1468 /* XXX DAPM perhaps:
1469 * - integrate this in general state-saving routine ???
1470 * - combine with the state-saving going on in pad_new ???
1471 * - introduce a new SAVE type that does all this in one go ?
1475 Perl_pad_block_start(pTHX_ int full)
1478 ASSERT_CURPAD_ACTIVE("pad_block_start");
1479 SAVEI32(PL_comppad_name_floor);
1480 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1482 PL_comppad_name_fill = PL_comppad_name_floor;
1483 if (PL_comppad_name_floor < 0)
1484 PL_comppad_name_floor = 0;
1485 SAVEI32(PL_min_intro_pending);
1486 SAVEI32(PL_max_intro_pending);
1487 PL_min_intro_pending = 0;
1488 SAVEI32(PL_comppad_name_fill);
1489 SAVEI32(PL_padix_floor);
1490 PL_padix_floor = PL_padix;
1491 PL_pad_reset_pending = FALSE;
1495 =for apidoc m|U32|intro_my
1497 "Introduce" my variables to visible status. This is called during parsing
1498 at the end of each statement to make lexical variables visible to
1499 subsequent statements.
1512 ASSERT_CURPAD_ACTIVE("intro_my");
1513 if (! PL_min_intro_pending)
1514 return PL_cop_seqmax;
1516 svp = AvARRAY(PL_comppad_name);
1517 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
1518 SV * const sv = svp[i];
1520 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1521 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1523 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
1524 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
1525 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1526 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
1527 (long)i, SvPVX_const(sv),
1528 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1529 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1533 seq = PL_cop_seqmax;
1535 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1537 PL_min_intro_pending = 0;
1538 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1539 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1540 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
1546 =for apidoc m|void|pad_leavemy
1548 Cleanup at end of scope during compilation: set the max seq number for
1549 lexicals in this scope and warn of any lexicals that never got introduced.
1555 Perl_pad_leavemy(pTHX)
1560 SV * const * const svp = AvARRAY(PL_comppad_name);
1562 PL_pad_reset_pending = FALSE;
1564 ASSERT_CURPAD_ACTIVE("pad_leavemy");
1565 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1566 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
1567 const SV * const sv = svp[off];
1568 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1569 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1570 "%"SVf" never introduced",
1574 /* "Deintroduce" my variables that are leaving with this scope. */
1575 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
1576 SV * const sv = svp[off];
1577 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1578 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1580 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
1581 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1582 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
1583 (long)off, SvPVX_const(sv),
1584 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1585 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
1587 if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
1588 && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
1589 OP *kid = newOP(OP_INTROCV, 0);
1591 o = op_prepend_elem(OP_LINESEQ, kid, o);
1596 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1598 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1599 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1604 =for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
1606 Abandon the tmp in the current pad at offset po and replace with a
1613 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1616 ASSERT_CURPAD_LEGAL("pad_swipe");
1619 if (AvARRAY(PL_comppad) != PL_curpad)
1620 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1621 AvARRAY(PL_comppad), PL_curpad);
1622 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1623 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1624 (long)po, (long)AvFILLp(PL_comppad));
1626 DEBUG_X(PerlIO_printf(Perl_debug_log,
1627 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1628 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1631 SvPADTMP_off(PL_curpad[po]);
1633 SvREFCNT_dec(PL_curpad[po]);
1636 /* if pad tmps aren't shared between ops, then there's no need to
1637 * create a new tmp when an existing op is freed */
1638 #ifdef USE_BROKEN_PAD_RESET
1639 PL_curpad[po] = newSV(0);
1640 SvPADTMP_on(PL_curpad[po]);
1642 PL_curpad[po] = &PL_sv_undef;
1644 if ((I32)po < PL_padix)
1649 =for apidoc m|void|pad_reset
1651 Mark all the current temporaries for reuse
1656 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1657 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1658 * on the stack by OPs that use them, there are several ways to get an alias
1659 * to a shared TARG. Such an alias will change randomly and unpredictably.
1660 * We avoid doing this until we can think of a Better Way.
1666 #ifdef USE_BROKEN_PAD_RESET
1667 if (AvARRAY(PL_comppad) != PL_curpad)
1668 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1669 AvARRAY(PL_comppad), PL_curpad);
1671 DEBUG_X(PerlIO_printf(Perl_debug_log,
1672 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1673 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1674 (long)PL_padix, (long)PL_padix_floor
1678 if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */
1680 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1681 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1682 SvPADTMP_off(PL_curpad[po]);
1684 PL_padix = PL_padix_floor;
1687 PL_pad_reset_pending = FALSE;
1691 =for apidoc Amx|void|pad_tidy|padtidy_type type
1693 Tidy up a pad at the end of compilation of the code to which it belongs.
1694 Jobs performed here are: remove most stuff from the pads of anonsub
1695 prototypes; give it a @_; mark temporaries as such. I<type> indicates
1696 the kind of subroutine:
1698 padtidy_SUB ordinary subroutine
1699 padtidy_SUBCLONE prototype for lexical closure
1700 padtidy_FORMAT format
1705 /* XXX DAPM surely most of this stuff should be done properly
1706 * at the right time beforehand, rather than going around afterwards
1707 * cleaning up our mistakes ???
1711 Perl_pad_tidy(pTHX_ padtidy_type type)
1715 ASSERT_CURPAD_ACTIVE("pad_tidy");
1717 /* If this CV has had any 'eval-capable' ops planted in it
1718 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1719 * anon prototypes in the chain of CVs should be marked as cloneable,
1720 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1721 * the right CvOUTSIDE.
1722 * If running with -d, *any* sub may potentially have an eval
1723 * executed within it.
1726 if (PL_cv_has_eval || PL_perldb) {
1728 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1729 if (cv != PL_compcv && CvCOMPILED(cv))
1730 break; /* no need to mark already-compiled code */
1732 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1733 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1740 /* extend curpad to match namepad */
1741 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1742 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
1744 if (type == padtidy_SUBCLONE) {
1745 SV * const * const namep = AvARRAY(PL_comppad_name);
1748 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1751 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1754 * The only things that a clonable function needs in its
1755 * pad are anonymous subs.
1756 * The rest are created anew during cloning.
1758 if (!((namesv = namep[ix]) != NULL &&
1759 namesv != &PL_sv_undef &&
1760 *SvPVX_const(namesv) == '&'))
1762 SvREFCNT_dec(PL_curpad[ix]);
1763 PL_curpad[ix] = NULL;
1767 else if (type == padtidy_SUB) {
1768 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1769 AV * const av = newAV(); /* Will be @_ */
1770 av_store(PL_comppad, 0, MUTABLE_SV(av));
1774 if (type == padtidy_SUB || type == padtidy_FORMAT) {
1775 SV * const * const namep = AvARRAY(PL_comppad_name);
1777 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1778 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1780 if (!SvPADMY(PL_curpad[ix])) {
1781 SvPADTMP_on(PL_curpad[ix]);
1782 } else if (!SvFAKE(namep[ix])) {
1783 /* This is a work around for how the current implementation of
1784 ?{ } blocks in regexps interacts with lexicals.
1786 One of our lexicals.
1787 Can't do this on all lexicals, otherwise sub baz() won't
1796 because completion of compiling &bar calling pad_tidy()
1797 would cause (top level) $foo to be marked as stale, and
1798 "no longer available". */
1799 SvPADSTALE_on(PL_curpad[ix]);
1803 PL_curpad = AvARRAY(PL_comppad);
1807 =for apidoc m|void|pad_free|PADOFFSET po
1809 Free the SV at offset po in the current pad.
1814 /* XXX DAPM integrate with pad_swipe ???? */
1816 Perl_pad_free(pTHX_ PADOFFSET po)
1820 ASSERT_CURPAD_LEGAL("pad_free");
1823 if (AvARRAY(PL_comppad) != PL_curpad)
1824 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1825 AvARRAY(PL_comppad), PL_curpad);
1827 Perl_croak(aTHX_ "panic: pad_free po");
1829 DEBUG_X(PerlIO_printf(Perl_debug_log,
1830 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1831 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1836 if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
1837 SvFLAGS(sv) &= ~SVs_PADTMP;
1839 if ((I32)po < PL_padix)
1844 =for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
1846 Dump the contents of a padlist
1852 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1861 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1866 pad_name = *PadlistARRAY(padlist);
1867 pad = PadlistARRAY(padlist)[1];
1868 pname = AvARRAY(pad_name);
1869 ppad = AvARRAY(pad);
1870 Perl_dump_indent(aTHX_ level, file,
1871 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1872 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1875 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1876 const SV *namesv = pname[ix];
1877 if (namesv && namesv == &PL_sv_undef) {
1882 Perl_dump_indent(aTHX_ level+1, file,
1883 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
1886 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1887 SvPVX_const(namesv),
1888 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1889 (unsigned long)PARENT_PAD_INDEX(namesv)
1893 Perl_dump_indent(aTHX_ level+1, file,
1894 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
1897 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1898 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1899 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
1904 Perl_dump_indent(aTHX_ level+1, file,
1905 "%2d. 0x%"UVxf"<%lu>\n",
1908 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1917 =for apidoc m|void|cv_dump|CV *cv|const char *title
1919 dump the contents of a CV
1925 S_cv_dump(pTHX_ const CV *cv, const char *title)
1928 const CV * const outside = CvOUTSIDE(cv);
1929 PADLIST* const padlist = CvPADLIST(cv);
1931 PERL_ARGS_ASSERT_CV_DUMP;
1933 PerlIO_printf(Perl_debug_log,
1934 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1937 (CvANON(cv) ? "ANON"
1938 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1939 : (cv == PL_main_cv) ? "MAIN"
1940 : CvUNIQUE(cv) ? "UNIQUE"
1941 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1944 : CvANON(outside) ? "ANON"
1945 : (outside == PL_main_cv) ? "MAIN"
1946 : CvUNIQUE(outside) ? "UNIQUE"
1947 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1949 PerlIO_printf(Perl_debug_log,
1950 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1951 do_dump_pad(1, Perl_debug_log, padlist, 1);
1954 #endif /* DEBUGGING */
1957 =for apidoc Am|CV *|cv_clone|CV *proto
1959 Clone a CV, making a lexical closure. I<proto> supplies the prototype
1960 of the function: its code, pad structure, and other attributes.
1961 The prototype is combined with a capture of outer lexicals to which the
1962 code refers, which are taken from the currently-executing instance of
1963 the immediately surrounding code.
1968 static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
1971 S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
1975 PADLIST* const protopadlist = CvPADLIST(proto);
1976 PAD *const protopad_name = *PadlistARRAY(protopadlist);
1977 const PAD *const protopad = PadlistARRAY(protopadlist)[1];
1978 SV** const pname = AvARRAY(protopad_name);
1979 SV** const ppad = AvARRAY(protopad);
1980 const I32 fname = AvFILLp(protopad_name);
1981 const I32 fpad = AvFILLp(protopad);
1984 bool subclones = FALSE;
1986 assert(!CvUNIQUE(proto));
1988 /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not
1989 * reliable. The currently-running sub is always the one we need to
1991 * For my subs, the currently-running sub may not be the one we want.
1992 * We have to check whether it is a clone of CvOUTSIDE.
1993 * Note that in general for formats, CvOUTSIDE != find_runcv.
1994 * Since formats may be nested inside closures, CvOUTSIDE may point
1995 * to a prototype; we instead want the cloned parent who called us.
1999 if (CvWEAKOUTSIDE(proto))
2000 outside = find_runcv(NULL);
2002 outside = CvOUTSIDE(proto);
2003 if ((CvCLONE(outside) && ! CvCLONED(outside))
2004 || !CvPADLIST(outside)
2005 || PadlistNAMES(CvPADLIST(outside))
2006 != protopadlist->xpadl_outid) {
2007 outside = find_runcv_where(
2008 FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL
2010 /* outside could be null */
2014 depth = outside ? CvDEPTH(outside) : 0;
2019 SAVESPTR(PL_compcv);
2021 if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */
2024 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2026 SAVESPTR(PL_comppad_name);
2027 PL_comppad_name = protopad_name;
2028 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
2030 av_fill(PL_comppad, fpad);
2032 PL_curpad = AvARRAY(PL_comppad);
2034 outpad = outside && CvPADLIST(outside)
2035 ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
2038 CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside));
2040 for (ix = fpad; ix > 0; ix--) {
2041 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2043 if (namesv && namesv != &PL_sv_undef) { /* lexical */
2044 if (SvFAKE(namesv)) { /* lexical from outside? */
2045 /* formats may have an inactive, or even undefined, parent;
2046 but state vars are always available. */
2047 if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
2048 || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv)
2049 && (!outside || !CvDEPTH(outside))) ) {
2050 S_unavailable(aTHX_ namesv);
2054 SvREFCNT_inc_simple_void_NN(sv);
2057 const char sigil = SvPVX_const(namesv)[0];
2059 /* If there are state subs, we need to clone them, too.
2060 But they may need to close over variables we have
2061 not cloned yet. So we will have to do a second
2062 pass. Furthermore, there may be state subs clos-
2063 ing over other state subs’ entries, so we have
2064 to put a stub here and then clone into it on the
2066 if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
2067 assert(SvTYPE(ppad[ix]) == SVt_PVCV);
2069 sv = newSV_type(SVt_PVCV);
2071 else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
2074 /* Just provide a stub, but name it. It will be
2075 upgrade to the real thing on scope entry. */
2076 sv = newSV_type(SVt_PVCV);
2079 share_hek(SvPVX_const(namesv)+1,
2081 * (SvUTF8(namesv) ? -1 : 1),
2085 else sv = SvREFCNT_inc(ppad[ix]);
2086 else if (sigil == '@')
2087 sv = MUTABLE_SV(newAV());
2088 else if (sigil == '%')
2089 sv = MUTABLE_SV(newHV());
2093 /* reset the 'assign only once' flag on each state var */
2094 if (sigil != '&' && SvPAD_STATE(namesv))
2098 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
2099 sv = SvREFCNT_inc_NN(ppad[ix]);
2109 for (ix = fpad; ix > 0; ix--) {
2110 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
2111 if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
2112 && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
2113 S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv);
2116 if (newcv) SvREFCNT_inc_simple_void_NN(cv);
2121 S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
2124 const bool newcv = !cv;
2126 assert(!CvUNIQUE(proto));
2128 if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
2129 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
2133 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
2136 CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
2137 else CvGV_set(cv,CvGV(proto));
2138 CvSTASH_set(cv, CvSTASH(proto));
2140 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
2142 CvSTART(cv) = CvSTART(proto);
2143 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
2146 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
2148 mg_copy((SV *)proto, (SV *)cv, 0, 0);
2150 if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
2153 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
2154 if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
2155 cv_dump(proto, "Proto");
2160 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
2161 * The prototype was marked as a candiate for const-ization,
2162 * so try to grab the current const value, and if successful,
2163 * turn into a const sub:
2165 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
2168 /* For this calling case, op_const_sv returns a *copy*, which we
2169 donate to newCONSTSUB. Yes, this is ugly, and should be killed.
2170 Need to fix how lib/constant.pm works to eliminate this. */
2171 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
2182 Perl_cv_clone(pTHX_ CV *proto)
2184 PERL_ARGS_ASSERT_CV_CLONE;
2186 if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
2187 return S_cv_clone(aTHX_ proto, NULL, NULL);
2190 /* Called only by pp_clonecv */
2192 Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
2194 PERL_ARGS_ASSERT_CV_CLONE_INTO;
2196 return S_cv_clone(aTHX_ proto, target, NULL);
2200 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
2202 For any anon CVs in the pad, change CvOUTSIDE of that CV from
2203 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2204 moved to a pre-existing CV struct.
2210 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2214 AV * const comppad_name = PadlistARRAY(padlist)[0];
2215 AV * const comppad = PadlistARRAY(padlist)[1];
2216 SV ** const namepad = AvARRAY(comppad_name);
2217 SV ** const curpad = AvARRAY(comppad);
2219 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
2220 PERL_UNUSED_ARG(old_cv);
2222 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
2223 const SV * const namesv = namepad[ix];
2224 if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
2225 && *SvPVX_const(namesv) == '&')
2227 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
2229 SvMAGICAL(curpad[ix])
2230 ? mg_find(curpad[ix], PERL_MAGIC_proto)
2232 CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
2233 if (CvOUTSIDE(innercv) == old_cv) {
2234 if (!CvWEAKOUTSIDE(innercv)) {
2235 SvREFCNT_dec(old_cv);
2236 SvREFCNT_inc_simple_void_NN(new_cv);
2238 CvOUTSIDE(innercv) = new_cv;
2241 else { /* format reference */
2242 SV * const rv = curpad[ix];
2244 if (!SvOK(rv)) continue;
2246 assert(SvWEAKREF(rv));
2247 innercv = (CV *)SvRV(rv);
2248 assert(!CvWEAKOUTSIDE(innercv));
2249 SvREFCNT_dec(CvOUTSIDE(innercv));
2250 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2257 =for apidoc m|void|pad_push|PADLIST *padlist|int depth
2259 Push a new pad frame onto the padlist, unless there's already a pad at
2260 this depth, in which case don't bother creating a new one. Then give
2261 the new pad an @_ in slot zero.
2267 Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
2271 PERL_ARGS_ASSERT_PAD_PUSH;
2273 if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
2274 PAD** const svp = PadlistARRAY(padlist);
2275 AV* const newpad = newAV();
2276 SV** const oldpad = AvARRAY(svp[depth-1]);
2277 I32 ix = AvFILLp((const AV *)svp[1]);
2278 const I32 names_fill = AvFILLp((const AV *)svp[0]);
2279 SV** const names = AvARRAY(svp[0]);
2282 for ( ;ix > 0; ix--) {
2283 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2284 const char sigil = SvPVX_const(names[ix])[0];
2285 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2286 || (SvFLAGS(names[ix]) & SVpad_STATE)
2289 /* outer lexical or anon code */
2290 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2292 else { /* our own lexical */
2295 sv = MUTABLE_SV(newAV());
2296 else if (sigil == '%')
2297 sv = MUTABLE_SV(newHV());
2300 av_store(newpad, ix, sv);
2304 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2305 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
2308 /* save temporaries on recursion? */
2309 SV * const sv = newSV(0);
2310 av_store(newpad, ix, sv);
2315 av_store(newpad, 0, MUTABLE_SV(av));
2318 padlist_store(padlist, depth, newpad);
2323 =for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2325 Looks up the type of the lexical variable at position I<po> in the
2326 currently-compiling pad. If the variable is typed, the stash of the
2327 class to which it is typed is returned. If not, C<NULL> is returned.
2333 Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2336 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
2337 if ( SvPAD_TYPED(*av) ) {
2338 return SvSTASH(*av);
2343 #if defined(USE_ITHREADS)
2345 # define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2348 =for apidoc padlist_dup
2356 Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param)
2362 PERL_ARGS_ASSERT_PADLIST_DUP;
2367 cloneall = param->flags & CLONEf_COPY_STACKS
2368 || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
2369 assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
2371 max = cloneall ? PadlistMAX(srcpad) : 1;
2373 Newx(dstpad, 1, PADLIST);
2374 ptr_table_store(PL_ptr_table, srcpad, dstpad);
2375 PadlistMAX(dstpad) = max;
2376 Newx(PadlistARRAY(dstpad), max + 1, PAD *);
2380 for (depth = 0; depth <= max; ++depth)
2381 PadlistARRAY(dstpad)[depth] =
2382 av_dup_inc(PadlistARRAY(srcpad)[depth], param);
2384 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2385 to build anything other than the first level of pads. */
2386 I32 ix = AvFILLp(PadlistARRAY(srcpad)[1]);
2388 const I32 names_fill = AvFILLp(PadlistARRAY(srcpad)[0]);
2389 const PAD *const srcpad1 = PadlistARRAY(srcpad)[1];
2390 SV **oldpad = AvARRAY(srcpad1);
2395 PadlistARRAY(dstpad)[0] =
2396 av_dup_inc(PadlistARRAY(srcpad)[0], param);
2397 names = AvARRAY(PadlistARRAY(dstpad)[0]);
2401 av_extend(pad1, ix);
2402 PadlistARRAY(dstpad)[1] = pad1;
2403 pad1a = AvARRAY(pad1);
2408 for ( ;ix > 0; ix--) {
2411 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2412 const char sigil = SvPVX_const(names[ix])[0];
2413 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2414 || (SvFLAGS(names[ix]) & SVpad_STATE)
2417 /* outer lexical or anon code */
2418 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2420 else { /* our own lexical */
2421 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2422 /* This is a work around for how the current
2423 implementation of ?{ } blocks in regexps
2424 interacts with lexicals. */
2425 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2430 sv = MUTABLE_SV(newAV());
2431 else if (sigil == '%')
2432 sv = MUTABLE_SV(newHV());
2440 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2441 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2444 /* save temporaries on recursion? */
2445 SV * const sv = newSV(0);
2448 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2449 FIXTHAT before merging this branch.
2450 (And I know how to) */
2451 if (SvPADMY(oldpad[ix]))
2459 args = newAV(); /* Will be @_ */
2461 pad1a[0] = (SV *)args;
2469 #endif /* USE_ITHREADS */
2472 Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val)
2476 SSize_t const oldmax = PadlistMAX(padlist);
2478 PERL_ARGS_ASSERT_PADLIST_STORE;
2482 if (key > PadlistMAX(padlist)) {
2483 av_extend_guts(NULL,key,&PadlistMAX(padlist),
2484 (SV ***)&PadlistARRAY(padlist),
2485 (SV ***)&PadlistARRAY(padlist));
2486 Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax,
2489 ary = PadlistARRAY(padlist);
2490 SvREFCNT_dec(ary[key]);
2497 * c-indentation-style: bsd
2499 * indent-tabs-mode: nil
2502 * ex: set ts=8 sts=4 sw=4 et: