static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
dVAR;
SV *attr;
int nret;
for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
STRLEN len;
const char *name = SvPV_const(attr, len);
const bool negated = (*name == '-');
if (negated) {
name++;
len--;
}
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
case 6:
switch (name[3]) {
case 'l':
if (memEQ(name, "lvalue", 6)) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
continue;
}
break;
case 'h':
if (memEQ(name, "method", 6)) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
continue;
}
break;
}
break;
}
break;
default:
if (memEQs(name, 6, "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++;
}
return nret;
}
static void
S_attributes__push_fetch(pTHX_ SV *sv)
{
dSP;
switch (SvTYPE(sv)) {
case SVt_PVCV:
{
cv_flags_t cvflags = CvFLAGS((const CV *)sv);
if (cvflags & CVf_LVALUE) {
XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
}
if (cvflags & CVf_METHOD) {
XPUSHs(newSVpvs_flags("method", SVs_TEMP));
}
if (cvflags & CVf_PURE) {
XPUSHs(newSVpvs_flags("pure", SVs_TEMP));
}
if (cvflags & CVf_TYPED) {
HV *typestash = CvTYPE((CV*)sv);
XPUSHs(newSVpvn_flags(HvNAME(typestash), HvNAMELEN(typestash),
SVs_TEMP|HvNAMEUTF8(typestash)));
}
break;
}
default:
break;
}
PUTBACK;
}
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 == '-');
if (negated) {
name++;
len--;
}
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
#ifdef CVf_ASSERTION
case 9:
if (memEQ(name, "assertion", 9)) {
if (negated)
CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
else
CvFLAGS((CV*)sv) |= CVf_ASSERTION;
continue;
}
break;
#endif
case 6:
switch (name[3]) {
case 'l':
#ifdef CVf_LVALUE
if (memEQ(name, "lvalue", 6)) {
if (negated)
CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
else
CvFLAGS((CV*)sv) |= CVf_LVALUE;
continue;
}
break;
case 'k':
#endif /* defined CVf_LVALUE */
if (memEQ(name, "locked", 6)) {
if (negated)
CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
else
CvFLAGS((CV*)sv) |= CVf_LOCKED;
continue;
}
break;
case 'h':
if (memEQ(name, "method", 6)) {
if (negated)
CvFLAGS((CV*)sv) &= ~CVf_METHOD;
else
CvFLAGS((CV*)sv) |= CVf_METHOD;
continue;
}
break;
}
break;
}
break;
default:
switch ((int)len) {
case 6:
switch (name[5]) {
case 'd':
if (memEQ(name, "share", 5)) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
continue;
}
break;
case 'e':
if (memEQ(name, "uniqu", 5)) {
if (SvTYPE(sv) == SVt_PVGV) {
if (negated) {
GvUNIQUE_off(sv);
} else {
GvUNIQUE_on(sv);
}
}
/* Hope this came from toke.c if not a GV. */
continue;
}
}
}
break;
}
/* anything recognized had a 'continue' above */
*retlist++ = attr;
nret++;
}
return nret;
}
/* 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;
}
