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