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         break;
 135     default:
 136         break;
 137     }
 138
 139     PUTBACK;
 140
 141 void
 142 _guess_stash(...)
 143   PREINIT:
 144     SV *rv, *sv;
 145     dXSTARG;
 146   PPCODE:
 147     if (items != 1) {
 148 usage:
 149         croak_xs_usage(cv, "$reference");
 150     }
 151
 152     rv = ST(0);
 153     ST(0) = TARG;
 154     if (!(SvOK(rv) && SvROK(rv)))
 155         goto usage;
 156     sv = SvRV(rv);
 157
 158     if (SvOBJECT(sv))
 159         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
 160 #if 0   /* this was probably a bad idea */
 161     else if (SvPADMY(sv))
 162         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 163 #endif
 164     else {
 165         const HV *stash = NULL;
 166         switch (SvTYPE(sv)) {
 167         case SVt_PVCV:
 168             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 169                 stash = GvSTASH(CvGV(sv));
 170             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 171                 stash = CvSTASH(sv);
 172             break;
 173         case SVt_PVGV:
 174             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
 175                 stash = GvESTASH(MUTABLE_GV(sv));
 176             break;
 177         default:
 178             break;
 179         }
 180         if (stash)
 181             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
 182     }
 183
 184     SvSETMAGIC(TARG);
 185     XSRETURN(1);
 186
 187 void
 188 reftype(...)
 189   PREINIT:
 190     SV *rv, *sv;
 191     dXSTARG;
 192   PPCODE:
 193     if (items != 1) {
 194 usage:
 195         croak_xs_usage(cv, "$reference");
 196     }
 197
 198     rv = ST(0);
 199     ST(0) = TARG;
 200     SvGETMAGIC(rv);
 201     if (!(SvOK(rv) && SvROK(rv)))
 202         goto usage;
 203     sv = SvRV(rv);
 204     sv_setpv(TARG, sv_reftype(sv, 0));
 205     SvSETMAGIC(TARG);
 206
 207     XSRETURN(1);
 208 /*
 209  * Local variables:
 210  * c-indentation-style: bsd
 211  * c-basic-offset: 4
 212  * indent-tabs-mode: t
 213  * End:
 214  *
 215  * ex: set ts=8 sts=4 sw=4 noet:
 216  */