X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=xsutils.c;h=c09a376b98dea5f3f378e26682b5b53ca2714406;hb=f8952f9c0d30f65af1114a6384b97ad7770dce81;hp=0f5989b3dd51c6dbb701172a1dae7c37d14be0a3;hpb=121e869fb2aaab8c71b6af27ce8b64742ff5347e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/xsutils.c b/xsutils.c index 0f5989b..c09a376 100644 --- a/xsutils.c +++ b/xsutils.c @@ -1,3 +1,19 @@ +/* xsutils.c + * + * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005 + * by Larry Wall and others + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* + * "Perilous to us all are the devices of an art deeper than we possess + * ourselves." --Gandalf + */ + + #include "EXTERN.h" #define PERL_IN_XSUTILS_C #include "perl.h" @@ -7,12 +23,12 @@ */ /* package attributes; */ -void XS_attributes__warn_reserved(pTHXo_ CV *cv); -void XS_attributes_reftype(pTHXo_ CV *cv); -void XS_attributes__modify_attrs(pTHXo_ CV *cv); -void XS_attributes__guess_stash(pTHXo_ CV *cv); -void XS_attributes__fetch_attrs(pTHXo_ CV *cv); -void XS_attributes_bootstrap(pTHXo_ CV *cv); +void XS_attributes__warn_reserved(pTHX_ CV *cv); +void XS_attributes_reftype(pTHX_ CV *cv); +void XS_attributes__modify_attrs(pTHX_ CV *cv); +void XS_attributes__guess_stash(pTHX_ CV *cv); +void XS_attributes__fetch_attrs(pTHX_ CV *cv); +void XS_attributes_bootstrap(pTHX_ CV *cv); /* @@ -38,7 +54,7 @@ Perl_boot_core_xsutils(pTHX) #include "XSUB.h" static int -modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs) +modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) { SV *attr; char *name; @@ -55,19 +71,32 @@ modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs) 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) { + switch (name[3]) { case 'l': #ifdef CVf_LVALUE - if (strEQ(name, "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 (strEQ(name, "locked")) { + if (memEQ(name, "locked", 6)) { if (negated) CvFLAGS((CV*)sv) &= ~CVf_LOCKED; else @@ -75,8 +104,8 @@ modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs) continue; } break; - case 'm': - if (strEQ(name, "method")) { + case 'h': + if (memEQ(name, "method", 6)) { if (negated) CvFLAGS((CV*)sv) &= ~CVf_METHOD; else @@ -89,7 +118,30 @@ modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs) } break; default: - /* nothing, yet */ + 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 */ @@ -109,6 +161,9 @@ XS(XS_attributes_bootstrap) dXSARGS; char *file = __FILE__; + if( items > 1 ) + Perl_croak(aTHX_ "Usage: attributes::bootstrap $module"); + newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, ""); newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file); newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$"); @@ -134,7 +189,7 @@ usage: goto usage; sv = SvRV(rv); if (items > 1) - XSRETURN(modify_SV_attributes(aTHXo_ sv, &ST(0), &ST(1), items-1)); + XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1)); XSRETURN(0); } @@ -168,6 +223,14 @@ usage: #endif if (cvflags & CVf_METHOD) XPUSHs(sv_2mortal(newSVpvn("method", 6))); + if (GvUNIQUE(CvGV((CV*)sv))) + XPUSHs(sv_2mortal(newSVpvn("unique", 6))); + if (cvflags & CVf_ASSERTION) + XPUSHs(sv_2mortal(newSVpvn("assertion", 9))); + break; + case SVt_PVGV: + if (GvUNIQUE(sv)) + XPUSHs(sv_2mortal(newSVpvn("unique", 6))); break; default: break; @@ -180,11 +243,7 @@ XS(XS_attributes__guess_stash) { dXSARGS; SV *rv, *sv; -#ifdef dXSTARGET - dXSTARGET; -#else - SV * TARG = sv_newmortal(); -#endif + dXSTARG; if (items != 1) { usage: @@ -208,18 +267,17 @@ usage: HV *stash = Nullhv; switch (SvTYPE(sv)) { case SVt_PVCV: - if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)) && - HvNAME(GvSTASH(CvGV(sv)))) + if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv))) stash = GvSTASH(CvGV(sv)); - else if (/* !CvANON(sv) && */ CvSTASH(sv) && HvNAME(CvSTASH(sv))) + else if (/* !CvANON(sv) && */ CvSTASH(sv)) stash = CvSTASH(sv); break; case SVt_PVMG: - if (!(SvFAKE(sv) && SvTIED_mg(sv, '*'))) + if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob))) break; /*FALLTHROUGH*/ case SVt_PVGV: - if (GvGP(sv) && GvESTASH((GV*)sv) && HvNAME(GvESTASH((GV*)sv))) + if (GvGP(sv) && GvESTASH((GV*)sv)) stash = GvESTASH((GV*)sv); break; default: @@ -229,9 +287,7 @@ usage: sv_setpv(TARG, HvNAME(stash)); } -#ifdef dXSTARGET SvSETMAGIC(TARG); -#endif XSRETURN(1); } @@ -239,11 +295,7 @@ XS(XS_attributes_reftype) { dXSARGS; SV *rv, *sv; -#ifdef dXSTARGET - dXSTARGET; -#else - SV * TARG = sv_newmortal(); -#endif + dXSTARG; if (items != 1) { usage: @@ -253,13 +305,13 @@ usage: rv = ST(0); ST(0) = TARG; + if (SvGMAGICAL(rv)) + mg_get(rv); if (!(SvOK(rv) && SvROK(rv))) goto usage; sv = SvRV(rv); sv_setpv(TARG, sv_reftype(sv, 0)); -#ifdef dXSTARGET SvSETMAGIC(TARG); -#endif XSRETURN(1); } @@ -267,11 +319,6 @@ usage: XS(XS_attributes__warn_reserved) { dXSARGS; -#ifdef dXSTARGET - dXSTARGET; -#else - SV * TARG = sv_newmortal(); -#endif if (items != 0) { Perl_croak(aTHX_ @@ -279,11 +326,7 @@ XS(XS_attributes__warn_reserved) } EXTEND(SP,1); - ST(0) = TARG; - sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0); -#ifdef dXSTARGET - SvSETMAGIC(TARG); -#endif + ST(0) = boolSV(ckWARN(WARN_RESERVED)); XSRETURN(1); }