ext/attributes/attributes.xs

   1 /*    xsutils.c
   2  *
   3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   4  *    by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * 'Perilous to us all are the devices of an art deeper than we possess
  13  *  ourselves.'                                            --Gandalf
  14  *
  15  *     [p.597 of _The Lord of the Rings_, III/xi: "The Palantír"]
  16  */
  17
  18
  19 #include "EXTERN.h"
  20 #include "perl.h"
  21 #include "XSUB.h"
  22
  23 /*
  24  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
  25  */
  26
  27 static int
  28 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
  29 {
  30     dVAR;
  31     SV *attr;
  32     int nret;
  33
  34     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  35         STRLEN len;
  36         const char *name = SvPV_const(attr, len);
  37         const bool negated = (*name == '-');
  38
  39         if (negated) {
  40             name++;
  41             len--;
  42         }
  43         switch (SvTYPE(sv)) {
  44         case SVt_PVCV:
  45             switch ((int)len) {
  46             case 6:
  47                 switch (name[3]) {
  48                 case 'l':
  49                     if (memEQ(name, "lvalue", 6)) {
  50                         if (negated)
  51                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
  52                         else
  53                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
  54                         continue;
  55                     }
  56                     break;
  57                 case 'h':
  58                     if (memEQ(name, "method", 6)) {
  59                         if (negated)
  60                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
  61                         else
  62                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
  63                         continue;
  64                     }
  65                     break;
  66                 }
  67                 break;
  68             }
  69             break;
  70         default:
  71             if (memEQs(name, 6, "shared")) {
  72                         if (negated)
  73                             Perl_croak(aTHX_ "A variable may not be unshared");
  74                         SvSHARE(sv);
  75                         continue;
  76             }
  77             break;
  78         }
  79         /* anything recognized had a 'continue' above */
  80         *retlist++ = attr;
  81         nret++;
  82     }
  83
  84     return nret;
  85 }
  86
  87 MODULE = attributes             PACKAGE = attributes
  88
  89 void
  90 _modify_attrs(...)
  91   PREINIT:
  92     SV *rv, *sv;
  93   PPCODE:
  94
  95     if (items < 1) {
  96 usage:
  97         croak_xs_usage(cv, "@attributes");
  98     }
  99
 100     rv = ST(0);
 101     if (!(SvOK(rv) && SvROK(rv)))
 102         goto usage;
 103     sv = SvRV(rv);
 104     if (items > 1)
 105         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 106
 107     XSRETURN(0);
 108
 109 void
 110 _fetch_attrs(...)
 111   PREINIT:
 112     SV *rv, *sv;
 113     cv_flags_t cvflags;
 114   PPCODE:
 115     if (items != 1) {
 116 usage:
 117         croak_xs_usage(cv, "$reference");
 118     }
 119
 120     rv = ST(0);
 121     if (!(SvOK(rv) && SvROK(rv)))
 122         goto usage;
 123     sv = SvRV(rv);
 124
 125     switch (SvTYPE(sv)) {
 126     case SVt_PVCV:
 127         cvflags = CvFLAGS((const CV *)sv);
 128         if (cvflags & CVf_LOCKED)
 129             XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
 130         if (cvflags & CVf_LVALUE)
 131             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
 132         if (cvflags & CVf_METHOD)
 133             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
 134         if (GvUNIQUE(CvGV((const CV *)sv)))
 135             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
 136         break;
 137     case SVt_PVGV:
 138         if (isGV_with_GP(sv) && GvUNIQUE(sv))
 139             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
 140         break;
 141     default:
 142         break;
 143     }
 144
 145     PUTBACK;
 146
 147 void
 148 _guess_stash(...)
 149   PREINIT:
 150     SV *rv, *sv;
 151     dXSTARG;
 152   PPCODE:
 153     if (items != 1) {
 154 usage:
 155         croak_xs_usage(cv, "$reference");
 156     }
 157
 158     rv = ST(0);
 159     ST(0) = TARG;
 160     if (!(SvOK(rv) && SvROK(rv)))
 161         goto usage;
 162     sv = SvRV(rv);
 163
 164     if (SvOBJECT(sv))
 165         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
 166 #if 0   /* this was probably a bad idea */
 167     else if (SvPADMY(sv))
 168         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 169 #endif
 170     else {
 171         const HV *stash = NULL;
 172         switch (SvTYPE(sv)) {
 173         case SVt_PVCV:
 174             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 175                 stash = GvSTASH(CvGV(sv));
 176             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 177                 stash = CvSTASH(sv);
 178             break;
 179         case SVt_PVGV:
 180             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
 181                 stash = GvESTASH(MUTABLE_GV(sv));
 182             break;
 183         default:
 184             break;
 185         }
 186         if (stash)
 187             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
 188     }
 189
 190     SvSETMAGIC(TARG);
 191     XSRETURN(1);
 192
 193 void
 194 reftype(...)
 195   PREINIT:
 196     SV *rv, *sv;
 197     dXSTARG;
 198   PPCODE:
 199     if (items != 1) {
 200 usage:
 201         croak_xs_usage(cv, "$reference");
 202     }
 203
 204     rv = ST(0);
 205     ST(0) = TARG;
 206     SvGETMAGIC(rv);
 207     if (!(SvOK(rv) && SvROK(rv)))
 208         goto usage;
 209     sv = SvRV(rv);
 210     sv_setpv(TARG, sv_reftype(sv, 0));
 211     SvSETMAGIC(TARG);
 212
 213     XSRETURN(1);
 214 /*
 215  * Local variables:
 216  * c-indentation-style: bsd
 217  * c-basic-offset: 4
 218  * indent-tabs-mode: t
 219  * End:
 220  *
 221  * ex: set ts=8 sts=4 sw=4 noet:
 222  */