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 /*
  11  * "Perilous to us all are the devices of an art deeper than we possess
  12  * ourselves." --Gandalf
  13  */
  14
  15
  16 #include "EXTERN.h"
  17 #define PERL_IN_XSUTILS_C
  18 #include "perl.h"
  19
  20 /*
  21  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
  22  */
  23
  24 /* package attributes; */
  25 void XS_attributes__warn_reserved(pTHX_ CV *cv);
  26 void XS_attributes_reftype(pTHX_ CV *cv);
  27 void XS_attributes__modify_attrs(pTHX_ CV *cv);
  28 void XS_attributes__guess_stash(pTHX_ CV *cv);
  29 void XS_attributes__fetch_attrs(pTHX_ CV *cv);
  30 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 void
  46 Perl_boot_core_xsutils(pTHX)
  47 {
  48     char *file = __FILE__;
  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     SV *attr;
  59     char *name;
  60     STRLEN len;
  61     bool negated;
  62     int nret;
  63
  64     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  65         name = SvPV(attr, len);
  66         if ((negated = (*name == '-'))) {
  67             name++;
  68             len--;
  69         }
  70         switch (SvTYPE(sv)) {
  71         case SVt_PVCV:
  72             switch ((int)len) {
  73             case 6:
  74                 switch (*name) {
  75                 case 'l':
  76 #ifdef CVf_LVALUE
  77                     if (strEQ(name, "lvalue")) {
  78                         if (negated)
  79                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  80                         else
  81                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  82                         continue;
  83                     }
  84 #endif /* defined CVf_LVALUE */
  85                     if (strEQ(name, "locked")) {
  86                         if (negated)
  87                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
  88                         else
  89                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
  90                         continue;
  91                     }
  92                     break;
  93                 case 'm':
  94                     if (strEQ(name, "method")) {
  95                         if (negated)
  96                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
  97                         else
  98                             CvFLAGS((CV*)sv) |= CVf_METHOD;
  99                         continue;
 100                     }
 101                     break;
 102                 case 'u':
 103                     if (strEQ(name, "unique")) {
 104                         if (negated)
 105                             GvUNIQUE_off(CvGV((CV*)sv));
 106                         else
 107                             GvUNIQUE_on(CvGV((CV*)sv));
 108                         continue;
 109                     }
 110                     break;
 111                 }
 112                 break;
 113             }
 114             break;
 115         default:
 116             switch ((int)len) {
 117             case 6:
 118                 switch (*name) {
 119                 case 'u':
 120                     if (strEQ(name, "unique")) {
 121                         if (SvTYPE(sv) == SVt_PVGV) {
 122                             if (negated)
 123                                 GvUNIQUE_off(sv);
 124                             else
 125                                 GvUNIQUE_on(sv);
 126                         }
 127                         /* Hope this came from toke.c if not a GV. */
 128                         continue;
 129                     }
 130                 }
 131             }
 132             break;
 133         }
 134         /* anything recognized had a 'continue' above */
 135         *retlist++ = attr;
 136         nret++;
 137     }
 138
 139     return nret;
 140 }
 141
 142
 143
 144 /* package attributes; */
 145
 146 XS(XS_attributes_bootstrap)
 147 {
 148     dXSARGS;
 149     char *file = __FILE__;
 150
 151     if( items > 1 )
 152         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 153
 154     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
 155     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 156     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 157     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 158     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 159
 160     XSRETURN(0);
 161 }
 162
 163 XS(XS_attributes__modify_attrs)
 164 {
 165     dXSARGS;
 166     SV *rv, *sv;
 167
 168     if (items < 1) {
 169 usage:
 170         Perl_croak(aTHX_
 171                    "Usage: attributes::_modify_attrs $reference, @attributes");
 172     }
 173
 174     rv = ST(0);
 175     if (!(SvOK(rv) && SvROK(rv)))
 176         goto usage;
 177     sv = SvRV(rv);
 178     if (items > 1)
 179         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 180
 181     XSRETURN(0);
 182 }
 183
 184 XS(XS_attributes__fetch_attrs)
 185 {
 186     dXSARGS;
 187     SV *rv, *sv;
 188     cv_flags_t cvflags;
 189
 190     if (items != 1) {
 191 usage:
 192         Perl_croak(aTHX_
 193                    "Usage: attributes::_fetch_attrs $reference");
 194     }
 195
 196     rv = ST(0);
 197     SP -= items;
 198     if (!(SvOK(rv) && SvROK(rv)))
 199         goto usage;
 200     sv = SvRV(rv);
 201
 202     switch (SvTYPE(sv)) {
 203     case SVt_PVCV:
 204         cvflags = CvFLAGS((CV*)sv);
 205         if (cvflags & CVf_LOCKED)
 206             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
 207 #ifdef CVf_LVALUE
 208         if (cvflags & CVf_LVALUE)
 209             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
 210 #endif
 211         if (cvflags & CVf_METHOD)
 212             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
 213         if (GvUNIQUE(CvGV((CV*)sv)))
 214             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 215         break;
 216     case SVt_PVGV:
 217         if (GvUNIQUE(sv))
 218             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 219         break;
 220     default:
 221         break;
 222     }
 223
 224     PUTBACK;
 225 }
 226
 227 XS(XS_attributes__guess_stash)
 228 {
 229     dXSARGS;
 230     SV *rv, *sv;
 231 #ifdef dXSTARGET
 232     dXSTARGET;
 233 #else
 234     SV * TARG = sv_newmortal();
 235 #endif
 236
 237     if (items != 1) {
 238 usage:
 239         Perl_croak(aTHX_
 240                    "Usage: attributes::_guess_stash $reference");
 241     }
 242
 243     rv = ST(0);
 244     ST(0) = TARG;
 245     if (!(SvOK(rv) && SvROK(rv)))
 246         goto usage;
 247     sv = SvRV(rv);
 248
 249     if (SvOBJECT(sv))
 250         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
 251 #if 0   /* this was probably a bad idea */
 252     else if (SvPADMY(sv))
 253         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 254 #endif
 255     else {
 256         HV *stash = Nullhv;
 257         switch (SvTYPE(sv)) {
 258         case SVt_PVCV:
 259             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 260                 stash = GvSTASH(CvGV(sv));
 261             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 262                 stash = CvSTASH(sv);
 263             break;
 264         case SVt_PVMG:
 265             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
 266                 break;
 267             /*FALLTHROUGH*/
 268         case SVt_PVGV:
 269             if (GvGP(sv) && GvESTASH((GV*)sv))
 270                 stash = GvESTASH((GV*)sv);
 271             break;
 272         default:
 273             break;
 274         }
 275         if (stash)
 276             sv_setpv(TARG, HvNAME(stash));
 277     }
 278
 279 #ifdef dXSTARGET
 280     SvSETMAGIC(TARG);
 281 #endif
 282     XSRETURN(1);
 283 }
 284
 285 XS(XS_attributes_reftype)
 286 {
 287     dXSARGS;
 288     SV *rv, *sv;
 289 #ifdef dXSTARGET
 290     dXSTARGET;
 291 #else
 292     SV * TARG = sv_newmortal();
 293 #endif
 294
 295     if (items != 1) {
 296 usage:
 297         Perl_croak(aTHX_
 298                    "Usage: attributes::reftype $reference");
 299     }
 300
 301     rv = ST(0);
 302     ST(0) = TARG;
 303     if (SvGMAGICAL(rv))
 304         mg_get(rv);
 305     if (!(SvOK(rv) && SvROK(rv)))
 306         goto usage;
 307     sv = SvRV(rv);
 308     sv_setpv(TARG, sv_reftype(sv, 0));
 309 #ifdef dXSTARGET
 310     SvSETMAGIC(TARG);
 311 #endif
 312
 313     XSRETURN(1);
 314 }
 315
 316 XS(XS_attributes__warn_reserved)
 317 {
 318     dXSARGS;
 319 #ifdef dXSTARGET
 320     dXSTARGET;
 321 #else
 322     SV * TARG = sv_newmortal();
 323 #endif
 324
 325     if (items != 0) {
 326         Perl_croak(aTHX_
 327                    "Usage: attributes::_warn_reserved ()");
 328     }
 329
 330     EXTEND(SP,1);
 331     ST(0) = TARG;
 332     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
 333 #ifdef dXSTARGET
 334     SvSETMAGIC(TARG);
 335 #endif
 336
 337     XSRETURN(1);
 338 }
 339