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 #define PERL_NO_GET_CONTEXT
  19
  20 #include "EXTERN.h"
  21 #include "perl.h"
  22 #include "XSUB.h"
  23
  24 /*
  25  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
  26  */
  27
  28 static int
  29 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
  30 {
  31     dVAR;
  32     SV *attr;
  33     int nret;
  34
  35     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  36         STRLEN len;
  37         const char *name = SvPV_const(attr, len);
  38         const bool negated = (*name == '-');
  39
  40         if (negated) {
  41             name++;
  42             len--;
  43         }
  44         switch (SvTYPE(sv)) {
  45         case SVt_PVCV:
  46             switch ((int)len) {
  47             case 6:
  48                 switch (name[3]) {
  49                 case 'l':
  50                     if (memEQ(name, "lvalue", 6)) {
  51                         if (negated)
  52                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
  53                         else
  54                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
  55                         continue;
  56                     }
  57                     break;
  58                 case 'h':
  59                     if (memEQ(name, "method", 6)) {
  60                         if (negated)
  61                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
  62                         else
  63                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
  64                         continue;
  65                     }
  66                     break;
  67                 }
  68                 break;
  69             }
  70             break;
  71         default:
  72             if (memEQs(name, 6, "shared")) {
  73                         if (negated)
  74                             Perl_croak(aTHX_ "A variable may not be unshared");
  75                         SvSHARE(sv);
  76                         continue;
  77             }
  78             break;
  79         }
  80         /* anything recognized had a 'continue' above */
  81         *retlist++ = attr;
  82         nret++;
  83     }
  84
  85     return nret;
  86 }
  87
  88 MODULE = attributes             PACKAGE = attributes
  89
  90 void
  91 _modify_attrs(...)
  92   PREINIT:
  93     SV *rv, *sv;
  94   PPCODE:
  95
  96     if (items < 1) {
  97 usage:
  98         croak_xs_usage(cv, "@attributes");
  99     }
 100
 101     rv = ST(0);
 102     if (!(SvOK(rv) && SvROK(rv)))
 103         goto usage;
 104     sv = SvRV(rv);
 105     if (items > 1)
 106         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 107
 108     XSRETURN(0);
 109
 110 void
 111 _fetch_attrs(...)
 112   PROTOTYPE: $
 113   PREINIT:
 114     SV *rv, *sv;
 115     cv_flags_t cvflags;
 116   PPCODE:
 117     if (items != 1) {
 118 usage:
 119         croak_xs_usage(cv, "$reference");
 120     }
 121
 122     rv = ST(0);
 123     if (!(SvOK(rv) && SvROK(rv)))
 124         goto usage;
 125     sv = SvRV(rv);
 126
 127     switch (SvTYPE(sv)) {
 128     case SVt_PVCV:
 129         cvflags = CvFLAGS((const CV *)sv);
 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   PROTOTYPE: $
 144   PREINIT:
 145     SV *rv, *sv;
 146     dXSTARG;
 147   PPCODE:
 148     if (items != 1) {
 149 usage:
 150         croak_xs_usage(cv, "$reference");
 151     }
 152
 153     rv = ST(0);
 154     ST(0) = TARG;
 155     if (!(SvOK(rv) && SvROK(rv)))
 156         goto usage;
 157     sv = SvRV(rv);
 158
 159     if (SvOBJECT(sv))
 160         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
 161 #if 0   /* this was probably a bad idea */
 162     else if (SvPADMY(sv))
 163         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 164 #endif
 165     else {
 166         const HV *stash = NULL;
 167         switch (SvTYPE(sv)) {
 168         case SVt_PVCV:
 169             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 170                 stash = GvSTASH(CvGV(sv));
 171             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 172                 stash = CvSTASH(sv);
 173             break;
 174         case SVt_PVGV:
 175             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
 176                 stash = GvESTASH(MUTABLE_GV(sv));
 177             break;
 178         default:
 179             break;
 180         }
 181         if (stash)
 182             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
 183     }
 184
 185     SvSETMAGIC(TARG);
 186     XSRETURN(1);
 187
 188 void
 189 reftype(...)
 190   PROTOTYPE: $
 191   PREINIT:
 192     SV *rv, *sv;
 193     dXSTARG;
 194   PPCODE:
 195     if (items != 1) {
 196 usage:
 197         croak_xs_usage(cv, "$reference");
 198     }
 199
 200     rv = ST(0);
 201     ST(0) = TARG;
 202     SvGETMAGIC(rv);
 203     if (!(SvOK(rv) && SvROK(rv)))
 204         goto usage;
 205     sv = SvRV(rv);
 206     sv_setpv(TARG, sv_reftype(sv, 0));
 207     SvSETMAGIC(TARG);
 208
 209     XSRETURN(1);
 210 /*
 211  * Local variables:
 212  * c-indentation-style: bsd
 213  * c-basic-offset: 4
 214  * indent-tabs-mode: t
 215  * End:
 216  *
 217  * ex: set ts=8 sts=4 sw=4 noet:
 218  */