/*
=head1 Pad Data Structures
-This file contains the functions that create and manipulate scratchpads,
-which are array-of-array data structures attached to a CV (ie a sub)
-and which store lexical variables and opcode temporary and per-thread
-values.
+=for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
-=for apidoc m|AV *|CvPADLIST|CV *cv
-CV's can have CvPADLIST(cv) set to point to an AV.
+CV's can have CvPADLIST(cv) set to point to an AV. This is the CV's
+scratchpad, which stores lexical variables and opcode temporary and
+per-thread values.
For these purposes "forms" are a kind-of CV, eval""s are too (except they're
not callable at will and are always thrown away after the eval"" is done
but that is really the callers pad (a slot of which is allocated by
every entersub).
-The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
-is managed "manual" (mostly in pad.c) rather than normal av.c rules.
+The CvPADLIST AV has the REFCNT of its component items managed "manually"
+(mostly in pad.c) rather than by normal av.c rules. So we turn off AvREAL
+just before freeing it, to let av.c know not to touch the entries.
The items in the AV are not SVs as for a normal AV, but other AVs:
0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
The 0'th slot of a frame AV is an AV which is @_.
other entries are storage for variables and op targets.
-During compilation:
-C<PL_comppad_name> is set to the names AV.
-C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
-C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
-
-During execution, C<PL_comppad> and C<PL_curpad> refer to the live
-frame of the currently executing sub.
-
Iterating over the names AV iterates over all possible pad
items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
&PL_sv_undef "names" (see pad_alloc()).
The SVs in the names AV have their PV being the name of the variable.
xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
-which the name is valid. For typed lexicals name SV is SVt_PVMG and SvSTASH
+which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
+_HIGH). During compilation, these fields may hold the special value
+PERL_PADSEQ_INTRO to indicate various stages:
+
+ COP_SEQ_RANGE_LOW _HIGH
+ ----------------- -----
+ PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
+ valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
+ valid-seq# valid-seq# compilation of scope complete: { my ($x) }
+
+For typed lexicals name SV is SVt_PVMG and SvSTASH
points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
SvOURSTASH slot pointing at the stash of the associated global (so that
duplicate C<our> declarations in the same package can be detected). SvUVX is
For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
+=for apidoc AmxU|AV *|PL_comppad_name
+
+During compilation, this points to the array containing the names part
+of the pad for the currently-compiling code.
+
+=for apidoc AmxU|AV *|PL_comppad
+
+During compilation, this points to the array containing the values
+part of the pad for the currently-compiling code. (At runtime a CV may
+have many such value arrays; at compile time just one is constructed.)
+At runtime, this points to the array containing the currently-relevant
+values for the pad for the currently-executing code.
+
+=for apidoc AmxU|SV **|PL_curpad
+
+Points directly to the body of the L</PL_comppad> array.
+(I.e., this is C<AvARRAY(PL_comppad)>.)
+
=cut
*/
#define PARENT_FAKELEX_FLAGS_set(sv,val) \
STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
-#define PAD_MAX I32_MAX
+/*
+=for apidoc mx|void|pad_peg|const char *s
+
+When PERL_MAD is enabled, this is a small no-op function that gets called
+at the start of each pad-related function. It can be breakpointed to
+track all pad operations. The parameter is a string indicating the type
+of pad operation being performed.
+
+=cut
+*/
#ifdef PERL_MAD
void pad_peg(const char* s) {
#endif
/*
-=for apidoc pad_new
+This is basically sv_eq_flags() in sv.c, but we avoid the magic
+and bytes checking.
+*/
-Create a new compiling padlist, saving and updating the various global
-vars at the same time as creating the pad itself. The following flags
-can be OR'ed together:
+static bool
+sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
+ if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
+ const char *pv1 = SvPVX_const(sv);
+ STRLEN cur1 = SvCUR(sv);
+ const char *pv2 = pv;
+ STRLEN cur2 = pvlen;
+ if (PL_encoding) {
+ SV* svrecode = NULL;
+ if (SvUTF8(sv)) {
+ svrecode = newSVpvn(pv2, cur2);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv2 = SvPV_const(svrecode, cur2);
+ }
+ else {
+ svrecode = newSVpvn(pv1, cur1);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv1 = SvPV_const(svrecode, cur1);
+ }
+ SvREFCNT_dec(svrecode);
+ }
+ if (flags & SVf_UTF8)
+ return (bytes_cmp_utf8(
+ (const U8*)pv1, cur1,
+ (const U8*)pv2, cur2) == 0);
+ else
+ return (bytes_cmp_utf8(
+ (const U8*)pv2, cur2,
+ (const U8*)pv1, cur1) == 0);
+ }
+ else
+ return ((SvPVX_const(sv) == pv)
+ || memEQ(SvPVX_const(sv), pv, pvlen));
+}
+
+
+/*
+=for apidoc Am|PADLIST *|pad_new|int flags
+
+Create a new padlist, updating the global variables for the
+currently-compiling padlist to point to the new padlist. The following
+flags can be OR'ed together:
padnew_CLONE this pad is for a cloned CV
- padnew_SAVE save old globals
+ padnew_SAVE save old globals on the save stack
padnew_SAVESUB also save extra stuff for start of sub
=cut
av_store(pad, 0, NULL);
}
- AvREAL_off(padlist);
/* Most subroutines never recurse, hence only need 2 entries in the padlist
array - names, and depth=1. The default for av_store() is to allocate
0..3, and even an explicit call to av_extend() with <3 will be rounded
PTR2UV(cv), PTR2UV(PL_comppad))
);
-#ifdef USE_ITHREADS
- if (CvFILE(cv) && !CvISXSUB(cv)) {
- /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
}
CvFILE(cv) = NULL;
-#endif
if (!CvISXSUB(cv) && CvROOT(cv)) {
if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
PL_comppad_name = NULL;
SvREFCNT_dec(sv);
}
+ AvREAL_off(CvPADLIST(cv));
SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
CvPADLIST(cv) = NULL;
}
CvXSUB(cv) = NULL;
}
/* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
- * ref status of CvOUTSIDE and CvGV */
- CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
+ * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
+ * to choose an error message */
+ CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
}
+/*
+=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
+
+Allocates a place in the currently-compiling
+pad (via L<perlapi/pad_alloc>) and
+then stores a name for that entry. I<namesv> is adopted and becomes the
+name entry; it must already contain the name string and be sufficiently
+upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
+added to I<namesv>. None of the other
+processing of L<perlapi/pad_add_name_pvn>
+is done. Returns the offset of the allocated pad slot.
+
+=cut
+*/
+
static PADOFFSET
-S_pad_add_name_sv(pTHX_ SV *namesv, const U32 flags, HV *typestash,
- HV *ourstash)
+S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
{
dVAR;
const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
- PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
+ PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
- ASSERT_CURPAD_ACTIVE("pad_add_name");
+ ASSERT_CURPAD_ACTIVE("pad_alloc_name");
if (typestash) {
assert(SvTYPE(namesv) == SVt_PVMG);
}
/*
-=for apidoc pad_add_name
+=for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
-Create a new name and associated PADMY SV in the current pad; return the
-offset.
-If C<typestash> is valid, the name is for a typed lexical; set the
-name's stash to that value.
-If C<ourstash> is valid, it's an our lexical, set the name's
-SvOURSTASH to that value
+Allocates a place in the currently-compiling pad for a named lexical
+variable. Stores the name and other metadata in the name part of the
+pad, and makes preparations to manage the variable's lexical scoping.
+Returns the offset of the allocated pad slot.
-If fake, it means we're cloning an existing entry
+I<namepv>/I<namelen> specify the variable's name, including leading sigil.
+If I<typestash> is non-null, the name is for a typed lexical, and this
+identifies the type. If I<ourstash> is non-null, it's a lexical reference
+to a package variable, and this identifies the package. The following
+flags can be OR'ed together:
+
+ padadd_OUR redundantly specifies if it's a package var
+ padadd_STATE variable will retain value persistently
+ padadd_NO_DUP_CHECK skip check for lexical shadowing
=cut
*/
PADOFFSET
-Perl_pad_add_name(pTHX_ const char *name, const STRLEN len, const U32 flags,
- HV *typestash, HV *ourstash)
+Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
+ U32 flags, HV *typestash, HV *ourstash)
{
dVAR;
PADOFFSET offset;
SV *namesv;
+ bool is_utf8;
- PERL_ARGS_ASSERT_PAD_ADD_NAME;
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
- if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
- Perl_croak(aTHX_ "panic: pad_add_name illegal flag bits 0x%" UVxf,
+ if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
+ Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
(UV)flags);
namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
+
+ if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
+ namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
+ }
- /* Until we're using the length for real, cross check that we're being told
- the truth. */
- PERL_UNUSED_ARG(len);
- assert(strlen(name) == len);
+ sv_setpvn(namesv, namepv, namelen);
- sv_setpv(namesv, name);
+ if (is_utf8) {
+ flags |= padadd_UTF8_NAME;
+ SvUTF8_on(namesv);
+ }
+ else
+ flags &= ~padadd_UTF8_NAME;
if ((flags & padadd_NO_DUP_CHECK) == 0) {
/* check for duplicate declaration */
pad_check_dup(namesv, flags & padadd_OUR, ourstash);
}
- offset = pad_add_name_sv(namesv, flags, typestash, ourstash);
+ offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
/* not yet introduced */
- COP_SEQ_RANGE_LOW_set(namesv, PAD_MAX); /* min */
- COP_SEQ_RANGE_HIGH_set(namesv, 0); /* max */
+ COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
+ COP_SEQ_RANGE_HIGH_set(namesv, 0);
if (!PL_min_intro_pending)
PL_min_intro_pending = offset;
/* if it's not a simple scalar, replace with an AV or HV */
assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
assert(SvREFCNT(PL_curpad[offset]) == 1);
- if (*name == '@')
+ if (namelen != 0 && *namepv == '@')
sv_upgrade(PL_curpad[offset], SVt_PVAV);
- else if (*name == '%')
+ else if (namelen != 0 && *namepv == '%')
sv_upgrade(PL_curpad[offset], SVt_PVHV);
assert(SvPADMY(PL_curpad[offset]));
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
- (long)offset, name, PTR2UV(PL_curpad[offset])));
+ (long)offset, SvPVX(namesv),
+ PTR2UV(PL_curpad[offset])));
return offset;
}
+/*
+=for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
+Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+=cut
+*/
+
+PADOFFSET
+Perl_pad_add_name_pv(pTHX_ const char *name,
+ const U32 flags, HV *typestash, HV *ourstash)
+{
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
+ return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
+}
/*
-=for apidoc pad_alloc
+=for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
-Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
-the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
-for a slot which has no name and no active value.
+Exactly like L</pad_add_name_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
+ namepv = SvPV(name, namelen);
+ if (SvUTF8(name))
+ flags |= padadd_UTF8_NAME;
+ return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
+}
+
+/*
+=for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
+
+Allocates a place in the currently-compiling pad,
+returning the offset of the allocated pad slot.
+No name is initially attached to the pad slot.
+I<tmptype> is a set of flags indicating the kind of pad entry required,
+which will be set in the value SV for the allocated pad entry:
+
+ SVs_PADMY named lexical variable ("my", "our", "state")
+ SVs_PADTMP unnamed temporary store
+
+I<optype> should be an opcode indicating the type of operation that the
+pad entry is to support. This doesn't affect operational semantics,
+but is used for debugging.
=cut
*/
if (PL_pad_reset_pending)
pad_reset();
if (tmptype & SVs_PADMY) {
+ /* For a my, simply push a null SV onto the end of PL_comppad. */
sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
retval = AvFILLp(PL_comppad);
}
else {
+ /* For a tmp, scan the pad from PL_padix upwards
+ * for a slot which has no name and no active value.
+ */
SV * const * const names = AvARRAY(PL_comppad_name);
const SSize_t names_fill = AvFILLp(PL_comppad_name);
for (;;) {
}
/*
-=for apidoc pad_add_anon
+=for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
-Add an anon code entry to the current compiling pad
+Allocates a place in the currently-compiling pad (via L</pad_alloc>)
+for an anonymous function that is lexically scoped inside the
+currently-compiling function.
+The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
+to the outer scope is weakened to avoid a reference loop.
+
+I<optype> should be an opcode indicating the type of operation that the
+pad entry is to support. This doesn't affect operational semantics,
+but is used for debugging.
=cut
*/
PADOFFSET
-Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
+Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
{
dVAR;
PADOFFSET ix;
pad_peg("add_anon");
sv_setpvs(name, "&");
- /* Are these two actually ever read? */
- COP_SEQ_RANGE_HIGH_set(name, ~0);
- COP_SEQ_RANGE_LOW_set(name, 1);
- ix = pad_alloc(op_type, SVs_PADMY);
+ /* These two aren't used; just make sure they're not equal to
+ * PERL_PADSEQ_INTRO */
+ COP_SEQ_RANGE_LOW_set(name, 0);
+ COP_SEQ_RANGE_HIGH_set(name, 0);
+ ix = pad_alloc(optype, SVs_PADMY);
av_store(PL_comppad_name, ix, name);
/* XXX DAPM use PL_curpad[] ? */
- av_store(PL_comppad, ix, sv);
- SvPADMY_on(sv);
+ av_store(PL_comppad, ix, (SV*)func);
+ SvPADMY_on((SV*)func);
/* to avoid ref loops, we never have parent + child referencing each
* other simultaneously */
- if (CvOUTSIDE((const CV *)sv)) {
- assert(!CvWEAKOUTSIDE((const CV *)sv));
- CvWEAKOUTSIDE_on(MUTABLE_CV(sv));
- SvREFCNT_dec(CvOUTSIDE(MUTABLE_CV(sv)));
+ if (CvOUTSIDE(func)) {
+ assert(!CvWEAKOUTSIDE(func));
+ CvWEAKOUTSIDE_on(func);
+ SvREFCNT_dec(CvOUTSIDE(func));
}
return ix;
}
-
-
/*
=for apidoc pad_check_dup
Check for duplicate declarations: report any of:
+
* a my in the current scope with the same name;
- * an our (anywhere in the pad) with the same name and the same stash
- as C<ourstash>
-C<is_our> indicates that the name to check is an 'our' declaration
+ * an our (anywhere in the pad) with the same name and the
+ same stash as C<ourstash>
+
+C<is_our> indicates that the name to check is an 'our' declaration.
=cut
*/
STATIC void
-S_pad_check_dup(pTHX_ SV *name, const U32 flags, const HV *ourstash)
+S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
{
dVAR;
SV **svp;
if (sv
&& sv != &PL_sv_undef
&& !SvFAKE(sv)
- && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
+ && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
+ || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
&& sv_eq(name, sv))
{
if (is_our && (SvPAD_OUR(sv)))
"\"%s\" variable %"SVf" masks earlier declaration in same %s",
(is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
sv,
- (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX ? "scope" : "statement"));
+ (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
+ ? "scope" : "statement"));
--off;
break;
}
if (sv
&& sv != &PL_sv_undef
&& !SvFAKE(sv)
- && (COP_SEQ_RANGE_HIGH(sv) == PAD_MAX || COP_SEQ_RANGE_HIGH(sv) == 0)
+ && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
+ || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
&& SvOURSTASH(sv) == ourstash
&& sv_eq(name, sv))
{
/*
-=for apidoc pad_findmy
+=for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
-Given a lexical name, try to find its offset, first in the current pad,
-or failing that, in the pads of any lexically enclosing subs (including
-the complications introduced by eval). If the name is found in an outer pad,
-then a fake entry is added to the current pad.
-Returns the offset in the current pad, or NOT_IN_PAD on failure.
+Given the name of a lexical variable, find its position in the
+currently-compiling pad.
+I<namepv>/I<namelen> specify the variable's name, including leading sigil.
+I<flags> is reserved and must be zero.
+If it is not in the current pad but appears in the pad of any lexically
+enclosing scope, then a pseudo-entry for it is added in the current pad.
+Returns the offset in the current pad,
+or C<NOT_IN_PAD> if no such lexical is in scope.
=cut
*/
PADOFFSET
-Perl_pad_findmy(pTHX_ const char *name, STRLEN len, U32 flags)
+Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
{
dVAR;
SV *out_sv;
const AV *nameav;
SV **name_svp;
- PERL_ARGS_ASSERT_PAD_FINDMY;
+ PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
- pad_peg("pad_findmy");
+ pad_peg("pad_findmy_pvn");
- if (flags)
- Perl_croak(aTHX_ "panic: pad_findmy illegal flag bits 0x%" UVxf,
+ if (flags & ~padadd_UTF8_NAME)
+ Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
(UV)flags);
- /* Yes, it is a bug (read work in progress) that we're not really using this
- length parameter, and instead relying on strlen() later on. But I'm not
- comfortable about changing the pad API piecemeal to use and rely on
- lengths. This only exists to avoid an "unused parameter" warning. */
- if (len < 2)
- return NOT_IN_PAD;
+ if (flags & padadd_UTF8_NAME) {
+ bool is_utf8 = TRUE;
+ namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
- /* But until we're using the length for real, cross check that we're being
- told the truth. */
- assert(strlen(name) == len);
+ if (is_utf8)
+ flags |= padadd_UTF8_NAME;
+ else
+ flags &= ~padadd_UTF8_NAME;
+ }
- offset = pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
- NULL, &out_sv, &out_flags);
+ offset = pad_findlex(namepv, namelen, flags,
+ PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
if ((PADOFFSET)offset != NOT_IN_PAD)
return offset;
if (namesv && namesv != &PL_sv_undef
&& !SvFAKE(namesv)
&& (SvPAD_OUR(namesv))
- && strEQ(SvPVX_const(namesv), name)
- && COP_SEQ_RANGE_LOW(namesv) == PAD_MAX /* min */
+ && SvCUR(namesv) == namelen
+ && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
+ flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
+ && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
)
return offset;
}
}
/*
- * Returns the offset of a lexical $_, if there is one, at run time.
- * Used by the UNDERBAR XS macro.
- */
+=for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
+
+Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
+instead of a string/length pair.
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
+{
+ PERL_ARGS_ASSERT_PAD_FINDMY_PV;
+ return pad_findmy_pvn(name, strlen(name), flags);
+}
+
+/*
+=for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
+
+Exactly like L</pad_findmy_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+*/
+
+PADOFFSET
+Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
+{
+ char *namepv;
+ STRLEN namelen;
+ PERL_ARGS_ASSERT_PAD_FINDMY_SV;
+ namepv = SvPV(name, namelen);
+ if (SvUTF8(name))
+ flags |= padadd_UTF8_NAME;
+ return pad_findmy_pvn(namepv, namelen, flags);
+}
+
+/*
+=for apidoc Amp|PADOFFSET|find_rundefsvoffset
+
+Find the position of the lexical C<$_> in the pad of the
+currently-executing function. Returns the offset in the current pad,
+or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
+the global one should be used instead).
+L</find_rundefsv> is likely to be more convenient.
+
+=cut
+*/
PADOFFSET
Perl_find_rundefsvoffset(pTHX)
dVAR;
SV *out_sv;
int out_flags;
- return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+ return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
NULL, &out_sv, &out_flags);
}
/*
- * Returns a lexical $_, if there is one, at run time ; or the global one
- * otherwise.
- */
+=for apidoc Am|SV *|find_rundefsv
+
+Find and return the variable that is named C<$_> in the lexical scope
+of the currently-executing function. This may be a lexical C<$_>,
+or will otherwise be the global one.
+
+=cut
+*/
SV *
Perl_find_rundefsv(pTHX)
int flags;
PADOFFSET po;
- po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+ po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
NULL, &namesv, &flags);
- if (po == NOT_IN_PAD
- || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
+ if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
return DEFSV;
return PAD_SVl(po);
}
+SV *
+Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
+{
+ SV *namesv;
+ int flags;
+ PADOFFSET po;
+
+ PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
+
+ po = pad_findlex("$_", 2, 0, cv, seq, 1,
+ NULL, &namesv, &flags);
+
+ if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
+ return DEFSV;
+
+ return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
+}
+
/*
-=for apidoc pad_findlex
+=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
Find a named lexical anywhere in a chain of nested pads. Add fake entries
in the inner pads if it's found in an outer one.
STATIC PADOFFSET
-S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn,
- SV** out_capture, SV** out_name_sv, int *out_flags)
+S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
+ int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
{
dVAR;
I32 offset, new_offset;
PERL_ARGS_ASSERT_PAD_FINDLEX;
+ if (flags & ~padadd_UTF8_NAME)
+ Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
+ (UV)flags);
+
*out_flags = 0;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
- PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
+ "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
+ PTR2UV(cv), (int)namelen, namepv, (int)seq,
+ out_capture ? " capturing" : "" ));
/* first, search this pad */
for (offset = AvFILLp(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
if (namesv && namesv != &PL_sv_undef
- && strEQ(SvPVX_const(namesv), name))
+ && SvCUR(namesv) == namelen
+ && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
+ flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
{
- if (SvFAKE(namesv))
+ if (SvFAKE(namesv)) {
fake_offset = offset; /* in case we don't find a real one */
- else if ( seq > COP_SEQ_RANGE_LOW(namesv) /* min */
- && seq <= COP_SEQ_RANGE_HIGH(namesv)) /* max */
- break;
+ continue;
+ }
+ /* is seq within the range _LOW to _HIGH ?
+ * This is complicated by the fact that PL_cop_seqmax
+ * may have wrapped around at some point */
+ if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
+ continue; /* not yet introduced */
+
+ if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
+ /* in compiling scope */
+ if (
+ (seq > COP_SEQ_RANGE_LOW(namesv))
+ ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
+ : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
+ )
+ break;
+ }
+ else if (
+ (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
+ ?
+ ( seq > COP_SEQ_RANGE_LOW(namesv)
+ || seq <= COP_SEQ_RANGE_HIGH(namesv))
+
+ : ( seq > COP_SEQ_RANGE_LOW(namesv)
+ && seq <= COP_SEQ_RANGE_HIGH(namesv))
+ )
+ break;
}
}
{
if (warn)
Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", name);
+ "Variable \"%"SVf"\" is not available",
+ newSVpvn_flags(namepv, namelen,
+ SVs_TEMP |
+ (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
+
*out_capture = NULL;
}
&& warn && ckWARN(WARN_CLOSURE)) {
newwarn = 0;
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" will not stay shared", name);
+ "Variable \"%"SVf"\" will not stay shared",
+ newSVpvn_flags(namepv, namelen,
+ SVs_TEMP |
+ (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
}
if (fake_offset && CvANON(cv)
"Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
PTR2UV(cv)));
n = *out_name_sv;
- (void) pad_findlex(name, CvOUTSIDE(cv),
+ (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
CvOUTSIDE_SEQ(cv),
newwarn, out_capture, out_name_sv, out_flags);
*out_name_sv = n;
&& !SvPAD_STATE(name_svp[offset]))
{
Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", name);
+ "Variable \"%"SVf"\" is not available",
+ newSVpvn_flags(namepv, namelen,
+ SVs_TEMP |
+ (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
*out_capture = NULL;
}
}
if (!*out_capture) {
- if (*name == '@')
+ if (namelen != 0 && *namepv == '@')
*out_capture = sv_2mortal(MUTABLE_SV(newAV()));
- else if (*name == '%')
+ else if (namelen != 0 && *namepv == '%')
*out_capture = sv_2mortal(MUTABLE_SV(newHV()));
else
*out_capture = sv_newmortal();
new_capturep = out_capture ? out_capture :
CvLATE(cv) ? NULL : &new_capture;
- offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
+ offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
new_capturep, out_name_sv, out_flags);
if ((PADOFFSET)offset == NOT_IN_PAD)
return NOT_IN_PAD;
PL_curpad = AvARRAY(PL_comppad);
new_offset
- = pad_add_name_sv(new_namesv,
+ = pad_alloc_name(new_namesv,
(SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
SvPAD_TYPED(*out_name_sv)
? SvSTASH(*out_name_sv) : NULL,
return new_offset;
}
-
#ifdef DEBUGGING
+
/*
-=for apidoc pad_sv
+=for apidoc Am|SV *|pad_sv|PADOFFSET po
-Get the value at offset po in the current pad.
+Get the value at offset I<po> in the current (compiling or executing) pad.
Use macro PAD_SV instead of calling this function directly.
=cut
*/
-
SV *
Perl_pad_sv(pTHX_ PADOFFSET po)
{
return PL_curpad[po];
}
-
/*
-=for apidoc pad_setsv
+=for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
-Set the entry at offset po in the current pad to sv.
+Set the value at offset I<po> in the current (compiling or executing) pad.
Use the macro PAD_SETSV() rather than calling this function directly.
=cut
);
PL_curpad[po] = sv;
}
-#endif
-
+#endif /* DEBUGGING */
/*
-=for apidoc pad_block_start
+=for apidoc m|void|pad_block_start|int full
Update the pad compilation state variables on entry to a new block
PL_pad_reset_pending = FALSE;
}
-
/*
-=for apidoc intro_my
+=for apidoc m|U32|intro_my
"Introduce" my variables to visible status.
dVAR;
SV **svp;
I32 i;
+ U32 seq;
ASSERT_CURPAD_ACTIVE("intro_my");
if (! PL_min_intro_pending)
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
SV * const sv = svp[i];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && !COP_SEQ_RANGE_HIGH(sv)) {
- COP_SEQ_RANGE_HIGH_set(sv, PAD_MAX); /* Don't know scope end yet. */
+ if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
+ && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
+ {
+ COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad intromy: %ld \"%s\", (%lu,%lu)\n",
);
}
}
+ seq = PL_cop_seqmax;
+ PL_cop_seqmax++;
+ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
+ PL_cop_seqmax++;
PL_min_intro_pending = 0;
PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
+ "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
- return PL_cop_seqmax++;
+ return seq;
}
/*
-=for apidoc pad_leavemy
+=for apidoc m|void|pad_leavemy
Cleanup at end of scope during compilation: set the max seq number for
lexicals in this scope and warn of any lexicals that never got introduced.
/* "Deintroduce" my variables that are leaving with this scope. */
for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
const SV * const sv = svp[off];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PAD_MAX) {
+ if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
+ && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
+ {
COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
}
}
PL_cop_seqmax++;
+ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
+ PL_cop_seqmax++;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
}
-
/*
-=for apidoc pad_swipe
+=for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
Abandon the tmp in the current pad at offset po and replace with a
new one.
PL_padix = po - 1;
}
-
/*
-=for apidoc pad_reset
+=for apidoc m|void|pad_reset
Mark all the current temporaries for reuse
PL_pad_reset_pending = FALSE;
}
-
/*
-=for apidoc pad_tidy
+=for apidoc Amx|void|pad_tidy|padtidy_type type
-Tidy up a pad after we've finished compiling it:
- * remove most stuff from the pads of anonsub prototypes;
- * give it a @_;
- * mark tmps as such.
+Tidy up a pad at the end of compilation of the code to which it belongs.
+Jobs performed here are: remove most stuff from the pads of anonsub
+prototypes; give it a @_; mark temporaries as such. I<type> indicates
+the kind of subroutine:
+
+ padtidy_SUB ordinary subroutine
+ padtidy_SUBCLONE prototype for lexical closure
+ padtidy_FORMAT format
=cut
*/
PL_curpad = AvARRAY(PL_comppad);
}
-
/*
-=for apidoc pad_free
+=for apidoc m|void|pad_free|PADOFFSET po
Free the SV at offset po in the current pad.
);
if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
- SvPADTMP_off(PL_curpad[po]);
+ SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
}
if ((I32)po < PL_padix)
PL_padix = po - 1;
}
-
-
/*
-=for apidoc do_dump_pad
+=for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
Dump the contents of a padlist
}
}
-
+#ifdef DEBUGGING
/*
-=for apidoc cv_dump
+=for apidoc m|void|cv_dump|CV *cv|const char *title
dump the contents of a CV
=cut
*/
-#ifdef DEBUGGING
STATIC void
S_cv_dump(pTHX_ const CV *cv, const char *title)
{
" PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
do_dump_pad(1, Perl_debug_log, padlist, 1);
}
-#endif /* DEBUGGING */
-
-
-
+#endif /* DEBUGGING */
/*
-=for apidoc cv_clone
+=for apidoc Am|CV *|cv_clone|CV *proto
-Clone a CV: make a new CV which points to the same code etc, but which
-has a newly-created pad built by copying the prototype pad and capturing
-any outer lexicals.
+Clone a CV, making a lexical closure. I<proto> supplies the prototype
+of the function: its code, pad structure, and other attributes.
+The prototype is combined with a capture of outer lexicals to which the
+code refers, which are taken from the currently-executing instance of
+the immediately surrounding code.
=cut
*/
CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
CvCLONED_on(cv);
-#ifdef USE_ITHREADS
- CvFILE(cv) = CvISXSUB(proto) ? CvFILE(proto)
- : savepv(CvFILE(proto));
-#else
- CvFILE(cv) = CvFILE(proto);
-#endif
+ CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
+ : CvFILE(proto);
CvGV_set(cv,CvGV(proto));
CvSTASH_set(cv, CvSTASH(proto));
OP_REFCNT_LOCK;
stale. And state vars are always available */
if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", SvPVX_const(namesv));
+ "Variable \"%"SVf"\" is not available", namesv);
sv = NULL;
}
else
return cv;
}
-
/*
-=for apidoc pad_fixup_inner_anons
+=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
For any anon CVs in the pad, change CvOUTSIDE of that CV from
old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
}
}
-
/*
-=for apidoc pad_push
+=for apidoc m|void|pad_push|PADLIST *padlist|int depth
Push a new pad frame onto the padlist, unless there's already a pad at
this depth, in which case don't bother creating a new one. Then give
}
}
+/*
+=for apidoc Am|HV *|pad_compname_type|PADOFFSET po
+
+Looks up the type of the lexical variable at position I<po> in the
+currently-compiling pad. If the variable is typed, the stash of the
+class to which it is typed is returned. If not, C<NULL> is returned.
+
+=cut
+*/
HV *
Perl_pad_compname_type(pTHX_ const PADOFFSET po)
# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
+/*
+=for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
+
+Duplicates a pad.
+
+=cut
+*/
+
AV *
-Perl_padlist_dup(pTHX_ AV *const srcpad, CLONE_PARAMS *const param)
+Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
{
AV *dstpad;
PERL_ARGS_ASSERT_PADLIST_DUP;
if (!srcpad)
return NULL;
- assert(!AvREAL(srcpad));
-
if (param->flags & CLONEf_COPY_STACKS
|| SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
- /* XXX padlists are real, but pretend to be not */
- AvREAL_on(srcpad);
dstpad = av_dup_inc(srcpad, param);
- AvREAL_off(srcpad);
- AvREAL_off(dstpad);
assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
} else {
/* CvDEPTH() on our subroutine will be set to 0, so there's no need
SV **names;
SV **pad1a;
AV *args;
- /* look for it in the table first.
- I *think* that it shouldn't be possible to find it there.
- Well, except for how Perl_sv_compile_2op() "works" :-( */
+ /* Look for it in the table first, as the padlist may have ended up
+ as an element of @DB::args (or theoretically even @_), so it may
+ may have been cloned already. It may also be there because of
+ how Perl_sv_compile_2op() "works". :-( */
dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
if (dstpad)
- return dstpad;
+ return (AV *)SvREFCNT_inc_simple_NN(dstpad);
dstpad = newAV();
ptr_table_store(PL_ptr_table, srcpad, dstpad);
- AvREAL_off(dstpad);
av_extend(dstpad, 1);
AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
names = AvARRAY(AvARRAY(dstpad)[0]);
return dstpad;
}
-#endif
+#endif /* USE_ITHREADS */
/*
* Local variables: