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 'k':
  58                     if (memEQ(name, "locked", 6)) {
  59                         if (negated)
  60                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LOCKED;
  61                         else
  62                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LOCKED;
  63                         continue;
  64                     }
  65                     break;
  66                 case 'h':
  67                     if (memEQ(name, "method", 6)) {
  68                         if (negated)
  69                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
  70                         else
  71                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
  72                         continue;
  73                     }
  74                     break;
  75                 }
  76                 break;
  77             }
  78             break;
  79         default:
  80             switch ((int)len) {
  81             case 6:
  82                 switch (name[5]) {
  83                 case 'd':
  84                     if (memEQ(name, "share", 5)) {
  85                         if (negated)
  86                             Perl_croak(aTHX_ "A variable may not be unshared");
  87                         SvSHARE(sv);
  88                         continue;
  89                     }
  90                     break;
  91                 case 'e':
  92                     if (memEQ(name, "uniqu", 5)) {
  93                         if (isGV_with_GP(sv)) {
  94                             if (negated) {
  95                                 GvUNIQUE_off(sv);
  96                             } else {
  97                                 GvUNIQUE_on(sv);
  98                             }
  99                         }
 100                         /* Hope this came from toke.c if not a GV. */
 101                         continue;
 102                     }
 103                 }
 104             }
 105             break;
 106         }
 107         /* anything recognized had a 'continue' above */
 108         *retlist++ = attr;
 109         nret++;
 110     }
 111
 112     return nret;
 113 }
 114
 115 MODULE = attributes             PACKAGE = attributes
 116
 117 void
 118 _modify_attrs(...)
 119   PREINIT:
 120     SV *rv, *sv;
 121   PPCODE:
 122
 123     if (items < 1) {
 124 usage:
 125         croak_xs_usage(cv, "@attributes");
 126     }
 127
 128     rv = ST(0);
 129     if (!(SvOK(rv) && SvROK(rv)))
 130         goto usage;
 131     sv = SvRV(rv);
 132     if (items > 1)
 133         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 134
 135     XSRETURN(0);
 136
 137 void
 138 _fetch_attrs(...)
 139   PREINIT:
 140     SV *rv, *sv;
 141     cv_flags_t cvflags;
 142   PPCODE:
 143     if (items != 1) {
 144 usage:
 145         croak_xs_usage(cv, "$reference");
 146     }
 147
 148     rv = ST(0);
 149     if (!(SvOK(rv) && SvROK(rv)))
 150         goto usage;
 151     sv = SvRV(rv);
 152
 153     switch (SvTYPE(sv)) {
 154     case SVt_PVCV:
 155         cvflags = CvFLAGS((const CV *)sv);
 156         if (cvflags & CVf_LOCKED)
 157             XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
 158         if (cvflags & CVf_LVALUE)
 159             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
 160         if (cvflags & CVf_METHOD)
 161             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
 162         if (GvUNIQUE(CvGV((const CV *)sv)))
 163             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
 164         break;
 165     case SVt_PVGV:
 166         if (isGV_with_GP(sv) && GvUNIQUE(sv))
 167             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
 168         break;
 169     default:
 170         break;
 171     }
 172
 173     PUTBACK;
 174
 175 void
 176 _guess_stash(...)
 177   PREINIT:
 178     SV *rv, *sv;
 179     dXSTARG;
 180   PPCODE:
 181     if (items != 1) {
 182 usage:
 183         croak_xs_usage(cv, "$reference");
 184     }
 185
 186     rv = ST(0);
 187     ST(0) = TARG;
 188     if (!(SvOK(rv) && SvROK(rv)))
 189         goto usage;
 190     sv = SvRV(rv);
 191
 192     if (SvOBJECT(sv))
 193         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
 194 #if 0   /* this was probably a bad idea */
 195     else if (SvPADMY(sv))
 196         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 197 #endif
 198     else {
 199         const HV *stash = NULL;
 200         switch (SvTYPE(sv)) {
 201         case SVt_PVCV:
 202             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 203                 stash = GvSTASH(CvGV(sv));
 204             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 205                 stash = CvSTASH(sv);
 206             break;
 207         case SVt_PVGV:
 208             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
 209                 stash = GvESTASH(MUTABLE_GV(sv));
 210             break;
 211         default:
 212             break;
 213         }
 214         if (stash)
 215             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
 216     }
 217
 218     SvSETMAGIC(TARG);
 219     XSRETURN(1);
 220
 221 void
 222 reftype(...)
 223   PREINIT:
 224     SV *rv, *sv;
 225     dXSTARG;
 226   PPCODE:
 227     if (items != 1) {
 228 usage:
 229         croak_xs_usage(cv, "$reference");
 230     }
 231
 232     rv = ST(0);
 233     ST(0) = TARG;
 234     SvGETMAGIC(rv);
 235     if (!(SvOK(rv) && SvROK(rv)))
 236         goto usage;
 237     sv = SvRV(rv);
 238     sv_setpv(TARG, sv_reftype(sv, 0));
 239     SvSETMAGIC(TARG);
 240
 241     XSRETURN(1);
 242 /*
 243  * Local variables:
 244  * c-indentation-style: bsd
 245  * c-basic-offset: 4
 246  * indent-tabs-mode: t
 247  * End:
 248  *
 249  * ex: set ts=8 sts=4 sw=4 noet:
 250  */