Commit | Line | Data |
d6376244 |
1 | /* xsutils.c |
2 | * |
1129b882 |
3 | * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 |
371fce9b |
4 | * by Larry Wall and others |
d6376244 |
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 | |
d31a8517 |
11 | /* |
4ac71550 |
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"] |
d31a8517 |
16 | */ |
17 | |
18 | |
09bef843 |
19 | #include "EXTERN.h" |
09bef843 |
20 | #include "perl.h" |
48462a74 |
21 | #include "XSUB.h" |
09bef843 |
22 | |
23 | /* |
24 | * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us). |
25 | */ |
26 | |
349fd7b7 |
27 | static int |
acfe0abc |
28 | modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) |
09bef843 |
29 | { |
97aff369 |
30 | dVAR; |
09bef843 |
31 | SV *attr; |
09bef843 |
32 | int nret; |
33 | |
34 | for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) { |
4373e329 |
35 | STRLEN len; |
cfd0369c |
36 | const char *name = SvPV_const(attr, len); |
4373e329 |
37 | const bool negated = (*name == '-'); |
38 | |
39 | if (negated) { |
09bef843 |
40 | name++; |
41 | len--; |
42 | } |
43 | switch (SvTYPE(sv)) { |
44 | case SVt_PVCV: |
45 | switch ((int)len) { |
46 | case 6: |
8cad210e |
47 | switch (name[3]) { |
d5adc3a1 |
48 | case 'l': |
8cad210e |
49 | if (memEQ(name, "lvalue", 6)) { |
09bef843 |
50 | if (negated) |
ea726b52 |
51 | CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE; |
09bef843 |
52 | else |
ea726b52 |
53 | CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE; |
09bef843 |
54 | continue; |
55 | } |
8cad210e |
56 | break; |
8cad210e |
57 | case 'h': |
58 | if (memEQ(name, "method", 6)) { |
09bef843 |
59 | if (negated) |
ea726b52 |
60 | CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD; |
09bef843 |
61 | else |
ea726b52 |
62 | CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD; |
09bef843 |
63 | continue; |
64 | } |
65 | break; |
66 | } |
67 | break; |
68 | } |
69 | break; |
70 | default: |
f1a3ce43 |
71 | if (memEQs(name, 6, "shared")) { |
13c1b207 |
72 | if (negated) |
73 | Perl_croak(aTHX_ "A variable may not be unshared"); |
74 | SvSHARE(sv); |
75 | continue; |
f1a3ce43 |
76 | } |
09bef843 |
77 | break; |
78 | } |
79 | /* anything recognized had a 'continue' above */ |
80 | *retlist++ = attr; |
81 | nret++; |
82 | } |
83 | |
84 | return nret; |
85 | } |
86 | |
48462a74 |
87 | MODULE = attributes PACKAGE = attributes |
09bef843 |
88 | |
48462a74 |
89 | void |
90 | _modify_attrs(...) |
91 | PREINIT: |
09bef843 |
92 | SV *rv, *sv; |
48462a74 |
93 | PPCODE: |
09bef843 |
94 | |
95 | if (items < 1) { |
96 | usage: |
afa74d42 |
97 | croak_xs_usage(cv, "@attributes"); |
09bef843 |
98 | } |
99 | |
100 | rv = ST(0); |
101 | if (!(SvOK(rv) && SvROK(rv))) |
102 | goto usage; |
103 | sv = SvRV(rv); |
104 | if (items > 1) |
acfe0abc |
105 | XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1)); |
09bef843 |
106 | |
107 | XSRETURN(0); |
09bef843 |
108 | |
48462a74 |
109 | void |
110 | _fetch_attrs(...) |
6e0da8f3 |
111 | PROTOTYPE: $ |
48462a74 |
112 | PREINIT: |
09bef843 |
113 | SV *rv, *sv; |
114 | cv_flags_t cvflags; |
48462a74 |
115 | PPCODE: |
09bef843 |
116 | if (items != 1) { |
117 | usage: |
afa74d42 |
118 | croak_xs_usage(cv, "$reference"); |
09bef843 |
119 | } |
120 | |
121 | rv = ST(0); |
09bef843 |
122 | if (!(SvOK(rv) && SvROK(rv))) |
123 | goto usage; |
124 | sv = SvRV(rv); |
125 | |
126 | switch (SvTYPE(sv)) { |
127 | case SVt_PVCV: |
ea726b52 |
128 | cvflags = CvFLAGS((const CV *)sv); |
09bef843 |
129 | if (cvflags & CVf_LVALUE) |
84bafc02 |
130 | XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP)); |
09bef843 |
131 | if (cvflags & CVf_METHOD) |
84bafc02 |
132 | XPUSHs(newSVpvs_flags("method", SVs_TEMP)); |
09bef843 |
133 | break; |
134 | default: |
135 | break; |
136 | } |
137 | |
138 | PUTBACK; |
09bef843 |
139 | |
48462a74 |
140 | void |
141 | _guess_stash(...) |
6e0da8f3 |
142 | PROTOTYPE: $ |
48462a74 |
143 | PREINIT: |
09bef843 |
144 | SV *rv, *sv; |
d277572a |
145 | dXSTARG; |
48462a74 |
146 | PPCODE: |
09bef843 |
147 | if (items != 1) { |
148 | usage: |
afa74d42 |
149 | croak_xs_usage(cv, "$reference"); |
09bef843 |
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)) |
7423f6db |
159 | sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv))); |
09bef843 |
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 { |
5c284bb0 |
165 | const HV *stash = NULL; |
09bef843 |
166 | switch (SvTYPE(sv)) { |
167 | case SVt_PVCV: |
6676db26 |
168 | if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv))) |
09bef843 |
169 | stash = GvSTASH(CvGV(sv)); |
6676db26 |
170 | else if (/* !CvANON(sv) && */ CvSTASH(sv)) |
09bef843 |
171 | stash = CvSTASH(sv); |
172 | break; |
09bef843 |
173 | case SVt_PVGV: |
159b6efe |
174 | if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv))) |
175 | stash = GvESTASH(MUTABLE_GV(sv)); |
09bef843 |
176 | break; |
177 | default: |
178 | break; |
179 | } |
180 | if (stash) |
7423f6db |
181 | sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash)); |
09bef843 |
182 | } |
183 | |
09bef843 |
184 | SvSETMAGIC(TARG); |
09bef843 |
185 | XSRETURN(1); |
09bef843 |
186 | |
48462a74 |
187 | void |
188 | reftype(...) |
6e0da8f3 |
189 | PROTOTYPE: $ |
48462a74 |
190 | PREINIT: |
09bef843 |
191 | SV *rv, *sv; |
d277572a |
192 | dXSTARG; |
48462a74 |
193 | PPCODE: |
09bef843 |
194 | if (items != 1) { |
195 | usage: |
afa74d42 |
196 | croak_xs_usage(cv, "$reference"); |
09bef843 |
197 | } |
198 | |
199 | rv = ST(0); |
200 | ST(0) = TARG; |
5b295bef |
201 | SvGETMAGIC(rv); |
121e869f |
202 | if (!(SvOK(rv) && SvROK(rv))) |
09bef843 |
203 | goto usage; |
204 | sv = SvRV(rv); |
205 | sv_setpv(TARG, sv_reftype(sv, 0)); |
09bef843 |
206 | SvSETMAGIC(TARG); |
09bef843 |
207 | |
208 | XSRETURN(1); |
66610fdd |
209 | /* |
210 | * Local variables: |
211 | * c-indentation-style: bsd |
212 | * c-basic-offset: 4 |
213 | * indent-tabs-mode: t |
214 | * End: |
215 | * |
37442d52 |
216 | * ex: set ts=8 sts=4 sw=4 noet: |
f1a3ce43 |
217 | */ |