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 default: 75 if (len > 10 && memEQ(name, "prototype(", 10)) { 76 SV * proto = newSVpvn(name+10,len-11); 77 HEK *const hek = CvNAME_HEK((CV *)sv); 78 SV *subname; 79 if (name[len-1] != ')') 80 Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list"); 81 if (hek) 82 subname = sv_2mortal(newSVhek(hek)); 83 else 84 subname=(SV *)CvGV((const CV *)sv); 85 if (ckWARN(WARN_ILLEGALPROTO)) 86 Perl_validate_proto(aTHX_ subname, proto, TRUE); 87 Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv, 88 (const GV *)subname, 89 name+10, 90 len-11, 91 SvUTF8(attr)); 92 sv_setpvn(MUTABLE_SV(sv), name+10, len-11); 93 if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv)); 94 continue; 95 } 96 break; 97 } 98 break; 99 default: 100 if (memEQs(name, len, "shared")) { 101 if (negated) 102 Perl_croak(aTHX_ "A variable may not be unshared"); 103 SvSHARE(sv); 104 continue; 105 } 106 break; 107 } 108 /* anything recognized had a 'continue' above */ 109 *retlist++ = attr; 110 nret++; 111 } 112 113 return nret; 114 } 115 116 MODULE = attributes PACKAGE = attributes 117 118 void 119 _modify_attrs(...) 120 PREINIT: 121 SV *rv, *sv; 122 PPCODE: 123 124 if (items < 1) { 125 usage: 126 croak_xs_usage(cv, "@attributes"); 127 } 128 129 rv = ST(0); 130 if (!(SvOK(rv) && SvROK(rv))) 131 goto usage; 132 sv = SvRV(rv); 133 if (items > 1) 134 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1)); 135 136 XSRETURN(0); 137 138 void 139 _fetch_attrs(...) 140 PROTOTYPE: $ 141 PREINIT: 142 SV *rv, *sv; 143 cv_flags_t cvflags; 144 PPCODE: 145 if (items != 1) { 146 usage: 147 croak_xs_usage(cv, "$reference"); 148 } 149 150 rv = ST(0); 151 if (!(SvOK(rv) && SvROK(rv))) 152 goto usage; 153 sv = SvRV(rv); 154 155 switch (SvTYPE(sv)) { 156 case SVt_PVCV: 157 cvflags = CvFLAGS((const CV *)sv); 158 if (cvflags & CVf_LVALUE) 159 XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP)); 160 if (cvflags & CVf_METHOD) 161 XPUSHs(newSVpvs_flags("method", SVs_TEMP)); 162 break; 163 default: 164 break; 165 } 166 167 PUTBACK; 168 169 void 170 _guess_stash(...) 171 PROTOTYPE: $ 172 PREINIT: 173 SV *rv, *sv; 174 dXSTARG; 175 PPCODE: 176 if (items != 1) { 177 usage: 178 croak_xs_usage(cv, "$reference"); 179 } 180 181 rv = ST(0); 182 ST(0) = TARG; 183 if (!(SvOK(rv) && SvROK(rv))) 184 goto usage; 185 sv = SvRV(rv); 186 187 if (SvOBJECT(sv)) 188 Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(SvSTASH(sv))); 189 #if 0 /* this was probably a bad idea */ 190 else if (SvPADMY(sv)) 191 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */ 192 #endif 193 else { 194 const HV *stash = NULL; 195 switch (SvTYPE(sv)) { 196 case SVt_PVCV: 197 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv))) 198 stash = GvSTASH(CvGV(sv)); 199 else if (/* !CvANON(sv) && */ CvSTASH(sv)) 200 stash = CvSTASH(sv); 201 break; 202 case SVt_PVGV: 203 if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv))) 204 stash = GvESTASH(MUTABLE_GV(sv)); 205 break; 206 default: 207 break; 208 } 209 if (stash) 210 Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(stash)); 211 } 212 213 SvSETMAGIC(TARG); 214 XSRETURN(1); 215 216 void 217 reftype(...) 218 PROTOTYPE: $ 219 PREINIT: 220 SV *rv, *sv; 221 dXSTARG; 222 PPCODE: 223 if (items != 1) { 224 usage: 225 croak_xs_usage(cv, "$reference"); 226 } 227 228 rv = ST(0); 229 ST(0) = TARG; 230 SvGETMAGIC(rv); 231 if (!(SvOK(rv) && SvROK(rv))) 232 goto usage; 233 sv = SvRV(rv); 234 sv_setpv(TARG, sv_reftype(sv, 0)); 235 SvSETMAGIC(TARG); 236 237 XSRETURN(1); 238 /* 239 * Local variables: 240 * c-indentation-style: bsd 241 * c-basic-offset: 4 242 * indent-tabs-mode: nil 243 * End: 244 * 245 * ex: set ts=8 sts=4 sw=4 et: 246 */ 247