xsutils.c

   1 /*    xsutils.c
   2  *
   3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, by Larry Wall and others
   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 'a':
  76                     if (strEQ(name, "assertion")) {
  77                         if (negated)
  78                             CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
  79                         else
  80                             CvFLAGS((CV*)sv) |= CVf_ASSERTION;
  81                         continue;
  82                     }
  83                     break;
  84                 case 'l':
  85 #ifdef CVf_LVALUE
  86                     if (strEQ(name, "lvalue")) {
  87                         if (negated)
  88                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  89                         else
  90                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  91                         continue;
  92                     }
  93 #endif /* defined CVf_LVALUE */
  94                     if (strEQ(name, "locked")) {
  95                         if (negated)
  96                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
  97                         else
  98                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
  99                         continue;
 100                     }
 101                     break;
 102                 case 'm':
 103                     if (strEQ(name, "method")) {
 104                         if (negated)
 105                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
 106                         else
 107                             CvFLAGS((CV*)sv) |= CVf_METHOD;
 108                         continue;
 109                     }
 110                     break;
 111                 case 'u':
 112                     if (strEQ(name, "unique")) {
 113                         if (negated)
 114                             GvUNIQUE_off(CvGV((CV*)sv));
 115                         else
 116                             GvUNIQUE_on(CvGV((CV*)sv));
 117                         continue;
 118                     }
 119                     break;
 120                 }
 121                 break;
 122             }
 123             break;
 124         default:
 125             switch ((int)len) {
 126             case 6:
 127                 switch (*name) {
 128                 case 's':
 129                     if (strEQ(name, "shared")) {
 130                         if (negated)
 131                             Perl_croak(aTHX_ "A variable may not be unshared");
 132                         SvSHARE(sv);
 133                         continue;
 134                     }
 135                     break;
 136                 case 'u':
 137                     if (strEQ(name, "unique")) {
 138                         if (SvTYPE(sv) == SVt_PVGV) {
 139                             if (negated)
 140                                 GvUNIQUE_off(sv);
 141                             else
 142                                 GvUNIQUE_on(sv);
 143                         }
 144                         /* Hope this came from toke.c if not a GV. */
 145                         continue;
 146                     }
 147                 }
 148             }
 149             break;
 150         }
 151         /* anything recognized had a 'continue' above */
 152         *retlist++ = attr;
 153         nret++;
 154     }
 155
 156     return nret;
 157 }
 158
 159
 160
 161 /* package attributes; */
 162
 163 XS(XS_attributes_bootstrap)
 164 {
 165     dXSARGS;
 166     char *file = __FILE__;
 167
 168     if( items > 1 )
 169         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 170
 171     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
 172     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 173     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 174     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 175     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 176
 177     XSRETURN(0);
 178 }
 179
 180 XS(XS_attributes__modify_attrs)
 181 {
 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     dXSARGS;
 204     SV *rv, *sv;
 205     cv_flags_t cvflags;
 206
 207     if (items != 1) {
 208 usage:
 209         Perl_croak(aTHX_
 210                    "Usage: attributes::_fetch_attrs $reference");
 211     }
 212
 213     rv = ST(0);
 214     SP -= items;
 215     if (!(SvOK(rv) && SvROK(rv)))
 216         goto usage;
 217     sv = SvRV(rv);
 218
 219     switch (SvTYPE(sv)) {
 220     case SVt_PVCV:
 221         cvflags = CvFLAGS((CV*)sv);
 222         if (cvflags & CVf_LOCKED)
 223             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
 224 #ifdef CVf_LVALUE
 225         if (cvflags & CVf_LVALUE)
 226             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
 227 #endif
 228         if (cvflags & CVf_METHOD)
 229             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
 230         if (GvUNIQUE(CvGV((CV*)sv)))
 231             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 232         if (cvflags & CVf_ASSERTION)
 233             XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
 234         break;
 235     case SVt_PVGV:
 236         if (GvUNIQUE(sv))
 237             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 238         break;
 239     default:
 240         break;
 241     }
 242
 243     PUTBACK;
 244 }
 245
 246 XS(XS_attributes__guess_stash)
 247 {
 248     dXSARGS;
 249     SV *rv, *sv;
 250 #ifdef dXSTARGET
 251     dXSTARGET;
 252 #else
 253     SV * TARG = sv_newmortal();
 254 #endif
 255
 256     if (items != 1) {
 257 usage:
 258         Perl_croak(aTHX_
 259                    "Usage: attributes::_guess_stash $reference");
 260     }
 261
 262     rv = ST(0);
 263     ST(0) = TARG;
 264     if (!(SvOK(rv) && SvROK(rv)))
 265         goto usage;
 266     sv = SvRV(rv);
 267
 268     if (SvOBJECT(sv))
 269         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
 270 #if 0   /* this was probably a bad idea */
 271     else if (SvPADMY(sv))
 272         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 273 #endif
 274     else {
 275         HV *stash = Nullhv;
 276         switch (SvTYPE(sv)) {
 277         case SVt_PVCV:
 278             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 279                 stash = GvSTASH(CvGV(sv));
 280             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 281                 stash = CvSTASH(sv);
 282             break;
 283         case SVt_PVMG:
 284             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
 285                 break;
 286             /*FALLTHROUGH*/
 287         case SVt_PVGV:
 288             if (GvGP(sv) && GvESTASH((GV*)sv))
 289                 stash = GvESTASH((GV*)sv);
 290             break;
 291         default:
 292             break;
 293         }
 294         if (stash)
 295             sv_setpv(TARG, HvNAME(stash));
 296     }
 297
 298 #ifdef dXSTARGET
 299     SvSETMAGIC(TARG);
 300 #endif
 301     XSRETURN(1);
 302 }
 303
 304 XS(XS_attributes_reftype)
 305 {
 306     dXSARGS;
 307     SV *rv, *sv;
 308 #ifdef dXSTARGET
 309     dXSTARGET;
 310 #else
 311     SV * TARG = sv_newmortal();
 312 #endif
 313
 314     if (items != 1) {
 315 usage:
 316         Perl_croak(aTHX_
 317                    "Usage: attributes::reftype $reference");
 318     }
 319
 320     rv = ST(0);
 321     ST(0) = TARG;
 322     if (SvGMAGICAL(rv))
 323         mg_get(rv);
 324     if (!(SvOK(rv) && SvROK(rv)))
 325         goto usage;
 326     sv = SvRV(rv);
 327     sv_setpv(TARG, sv_reftype(sv, 0));
 328 #ifdef dXSTARGET
 329     SvSETMAGIC(TARG);
 330 #endif
 331
 332     XSRETURN(1);
 333 }
 334
 335 XS(XS_attributes__warn_reserved)
 336 {
 337     dXSARGS;
 338 #ifdef dXSTARGET
 339     dXSTARGET;
 340 #else
 341     SV * TARG = sv_newmortal();
 342 #endif
 343
 344     if (items != 0) {
 345         Perl_croak(aTHX_
 346                    "Usage: attributes::_warn_reserved ()");
 347     }
 348
 349     EXTEND(SP,1);
 350     ST(0) = TARG;
 351     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
 352 #ifdef dXSTARGET
 353     SvSETMAGIC(TARG);
 354 #endif
 355
 356     XSRETURN(1);
 357 }
 358