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