File Coverage

ext/attributes/attributes.xs
Criterion Covered Total %
statement 67 83 80.7
branch n/a
condition n/a
subroutine n/a
total 67 83 80.7


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