xsutils.c

   1 #include "EXTERN.h"
   2 #define PERL_IN_XSUTILS_C
   3 #include "perl.h"
   4
   5 /*
   6  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
   7  */
   8
   9 /* package attributes; */
  10 void XS_attributes__warn_reserved(pTHXo_ CV *cv);
  11 void XS_attributes_reftype(pTHXo_ CV *cv);
  12 void XS_attributes__modify_attrs(pTHXo_ CV *cv);
  13 void XS_attributes__guess_stash(pTHXo_ CV *cv);
  14 void XS_attributes__fetch_attrs(pTHXo_ CV *cv);
  15 void XS_attributes_bootstrap(pTHXo_ CV *cv);
  16
  17
  18 /*
  19  * Note that only ${pkg}::bootstrap definitions should go here.
  20  * This helps keep down the start-up time, which is especially
  21  * relevant for users who don't invoke any features which are
  22  * (partially) implemented here.
  23  *
  24  * The various bootstrap definitions can take care of doing
  25  * package-specific newXS() calls.  Since the layout of the
  26  * bundled *.pm files is in a version-specific directory,
  27  * version checks in these bootstrap calls are optional.
  28  */
  29
  30 void
  31 Perl_boot_core_xsutils(pTHX)
  32 {
  33     char *file = __FILE__;
  34
  35     newXS("attributes::bootstrap",      XS_attributes_bootstrap,        file);
  36 }
  37
  38 #include "XSUB.h"
  39
  40 static int
  41 modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
  42 {
  43     SV *attr;
  44     char *name;
  45     STRLEN len;
  46     bool negated;
  47     int nret;
  48
  49     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  50         name = SvPV(attr, len);
  51         if ((negated = (*name == '-')) || (*name == '+')) {
  52             name++;
  53             len--;
  54         }
  55         switch (SvTYPE(sv)) {
  56         case SVt_PVCV:
  57             switch ((int)len) {
  58             case 6:
  59                 switch (*name) {
  60                 case 'l':
  61 #ifdef CVf_LVALUE
  62                     if (strEQ(name, "lvalue")) {
  63                         if (negated)
  64                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  65                         else
  66                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  67                         continue;
  68                     }
  69 #endif /* defined CVf_LVALUE */
  70                     if (strEQ(name, "locked")) {
  71                         if (negated)
  72                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
  73                         else
  74                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
  75                         continue;
  76                     }
  77                     break;
  78                 case 'm':
  79                     if (strEQ(name, "method")) {
  80                         if (negated)
  81                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
  82                         else
  83                             CvFLAGS((CV*)sv) |= CVf_METHOD;
  84                         continue;
  85                     }
  86                     break;
  87                 }
  88                 break;
  89             }
  90           case SVt_IV:
  91           case SVt_NV:
  92           case SVt_PV:
  93           case SVt_PVIV:
  94           case SVt_PVNV:
  95           case SVt_PVAV:
  96           case SVt_PVHV:
  97             switch ((int)len) {
  98               case 8:
  99                 switch (*name) {
 100                   case 'r':
 101                     if (strEQ(name, "readonly")) {
 102                         if (negated)
 103                             SvREADONLY_off(sv);
 104                         else
 105                             SvREADONLY_on(sv);
 106                         if (SvTYPE(sv) == SVt_PVAV && SvMAGIC(sv)
 107                             && mg_find(sv, 'I')) { /* @ISA */
 108                             if (negated)
 109                                 PL_hints &= ~HINT_CT_MRESOLVE;
 110                             else
 111                                 PL_hints |= HINT_CT_MRESOLVE;
 112                         }
 113                         continue;
 114                     }
 115                     break;
 116                 }
 117             }
 118             break;
 119         default:
 120             /* nothing, yet */
 121             break;
 122         }
 123         /* anything recognized had a 'continue' above */
 124         *retlist++ = attr;
 125         nret++;
 126     }
 127
 128     return nret;
 129 }
 130
 131
 132
 133 /* package attributes; */
 134
 135 XS(XS_attributes_bootstrap)
 136 {
 137     dXSARGS;
 138     char *file = __FILE__;
 139
 140     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
 141     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 142     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 143     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 144     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 145
 146     XSRETURN(0);
 147 }
 148
 149 XS(XS_attributes__modify_attrs)
 150 {
 151     dXSARGS;
 152     SV *rv, *sv;
 153
 154     if (items < 1) {
 155 usage:
 156         Perl_croak(aTHX_
 157                    "Usage: attributes::_modify_attrs $reference, @attributes");
 158     }
 159
 160     rv = ST(0);
 161     if (!(SvOK(rv) && SvROK(rv)))
 162         goto usage;
 163     sv = SvRV(rv);
 164     if (items > 1)
 165         XSRETURN(modify_SV_attributes(aTHXo_ sv, &ST(0), &ST(1), items-1));
 166
 167     XSRETURN(0);
 168 }
 169
 170 XS(XS_attributes__fetch_attrs)
 171 {
 172     dXSARGS;
 173     SV *rv, *sv;
 174     cv_flags_t cvflags;
 175
 176     if (items != 1) {
 177 usage:
 178         Perl_croak(aTHX_
 179                    "Usage: attributes::_fetch_attrs $reference");
 180     }
 181
 182     rv = ST(0);
 183     SP -= items;
 184     if (!(SvOK(rv) && SvROK(rv)))
 185         goto usage;
 186     sv = SvRV(rv);
 187
 188     switch (SvTYPE(sv)) {
 189     case SVt_PVCV:
 190         cvflags = CvFLAGS((CV*)sv);
 191         if (cvflags & CVf_LOCKED)
 192             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
 193 #ifdef CVf_LVALUE
 194         if (cvflags & CVf_LVALUE)
 195             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
 196 #endif
 197         if (cvflags & CVf_METHOD)
 198             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
 199         break;
 200     default:
 201         break;
 202     }
 203
 204     PUTBACK;
 205 }
 206
 207 XS(XS_attributes__guess_stash)
 208 {
 209     dXSARGS;
 210     SV *rv, *sv;
 211 #ifdef dXSTARGET
 212     dXSTARGET;
 213 #else
 214     SV * TARG = sv_newmortal();
 215 #endif
 216
 217     if (items != 1) {
 218 usage:
 219         Perl_croak(aTHX_
 220                    "Usage: attributes::_guess_stash $reference");
 221     }
 222
 223     rv = ST(0);
 224     ST(0) = TARG;
 225     if (!(SvOK(rv) && SvROK(rv)))
 226         goto usage;
 227     sv = SvRV(rv);
 228
 229     if (SvOBJECT(sv))
 230         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
 231 #if 0   /* this was probably a bad idea */
 232     else if (SvPADMY(sv))
 233         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 234 #endif
 235     else {
 236         HV *stash = Nullhv;
 237         switch (SvTYPE(sv)) {
 238         case SVt_PVCV:
 239             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)) &&
 240                             HvNAME(GvSTASH(CvGV(sv))))
 241                 stash = GvSTASH(CvGV(sv));
 242             else if (/* !CvANON(sv) && */ CvSTASH(sv) && HvNAME(CvSTASH(sv)))
 243                 stash = CvSTASH(sv);
 244             break;
 245         case SVt_PVMG:
 246             if (!(SvFAKE(sv) && SvTIED_mg(sv, '*')))
 247                 break;
 248             /*FALLTHROUGH*/
 249         case SVt_PVGV:
 250             if (GvGP(sv) && GvESTASH((GV*)sv) && HvNAME(GvESTASH((GV*)sv)))
 251                 stash = GvESTASH((GV*)sv);
 252             break;
 253         default:
 254             break;
 255         }
 256         if (stash)
 257             sv_setpv(TARG, HvNAME(stash));
 258     }
 259
 260 #ifdef dXSTARGET
 261     SvSETMAGIC(TARG);
 262 #endif
 263     XSRETURN(1);
 264 }
 265
 266 XS(XS_attributes_reftype)
 267 {
 268     dXSARGS;
 269     SV *rv, *sv;
 270 #ifdef dXSTARGET
 271     dXSTARGET;
 272 #else
 273     SV * TARG = sv_newmortal();
 274 #endif
 275
 276     if (items != 1) {
 277 usage:
 278         Perl_croak(aTHX_
 279                    "Usage: attributes::reftype $reference");
 280     }
 281
 282     rv = ST(0);
 283     ST(0) = TARG;
 284     if (SvGMAGICAL(rv))
 285         mg_get(rv);
 286     if (!(SvOK(rv) && SvROK(rv)))
 287         goto usage;
 288     sv = SvRV(rv);
 289     sv_setpv(TARG, sv_reftype(sv, 0));
 290 #ifdef dXSTARGET
 291     SvSETMAGIC(TARG);
 292 #endif
 293
 294     XSRETURN(1);
 295 }
 296
 297 XS(XS_attributes__warn_reserved)
 298 {
 299     dXSARGS;
 300 #ifdef dXSTARGET
 301     dXSTARGET;
 302 #else
 303     SV * TARG = sv_newmortal();
 304 #endif
 305
 306     if (items != 0) {
 307         Perl_croak(aTHX_
 308                    "Usage: attributes::_warn_reserved ()");
 309     }
 310
 311     EXTEND(SP,1);
 312     ST(0) = TARG;
 313     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
 314 #ifdef dXSTARGET
 315     SvSETMAGIC(TARG);
 316 #endif
 317
 318     XSRETURN(1);
 319 }
 320