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__warn_reserved(pTHX_ CV *cv);
  27 PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
  28 PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
  29 PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
  30 PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
  31 PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
  32
  33
  34 /*
  35  * Note that only ${pkg}::bootstrap definitions should go here.
  36  * This helps keep down the start-up time, which is especially
  37  * relevant for users who don't invoke any features which are
  38  * (partially) implemented here.
  39  *
  40  * The various bootstrap definitions can take care of doing
  41  * package-specific newXS() calls.  Since the layout of the
  42  * bundled *.pm files is in a version-specific directory,
  43  * version checks in these bootstrap calls are optional.
  44  */
  45
  46 void
  47 Perl_boot_core_xsutils(pTHX)
  48 {
  49     const char file[] = __FILE__;
  50
  51     newXS("attributes::bootstrap",      XS_attributes_bootstrap,        file);
  52 }
  53
  54 #include "XSUB.h"
  55
  56 static int
  57 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
  58 {
  59     dVAR;
  60     SV *attr;
  61     int nret;
  62
  63     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  64         STRLEN len;
  65         const char *name = SvPV_const(attr, len);
  66         const bool negated = (*name == '-');
  67
  68         if (negated) {
  69             name++;
  70             len--;
  71         }
  72         switch (SvTYPE(sv)) {
  73         case SVt_PVCV:
  74             switch ((int)len) {
  75 #ifdef CVf_ASSERTION
  76             case 9:
  77                 if (memEQ(name, "assertion", 9)) {
  78                     if (negated)
  79                         CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
  80                     else
  81                         CvFLAGS((CV*)sv) |= CVf_ASSERTION;
  82                     continue;
  83                 }
  84                 break;
  85 #endif
  86             case 6:
  87                 switch (name[3]) {
  88                 case 'l':
  89 #ifdef CVf_LVALUE
  90                     if (memEQ(name, "lvalue", 6)) {
  91                         if (negated)
  92                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  93                         else
  94                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  95                         continue;
  96                     }
  97                     break;
  98                 case 'k':
  99 #endif /* defined CVf_LVALUE */
 100                     if (memEQ(name, "locked", 6)) {
 101                         if (negated)
 102                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
 103                         else
 104                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
 105                         continue;
 106                     }
 107                     break;
 108                 case 'h':
 109                     if (memEQ(name, "method", 6)) {
 110                         if (negated)
 111                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
 112                         else
 113                             CvFLAGS((CV*)sv) |= CVf_METHOD;
 114                         continue;
 115                     }
 116                     break;
 117                 }
 118                 break;
 119             }
 120             break;
 121         default:
 122             switch ((int)len) {
 123             case 6:
 124                 switch (name[5]) {
 125                 case 'd':
 126                     if (memEQ(name, "share", 5)) {
 127                         if (negated)
 128                             Perl_croak(aTHX_ "A variable may not be unshared");
 129                         SvSHARE(sv);
 130                         continue;
 131                     }
 132                     break;
 133                 case 'e':
 134                     if (memEQ(name, "uniqu", 5)) {
 135                         if (SvTYPE(sv) == SVt_PVGV) {
 136                             if (negated) {
 137                                 GvUNIQUE_off(sv);
 138                             } else {
 139                                 GvUNIQUE_on(sv);
 140                             }
 141                         }
 142                         /* Hope this came from toke.c if not a GV. */
 143                         continue;
 144                     }
 145                 }
 146             }
 147             break;
 148         }
 149         /* anything recognized had a 'continue' above */
 150         *retlist++ = attr;
 151         nret++;
 152     }
 153
 154     return nret;
 155 }
 156
 157
 158
 159 /* package attributes; */
 160
 161 XS(XS_attributes_bootstrap)
 162 {
 163     dVAR;
 164     dXSARGS;
 165     const char file[] = __FILE__;
 166
 167     if( items > 1 )
 168         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 169
 170     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
 171     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 172     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 173     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 174     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 175
 176     XSRETURN(0);
 177 }
 178
 179 XS(XS_attributes__modify_attrs)
 180 {
 181     dVAR;
 182     dXSARGS;
 183     SV *rv, *sv;
 184
 185     if (items < 1) {
 186 usage:
 187         Perl_croak(aTHX_
 188                    "Usage: attributes::_modify_attrs $reference, @attributes");
 189     }
 190
 191     rv = ST(0);
 192     if (!(SvOK(rv) && SvROK(rv)))
 193         goto usage;
 194     sv = SvRV(rv);
 195     if (items > 1)
 196         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 197
 198     XSRETURN(0);
 199 }
 200
 201 XS(XS_attributes__fetch_attrs)
 202 {
 203     dVAR;
 204     dXSARGS;
 205     SV *rv, *sv;
 206     cv_flags_t cvflags;
 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
 254     if (items != 1) {
 255 usage:
 256         Perl_croak(aTHX_
 257                    "Usage: attributes::_guess_stash $reference");
 258     }
 259
 260     rv = ST(0);
 261     ST(0) = TARG;
 262     if (!(SvOK(rv) && SvROK(rv)))
 263         goto usage;
 264     sv = SvRV(rv);
 265
 266     if (SvOBJECT(sv))
 267         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
 268 #if 0   /* this was probably a bad idea */
 269     else if (SvPADMY(sv))
 270         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 271 #endif
 272     else {
 273         const HV *stash = NULL;
 274         switch (SvTYPE(sv)) {
 275         case SVt_PVCV:
 276             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 277                 stash = GvSTASH(CvGV(sv));
 278             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 279                 stash = CvSTASH(sv);
 280             break;
 281         case SVt_PVMG:
 282             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
 283                 break;
 284             /*FALLTHROUGH*/
 285         case SVt_PVGV:
 286             if (GvGP(sv) && GvESTASH((GV*)sv))
 287                 stash = GvESTASH((GV*)sv);
 288             break;
 289         default:
 290             break;
 291         }
 292         if (stash)
 293             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
 294     }
 295
 296     SvSETMAGIC(TARG);
 297     XSRETURN(1);
 298 }
 299
 300 XS(XS_attributes_reftype)
 301 {
 302     dVAR;
 303     dXSARGS;
 304     SV *rv, *sv;
 305     dXSTARG;
 306
 307     if (items != 1) {
 308 usage:
 309         Perl_croak(aTHX_
 310                    "Usage: attributes::reftype $reference");
 311     }
 312
 313     rv = ST(0);
 314     ST(0) = TARG;
 315     SvGETMAGIC(rv);
 316     if (!(SvOK(rv) && SvROK(rv)))
 317         goto usage;
 318     sv = SvRV(rv);
 319     sv_setpv(TARG, sv_reftype(sv, 0));
 320     SvSETMAGIC(TARG);
 321
 322     XSRETURN(1);
 323 }
 324
 325 XS(XS_attributes__warn_reserved)
 326 {
 327     dVAR;
 328     dXSARGS;
 329
 330     if (items != 0) {
 331         Perl_croak(aTHX_
 332                    "Usage: attributes::_warn_reserved ()");
 333     }
 334
 335     EXTEND(SP,1);
 336     ST(0) = boolSV(ckWARN(WARN_RESERVED));
 337
 338     XSRETURN(1);
 339 }
 340
 341 /*
 342  * Local variables:
 343  * c-indentation-style: bsd
 344  * c-basic-offset: 4
 345  * indent-tabs-mode: t
 346  * End:
 347  *
 348  * ex: set ts=8 sts=4 sw=4 noet:
 349  */