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
|
|
|
|
|
|
*/ |