xsutils.c

   1 /*    xsutils.c
   2  *
   3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005
   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 void XS_attributes__warn_reserved(pTHX_ CV *cv);
  27 void XS_attributes_reftype(pTHX_ CV *cv);
  28 void XS_attributes__modify_attrs(pTHX_ CV *cv);
  29 void XS_attributes__guess_stash(pTHX_ CV *cv);
  30 void XS_attributes__fetch_attrs(pTHX_ CV *cv);
  31 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     SV *attr;
  60     char *name;
  61     STRLEN len;
  62     bool negated;
  63     int nret;
  64
  65     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  66         name = SvPV(attr, len);
  67         if ((negated = (*name == '-'))) {
  68             name++;
  69             len--;
  70         }
  71         switch (SvTYPE(sv)) {
  72         case SVt_PVCV:
  73             switch ((int)len) {
  74 #ifdef CVf_ASSERTION
  75             case 9:
  76                 if (memEQ(name, "assertion", 9)) {
  77                     if (negated)
  78                         CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
  79                     else
  80                         CvFLAGS((CV*)sv) |= CVf_ASSERTION;
  81                     continue;
  82                 }
  83                 break;
  84 #endif
  85             case 6:
  86                 switch (name[3]) {
  87                 case 'l':
  88 #ifdef CVf_LVALUE
  89                     if (memEQ(name, "lvalue", 6)) {
  90                         if (negated)
  91                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  92                         else
  93                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  94                         continue;
  95                     }
  96                     break;
  97                 case 'k':
  98 #endif /* defined CVf_LVALUE */
  99                     if (memEQ(name, "locked", 6)) {
 100                         if (negated)
 101                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
 102                         else
 103                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
 104                         continue;
 105                     }
 106                     break;
 107                 case 'h':
 108                     if (memEQ(name, "method", 6)) {
 109                         if (negated)
 110                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
 111                         else
 112                             CvFLAGS((CV*)sv) |= CVf_METHOD;
 113                         continue;
 114                     }
 115                     break;
 116                 }
 117                 break;
 118             }
 119             break;
 120         default:
 121             switch ((int)len) {
 122             case 6:
 123                 switch (name[5]) {
 124                 case 'd':
 125                     if (memEQ(name, "share", 5)) {
 126                         if (negated)
 127                             Perl_croak(aTHX_ "A variable may not be unshared");
 128                         SvSHARE(sv);
 129                         continue;
 130                     }
 131                     break;
 132                 case 'e':
 133                     if (memEQ(name, "uniqu", 5)) {
 134                         if (SvTYPE(sv) == SVt_PVGV) {
 135                             if (negated)
 136                                 GvUNIQUE_off(sv);
 137                             else
 138                                 GvUNIQUE_on(sv);
 139                         }
 140                         /* Hope this came from toke.c if not a GV. */
 141                         continue;
 142                     }
 143                 }
 144             }
 145             break;
 146         }
 147         /* anything recognized had a 'continue' above */
 148         *retlist++ = attr;
 149         nret++;
 150     }
 151
 152     return nret;
 153 }
 154
 155
 156
 157 /* package attributes; */
 158
 159 XS(XS_attributes_bootstrap)
 160 {
 161     dXSARGS;
 162     const char file[] = __FILE__;
 163     (void)cv;
 164
 165     if( items > 1 )
 166         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 167
 168     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
 169     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 170     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 171     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 172     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 173
 174     XSRETURN(0);
 175 }
 176
 177 XS(XS_attributes__modify_attrs)
 178 {
 179     dXSARGS;
 180     SV *rv, *sv;
 181     (void)cv;
 182
 183     if (items < 1) {
 184 usage:
 185         Perl_croak(aTHX_
 186                    "Usage: attributes::_modify_attrs $reference, @attributes");
 187     }
 188
 189     rv = ST(0);
 190     if (!(SvOK(rv) && SvROK(rv)))
 191         goto usage;
 192     sv = SvRV(rv);
 193     if (items > 1)
 194         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 195
 196     XSRETURN(0);
 197 }
 198
 199 XS(XS_attributes__fetch_attrs)
 200 {
 201     dXSARGS;
 202     SV *rv, *sv;
 203     cv_flags_t cvflags;
 204     (void)cv;
 205
 206     if (items != 1) {
 207 usage:
 208         Perl_croak(aTHX_
 209                    "Usage: attributes::_fetch_attrs $reference");
 210     }
 211
 212     rv = ST(0);
 213     SP -= items;
 214     if (!(SvOK(rv) && SvROK(rv)))
 215         goto usage;
 216     sv = SvRV(rv);
 217
 218     switch (SvTYPE(sv)) {
 219     case SVt_PVCV:
 220         cvflags = CvFLAGS((CV*)sv);
 221         if (cvflags & CVf_LOCKED)
 222             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
 223 #ifdef CVf_LVALUE
 224         if (cvflags & CVf_LVALUE)
 225             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
 226 #endif
 227         if (cvflags & CVf_METHOD)
 228             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
 229         if (GvUNIQUE(CvGV((CV*)sv)))
 230             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 231         break;
 232     case SVt_PVGV:
 233         if (GvUNIQUE(sv))
 234             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 235         break;
 236     default:
 237         break;
 238     }
 239
 240     PUTBACK;
 241 }
 242
 243 XS(XS_attributes__guess_stash)
 244 {
 245     dXSARGS;
 246     SV *rv, *sv;
 247     dXSTARG;
 248     (void)cv;
 249
 250     if (items != 1) {
 251 usage:
 252         Perl_croak(aTHX_
 253                    "Usage: attributes::_guess_stash $reference");
 254     }
 255
 256     rv = ST(0);
 257     ST(0) = TARG;
 258     if (!(SvOK(rv) && SvROK(rv)))
 259         goto usage;
 260     sv = SvRV(rv);
 261
 262     if (SvOBJECT(sv))
 263         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
 264 #if 0   /* this was probably a bad idea */
 265     else if (SvPADMY(sv))
 266         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 267 #endif
 268     else {
 269         const HV *stash = Nullhv;
 270         switch (SvTYPE(sv)) {
 271         case SVt_PVCV:
 272             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 273                 stash = GvSTASH(CvGV(sv));
 274             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 275                 stash = CvSTASH(sv);
 276             break;
 277         case SVt_PVMG:
 278             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
 279                 break;
 280             /*FALLTHROUGH*/
 281         case SVt_PVGV:
 282             if (GvGP(sv) && GvESTASH((GV*)sv))
 283                 stash = GvESTASH((GV*)sv);
 284             break;
 285         default:
 286             break;
 287         }
 288         if (stash)
 289             sv_setpv(TARG, HvNAME(stash));
 290     }
 291
 292     SvSETMAGIC(TARG);
 293     XSRETURN(1);
 294 }
 295
 296 XS(XS_attributes_reftype)
 297 {
 298     dXSARGS;
 299     SV *rv, *sv;
 300     dXSTARG;
 301     (void)cv;
 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     SvSETMAGIC(TARG);
 318
 319     XSRETURN(1);
 320 }
 321
 322 XS(XS_attributes__warn_reserved)
 323 {
 324     dXSARGS;
 325     (void)cv;
 326
 327     if (items != 0) {
 328         Perl_croak(aTHX_
 329                    "Usage: attributes::_warn_reserved ()");
 330     }
 331
 332     EXTEND(SP,1);
 333     ST(0) = boolSV(ckWARN(WARN_RESERVED));
 334
 335     XSRETURN(1);
 336 }
 337