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