xsutils.c

   1 /*    xsutils.c
   2  *
   3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
   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 6:
  75                 switch (*name) {
  76                 case 'a':
  77                     if (strEQ(name, "assertion")) {
  78                         if (negated)
  79                             CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
  80                         else
  81                             CvFLAGS((CV*)sv) |= CVf_ASSERTION;
  82                         continue;
  83                     }
  84                     break;
  85                 case 'l':
  86 #ifdef CVf_LVALUE
  87                     if (strEQ(name, "lvalue")) {
  88                         if (negated)
  89                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
  90                         else
  91                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
  92                         continue;
  93                     }
  94 #endif /* defined CVf_LVALUE */
  95                     if (strEQ(name, "locked")) {
  96                         if (negated)
  97                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
  98                         else
  99                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
 100                         continue;
 101                     }
 102                     break;
 103                 case 'm':
 104                     if (strEQ(name, "method")) {
 105                         if (negated)
 106                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
 107                         else
 108                             CvFLAGS((CV*)sv) |= CVf_METHOD;
 109                         continue;
 110                     }
 111                     break;
 112                 }
 113                 break;
 114             }
 115             break;
 116         default:
 117             switch ((int)len) {
 118             case 6:
 119                 switch (*name) {
 120                 case 's':
 121                     if (strEQ(name, "shared")) {
 122                         if (negated)
 123                             Perl_croak(aTHX_ "A variable may not be unshared");
 124                         SvSHARE(sv);
 125                         continue;
 126                     }
 127                     break;
 128                 case 'u':
 129                     if (strEQ(name, "unique")) {
 130                         if (SvTYPE(sv) == SVt_PVGV) {
 131                             if (negated)
 132                                 GvUNIQUE_off(sv);
 133                             else
 134                                 GvUNIQUE_on(sv);
 135                         }
 136                         /* Hope this came from toke.c if not a GV. */
 137                         continue;
 138                     }
 139                 }
 140             }
 141             break;
 142         }
 143         /* anything recognized had a 'continue' above */
 144         *retlist++ = attr;
 145         nret++;
 146     }
 147
 148     return nret;
 149 }
 150
 151
 152
 153 /* package attributes; */
 154
 155 XS(XS_attributes_bootstrap)
 156 {
 157     dXSARGS;
 158     char *file = __FILE__;
 159
 160     if( items > 1 )
 161         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
 162
 163     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
 164     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 165     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 166     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 167     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 168
 169     XSRETURN(0);
 170 }
 171
 172 XS(XS_attributes__modify_attrs)
 173 {
 174     dXSARGS;
 175     SV *rv, *sv;
 176
 177     if (items < 1) {
 178 usage:
 179         Perl_croak(aTHX_
 180                    "Usage: attributes::_modify_attrs $reference, @attributes");
 181     }
 182
 183     rv = ST(0);
 184     if (!(SvOK(rv) && SvROK(rv)))
 185         goto usage;
 186     sv = SvRV(rv);
 187     if (items > 1)
 188         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 189
 190     XSRETURN(0);
 191 }
 192
 193 XS(XS_attributes__fetch_attrs)
 194 {
 195     dXSARGS;
 196     SV *rv, *sv;
 197     cv_flags_t cvflags;
 198
 199     if (items != 1) {
 200 usage:
 201         Perl_croak(aTHX_
 202                    "Usage: attributes::_fetch_attrs $reference");
 203     }
 204
 205     rv = ST(0);
 206     SP -= items;
 207     if (!(SvOK(rv) && SvROK(rv)))
 208         goto usage;
 209     sv = SvRV(rv);
 210
 211     switch (SvTYPE(sv)) {
 212     case SVt_PVCV:
 213         cvflags = CvFLAGS((CV*)sv);
 214         if (cvflags & CVf_LOCKED)
 215             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
 216 #ifdef CVf_LVALUE
 217         if (cvflags & CVf_LVALUE)
 218             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
 219 #endif
 220         if (cvflags & CVf_METHOD)
 221             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
 222         if (GvUNIQUE(CvGV((CV*)sv)))
 223             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 224         if (cvflags & CVf_ASSERTION)
 225             XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
 226         break;
 227     case SVt_PVGV:
 228         if (GvUNIQUE(sv))
 229             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
 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(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         HV *stash = Nullhv;
 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_PVMG:
 272             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
 273                 break;
 274             /*FALLTHROUGH*/
 275         case SVt_PVGV:
 276             if (GvGP(sv) && GvESTASH((GV*)sv))
 277                 stash = GvESTASH((GV*)sv);
 278             break;
 279         default:
 280             break;
 281         }
 282         if (stash)
 283             sv_setpv(TARG, HvNAME(stash));
 284     }
 285
 286     SvSETMAGIC(TARG);
 287     XSRETURN(1);
 288 }
 289
 290 XS(XS_attributes_reftype)
 291 {
 292     dXSARGS;
 293     SV *rv, *sv;
 294     dXSTARG;
 295
 296     if (items != 1) {
 297 usage:
 298         Perl_croak(aTHX_
 299                    "Usage: attributes::reftype $reference");
 300     }
 301
 302     rv = ST(0);
 303     ST(0) = TARG;
 304     if (SvGMAGICAL(rv))
 305         mg_get(rv);
 306     if (!(SvOK(rv) && SvROK(rv)))
 307         goto usage;
 308     sv = SvRV(rv);
 309     sv_setpv(TARG, sv_reftype(sv, 0));
 310     SvSETMAGIC(TARG);
 311
 312     XSRETURN(1);
 313 }
 314
 315 XS(XS_attributes__warn_reserved)
 316 {
 317     dXSARGS;
 318
 319     if (items != 0) {
 320         Perl_croak(aTHX_
 321                    "Usage: attributes::_warn_reserved ()");
 322     }
 323
 324     EXTEND(SP,1);
 325     ST(0) = boolSV(ckWARN(WARN_RESERVED));
 326
 327     XSRETURN(1);
 328 }
 329