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