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