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 's':
 120                     if (strEQ(name, "shared")) {
 121                         if (negated)
 122                             Perl_croak(aTHX_ "A variable may not be unshared");
 123                         SvSHARE(sv);
 124                         continue;
 125                     }
 126                     break;
 127                 case 'u':
 128                     if (strEQ(name, "unique")) {
 129                         if (SvTYPE(sv) == SVt_PVGV) {
 130                             if (negated)
 131                                 GvUNIQUE_off(sv);
 132                             else
 133                                 GvUNIQUE_on(sv);
 134                         }
 135                         /* Hope this came from toke.c if not a GV. */
 136                         continue;
 137                     }
 138                 }
 139             }
 140             break;
 141         }
 142         /* anything recognized had a 'continue' above */
 143         *retlist++ = attr;
 144         nret++;
 145     }
 146
 147     return nret;
 148 }
 149
 150
 151
 152 /* package attributes; */
 153
 154 XS(XS_attributes_bootstrap)
 155 {
 156     dXSARGS;
 157     char *file = __FILE__;
 158
 159     if( items > 1 )
 160         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 161
 162     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
 163     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 164     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 165     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 166     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 167
 168     XSRETURN(0);
 169 }
 170
 171 XS(XS_attributes__modify_attrs)
 172 {
 173     dXSARGS;
 174     SV *rv, *sv;
 175
 176     if (items < 1) {
 177 usage:
 178         Perl_croak(aTHX_
 179                    "Usage: attributes::_modify_attrs $reference, @attributes");
 180     }
 181
 182     rv = ST(0);
 183     if (!(SvOK(rv) && SvROK(rv)))
 184         goto usage;
 185     sv = SvRV(rv);
 186     if (items > 1)
 187         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 188
 189     XSRETURN(0);
 190 }
 191
 192 XS(XS_attributes__fetch_attrs)
 193 {
 194     dXSARGS;
 195     SV *rv, *sv;
 196     cv_flags_t cvflags;
 197
 198     if (items != 1) {
 199 usage:
 200         Perl_croak(aTHX_
 201                    "Usage: attributes::_fetch_attrs $reference");
 202     }
 203
 204     rv = ST(0);
 205     SP -= items;
 206     if (!(SvOK(rv) && SvROK(rv)))
 207         goto usage;
 208     sv = SvRV(rv);
 209
 210     switch (SvTYPE(sv)) {
 211     case SVt_PVCV:
 212         cvflags = CvFLAGS((CV*)sv);
 213         if (cvflags & CVf_LOCKED)
 214             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
 215 #ifdef CVf_LVALUE
 216         if (cvflags & CVf_LVALUE)
 217             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
 218 #endif
 219         if (cvflags & CVf_METHOD)
 220             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
 221         if (GvUNIQUE(CvGV((CV*)sv)))
 222             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 223         break;
 224     case SVt_PVGV:
 225         if (GvUNIQUE(sv))
 226             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 227         break;
 228     default:
 229         break;
 230     }
 231
 232     PUTBACK;
 233 }
 234
 235 XS(XS_attributes__guess_stash)
 236 {
 237     dXSARGS;
 238     SV *rv, *sv;
 239 #ifdef dXSTARGET
 240     dXSTARGET;
 241 #else
 242     SV * TARG = sv_newmortal();
 243 #endif
 244
 245     if (items != 1) {
 246 usage:
 247         Perl_croak(aTHX_
 248                    "Usage: attributes::_guess_stash $reference");
 249     }
 250
 251     rv = ST(0);
 252     ST(0) = TARG;
 253     if (!(SvOK(rv) && SvROK(rv)))
 254         goto usage;
 255     sv = SvRV(rv);
 256
 257     if (SvOBJECT(sv))
 258         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
 259 #if 0   /* this was probably a bad idea */
 260     else if (SvPADMY(sv))
 261         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 262 #endif
 263     else {
 264         HV *stash = Nullhv;
 265         switch (SvTYPE(sv)) {
 266         case SVt_PVCV:
 267             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 268                 stash = GvSTASH(CvGV(sv));
 269             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 270                 stash = CvSTASH(sv);
 271             break;
 272         case SVt_PVMG:
 273             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
 274                 break;
 275             /*FALLTHROUGH*/
 276         case SVt_PVGV:
 277             if (GvGP(sv) && GvESTASH((GV*)sv))
 278                 stash = GvESTASH((GV*)sv);
 279             break;
 280         default:
 281             break;
 282         }
 283         if (stash)
 284             sv_setpv(TARG, HvNAME(stash));
 285     }
 286
 287 #ifdef dXSTARGET
 288     SvSETMAGIC(TARG);
 289 #endif
 290     XSRETURN(1);
 291 }
 292
 293 XS(XS_attributes_reftype)
 294 {
 295     dXSARGS;
 296     SV *rv, *sv;
 297 #ifdef dXSTARGET
 298     dXSTARGET;
 299 #else
 300     SV * TARG = sv_newmortal();
 301 #endif
 302
 303     if (items != 1) {
 304 usage:
 305         Perl_croak(aTHX_
 306                    "Usage: attributes::reftype $reference");
 307     }
 308
 309     rv = ST(0);
 310     ST(0) = TARG;
 311     if (SvGMAGICAL(rv))
 312         mg_get(rv);
 313     if (!(SvOK(rv) && SvROK(rv)))
 314         goto usage;
 315     sv = SvRV(rv);
 316     sv_setpv(TARG, sv_reftype(sv, 0));
 317 #ifdef dXSTARGET
 318     SvSETMAGIC(TARG);
 319 #endif
 320
 321     XSRETURN(1);
 322 }
 323
 324 XS(XS_attributes__warn_reserved)
 325 {
 326     dXSARGS;
 327 #ifdef dXSTARGET
 328     dXSTARGET;
 329 #else
 330     SV * TARG = sv_newmortal();
 331 #endif
 332
 333     if (items != 0) {
 334         Perl_croak(aTHX_
 335                    "Usage: attributes::_warn_reserved ()");
 336     }
 337
 338     EXTEND(SP,1);
 339     ST(0) = TARG;
 340     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
 341 #ifdef dXSTARGET
 342     SvSETMAGIC(TARG);
 343 #endif
 344
 345     XSRETURN(1);
 346 }
 347