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     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 5:
  47                 if (memEQ(name, "const", 5)) {
  48                     if (negated)
  49                         CvANONCONST_off(sv);
  50                     else {
  51                         const bool warn = (!CvANON(sv) || CvCLONED(sv))
  52                                        && !CvANONCONST(sv);
  53                         CvANONCONST_on(sv);
  54                         if (warn)
  55                             break;
  56                     }
  57                     continue;
  58                 }
  59                 break;
  60             case 6:
  61                 switch (name[3]) {
  62                 case 'l':
  63                     if (memEQ(name, "lvalue", 6)) {
  64                         bool warn =
  65                             !CvISXSUB(MUTABLE_CV(sv))
  66                          && CvROOT(MUTABLE_CV(sv))
  67                          && !CvLVALUE(MUTABLE_CV(sv)) != negated;
  68                         if (negated)
  69                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
  70                         else
  71                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
  72                         if (warn) break;
  73                         continue;
  74                     }
  75                     break;
  76                 case 'h':
  77                     if (memEQ(name, "method", 6)) {
  78                         if (negated)
  79                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
  80                         else
  81                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
  82                         continue;
  83                     }
  84                     break;
  85                 }
  86                 break;
  87             default:
  88                 if (len > 10 && memEQ(name, "prototype(", 10)) {
  89                     SV * proto = newSVpvn(name+10,len-11);
  90                     HEK *const hek = CvNAME_HEK((CV *)sv);
  91                     SV *subname;
  92                     if (name[len-1] != ')')
  93                         Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
  94                     if (hek)
  95                         subname = sv_2mortal(newSVhek(hek));
  96                     else
  97                         subname=(SV *)CvGV((const CV *)sv);
  98                     if (ckWARN(WARN_ILLEGALPROTO))
  99                         Perl_validate_proto(aTHX_ subname, proto, TRUE);
 100                     Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
 101                                                     (const GV *)subname,
 102                                                     name+10,
 103                                                     len-11,
 104                                                     SvUTF8(attr));
 105                     sv_setpvn(MUTABLE_SV(sv), name+10, len-11);
 106                     if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv));
 107                     continue;
 108                 }
 109                 break;
 110             }
 111             break;
 112         default:
 113             if (memEQs(name, len, "shared")) {
 114                         if (negated)
 115                             Perl_croak(aTHX_ "A variable may not be unshared");
 116                         SvSHARE(sv);
 117                         continue;
 118             }
 119             break;
 120         }
 121         /* anything recognized had a 'continue' above */
 122         *retlist++ = attr;
 123         nret++;
 124     }
 125
 126     return nret;
 127 }
 128
 129 MODULE = attributes             PACKAGE = attributes
 130
 131 void
 132 _modify_attrs(...)
 133   PREINIT:
 134     SV *rv, *sv;
 135   PPCODE:
 136
 137     if (items < 1) {
 138 usage:
 139         croak_xs_usage(cv, "@attributes");
 140     }
 141
 142     rv = ST(0);
 143     if (!(SvOK(rv) && SvROK(rv)))
 144         goto usage;
 145     sv = SvRV(rv);
 146     if (items > 1)
 147         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 148
 149     XSRETURN(0);
 150
 151 void
 152 _fetch_attrs(...)
 153   PROTOTYPE: $
 154   PREINIT:
 155     SV *rv, *sv;
 156     cv_flags_t cvflags;
 157   PPCODE:
 158     if (items != 1) {
 159 usage:
 160         croak_xs_usage(cv, "$reference");
 161     }
 162
 163     rv = ST(0);
 164     if (!(SvOK(rv) && SvROK(rv)))
 165         goto usage;
 166     sv = SvRV(rv);
 167
 168     switch (SvTYPE(sv)) {
 169     case SVt_PVCV:
 170         cvflags = CvFLAGS((const CV *)sv);
 171         if (cvflags & CVf_LVALUE)
 172             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
 173         if (cvflags & CVf_METHOD)
 174             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
 175         break;
 176     default:
 177         break;
 178     }
 179
 180     PUTBACK;
 181
 182 void
 183 _guess_stash(...)
 184   PROTOTYPE: $
 185   PREINIT:
 186     SV *rv, *sv;
 187     dXSTARG;
 188   PPCODE:
 189     if (items != 1) {
 190 usage:
 191         croak_xs_usage(cv, "$reference");
 192     }
 193
 194     rv = ST(0);
 195     ST(0) = TARG;
 196     if (!(SvOK(rv) && SvROK(rv)))
 197         goto usage;
 198     sv = SvRV(rv);
 199
 200     if (SvOBJECT(sv))
 201         Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(SvSTASH(sv)));
 202 #if 0   /* this was probably a bad idea */
 203     else if (SvPADMY(sv))
 204         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 205 #endif
 206     else {
 207         const HV *stash = NULL;
 208         switch (SvTYPE(sv)) {
 209         case SVt_PVCV:
 210             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 211                 stash = GvSTASH(CvGV(sv));
 212             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 213                 stash = CvSTASH(sv);
 214             break;
 215         case SVt_PVGV:
 216             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
 217                 stash = GvESTASH(MUTABLE_GV(sv));
 218             break;
 219         default:
 220             break;
 221         }
 222         if (stash)
 223             Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(stash));
 224     }
 225
 226     SvSETMAGIC(TARG);
 227     XSRETURN(1);
 228
 229 void
 230 reftype(...)
 231   PROTOTYPE: $
 232   PREINIT:
 233     SV *rv, *sv;
 234     dXSTARG;
 235   PPCODE:
 236     if (items != 1) {
 237 usage:
 238         croak_xs_usage(cv, "$reference");
 239     }
 240
 241     rv = ST(0);
 242     ST(0) = TARG;
 243     SvGETMAGIC(rv);
 244     if (!(SvOK(rv) && SvROK(rv)))
 245         goto usage;
 246     sv = SvRV(rv);
 247     sv_setpv(TARG, sv_reftype(sv, 0));
 248     SvSETMAGIC(TARG);
 249
 250     XSRETURN(1);
 251 /*
 252  * ex: set ts=8 sts=4 sw=4 et:
 253  */