GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
register const char *nend;
const char *nsplit = 0;
GV* gv;
for (nend = name; *nend; nend++) {
if (*nend == '\'')
nsplit = nend;
else if (*nend == ':' && *(nend + 1) == ':')
nsplit = ++nend;
}
if (nsplit) {
const char *origname = name;
name = nsplit + 1;
if (*nsplit == ':')
--nsplit;
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
else
stash = gv_stashpvn(origname, nsplit - origname, TRUE);
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
if (!gv) {
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = (GV*)&PL_sv_yes;
else if (autoload)
gv = gv_autoload4(stash, name, nend - name, TRUE);
}
else if (autoload) {
CV* cv = GvCV(gv);
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* stubgv;
GV* autogv;
if (CvANON(cv))
stubgv = gv;
else {
stubgv = CvGV(cv);
if (GvCV(stubgv) != cv) /* orphaned import */
stubgv = gv;
}
autogv = gv_autoload4(GvSTASH(stubgv),
GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
if (autogv)
gv = autogv;
}
}
return gv;
}
static void
S_lazy_init_host_obj(kino_Obj *self)
{
SV *inner_obj = newSV(0);
SvOBJECT_on(inner_obj);
PL_sv_objcount++;
SvUPGRADE(inner_obj, SVt_PVMG);
sv_setiv(inner_obj, PTR2IV(self));
// Connect class association.
kino_CharBuf *class_name = Kino_VTable_Get_Name(self->vtable);
HV *stash = gv_stashpvn((char*)Kino_CB_Get_Ptr8(class_name),
Kino_CB_Get_Size(class_name), TRUE);
SvSTASH_set(inner_obj, (HV*)SvREFCNT_inc(stash));
/* Up till now we've been keeping track of the refcount in
* self->ref.count. We're replacing ref.count with ref.host_obj, which
* will assume responsibility for maintaining the refcount. ref.host_obj
* starts off with a refcount of 1, so we need to transfer any refcounts
* in excess of that. */
size_t old_refcount = self->ref.count;
self->ref.host_obj = inner_obj;
while (old_refcount > 1) {
SvREFCNT_inc_simple_void_NN(inner_obj);
old_refcount--;
}
}
HV*
Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
{
register char *ptr;
STRLEN len;
ptr = SvPV(sv,len);
return gv_stashpvn(ptr, len, create);
}
/* The "gv" parameter should be the glob known to Perl code as *!
* The scalar must already have been magicalized.
*/
STATIC void
S_require_errno(pTHX_ GV *gv)
{
HV* stash = gv_stashpvn("Errno",5,FALSE);
if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
dSP;
PUTBACK;
ENTER;
save_scalar(gv); /* keep the value of $! */
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
newSVpvn("Errno",5), Nullsv);
LEAVE;
SPAGAIN;
stash = gv_stashpvn("Errno",5,FALSE);
if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
}
}
GV *p5_look_up_package_method(PerlInterpreter *my_perl, char *module, char *name) {
PERL_SET_CONTEXT(my_perl);
{
HV * const pkg = gv_stashpvn(module, strlen(module), 0);
GV * const gv = gv_fetchmeth_pvn(pkg, name, strlen(name), -1, SVf_UTF8);
if (gv && isGV(gv))
return gv;
return NULL;
}
}
static void boot_B_Sizeof(void)
{
HV *stash = gv_stashpvn("B::Sizeof", 9, TRUE);
(void)newCONSTSUB(stash, "OP", newSViv(sizeof(OP)));
(void)newCONSTSUB(stash, "PMOP", newSViv(sizeof(PMOP)));
(void)newCONSTSUB(stash, "UNOP", newSViv(sizeof(UNOP)));
(void)newCONSTSUB(stash, "BINOP", newSViv(sizeof(BINOP)));
(void)newCONSTSUB(stash, "LISTOP", newSViv(sizeof(LISTOP)));
(void)newCONSTSUB(stash, "LOGOP", newSViv(sizeof(LOGOP)));
(void)newCONSTSUB(stash, "SVOP", newSViv(sizeof(SVOP)));
(void)newCONSTSUB(stash, "GVOP", newSViv(sizeof(GVOP)));
(void)newCONSTSUB(stash, "PVOP", newSViv(sizeof(PVOP)));
(void)newCONSTSUB(stash, "COP", newSViv(sizeof(COP)));
(void)newCONSTSUB(stash, "LOOP", newSViv(sizeof(LOOP)));
(void)newCONSTSUB(stash, "SV", newSViv(sizeof(SV)));
(void)newCONSTSUB(stash, "HV", newSViv(sizeof(HV)));
(void)newCONSTSUB(stash, "AV", newSViv(sizeof(AV)));
(void)newCONSTSUB(stash, "NV", newSViv(sizeof(NV)));
(void)newCONSTSUB(stash, "IV", newSViv(sizeof(IV)));
(void)newCONSTSUB(stash, "CV", newSViv(sizeof(CV)));
(void)newCONSTSUB(stash, "GV", newSViv(sizeof(GV)));
(void)newCONSTSUB(stash, "GP", newSViv(sizeof(GP)));
(void)newCONSTSUB(stash, "U32", newSViv(sizeof(U32)));
(void)newCONSTSUB(stash, "U16", newSViv(sizeof(U16)));
(void)newCONSTSUB(stash, "U8", newSViv(sizeof(U8)));
#ifdef XRV
(void)newCONSTSUB(stash, "XRV", newSViv(sizeof(XRV)));
#endif
(void)newCONSTSUB(stash, "XPV", newSViv(sizeof(XPV)));
(void)newCONSTSUB(stash, "XPVIV", newSViv(sizeof(XPVIV)));
(void)newCONSTSUB(stash, "XPVUV", newSViv(sizeof(XPVUV)));
(void)newCONSTSUB(stash, "XPVNV", newSViv(sizeof(XPVNV)));
(void)newCONSTSUB(stash, "XPVMG", newSViv(sizeof(XPVMG)));
(void)newCONSTSUB(stash, "XPVLV", newSViv(sizeof(XPVLV)));
(void)newCONSTSUB(stash, "XPVGV", newSViv(sizeof(XPVGV)));
#ifdef XPVBM
(void)newCONSTSUB(stash, "XPVBM", newSViv(sizeof(XPVBM)));
#endif
(void)newCONSTSUB(stash, "XPVFM", newSViv(sizeof(XPVFM)));
(void)newCONSTSUB(stash, "XPVIO", newSViv(sizeof(XPVIO)));
(void)newCONSTSUB(stash, "XPVCV", newSViv(sizeof(XPVCV)));
(void)newCONSTSUB(stash, "XPVAV", newSViv(sizeof(XPVAV)));
(void)newCONSTSUB(stash, "XPVHV", newSViv(sizeof(XPVHV)));
(void)newCONSTSUB(stash, "HE", newSViv(sizeof(HE)));
(void)newCONSTSUB(stash, "HEK", newSViv(sizeof(HEK)));
(void)newCONSTSUB(stash, "MAGIC", newSViv(sizeof(MAGIC)));
(void)newCONSTSUB(stash, "REGEXP", newSViv(sizeof(REGEXP)));
}
/*
=for apidoc mro_method_changed_in
Invalidates method caching on any child classes
of the given stash, so that they might notice
the changes in this one.
Ideally, all instances of C<PL_sub_generation++> in
perl source outside of C<mro.c> should be
replaced by calls to this.
Perl automatically handles most of the common
ways a method might be redefined. However, there
are a few ways you could change a method in a stash
without the cache code noticing, in which case you
need to call this method afterwards:
1) Directly manipulating the stash HV entries from
XS code.
2) Assigning a reference to a readonly scalar
constant into a stash entry in order to create
a constant subroutine (like constant.pm
does).
This same method is available from pure perl
via, C<mro::method_changed_in(classname)>.
=cut
*/
void
Perl_mro_method_changed_in(pTHX_ HV *stash)
{
const char * const stashname = HvNAME_get(stash);
const STRLEN stashname_len = HvNAMELEN_get(stash);
SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
/* Inc the package generation, since a local method changed */
HvMROMETA(stash)->pkg_gen++;
/* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
invalidate all method caches globally */
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
PL_sub_generation++;
return;
}
/* else, invalidate the method caches of all child classes,
but not itself */
if(isarev) {
HE* iter;
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 len;
const char* const revkey = hv_iterkey(iter, &len);
HV* const revstash = gv_stashpvn(revkey, len, 0);
struct mro_meta* mrometa;
if(!revstash) continue;
mrometa = HvMROMETA(revstash);
mrometa->cache_gen++;
if(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
}
}
}
SV *p5_call_inherited_package_method(PerlInterpreter *my_perl, char *package, char *base_package, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
SV * retval = NULL;
HV * stash = gv_stashpvn(package, strlen(package), SVf_UTF8);
int flags = G_ARRAY | G_EVAL;
if (stash == NULL) {
*type = -1; /* signal that a wrapper package needs to be created */
return NULL;
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(newSVpv(package, 0));
push_arguments(sp, len, args);
{
GV * const gv = p5_look_up_package_method(my_perl, base_package, name);
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
*count = call_sv(rv, flags);
}
SPAGAIN;
handle_p5_error(err);
retval = pop_return_values(my_perl, sp, *count, type);
FREETMPS;
LEAVE;
return retval;
}
}
HV*
Perl_gv_stashpv(pTHX_ const char *name, I32 create)
{
return gv_stashpvn(name, strlen(name), create);
}
GV *
Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
AV* av;
GV* topgv;
GV* gv;
GV** gvp;
CV* cv;
if (!stash)
return 0;
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
name, HvNAME(stash));
DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
if (!gvp)
topgv = Nullgv;
else {
topgv = *gvp;
if (SvTYPE(topgv) != SVt_PVGV)
gv_init(topgv, stash, name, len, TRUE);
if ((cv = GvCV(topgv))) {
/* If genuine method or valid cache entry, use it */
if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
return topgv;
/* Stale cached entry: junk it */
SvREFCNT_dec(cv);
GvCV(topgv) = cv = Nullcv;
GvCVGEN(topgv) = 0;
}
else if (GvCVGEN(topgv) == PL_sub_generation)
return 0; /* cache indicates sub doesn't exist */
}
gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
/* create and re-create @.*::SUPER::ISA on demand */
if (!av || !SvMAGIC(av)) {
char* packname = HvNAME(stash);
STRLEN packlen = strlen(packname);
if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
HV* basestash;
packlen -= 7;
basestash = gv_stashpvn(packname, packlen, TRUE);
gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
if (!gvp || !(gv = *gvp))
Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, "ISA", 3, TRUE);
SvREFCNT_dec(GvAV(gv));
GvAV(gv) = (AV*)SvREFCNT_inc(av);
}
}
}
if (av) {
SV** svp = AvARRAY(av);
/* NOTE: No support for tied ISA */
I32 items = AvFILLp(av) + 1;
while (items--) {
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
gv = gv_fetchmeth(basestash, name, len,
(level >= 0) ? level + 1 : level - 1);
if (gv)
goto gotcha;
}
}
/* if at top level, try UNIVERSAL */
if (level == 0 || level == -1) {
HV* lastchance;
if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
if ((gv = gv_fetchmeth(lastchance, name, len,
(level >= 0) ? level + 1 : level - 1)))
{
gotcha:
/*
* Cache method in topgv if:
* 1. topgv has no synonyms (else inheritance crosses wires)
* 2. method isn't a stub (else AUTOLOAD fails spectacularly)
*/
if (topgv &&
GvREFCNT(topgv) == 1 &&
(cv = GvCV(gv)) &&
(CvROOT(cv) || CvXSUB(cv)))
{
if ((cv = GvCV(topgv)))
SvREFCNT_dec(cv);
GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
GvCVGEN(topgv) = PL_sub_generation;
}
return gv;
}
else if (topgv && GvREFCNT(topgv) == 1) {
/* cache the fact that the method is not defined */
GvCVGEN(topgv) = PL_sub_generation;
}
}
}
return 0;
}
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
register const char *nend;
const char *nsplit = 0;
GV* gv;
HV* ostash = stash;
if (stash && SvTYPE(stash) < SVt_PVHV)
stash = Nullhv;
for (nend = name; *nend; nend++) {
if (*nend == '\'')
nsplit = nend;
else if (*nend == ':' && *(nend + 1) == ':')
nsplit = ++nend;
}
if (nsplit) {
const char *origname = name;
name = nsplit + 1;
if (*nsplit == ':')
--nsplit;
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
/* __PACKAGE__::SUPER stash should be autovivified */
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
else {
/* don't autovifify if ->NoSuchStash::method */
stash = gv_stashpvn(origname, nsplit - origname, FALSE);
/* however, explicit calls to Pkg::SUPER::method may
happen, and may require autovivification to work */
if (!stash && (nsplit - origname) >= 7 &&
strnEQ(nsplit - 7, "::SUPER", 7) &&
gv_stashpvn(origname, nsplit - origname - 7, FALSE))
stash = gv_stashpvn(origname, nsplit - origname, TRUE);
}
ostash = stash;
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
if (!gv) {
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = (GV*)&PL_sv_yes;
else if (autoload)
gv = gv_autoload4(ostash, name, nend - name, TRUE);
}
else if (autoload) {
CV* cv = GvCV(gv);
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* stubgv;
GV* autogv;
if (CvANON(cv))
stubgv = gv;
else {
stubgv = CvGV(cv);
if (GvCV(stubgv) != cv) /* orphaned import */
stubgv = gv;
}
autogv = gv_autoload4(GvSTASH(stubgv),
GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
if (autogv)
gv = autogv;
}
}
return gv;
}
/*
=for apidoc mro_isa_changed_in
Takes the necessary steps (cache invalidations, mostly)
when the @ISA of the given package has changed. Invoked
by the C<setisa> magic, should not need to invoke directly.
=cut
*/
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
dVAR;
HV* isarev;
AV* linear_mro;
HE* iter;
SV** svp;
I32 items;
bool is_universal;
struct mro_meta * meta;
const char * const stashname = HvNAME_get(stash);
const STRLEN stashname_len = HvNAMELEN_get(stash);
PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
/* wipe out the cached linearizations for this stash */
meta = HvMROMETA(stash);
if (meta->mro_linear_dfs) {
SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
meta->mro_linear_dfs = NULL;
/* This is just acting as a shortcut pointer. */
meta->mro_linear_c3 = NULL;
} else if (meta->mro_linear_c3) {
/* Only the current MRO is stored, so this owns the data. */
SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3));
meta->mro_linear_c3 = NULL;
}
if (meta->isa) {
SvREFCNT_dec(meta->isa);
meta->isa = NULL;
}
/* Inc the package generation, since our @ISA changed */
meta->pkg_gen++;
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
PL_sub_generation++;
is_universal = TRUE;
}
else { /* Wipe the local method cache otherwise */
meta->cache_gen++;
is_universal = FALSE;
}
/* wipe next::method cache too */
if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches */
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 len;
const char* const revkey = hv_iterkey(iter, &len);
HV* revstash = gv_stashpvn(revkey, len, 0);
struct mro_meta* revmeta;
if(!revstash) continue;
revmeta = HvMROMETA(revstash);
if (revmeta->mro_linear_dfs) {
SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
revmeta->mro_linear_dfs = NULL;
/* This is just acting as a shortcut pointer. */
revmeta->mro_linear_c3 = NULL;
} else if (revmeta->mro_linear_c3) {
/* Only the current MRO is stored, so this owns the data. */
SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3));
revmeta->mro_linear_c3 = NULL;
}
if(!is_universal)
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
if (revmeta->isa) {
SvREFCNT_dec(revmeta->isa);
revmeta->isa = NULL;
}
}
}
/* Now iterate our MRO (parents), and do a few things:
1) instantiate with the "fake" flag if they don't exist
2) flag them as universal if we are universal
3) Add everything from our isarev to their isarev
*/
/* We're starting at the 2nd element, skipping ourselves here */
linear_mro = mro_get_linear_isa(stash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
while (items--) {
SV* const sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
/* That fetch should not fail. But if it had to create a new SV for
us, then we can detect it, because it will not be the correct type.
Probably faster and cleaner for us to free that scalar [very little
code actually executed to free it] and create a new HV than to
copy&paste [SIN!] the code from newHV() to allow us to upgrade the
new SV from SVt_NULL. */
mroisarev = MUTABLE_HV(HeVAL(he));
if(SvTYPE(mroisarev) != SVt_PVHV) {
SvREFCNT_dec(mroisarev);
mroisarev = newHV();
HeVAL(he) = MUTABLE_SV(mroisarev);
}
/* This hash only ever contains PL_sv_yes. Storing it over itself is
almost as cheap as calling hv_exists, so on aggregate we expect to
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
(void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 revkeylen;
char* const revkey = hv_iterkey(iter, &revkeylen);
(void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
}
}
}
}
/* helper for the default modify handler for builtin attributes */
static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
SV *attr;
int nret;
for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
STRLEN len;
const char *name = SvPV_const(attr, len);
const bool negated = (*name == '-');
HV *typestash;
if (negated) {
name++;
len--;
}
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
case 4:
if (memEQ(name, "pure", 4)) {
if (negated)
Perl_croak(aTHX_ "Illegal :-pure attribute");
CvPURE_on(sv);
goto next_attr;
}
break;
case 5:
if (memEQ(name, "const", 5)) {
if (negated)
CvCONST_off(sv);
else {
#ifndef USE_CPERL
const bool warn = (!CvANON(sv) || CvCLONED(sv))
&& !CvCONST(sv);
CvCONST_on(sv);
if (warn)
break;
#else
CvCONST_on(sv);
#endif
}
goto next_attr;
}
break;
case 6:
switch (name[3]) {
case 'l':
if (memEQ(name, "lvalue", 6)) {
bool warn =
!CvISXSUB(MUTABLE_CV(sv))
&& CvROOT(MUTABLE_CV(sv))
&& !CvLVALUE(MUTABLE_CV(sv)) != negated;
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
if (warn) break;
goto next_attr;
}
break;
case 'h':
if (memEQ(name, "method", 6)) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
goto next_attr;
}
break;
}
break;
default:
if (len > 10 && memEQ(name, "prototype(", 10)) {
SV * proto = newSVpvn(name+10,len-11);
HEK *const hek = CvNAME_HEK((CV *)sv);
SV *subname;
if (name[len-1] != ')')
Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
if (hek)
subname = sv_2mortal(newSVhek(hek));
else
subname=(SV *)CvGV((const CV *)sv);
if (ckWARN(WARN_ILLEGALPROTO))
Perl_validate_proto(aTHX_ subname, proto, TRUE);
Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
(const GV *)subname,
name+10,
len-11,
SvUTF8(attr));
sv_setpvn(MUTABLE_SV(sv), name+10, len-11);
if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv));
goto next_attr;
}
break;
}
if (!negated && (typestash = gv_stashpvn(name, len, SvUTF8(attr)))) {
CvTYPED_on(sv);
CvTYPE_set((CV*)sv, typestash);
continue;
}
break;
case SVt_IV:
case SVt_PVIV:
case SVt_PVMG:
if (memEQ(name, "unsigned", 8)
&& (SvIOK(sv) || SvUOK(sv)))
{
if (negated) /* :-unsigned alias for :signed */
SvIsUV_off(sv);
else
SvIsUV_on(sv);
continue;
}
/* fallthru - all other data types */
default:
if (memEQ(name, "const", 5)
&& !(SvFLAGS(sv) & SVf_PROTECT))
{
if (negated)
SvREADONLY_off(sv);
else
SvREADONLY_on(sv);
continue;
}
if (memEQs(name, len, "shared")) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
continue;
}
break;
}
/* anything recognized had a 'continue' above */
*retlist++ = attr;
nret++;
next_attr:
;
}
return nret;
}
