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 == '-'))) {
  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                 case 's':
  88                     if (strEQ(name, "shared")) {
  89                         if (negated)
  90                             GvSHARED_off(CvGV((CV*)sv));
  91                         else
  92                             GvSHARED_on(CvGV((CV*)sv));
  93                         continue;
  94                     }
  95                     break;
  96                 }
  97                 break;
  98             }
  99             break;
 100         default:
 101             switch ((int)len) {
 102               case 6:
 103                 switch (*name) {
 104                   case 's':
 105                     if (strEQ(name, "shared")) {
 106                         /* toke.c has already marked as GvSHARED */
 107                         continue;
 108                     }
 109                 }
 110             }
 111             break;
 112         }
 113         /* anything recognized had a 'continue' above */
 114         *retlist++ = attr;
 115         nret++;
 116     }
 117
 118     return nret;
 119 }
 120
 121
 122
 123 /* package attributes; */
 124
 125 XS(XS_attributes_bootstrap)
 126 {
 127     dXSARGS;
 128     char *file = __FILE__;
 129
 130     if( items > 1 )
 131         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 132
 133     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
 134     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 135     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 136     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 137     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 138
 139     XSRETURN(0);
 140 }
 141
 142 XS(XS_attributes__modify_attrs)
 143 {
 144     dXSARGS;
 145     SV *rv, *sv;
 146
 147     if (items < 1) {
 148 usage:
 149         Perl_croak(aTHX_
 150                    "Usage: attributes::_modify_attrs $reference, @attributes");
 151     }
 152
 153     rv = ST(0);
 154     if (!(SvOK(rv) && SvROK(rv)))
 155         goto usage;
 156     sv = SvRV(rv);
 157     if (items > 1)
 158         XSRETURN(modify_SV_attributes(aTHXo_ sv, &ST(0), &ST(1), items-1));
 159
 160     XSRETURN(0);
 161 }
 162
 163 XS(XS_attributes__fetch_attrs)
 164 {
 165     dXSARGS;
 166     SV *rv, *sv;
 167     cv_flags_t cvflags;
 168
 169     if (items != 1) {
 170 usage:
 171         Perl_croak(aTHX_
 172                    "Usage: attributes::_fetch_attrs $reference");
 173     }
 174
 175     rv = ST(0);
 176     SP -= items;
 177     if (!(SvOK(rv) && SvROK(rv)))
 178         goto usage;
 179     sv = SvRV(rv);
 180
 181     switch (SvTYPE(sv)) {
 182     case SVt_PVCV:
 183         cvflags = CvFLAGS((CV*)sv);
 184         if (cvflags & CVf_LOCKED)
 185             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
 186 #ifdef CVf_LVALUE
 187         if (cvflags & CVf_LVALUE)
 188             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
 189 #endif
 190         if (cvflags & CVf_METHOD)
 191             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
 192         if (GvSHARED(CvGV((CV*)sv)))
 193             XPUSHs(sv_2mortal(newSVpvn("shared", 6)));
 194         break;
 195     default:
 196         break;
 197     }
 198
 199     PUTBACK;
 200 }
 201
 202 XS(XS_attributes__guess_stash)
 203 {
 204     dXSARGS;
 205     SV *rv, *sv;
 206 #ifdef dXSTARGET
 207     dXSTARGET;
 208 #else
 209     SV * TARG = sv_newmortal();
 210 #endif
 211
 212     if (items != 1) {
 213 usage:
 214         Perl_croak(aTHX_
 215                    "Usage: attributes::_guess_stash $reference");
 216     }
 217
 218     rv = ST(0);
 219     ST(0) = TARG;
 220     if (!(SvOK(rv) && SvROK(rv)))
 221         goto usage;
 222     sv = SvRV(rv);
 223
 224     if (SvOBJECT(sv))
 225         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
 226 #if 0   /* this was probably a bad idea */
 227     else if (SvPADMY(sv))
 228         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 229 #endif
 230     else {
 231         HV *stash = Nullhv;
 232         switch (SvTYPE(sv)) {
 233         case SVt_PVCV:
 234             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)) &&
 235                             HvNAME(GvSTASH(CvGV(sv))))
 236                 stash = GvSTASH(CvGV(sv));
 237             else if (/* !CvANON(sv) && */ CvSTASH(sv) && HvNAME(CvSTASH(sv)))
 238                 stash = CvSTASH(sv);
 239             break;
 240         case SVt_PVMG:
 241             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
 242                 break;
 243             /*FALLTHROUGH*/
 244         case SVt_PVGV:
 245             if (GvGP(sv) && GvESTASH((GV*)sv) && HvNAME(GvESTASH((GV*)sv)))
 246                 stash = GvESTASH((GV*)sv);
 247             break;
 248         default:
 249             break;
 250         }
 251         if (stash)
 252             sv_setpv(TARG, HvNAME(stash));
 253     }
 254
 255 #ifdef dXSTARGET
 256     SvSETMAGIC(TARG);
 257 #endif
 258     XSRETURN(1);
 259 }
 260
 261 XS(XS_attributes_reftype)
 262 {
 263     dXSARGS;
 264     SV *rv, *sv;
 265 #ifdef dXSTARGET
 266     dXSTARGET;
 267 #else
 268     SV * TARG = sv_newmortal();
 269 #endif
 270
 271     if (items != 1) {
 272 usage:
 273         Perl_croak(aTHX_
 274                    "Usage: attributes::reftype $reference");
 275     }
 276
 277     rv = ST(0);
 278     ST(0) = TARG;
 279     if (SvGMAGICAL(rv))
 280         mg_get(rv);
 281     if (!(SvOK(rv) && SvROK(rv)))
 282         goto usage;
 283     sv = SvRV(rv);
 284     sv_setpv(TARG, sv_reftype(sv, 0));
 285 #ifdef dXSTARGET
 286     SvSETMAGIC(TARG);
 287 #endif
 288
 289     XSRETURN(1);
 290 }
 291
 292 XS(XS_attributes__warn_reserved)
 293 {
 294     dXSARGS;
 295 #ifdef dXSTARGET
 296     dXSTARGET;
 297 #else
 298     SV * TARG = sv_newmortal();
 299 #endif
 300
 301     if (items != 0) {
 302         Perl_croak(aTHX_
 303                    "Usage: attributes::_warn_reserved ()");
 304     }
 305
 306     EXTEND(SP,1);
 307     ST(0) = TARG;
 308     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
 309 #ifdef dXSTARGET
 310     SvSETMAGIC(TARG);
 311 #endif
 312
 313     XSRETURN(1);
 314 }
 315