xsutils.c

   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
  16
  17 #include "EXTERN.h"
  18 #define PERL_IN_XSUTILS_C
  19 #include "perl.h"
  20
  21 /*
  22  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
  23  */
  24
  25 /* package attributes; */
  26 PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
  27 PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
  28 PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
  29 PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
  30 PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
  31
  32
  33 /*
  34  * Note that only ${pkg}::bootstrap definitions should go here.
  35  * This helps keep down the start-up time, which is especially
  36  * relevant for users who don't invoke any features which are
  37  * (partially) implemented here.
  38  *
  39  * The various bootstrap definitions can take care of doing
  40  * package-specific newXS() calls.  Since the layout of the
  41  * bundled *.pm files is in a version-specific directory,
  42  * version checks in these bootstrap calls are optional.
  43  */
  44
  45 static const char file[] = __FILE__;
  46
  47 void
  48 Perl_boot_core_xsutils(pTHX)
  49 {
  50     newXS("attributes::bootstrap",      XS_attributes_bootstrap,        file);
  51 }
  52
  53 #include "XSUB.h"
  54
  55 static int
  56 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
  57 {
  58     dVAR;
  59     SV *attr;
  60     int nret;
  61
  62     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  63         STRLEN len;
  64         const char *name = SvPV_const(attr, len);
  65         const bool negated = (*name == '-');
  66
  67         if (negated) {
  68             name++;
  69             len--;
  70         }
  71         switch (SvTYPE(sv)) {
  72         case SVt_PVCV:
  73             switch ((int)len) {
  74             case 6:
  75                 switch (name[3]) {
  76 #ifdef CVf_LVALUE
  77                 case 'l':
  78                     if (memEQ(name, "lvalue", 6)) {
  79                         if (negated)
  80                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  81                         else
  82                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  83                         continue;
  84                     }
  85                     break;
  86 #endif
  87                 case 'k':
  88                     if (memEQ(name, "locked", 6)) {
  89                         if (negated)
  90                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
  91                         else
  92                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
  93                         continue;
  94                     }
  95                     break;
  96                 case 'h':
  97                     if (memEQ(name, "method", 6)) {
  98                         if (negated)
  99                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
 100                         else
 101                             CvFLAGS((CV*)sv) |= CVf_METHOD;
 102                         continue;
 103                     }
 104                     break;
 105                 }
 106                 break;
 107             }
 108             break;
 109         default:
 110             switch ((int)len) {
 111             case 6:
 112                 switch (name[5]) {
 113                 case 'd':
 114                     if (memEQ(name, "share", 5)) {
 115                         if (negated)
 116                             Perl_croak(aTHX_ "A variable may not be unshared");
 117                         SvSHARE(sv);
 118                         continue;
 119                     }
 120                     break;
 121                 case 'e':
 122                     if (memEQ(name, "uniqu", 5)) {
 123                         if (isGV_with_GP(sv)) {
 124                             if (negated) {
 125                                 GvUNIQUE_off(sv);
 126                             } else {
 127                                 GvUNIQUE_on(sv);
 128                             }
 129                         }
 130                         /* Hope this came from toke.c if not a GV. */
 131                         continue;
 132                     }
 133                 }
 134             }
 135             break;
 136         }
 137         /* anything recognized had a 'continue' above */
 138         *retlist++ = attr;
 139         nret++;
 140     }
 141
 142     return nret;
 143 }
 144
 145
 146
 147 /* package attributes; */
 148
 149 XS(XS_attributes_bootstrap)
 150 {
 151     dVAR;
 152     dXSARGS;
 153
 154     if( items > 1 )
 155         croak_xs_usage(cv, "$module");
 156
 157     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 158     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 159     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 160     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 161
 162     XSRETURN(0);
 163 }
 164
 165 XS(XS_attributes__modify_attrs)
 166 {
 167     dVAR;
 168     dXSARGS;
 169     SV *rv, *sv;
 170
 171     if (items < 1) {
 172 usage:
 173         croak_xs_usage(cv, "@attributes");
 174     }
 175
 176     rv = ST(0);
 177     if (!(SvOK(rv) && SvROK(rv)))
 178         goto usage;
 179     sv = SvRV(rv);
 180     if (items > 1)
 181         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 182
 183     XSRETURN(0);
 184 }
 185
 186 XS(XS_attributes__fetch_attrs)
 187 {
 188     dVAR;
 189     dXSARGS;
 190     SV *rv, *sv;
 191     cv_flags_t cvflags;
 192
 193     if (items != 1) {
 194 usage:
 195         croak_xs_usage(cv, "$reference");
 196     }
 197
 198     rv = ST(0);
 199     SP -= items;
 200     if (!(SvOK(rv) && SvROK(rv)))
 201         goto usage;
 202     sv = SvRV(rv);
 203
 204     switch (SvTYPE(sv)) {
 205     case SVt_PVCV:
 206         cvflags = CvFLAGS((CV*)sv);
 207         if (cvflags & CVf_LOCKED)
 208             XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
 209 #ifdef CVf_LVALUE
 210         if (cvflags & CVf_LVALUE)
 211             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
 212 #endif
 213         if (cvflags & CVf_METHOD)
 214             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
 215         if (GvUNIQUE(CvGV((CV*)sv)))
 216             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
 217         break;
 218     case SVt_PVGV:
 219         if (isGV_with_GP(sv) && GvUNIQUE(sv))
 220             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
 221         break;
 222     default:
 223         break;
 224     }
 225
 226     PUTBACK;
 227 }
 228
 229 XS(XS_attributes__guess_stash)
 230 {
 231     dVAR;
 232     dXSARGS;
 233     SV *rv, *sv;
 234     dXSTARG;
 235
 236     if (items != 1) {
 237 usage:
 238         croak_xs_usage(cv, "$reference");
 239     }
 240
 241     rv = ST(0);
 242     ST(0) = TARG;
 243     if (!(SvOK(rv) && SvROK(rv)))
 244         goto usage;
 245     sv = SvRV(rv);
 246
 247     if (SvOBJECT(sv))
 248         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
 249 #if 0   /* this was probably a bad idea */
 250     else if (SvPADMY(sv))
 251         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 252 #endif
 253     else {
 254         const HV *stash = NULL;
 255         switch (SvTYPE(sv)) {
 256         case SVt_PVCV:
 257             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 258                 stash = GvSTASH(CvGV(sv));
 259             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 260                 stash = CvSTASH(sv);
 261             break;
 262         case SVt_PVGV:
 263             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH((GV*)sv))
 264                 stash = GvESTASH((GV*)sv);
 265             break;
 266         default:
 267             break;
 268         }
 269         if (stash)
 270             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
 271     }
 272
 273     SvSETMAGIC(TARG);
 274     XSRETURN(1);
 275 }
 276
 277 XS(XS_attributes_reftype)
 278 {
 279     dVAR;
 280     dXSARGS;
 281     SV *rv, *sv;
 282     dXSTARG;
 283
 284     if (items != 1) {
 285 usage:
 286         croak_xs_usage(cv, "$reference");
 287     }
 288
 289     rv = ST(0);
 290     ST(0) = TARG;
 291     SvGETMAGIC(rv);
 292     if (!(SvOK(rv) && SvROK(rv)))
 293         goto usage;
 294     sv = SvRV(rv);
 295     sv_setpv(TARG, sv_reftype(sv, 0));
 296     SvSETMAGIC(TARG);
 297
 298     XSRETURN(1);
 299 }
 300
 301 /*
 302  * Local variables:
 303  * c-indentation-style: bsd
 304  * c-basic-offset: 4
 305  * indent-tabs-mode: t
 306  * End:
 307  *
 308  * ex: set ts=8 sts=4 sw=4 noet:
 309  */