xsutils.c

   1 /*    xsutils.c
   2  *
   3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   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 #ifdef CVf_ASSERTION
  75             case 9:
  76                 if (memEQ(name, "assertion", 9)) {
  77                     if (negated)
  78                         CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
  79                     else
  80                         CvFLAGS((CV*)sv) |= CVf_ASSERTION;
  81                     continue;
  82                 }
  83                 break;
  84 #endif
  85             case 6:
  86                 switch (name[3]) {
  87 #ifdef CVf_LVALUE
  88                 case 'l':
  89                     if (memEQ(name, "lvalue", 6)) {
  90                         if (negated)
  91                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  92                         else
  93                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  94                         continue;
  95                     }
  96                     break;
  97 #endif
  98                 case 'k':
  99                     if (memEQ(name, "locked", 6)) {
 100                         if (negated)
 101                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
 102                         else
 103                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
 104                         continue;
 105                     }
 106                     break;
 107                 case 'h':
 108                     if (memEQ(name, "method", 6)) {
 109                         if (negated)
 110                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
 111                         else
 112                             CvFLAGS((CV*)sv) |= CVf_METHOD;
 113                         continue;
 114                     }
 115                     break;
 116                 }
 117                 break;
 118             }
 119             break;
 120         default:
 121             switch ((int)len) {
 122             case 6:
 123                 switch (name[5]) {
 124                 case 'd':
 125                     if (memEQ(name, "share", 5)) {
 126                         if (negated)
 127                             Perl_croak(aTHX_ "A variable may not be unshared");
 128                         SvSHARE(sv);
 129                         continue;
 130                     }
 131                     break;
 132                 case 'e':
 133                     if (memEQ(name, "uniqu", 5)) {
 134                         if (SvTYPE(sv) == SVt_PVGV) {
 135                             if (negated) {
 136                                 GvUNIQUE_off(sv);
 137                             } else {
 138                                 GvUNIQUE_on(sv);
 139                             }
 140                         }
 141                         /* Hope this came from toke.c if not a GV. */
 142                         continue;
 143                     }
 144                 }
 145             }
 146             break;
 147         }
 148         /* anything recognized had a 'continue' above */
 149         *retlist++ = attr;
 150         nret++;
 151     }
 152
 153     return nret;
 154 }
 155
 156
 157
 158 /* package attributes; */
 159
 160 XS(XS_attributes_bootstrap)
 161 {
 162     dVAR;
 163     dXSARGS;
 164     PERL_UNUSED_ARG(cv);
 165
 166     if( items > 1 )
 167         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 168
 169     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 170     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 171     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 172     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 173
 174     XSRETURN(0);
 175 }
 176
 177 XS(XS_attributes__modify_attrs)
 178 {
 179     dVAR;
 180     dXSARGS;
 181     SV *rv, *sv;
 182     PERL_UNUSED_ARG(cv);
 183
 184     if (items < 1) {
 185 usage:
 186         Perl_croak(aTHX_
 187                    "Usage: attributes::_modify_attrs $reference, @attributes");
 188     }
 189
 190     rv = ST(0);
 191     if (!(SvOK(rv) && SvROK(rv)))
 192         goto usage;
 193     sv = SvRV(rv);
 194     if (items > 1)
 195         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 196
 197     XSRETURN(0);
 198 }
 199
 200 XS(XS_attributes__fetch_attrs)
 201 {
 202     dVAR;
 203     dXSARGS;
 204     SV *rv, *sv;
 205     cv_flags_t cvflags;
 206     PERL_UNUSED_ARG(cv);
 207
 208     if (items != 1) {
 209 usage:
 210         Perl_croak(aTHX_
 211                    "Usage: attributes::_fetch_attrs $reference");
 212     }
 213
 214     rv = ST(0);
 215     SP -= items;
 216     if (!(SvOK(rv) && SvROK(rv)))
 217         goto usage;
 218     sv = SvRV(rv);
 219
 220     switch (SvTYPE(sv)) {
 221     case SVt_PVCV:
 222         cvflags = CvFLAGS((CV*)sv);
 223         if (cvflags & CVf_LOCKED)
 224             XPUSHs(sv_2mortal(newSVpvs("locked")));
 225 #ifdef CVf_LVALUE
 226         if (cvflags & CVf_LVALUE)
 227             XPUSHs(sv_2mortal(newSVpvs("lvalue")));
 228 #endif
 229         if (cvflags & CVf_METHOD)
 230             XPUSHs(sv_2mortal(newSVpvs("method")));
 231         if (GvUNIQUE(CvGV((CV*)sv)))
 232             XPUSHs(sv_2mortal(newSVpvs("unique")));
 233         if (cvflags & CVf_ASSERTION)
 234             XPUSHs(sv_2mortal(newSVpvs("assertion")));
 235         break;
 236     case SVt_PVGV:
 237         if (GvUNIQUE(sv))
 238             XPUSHs(sv_2mortal(newSVpvs("unique")));
 239         break;
 240     default:
 241         break;
 242     }
 243
 244     PUTBACK;
 245 }
 246
 247 XS(XS_attributes__guess_stash)
 248 {
 249     dVAR;
 250     dXSARGS;
 251     SV *rv, *sv;
 252     dXSTARG;
 253     PERL_UNUSED_ARG(cv);
 254
 255     if (items != 1) {
 256 usage:
 257         Perl_croak(aTHX_
 258                    "Usage: attributes::_guess_stash $reference");
 259     }
 260
 261     rv = ST(0);
 262     ST(0) = TARG;
 263     if (!(SvOK(rv) && SvROK(rv)))
 264         goto usage;
 265     sv = SvRV(rv);
 266
 267     if (SvOBJECT(sv))
 268         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
 269 #if 0   /* this was probably a bad idea */
 270     else if (SvPADMY(sv))
 271         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 272 #endif
 273     else {
 274         const HV *stash = NULL;
 275         switch (SvTYPE(sv)) {
 276         case SVt_PVCV:
 277             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 278                 stash = GvSTASH(CvGV(sv));
 279             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 280                 stash = CvSTASH(sv);
 281             break;
 282         case SVt_PVGV:
 283             if (GvGP(sv) && GvESTASH((GV*)sv))
 284                 stash = GvESTASH((GV*)sv);
 285             break;
 286         default:
 287             break;
 288         }
 289         if (stash)
 290             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
 291     }
 292
 293     SvSETMAGIC(TARG);
 294     XSRETURN(1);
 295 }
 296
 297 XS(XS_attributes_reftype)
 298 {
 299     dVAR;
 300     dXSARGS;
 301     SV *rv, *sv;
 302     dXSTARG;
 303     PERL_UNUSED_ARG(cv);
 304
 305     if (items != 1) {
 306 usage:
 307         Perl_croak(aTHX_
 308                    "Usage: attributes::reftype $reference");
 309     }
 310
 311     rv = ST(0);
 312     ST(0) = TARG;
 313     SvGETMAGIC(rv);
 314     if (!(SvOK(rv) && SvROK(rv)))
 315         goto usage;
 316     sv = SvRV(rv);
 317     sv_setpv(TARG, sv_reftype(sv, 0));
 318     SvSETMAGIC(TARG);
 319
 320     XSRETURN(1);
 321 }
 322
 323 /*
 324  * Local variables:
 325  * c-indentation-style: bsd
 326  * c-basic-offset: 4
 327  * indent-tabs-mode: t
 328  * End:
 329  *
 330  * ex: set ts=8 sts=4 sw=4 noet:
 331  */