xsutils.c

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