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