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