xsutils.c

   1 /*    xsutils.c
   2  *
   3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   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 PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
  27 PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
  28 PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
  29 PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
  30 PERL_XS_EXPORT_C 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 static const char file[] = __FILE__;
  46
  47 void
  48 Perl_boot_core_xsutils(pTHX)
  49 {
  50     newXS("attributes::bootstrap", XS_attributes_bootstrap, (char *)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     int nret;
  60
  61     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  62         STRLEN len;
  63         const char *name = SvPV_const(attr, len);
  64         const bool negated = (*name == '-');
  65
  66         if (negated) {
  67             name++;
  68             len--;
  69         }
  70         switch (SvTYPE(sv)) {
  71         case SVt_PVCV:
  72             switch ((int)len) {
  73 #ifdef CVf_ASSERTION
  74             case 9:
  75                 if (memEQ(name, "assertion", 9)) {
  76                     if (negated)
  77                         CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
  78                     else
  79                         CvFLAGS((CV*)sv) |= CVf_ASSERTION;
  80                     continue;
  81                 }
  82                 break;
  83 #endif
  84             case 6:
  85                 switch (name[3]) {
  86 #ifdef CVf_LVALUE
  87                 case 'l':
  88                     if (memEQ(name, "lvalue", 6)) {
  89                         if (negated)
  90                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  91                         else
  92                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  93                         continue;
  94                     }
  95                     break;
  96 #endif
  97                 case 'k':
  98                     if (memEQ(name, "locked", 6)) {
  99                         if (negated)
 100                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
 101                         else
 102                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
 103                         continue;
 104                     }
 105                     break;
 106                 case 'h':
 107                     if (memEQ(name, "method", 6)) {
 108                         if (negated)
 109                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
 110                         else
 111                             CvFLAGS((CV*)sv) |= CVf_METHOD;
 112                         continue;
 113                     }
 114                     break;
 115                 }
 116                 break;
 117             }
 118             break;
 119         default:
 120             switch ((int)len) {
 121             case 6:
 122                 switch (name[5]) {
 123                 case 'd':
 124                     if (memEQ(name, "share", 5)) {
 125                         if (negated)
 126                             Perl_croak(aTHX_ "A variable may not be unshared");
 127                         SvSHARE(sv);
 128                         continue;
 129                     }
 130                     break;
 131                 case 'e':
 132                     if (memEQ(name, "uniqu", 5)) {
 133                         if (SvTYPE(sv) == SVt_PVGV) {
 134                             if (negated) {
 135                                 GvUNIQUE_off(sv);
 136                             } else {
 137                                 GvUNIQUE_on(sv);
 138                             }
 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
 163     if( items > 1 )
 164         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 165
 166     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    (char *)file);
 167     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, (char *)file, "$");
 168     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, (char *)file, "$");
 169     newXSproto("attributes::reftype",   XS_attributes_reftype,  (char *)file, "$");
 170
 171     XSRETURN(0);
 172 }
 173
 174 XS(XS_attributes__modify_attrs)
 175 {
 176     dXSARGS;
 177     SV *rv, *sv;
 178
 179     if (items < 1) {
 180 usage:
 181         Perl_croak(aTHX_
 182                    "Usage: attributes::_modify_attrs $reference, @attributes");
 183     }
 184
 185     rv = ST(0);
 186     if (!(SvOK(rv) && SvROK(rv)))
 187         goto usage;
 188     sv = SvRV(rv);
 189     if (items > 1)
 190         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 191
 192     XSRETURN(0);
 193 }
 194
 195 XS(XS_attributes__fetch_attrs)
 196 {
 197     dXSARGS;
 198     SV *rv, *sv;
 199     cv_flags_t cvflags;
 200
 201     if (items != 1) {
 202 usage:
 203         Perl_croak(aTHX_
 204                    "Usage: attributes::_fetch_attrs $reference");
 205     }
 206
 207     rv = ST(0);
 208     SP -= items;
 209     if (!(SvOK(rv) && SvROK(rv)))
 210         goto usage;
 211     sv = SvRV(rv);
 212
 213     switch (SvTYPE(sv)) {
 214     case SVt_PVCV:
 215         cvflags = CvFLAGS((CV*)sv);
 216         if (cvflags & CVf_LOCKED)
 217             XPUSHs(sv_2mortal(newSVpvs("locked")));
 218 #ifdef CVf_LVALUE
 219         if (cvflags & CVf_LVALUE)
 220             XPUSHs(sv_2mortal(newSVpvs("lvalue")));
 221 #endif
 222         if (cvflags & CVf_METHOD)
 223             XPUSHs(sv_2mortal(newSVpvs("method")));
 224         if (GvUNIQUE(CvGV((CV*)sv)))
 225             XPUSHs(sv_2mortal(newSVpvs("unique")));
 226         break;
 227     case SVt_PVGV:
 228         if (GvUNIQUE(sv))
 229             XPUSHs(sv_2mortal(newSVpvs("unique")));
 230         break;
 231     default:
 232         break;
 233     }
 234
 235     PUTBACK;
 236 }
 237
 238 XS(XS_attributes__guess_stash)
 239 {
 240     dXSARGS;
 241     SV *rv, *sv;
 242     dXSTARG;
 243
 244     if (items != 1) {
 245 usage:
 246         Perl_croak(aTHX_
 247                    "Usage: attributes::_guess_stash $reference");
 248     }
 249
 250     rv = ST(0);
 251     ST(0) = TARG;
 252     if (!(SvOK(rv) && SvROK(rv)))
 253         goto usage;
 254     sv = SvRV(rv);
 255
 256     if (SvOBJECT(sv))
 257         sv_setpv(TARG, HvNAME_get(SvSTASH(sv)));
 258 #if 0   /* this was probably a bad idea */
 259     else if (SvPADMY(sv))
 260         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 261 #endif
 262     else {
 263         const HV *stash = NULL;
 264         switch (SvTYPE(sv)) {
 265         case SVt_PVCV:
 266             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 267                 stash = GvSTASH(CvGV(sv));
 268             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 269                 stash = CvSTASH(sv);
 270             break;
 271         case SVt_PVGV:
 272             if (GvGP(sv) && GvESTASH((GV*)sv))
 273                 stash = GvESTASH((GV*)sv);
 274             break;
 275         default:
 276             break;
 277         }
 278         if (stash)
 279             sv_setpv(TARG, HvNAME_get(stash));
 280     }
 281
 282     SvSETMAGIC(TARG);
 283     XSRETURN(1);
 284 }
 285
 286 XS(XS_attributes_reftype)
 287 {
 288     dXSARGS;
 289     SV *rv, *sv;
 290     dXSTARG;
 291
 292     if (items != 1) {
 293 usage:
 294         Perl_croak(aTHX_
 295                    "Usage: attributes::reftype $reference");
 296     }
 297
 298     rv = ST(0);
 299     ST(0) = TARG;
 300     SvGETMAGIC(rv);
 301     if (!(SvOK(rv) && SvROK(rv)))
 302         goto usage;
 303     sv = SvRV(rv);
 304     sv_setpv(TARG, sv_reftype(sv, 0));
 305     SvSETMAGIC(TARG);
 306
 307     XSRETURN(1);
 308 }
 309
 310 /*
 311  * Local variables:
 312  * c-indentation-style: bsd
 313  * c-basic-offset: 4
 314  * indent-tabs-mode: t
 315  * End:
 316  *
 317  * ex: set ts=8 sts=4 sw=4 noet:
 318  */