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