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 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; }