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