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 #define PERL_NO_GET_CONTEXT 19 20 #include "EXTERN.h" 21 #include "perl.h" 22 #include "XSUB.h" 23 24 /* 25 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us). 26 */ 27 28 static int 29 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) 30 { 31 dVAR; 32 SV *attr; 33 int nret; 34 35 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) { 36 STRLEN len; 37 const char *name = SvPV_const(attr, len); 38 const bool negated = (*name == '-'); 39 40 if (negated) { 41 name++; 42 len--; 43 } 44 switch (SvTYPE(sv)) { 45 case SVt_PVCV: 46 switch ((int)len) { 47 case 6: 48 switch (name[3]) { 49 case 'l': 50 if (memEQ(name, "lvalue", 6)) { 51 bool warn = 52 !CvISXSUB(MUTABLE_CV(sv)) 53 && CvROOT(MUTABLE_CV(sv)) 54 && !CvLVALUE(MUTABLE_CV(sv)) != negated; 55 if (negated) 56 CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE; 57 else 58 CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE; 59 if (warn) break; 60 continue; 61 } 62 break; 63 case 'h': 64 if (memEQ(name, "method", 6)) { 65 if (negated) 66 CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD; 67 else 68 CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD; 69 continue; 70 } 71 break; 72 } 73 break; 74 } 75 break; 76 default: 77 if (memEQs(name, 6, "shared")) { 78 if (negated) 79 Perl_croak(aTHX_ "A variable may not be unshared"); 80 SvSHARE(sv); 81 continue; 82 } 83 break; 84 } 85 /* anything recognized had a 'continue' above */ 86 *retlist++ = attr; 87 nret++; 88 } 89 90 return nret; 91 } 92 93 MODULE = attributes PACKAGE = attributes 94 95 void 96 _modify_attrs(...) 97 PREINIT: 98 SV *rv, *sv; 99 PPCODE: 100 101 if (items < 1) { 102 usage: 103 croak_xs_usage(cv, "@attributes"); 104 } 105 106 rv = ST(0); 107 if (!(SvOK(rv) && SvROK(rv))) 108 goto usage; 109 sv = SvRV(rv); 110 if (items > 1) 111 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1)); 112 113 XSRETURN(0); 114 115 void 116 _fetch_attrs(...) 117 PROTOTYPE: $ 118 PREINIT: 119 SV *rv, *sv; 120 cv_flags_t cvflags; 121 PPCODE: 122 if (items != 1) { 123 usage: 124 croak_xs_usage(cv, "$reference"); 125 } 126 127 rv = ST(0); 128 if (!(SvOK(rv) && SvROK(rv))) 129 goto usage; 130 sv = SvRV(rv); 131 132 switch (SvTYPE(sv)) { 133 case SVt_PVCV: 134 cvflags = CvFLAGS((const CV *)sv); 135 if (cvflags & CVf_LVALUE) 136 XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP)); 137 if (cvflags & CVf_METHOD) 138 XPUSHs(newSVpvs_flags("method", SVs_TEMP)); 139 break; 140 default: 141 break; 142 } 143 144 PUTBACK; 145 146 void 147 _guess_stash(...) 148 PROTOTYPE: $ 149 PREINIT: 150 SV *rv, *sv; 151 dXSTARG; 152 PPCODE: 153 if (items != 1) { 154 usage: 155 croak_xs_usage(cv, "$reference"); 156 } 157 158 rv = ST(0); 159 ST(0) = TARG; 160 if (!(SvOK(rv) && SvROK(rv))) 161 goto usage; 162 sv = SvRV(rv); 163 164 if (SvOBJECT(sv)) 165 Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(SvSTASH(sv))); 166 #if 0 /* this was probably a bad idea */ 167 else if (SvPADMY(sv)) 168 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */ 169 #endif 170 else { 171 const HV *stash = NULL; 172 switch (SvTYPE(sv)) { 173 case SVt_PVCV: 174 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv))) 175 stash = GvSTASH(CvGV(sv)); 176 else if (/* !CvANON(sv) && */ CvSTASH(sv)) 177 stash = CvSTASH(sv); 178 break; 179 case SVt_PVGV: 180 if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv))) 181 stash = GvESTASH(MUTABLE_GV(sv)); 182 break; 183 default: 184 break; 185 } 186 if (stash) 187 Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(stash)); 188 } 189 190 SvSETMAGIC(TARG); 191 XSRETURN(1); 192 193 void 194 reftype(...) 195 PROTOTYPE: $ 196 PREINIT: 197 SV *rv, *sv; 198 dXSTARG; 199 PPCODE: 200 if (items != 1) { 201 usage: 202 croak_xs_usage(cv, "$reference"); 203 } 204 205 rv = ST(0); 206 ST(0) = TARG; 207 SvGETMAGIC(rv); 208 if (!(SvOK(rv) && SvROK(rv))) 209 goto usage; 210 sv = SvRV(rv); 211 sv_setpv(TARG, sv_reftype(sv, 0)); 212 SvSETMAGIC(TARG); 213 214 XSRETURN(1); 215 /* 216 * Local variables: 217 * c-indentation-style: bsd 218 * c-basic-offset: 4 219 * indent-tabs-mode: nil 220 * End: 221 * 222 * ex: set ts=8 sts=4 sw=4 et: 223 */ 224