This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove unneeded 'use' from ext/XS-APItest/t/peep.t Devel::Peek is not used by ext...
[perl5.git] / ext / attributes / attributes.xs
CommitLineData
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 *
15 * [p.597 of _The Lord of the Rings_, III/xi: "The Palantír"]
d31a8517
AT
16 */
17
18
09bef843 19#include "EXTERN.h"
09bef843 20#include "perl.h"
48462a74 21#include "XSUB.h"
09bef843
SB
22
23/*
24 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
25 */
26
349fd7b7 27static int
acfe0abc 28modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
09bef843 29{
97aff369 30 dVAR;
09bef843 31 SV *attr;
09bef843
SB
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
AL
37 const bool negated = (*name == '-');
38
39 if (negated) {
09bef843
SB
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
SB
54 continue;
55 }
8cad210e 56 break;
8cad210e
NC
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
SB
63 continue;
64 }
65 break;
66 }
67 break;
68 }
69 break;
70 default:
f1a3ce43 71 if (memEQs(name, 6, "shared")) {
13c1b207
DM
72 if (negated)
73 Perl_croak(aTHX_ "A variable may not be unshared");
74 SvSHARE(sv);
75 continue;
f1a3ce43 76 }
09bef843
SB
77 break;
78 }
79 /* anything recognized had a 'continue' above */
80 *retlist++ = attr;
81 nret++;
82 }
83
84 return nret;
85}
86
48462a74 87MODULE = attributes PACKAGE = attributes
09bef843 88
48462a74
NC
89void
90_modify_attrs(...)
91 PREINIT:
09bef843 92 SV *rv, *sv;
48462a74 93 PPCODE:
09bef843
SB
94
95 if (items < 1) {
96usage:
afa74d42 97 croak_xs_usage(cv, "@attributes");
09bef843
SB
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
SB
106
107 XSRETURN(0);
09bef843 108
48462a74
NC
109void
110_fetch_attrs(...)
6e0da8f3 111 PROTOTYPE: $
48462a74 112 PREINIT:
09bef843
SB
113 SV *rv, *sv;
114 cv_flags_t cvflags;
48462a74 115 PPCODE:
09bef843
SB
116 if (items != 1) {
117usage:
afa74d42 118 croak_xs_usage(cv, "$reference");
09bef843
SB
119 }
120
121 rv = ST(0);
09bef843
SB
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
SB
133 break;
134 default:
135 break;
136 }
137
138 PUTBACK;
09bef843 139
48462a74
NC
140void
141_guess_stash(...)
6e0da8f3 142 PROTOTYPE: $
48462a74 143 PREINIT:
09bef843 144 SV *rv, *sv;
d277572a 145 dXSTARG;
48462a74 146 PPCODE:
09bef843
SB
147 if (items != 1) {
148usage:
afa74d42 149 croak_xs_usage(cv, "$reference");
09bef843
SB
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
SB
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
SB
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
SB
171 stash = CvSTASH(sv);
172 break;
09bef843 173 case SVt_PVGV:
159b6efe
NC
174 if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
175 stash = GvESTASH(MUTABLE_GV(sv));
09bef843
SB
176 break;
177 default:
178 break;
179 }
180 if (stash)
7423f6db 181 sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
09bef843
SB
182 }
183
09bef843 184 SvSETMAGIC(TARG);
09bef843 185 XSRETURN(1);
09bef843 186
48462a74
NC
187void
188reftype(...)
6e0da8f3 189 PROTOTYPE: $
48462a74 190 PREINIT:
09bef843 191 SV *rv, *sv;
d277572a 192 dXSTARG;
48462a74 193 PPCODE:
09bef843
SB
194 if (items != 1) {
195usage:
afa74d42 196 croak_xs_usage(cv, "$reference");
09bef843
SB
197 }
198
199 rv = ST(0);
200 ST(0) = TARG;
5b295bef 201 SvGETMAGIC(rv);
121e869f 202 if (!(SvOK(rv) && SvROK(rv)))
09bef843
SB
203 goto usage;
204 sv = SvRV(rv);
205 sv_setpv(TARG, sv_reftype(sv, 0));
09bef843 206 SvSETMAGIC(TARG);
09bef843
SB
207
208 XSRETURN(1);
66610fdd
RGS
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 */