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     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             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             case 6:
  84                 switch (name[3]) {
  85                 case 'l':
  86 #ifdef CVf_LVALUE
  87                     if (memEQ(name, "lvalue", 6)) {
  88                         if (negated)
  89                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  90                         else
  91                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  92                         continue;
  93                     }
  94                     break;
  95                 case 'k':
  96 #endif /* defined CVf_LVALUE */
  97                     if (memEQ(name, "locked", 6)) {
  98                         if (negated)
  99                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
 100                         else
 101                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
 102                         continue;
 103                     }
 104                     break;
 105                 case 'h':
 106                     if (memEQ(name, "method", 6)) {
 107                         if (negated)
 108                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
 109                         else
 110                             CvFLAGS((CV*)sv) |= CVf_METHOD;
 111                         continue;
 112                     }
 113                     break;
 114                 }
 115                 break;
 116             }
 117             break;
 118         default:
 119             switch ((int)len) {
 120             case 6:
 121                 switch (name[5]) {
 122                 case 'd':
 123                     if (memEQ(name, "share", 5)) {
 124                         if (negated)
 125                             Perl_croak(aTHX_ "A variable may not be unshared");
 126                         SvSHARE(sv);
 127                         continue;
 128                     }
 129                     break;
 130                 case 'e':
 131                     if (memEQ(name, "uniqu", 5)) {
 132                         if (SvTYPE(sv) == SVt_PVGV) {
 133                             if (negated)
 134                                 GvUNIQUE_off(sv);
 135                             else
 136                                 GvUNIQUE_on(sv);
 137                         }
 138                         /* Hope this came from toke.c if not a GV. */
 139                         continue;
 140                     }
 141                 }
 142             }
 143             break;
 144         }
 145         /* anything recognized had a 'continue' above */
 146         *retlist++ = attr;
 147         nret++;
 148     }
 149
 150     return nret;
 151 }
 152
 153
 154
 155 /* package attributes; */
 156
 157 XS(XS_attributes_bootstrap)
 158 {
 159     dXSARGS;
 160     char *file = __FILE__;
 161
 162     if( items > 1 )
 163         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 164
 165     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
 166     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 167     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 168     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 169     newXSproto("attributes::reftype",   XS_attributes_reftype,  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(newSVpvn("locked", 6)));
 218 #ifdef CVf_LVALUE
 219         if (cvflags & CVf_LVALUE)
 220             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
 221 #endif
 222         if (cvflags & CVf_METHOD)
 223             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
 224         if (GvUNIQUE(CvGV((CV*)sv)))
 225             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 226         if (cvflags & CVf_ASSERTION)
 227             XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
 228         break;
 229     case SVt_PVGV:
 230         if (GvUNIQUE(sv))
 231             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 232         break;
 233     default:
 234         break;
 235     }
 236
 237     PUTBACK;
 238 }
 239
 240 XS(XS_attributes__guess_stash)
 241 {
 242     dXSARGS;
 243     SV *rv, *sv;
 244     dXSTARG;
 245
 246     if (items != 1) {
 247 usage:
 248         Perl_croak(aTHX_
 249                    "Usage: attributes::_guess_stash $reference");
 250     }
 251
 252     rv = ST(0);
 253     ST(0) = TARG;
 254     if (!(SvOK(rv) && SvROK(rv)))
 255         goto usage;
 256     sv = SvRV(rv);
 257
 258     if (SvOBJECT(sv))
 259         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
 260 #if 0   /* this was probably a bad idea */
 261     else if (SvPADMY(sv))
 262         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 263 #endif
 264     else {
 265         HV *stash = Nullhv;
 266         switch (SvTYPE(sv)) {
 267         case SVt_PVCV:
 268             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 269                 stash = GvSTASH(CvGV(sv));
 270             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 271                 stash = CvSTASH(sv);
 272             break;
 273         case SVt_PVMG:
 274             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
 275                 break;
 276             /*FALLTHROUGH*/
 277         case SVt_PVGV:
 278             if (GvGP(sv) && GvESTASH((GV*)sv))
 279                 stash = GvESTASH((GV*)sv);
 280             break;
 281         default:
 282             break;
 283         }
 284         if (stash)
 285             sv_setpv(TARG, HvNAME(stash));
 286     }
 287
 288     SvSETMAGIC(TARG);
 289     XSRETURN(1);
 290 }
 291
 292 XS(XS_attributes_reftype)
 293 {
 294     dXSARGS;
 295     SV *rv, *sv;
 296     dXSTARG;
 297
 298     if (items != 1) {
 299 usage:
 300         Perl_croak(aTHX_
 301                    "Usage: attributes::reftype $reference");
 302     }
 303
 304     rv = ST(0);
 305     ST(0) = TARG;
 306     if (SvGMAGICAL(rv))
 307         mg_get(rv);
 308     if (!(SvOK(rv) && SvROK(rv)))
 309         goto usage;
 310     sv = SvRV(rv);
 311     sv_setpv(TARG, sv_reftype(sv, 0));
 312     SvSETMAGIC(TARG);
 313
 314     XSRETURN(1);
 315 }
 316
 317 XS(XS_attributes__warn_reserved)
 318 {
 319     dXSARGS;
 320
 321     if (items != 0) {
 322         Perl_croak(aTHX_
 323                    "Usage: attributes::_warn_reserved ()");
 324     }
 325
 326     EXTEND(SP,1);
 327     ST(0) = boolSV(ckWARN(WARN_RESERVED));
 328
 329     XSRETURN(1);
 330 }
 331