xsutils.c

   1 /*    xsutils.c
   2  *
   3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   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  *     [p.597 of _The Lord of the Rings_, III/xi: "The Palantír"]
  16  */
  17
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_XSUTILS_C
  21 #include "perl.h"
  22
  23 /*
  24  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
  25  */
  26
  27 /* package attributes; */
  28 PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
  29 PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
  30 PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
  31 PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
  32 PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
  33
  34
  35 /*
  36  * Note that only ${pkg}::bootstrap definitions should go here.
  37  * This helps keep down the start-up time, which is especially
  38  * relevant for users who don't invoke any features which are
  39  * (partially) implemented here.
  40  *
  41  * The various bootstrap definitions can take care of doing
  42  * package-specific newXS() calls.  Since the layout of the
  43  * bundled *.pm files is in a version-specific directory,
  44  * version checks in these bootstrap calls are optional.
  45  */
  46
  47 static const char file[] = __FILE__;
  48
  49 void
  50 Perl_boot_core_xsutils(pTHX)
  51 {
  52     newXS("attributes::bootstrap",      XS_attributes_bootstrap,        file);
  53 }
  54
  55 #include "XSUB.h"
  56
  57 static int
  58 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
  59 {
  60     dVAR;
  61     SV *attr;
  62     int nret;
  63
  64     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
  65         STRLEN len;
  66         const char *name = SvPV_const(attr, len);
  67         const bool negated = (*name == '-');
  68
  69         if (negated) {
  70             name++;
  71             len--;
  72         }
  73         switch (SvTYPE(sv)) {
  74         case SVt_PVCV:
  75             switch ((int)len) {
  76             case 6:
  77                 switch (name[3]) {
  78 #ifdef CVf_LVALUE
  79                 case 'l':
  80                     if (memEQ(name, "lvalue", 6)) {
  81                         if (negated)
  82                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
  83                         else
  84                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
  85                         continue;
  86                     }
  87                     break;
  88 #endif
  89                 case 'k':
  90                     if (memEQ(name, "locked", 6)) {
  91                         if (negated)
  92                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LOCKED;
  93                         else
  94                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LOCKED;
  95                         continue;
  96                     }
  97                     break;
  98                 case 'h':
  99                     if (memEQ(name, "method", 6)) {
 100                         if (negated)
 101                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
 102                         else
 103                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
 104                         continue;
 105                     }
 106                     break;
 107                 }
 108                 break;
 109             }
 110             break;
 111         default:
 112             switch ((int)len) {
 113             case 6:
 114                 switch (name[5]) {
 115                 case 'd':
 116                     if (memEQ(name, "share", 5)) {
 117                         if (negated)
 118                             Perl_croak(aTHX_ "A variable may not be unshared");
 119                         SvSHARE(sv);
 120                         continue;
 121                     }
 122                     break;
 123                 case 'e':
 124                     if (memEQ(name, "uniqu", 5)) {
 125                         if (isGV_with_GP(sv)) {
 126                             if (negated) {
 127                                 GvUNIQUE_off(sv);
 128                             } else {
 129                                 GvUNIQUE_on(sv);
 130                             }
 131                         }
 132                         /* Hope this came from toke.c if not a GV. */
 133                         continue;
 134                     }
 135                 }
 136             }
 137             break;
 138         }
 139         /* anything recognized had a 'continue' above */
 140         *retlist++ = attr;
 141         nret++;
 142     }
 143
 144     return nret;
 145 }
 146
 147
 148
 149 /* package attributes; */
 150
 151 XS(XS_attributes_bootstrap)
 152 {
 153     dVAR;
 154     dXSARGS;
 155
 156     if( items > 1 )
 157         croak_xs_usage(cv, "$module");
 158
 159     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
 160     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
 161     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
 162     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
 163
 164     XSRETURN(0);
 165 }
 166
 167 XS(XS_attributes__modify_attrs)
 168 {
 169     dVAR;
 170     dXSARGS;
 171     SV *rv, *sv;
 172
 173     if (items < 1) {
 174 usage:
 175         croak_xs_usage(cv, "@attributes");
 176     }
 177
 178     rv = ST(0);
 179     if (!(SvOK(rv) && SvROK(rv)))
 180         goto usage;
 181     sv = SvRV(rv);
 182     if (items > 1)
 183         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
 184
 185     XSRETURN(0);
 186 }
 187
 188 XS(XS_attributes__fetch_attrs)
 189 {
 190     dVAR;
 191     dXSARGS;
 192     SV *rv, *sv;
 193     cv_flags_t cvflags;
 194
 195     if (items != 1) {
 196 usage:
 197         croak_xs_usage(cv, "$reference");
 198     }
 199
 200     rv = ST(0);
 201     SP -= items;
 202     if (!(SvOK(rv) && SvROK(rv)))
 203         goto usage;
 204     sv = SvRV(rv);
 205
 206     switch (SvTYPE(sv)) {
 207     case SVt_PVCV:
 208         cvflags = CvFLAGS((const CV *)sv);
 209         if (cvflags & CVf_LOCKED)
 210             XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
 211 #ifdef CVf_LVALUE
 212         if (cvflags & CVf_LVALUE)
 213             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
 214 #endif
 215         if (cvflags & CVf_METHOD)
 216             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
 217         if (GvUNIQUE(CvGV((const CV *)sv)))
 218             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
 219         break;
 220     case SVt_PVGV:
 221         if (isGV_with_GP(sv) && GvUNIQUE(sv))
 222             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
 223         break;
 224     default:
 225         break;
 226     }
 227
 228     PUTBACK;
 229 }
 230
 231 XS(XS_attributes__guess_stash)
 232 {
 233     dVAR;
 234     dXSARGS;
 235     SV *rv, *sv;
 236     dXSTARG;
 237
 238     if (items != 1) {
 239 usage:
 240         croak_xs_usage(cv, "$reference");
 241     }
 242
 243     rv = ST(0);
 244     ST(0) = TARG;
 245     if (!(SvOK(rv) && SvROK(rv)))
 246         goto usage;
 247     sv = SvRV(rv);
 248
 249     if (SvOBJECT(sv))
 250         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
 251 #if 0   /* this was probably a bad idea */
 252     else if (SvPADMY(sv))
 253         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
 254 #endif
 255     else {
 256         const HV *stash = NULL;
 257         switch (SvTYPE(sv)) {
 258         case SVt_PVCV:
 259             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
 260                 stash = GvSTASH(CvGV(sv));
 261             else if (/* !CvANON(sv) && */ CvSTASH(sv))
 262                 stash = CvSTASH(sv);
 263             break;
 264         case SVt_PVGV:
 265             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
 266                 stash = GvESTASH(MUTABLE_GV(sv));
 267             break;
 268         default:
 269             break;
 270         }
 271         if (stash)
 272             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
 273     }
 274
 275     SvSETMAGIC(TARG);
 276     XSRETURN(1);
 277 }
 278
 279 XS(XS_attributes_reftype)
 280 {
 281     dVAR;
 282     dXSARGS;
 283     SV *rv, *sv;
 284     dXSTARG;
 285
 286     if (items != 1) {
 287 usage:
 288         croak_xs_usage(cv, "$reference");
 289     }
 290
 291     rv = ST(0);
 292     ST(0) = TARG;
 293     SvGETMAGIC(rv);
 294     if (!(SvOK(rv) && SvROK(rv)))
 295         goto usage;
 296     sv = SvRV(rv);
 297     sv_setpv(TARG, sv_reftype(sv, 0));
 298     SvSETMAGIC(TARG);
 299
 300     XSRETURN(1);
 301 }
 302
 303 /*
 304  * Local variables:
 305  * c-indentation-style: bsd
 306  * c-basic-offset: 4
 307  * indent-tabs-mode: t
 308  * End:
 309  *
 310  * ex: set ts=8 sts=4 sw=4 noet:
 311  */