home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / xsutils.c < prev   
C/C++ Source or Header  |  2000-03-17  |  6KB  |  291 lines
  1. #include "EXTERN.h"
  2. #define PERL_IN_XSUTILS_C
  3. #include "perl.h"
  4.  
  5. /*
  6.  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
  7.  */
  8.  
  9. /* package attributes; */
  10. void XS_attributes__warn_reserved(pTHXo_ CV *cv);
  11. void XS_attributes_reftype(pTHXo_ CV *cv);
  12. void XS_attributes__modify_attrs(pTHXo_ CV *cv);
  13. void XS_attributes__guess_stash(pTHXo_ CV *cv);
  14. void XS_attributes__fetch_attrs(pTHXo_ CV *cv);
  15. void XS_attributes_bootstrap(pTHXo_ CV *cv);
  16.  
  17.  
  18. /*
  19.  * Note that only ${pkg}::bootstrap definitions should go here.
  20.  * This helps keep down the start-up time, which is especially
  21.  * relevant for users who don't invoke any features which are
  22.  * (partially) implemented here.
  23.  *
  24.  * The various bootstrap definitions can take care of doing
  25.  * package-specific newXS() calls.  Since the layout of the
  26.  * bundled *.pm files is in a version-specific directory,
  27.  * version checks in these bootstrap calls are optional.
  28.  */
  29.  
  30. void
  31. Perl_boot_core_xsutils(pTHX)
  32. {
  33.     char *file = __FILE__;
  34.  
  35.     newXS("attributes::bootstrap",    XS_attributes_bootstrap,    file);
  36. }
  37.  
  38. #include "XSUB.h"
  39.  
  40. static int
  41. modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
  42. {
  43.     SV *attr;
  44.     char *name;
  45.     STRLEN len;
  46.     bool negated;
  47.     int nret;
  48.  
  49.     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  50.     name = SvPV(attr, len);
  51.     if ((negated = (*name == '-'))) {
  52.         name++;
  53.         len--;
  54.     }
  55.     switch (SvTYPE(sv)) {
  56.     case SVt_PVCV:
  57.         switch ((int)len) {
  58.         case 6:
  59.         switch (*name) {
  60.         case 'l':
  61. #ifdef CVf_LVALUE
  62.             if (strEQ(name, "lvalue")) {
  63.             if (negated)
  64.                 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  65.             else
  66.                 CvFLAGS((CV*)sv) |= CVf_LVALUE;
  67.             continue;
  68.             }
  69. #endif /* defined CVf_LVALUE */
  70.             if (strEQ(name, "locked")) {
  71.             if (negated)
  72.                 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
  73.             else
  74.                 CvFLAGS((CV*)sv) |= CVf_LOCKED;
  75.             continue;
  76.             }
  77.             break;
  78.         case 'm':
  79.             if (strEQ(name, "method")) {
  80.             if (negated)
  81.                 CvFLAGS((CV*)sv) &= ~CVf_METHOD;
  82.             else
  83.                 CvFLAGS((CV*)sv) |= CVf_METHOD;
  84.             continue;
  85.             }
  86.             break;
  87.         }
  88.         break;
  89.         }
  90.         break;
  91.     default:
  92.         /* nothing, yet */
  93.         break;
  94.     }
  95.     /* anything recognized had a 'continue' above */
  96.     *retlist++ = attr;
  97.     nret++;
  98.     }
  99.  
  100.     return nret;
  101. }
  102.  
  103.  
  104.  
  105. /* package attributes; */
  106.  
  107. XS(XS_attributes_bootstrap)
  108. {
  109.     dXSARGS;
  110.     char *file = __FILE__;
  111.  
  112.     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
  113.     newXS("attributes::_modify_attrs",    XS_attributes__modify_attrs,    file);
  114.     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
  115.     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
  116.     newXSproto("attributes::reftype",    XS_attributes_reftype,    file, "$");
  117.  
  118.     XSRETURN(0);
  119. }
  120.  
  121. XS(XS_attributes__modify_attrs)
  122. {
  123.     dXSARGS;
  124.     SV *rv, *sv;
  125.  
  126.     if (items < 1) {
  127. usage:
  128.     Perl_croak(aTHX_
  129.            "Usage: attributes::_modify_attrs $reference, @attributes");
  130.     }
  131.  
  132.     rv = ST(0);
  133.     if (!(SvOK(rv) && SvROK(rv)))
  134.     goto usage;
  135.     sv = SvRV(rv);
  136.     if (items > 1)
  137.     XSRETURN(modify_SV_attributes(aTHXo_ sv, &ST(0), &ST(1), items-1));
  138.  
  139.     XSRETURN(0);
  140. }
  141.  
  142. XS(XS_attributes__fetch_attrs)
  143. {
  144.     dXSARGS;
  145.     SV *rv, *sv;
  146.     cv_flags_t cvflags;
  147.  
  148.     if (items != 1) {
  149. usage:
  150.     Perl_croak(aTHX_
  151.            "Usage: attributes::_fetch_attrs $reference");
  152.     }
  153.  
  154.     rv = ST(0);
  155.     SP -= items;
  156.     if (!(SvOK(rv) && SvROK(rv)))
  157.     goto usage;
  158.     sv = SvRV(rv);
  159.  
  160.     switch (SvTYPE(sv)) {
  161.     case SVt_PVCV:
  162.     cvflags = CvFLAGS((CV*)sv);
  163.     if (cvflags & CVf_LOCKED)
  164.         XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
  165. #ifdef CVf_LVALUE
  166.     if (cvflags & CVf_LVALUE)
  167.         XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
  168. #endif
  169.     if (cvflags & CVf_METHOD)
  170.         XPUSHs(sv_2mortal(newSVpvn("method", 6)));
  171.     break;
  172.     default:
  173.     break;
  174.     }
  175.  
  176.     PUTBACK;
  177. }
  178.  
  179. XS(XS_attributes__guess_stash)
  180. {
  181.     dXSARGS;
  182.     SV *rv, *sv;
  183. #ifdef dXSTARGET
  184.     dXSTARGET;
  185. #else
  186.     SV * TARG = sv_newmortal();
  187. #endif
  188.  
  189.     if (items != 1) {
  190. usage:
  191.     Perl_croak(aTHX_
  192.            "Usage: attributes::_guess_stash $reference");
  193.     }
  194.  
  195.     rv = ST(0);
  196.     ST(0) = TARG;
  197.     if (!(SvOK(rv) && SvROK(rv)))
  198.     goto usage;
  199.     sv = SvRV(rv);
  200.  
  201.     if (SvOBJECT(sv))
  202.     sv_setpv(TARG, HvNAME(SvSTASH(sv)));
  203. #if 0    /* this was probably a bad idea */
  204.     else if (SvPADMY(sv))
  205.     sv_setsv(TARG, &PL_sv_no);    /* unblessed lexical */
  206. #endif
  207.     else {
  208.     HV *stash = Nullhv;
  209.     switch (SvTYPE(sv)) {
  210.     case SVt_PVCV:
  211.         if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)) &&
  212.                 HvNAME(GvSTASH(CvGV(sv))))
  213.         stash = GvSTASH(CvGV(sv));
  214.         else if (/* !CvANON(sv) && */ CvSTASH(sv) && HvNAME(CvSTASH(sv)))
  215.         stash = CvSTASH(sv);
  216.         break;
  217.     case SVt_PVMG:
  218.         if (!(SvFAKE(sv) && SvTIED_mg(sv, '*')))
  219.         break;
  220.         /*FALLTHROUGH*/
  221.     case SVt_PVGV:
  222.         if (GvGP(sv) && GvESTASH((GV*)sv) && HvNAME(GvESTASH((GV*)sv)))
  223.         stash = GvESTASH((GV*)sv);
  224.         break;
  225.     default:
  226.         break;
  227.     }
  228.     if (stash)
  229.         sv_setpv(TARG, HvNAME(stash));
  230.     }
  231.  
  232. #ifdef dXSTARGET
  233.     SvSETMAGIC(TARG);
  234. #endif
  235.     XSRETURN(1);
  236. }
  237.  
  238. XS(XS_attributes_reftype)
  239. {
  240.     dXSARGS;
  241.     SV *rv, *sv;
  242. #ifdef dXSTARGET
  243.     dXSTARGET;
  244. #else
  245.     SV * TARG = sv_newmortal();
  246. #endif
  247.  
  248.     if (items != 1) {
  249. usage:
  250.     Perl_croak(aTHX_
  251.            "Usage: attributes::reftype $reference");
  252.     }
  253.  
  254.     rv = ST(0);
  255.     ST(0) = TARG;
  256.     if (!(SvOK(rv) && SvROK(rv)))
  257.     goto usage;
  258.     sv = SvRV(rv);
  259.     sv_setpv(TARG, sv_reftype(sv, 0));
  260. #ifdef dXSTARGET
  261.     SvSETMAGIC(TARG);
  262. #endif
  263.  
  264.     XSRETURN(1);
  265. }
  266.  
  267. XS(XS_attributes__warn_reserved)
  268. {
  269.     dXSARGS;
  270. #ifdef dXSTARGET
  271.     dXSTARGET;
  272. #else
  273.     SV * TARG = sv_newmortal();
  274. #endif
  275.  
  276.     if (items != 0) {
  277.     Perl_croak(aTHX_
  278.            "Usage: attributes::_warn_reserved ()");
  279.     }
  280.  
  281.     EXTEND(SP,1);
  282.     ST(0) = TARG;
  283.     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
  284. #ifdef dXSTARGET
  285.     SvSETMAGIC(TARG);
  286. #endif
  287.  
  288.     XSRETURN(1);
  289. }
  290.  
  291.