line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#define PERL_NO_GET_CONTEXT |
2
|
|
|
|
|
|
|
#include |
3
|
|
|
|
|
|
|
#include |
4
|
|
|
|
|
|
|
#include |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
#define NEED_PL_parser |
7
|
|
|
|
|
|
|
#include "ppport.h" |
8
|
|
|
|
|
|
|
#include "mgx.h" |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
static void |
11
|
2
|
|
|
|
|
|
my_qerror(pTHX_ SV *err) |
12
|
|
|
|
|
|
|
{ |
13
|
|
|
|
|
|
|
dVAR; |
14
|
2
|
50
|
|
|
|
|
if (PL_in_eval) |
15
|
2
|
50
|
|
|
|
|
sv_catsv(ERRSV, err); |
16
|
0
|
0
|
|
|
|
|
else if (PL_errors) |
17
|
0
|
|
|
|
|
|
sv_catsv(PL_errors, err); |
18
|
|
|
|
|
|
|
else |
19
|
0
|
|
|
|
|
|
Perl_warn(aTHX_ "%"SVf, SVfARG(err)); |
20
|
2
|
50
|
|
|
|
|
++PL_error_count; |
21
|
2
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
#undef qerror |
23
|
|
|
|
|
|
|
#define qerror(msg) my_qerror(aTHX_ msg) |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
#define PACKAGE "Sub::Attribute" |
27
|
|
|
|
|
|
|
#define META_ATTR "ATTR_SUB" |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
#define MY_CXT_KEY PACKAGE "::_guts" XS_VERSION |
30
|
|
|
|
|
|
|
typedef struct { |
31
|
|
|
|
|
|
|
AV* queue; |
32
|
|
|
|
|
|
|
I32 debug; |
33
|
|
|
|
|
|
|
} my_cxt_t; |
34
|
|
|
|
|
|
|
START_MY_CXT |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
enum { |
37
|
|
|
|
|
|
|
SA_KLASS, |
38
|
|
|
|
|
|
|
SA_CODE, |
39
|
|
|
|
|
|
|
SA_NAME, |
40
|
|
|
|
|
|
|
SA_DATA, |
41
|
|
|
|
|
|
|
SA_METHOD |
42
|
|
|
|
|
|
|
}; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
static void |
45
|
71
|
|
|
|
|
|
apply_handler(pTHX_ pMY_CXT_ AV* const handler){ |
46
|
71
|
|
|
|
|
|
SV* const klass = AvARRAY(handler)[SA_KLASS]; |
47
|
71
|
|
|
|
|
|
SV* const code_ref = AvARRAY(handler)[SA_CODE]; |
48
|
71
|
|
|
|
|
|
CV* const cv = (CV*)SvRV(code_ref); |
49
|
71
|
|
|
|
|
|
SV* const name = AvARRAY(handler)[SA_NAME]; |
50
|
71
|
|
|
|
|
|
SV* const data = AvARRAY(handler)[SA_DATA]; |
51
|
71
|
|
|
|
|
|
SV* const method = AvARRAY(handler)[SA_METHOD]; |
52
|
71
|
|
|
|
|
|
dSP; |
53
|
|
|
|
|
|
|
|
54
|
71
|
50
|
|
|
|
|
if(sv_true(ERRSV)){ /* dying by bad attributes */ |
|
|
100
|
|
|
|
|
|
55
|
2
|
50
|
|
|
|
|
qerror(ERRSV); |
56
|
2
|
|
|
|
|
|
return; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
assert(CvGV(cv)); |
60
|
|
|
|
|
|
|
assert(SvTYPE(method) == SVt_PVCV); |
61
|
|
|
|
|
|
|
|
62
|
69
|
50
|
|
|
|
|
if(MY_CXT.debug){ |
63
|
0
|
0
|
|
|
|
|
warn("apply attribute :%s%s to &%s in %"SVf, |
64
|
0
|
|
|
|
|
|
GvNAME(CvGV((CV*)method)), |
65
|
0
|
0
|
|
|
|
|
SvOK(data) ? form("(%"SVf")", data) : "", |
|
|
0
|
|
|
|
|
|
66
|
0
|
|
|
|
|
|
GvNAME(CvGV(cv)), |
67
|
|
|
|
|
|
|
klass |
68
|
|
|
|
|
|
|
); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
69
|
50
|
|
|
|
|
PUSHMARK(SP); |
72
|
69
|
50
|
|
|
|
|
EXTEND(SP, 5); |
73
|
|
|
|
|
|
|
|
74
|
69
|
|
|
|
|
|
PUSHs(klass); |
75
|
69
|
100
|
|
|
|
|
if(!CvANON(cv)){ |
76
|
68
|
|
|
|
|
|
mPUSHs(newRV_inc((SV*)CvGV(cv))); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
else{ |
79
|
1
|
|
|
|
|
|
PUSHs(&PL_sv_undef); /* anonymous subroutines */ |
80
|
|
|
|
|
|
|
} |
81
|
69
|
|
|
|
|
|
PUSHs(code_ref); |
82
|
69
|
|
|
|
|
|
PUSHs(name); |
83
|
69
|
|
|
|
|
|
PUSHs(data); |
84
|
|
|
|
|
|
|
|
85
|
69
|
|
|
|
|
|
PUTBACK; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
I32 retval; |
88
|
69
|
|
|
|
|
|
retval = call_sv(method, G_VOID | G_EVAL); |
89
|
69
|
|
|
|
|
|
PL_stack_sp -= retval; |
90
|
|
|
|
|
|
|
|
91
|
69
|
50
|
|
|
|
|
if(sv_true(ERRSV)){ |
|
|
50
|
|
|
|
|
|
92
|
0
|
|
|
|
|
|
SV* const msg = sv_newmortal(); |
93
|
0
|
0
|
|
|
|
|
sv_setpvf(msg, "Can't apply attribute %"SVf" because: %"SVf, name, ERRSV); |
94
|
0
|
|
|
|
|
|
qerror(msg); |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
static int |
99
|
24
|
|
|
|
|
|
sa_process_queue(pTHX_ SV* const sv, MAGIC* const mg){ |
100
|
|
|
|
|
|
|
dMY_CXT; |
101
|
24
|
|
|
|
|
|
SV** svp = AvARRAY(MY_CXT.queue); |
102
|
24
|
|
|
|
|
|
SV** const end = svp + AvFILLp(MY_CXT.queue) + 1; |
103
|
|
|
|
|
|
|
PERL_UNUSED_ARG(sv); |
104
|
|
|
|
|
|
|
PERL_UNUSED_ARG(mg); |
105
|
|
|
|
|
|
|
|
106
|
24
|
|
|
|
|
|
ENTER; |
107
|
24
|
|
|
|
|
|
SAVETMPS; |
108
|
|
|
|
|
|
|
|
109
|
95
|
100
|
|
|
|
|
while(svp != end){ |
110
|
71
|
|
|
|
|
|
apply_handler(aTHX_ aMY_CXT_ (AV*)*svp); |
111
|
71
|
|
|
|
|
|
svp++; |
112
|
|
|
|
|
|
|
|
113
|
71
|
100
|
|
|
|
|
FREETMPS; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
24
|
|
|
|
|
|
LEAVE; |
117
|
|
|
|
|
|
|
|
118
|
24
|
|
|
|
|
|
av_clear(MY_CXT.queue); |
119
|
24
|
|
|
|
|
|
return 0; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
static SV* |
123
|
84
|
|
|
|
|
|
sa_newSVsv_share(pTHX_ SV* const sv){ |
124
|
|
|
|
|
|
|
STRLEN len; |
125
|
84
|
50
|
|
|
|
|
const char* const pv = SvPV_const(sv, len); |
126
|
84
|
|
|
|
|
|
return newSVpvn_share(pv, len, 0U); |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
static MGVTBL hook_scope_vtbl = { |
130
|
|
|
|
|
|
|
NULL, /* get */ |
131
|
|
|
|
|
|
|
NULL, /* set */ |
132
|
|
|
|
|
|
|
NULL, /* len */ |
133
|
|
|
|
|
|
|
NULL, /* clear */ |
134
|
|
|
|
|
|
|
sa_process_queue, /* free */ |
135
|
|
|
|
|
|
|
NULL, /* copy */ |
136
|
|
|
|
|
|
|
NULL, /* dup */ |
137
|
|
|
|
|
|
|
#ifdef MGf_LOCAL |
138
|
|
|
|
|
|
|
NULL, /* local */ |
139
|
|
|
|
|
|
|
#endif |
140
|
|
|
|
|
|
|
}; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
static MGVTBL attr_handler_vtbl; |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
MODULE = Sub::Attribute PACKAGE = Sub::Attribute |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
PROTOTYPES: DISABLE |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
BOOT: |
151
|
|
|
|
|
|
|
{ |
152
|
11
|
|
|
|
|
|
const char* const d = PerlEnv_getenv("SUB_ATTRIBUTE_DEBUG"); |
153
|
|
|
|
|
|
|
MY_CXT_INIT; |
154
|
11
|
|
|
|
|
|
MY_CXT.queue = newAV(); |
155
|
11
|
50
|
|
|
|
|
MY_CXT.debug = (d && *d != '\0' && strNE(d, "0")); |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
void |
159
|
|
|
|
|
|
|
CLONE(...) |
160
|
|
|
|
|
|
|
CODE: |
161
|
|
|
|
|
|
|
MY_CXT_CLONE; |
162
|
0
|
|
|
|
|
|
MY_CXT.queue = newAV(); |
163
|
|
|
|
|
|
|
PERL_UNUSED_VAR(items); |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
void |
166
|
|
|
|
|
|
|
MODIFY_CODE_ATTRIBUTES(SV* klass, CV* code, ...) |
167
|
|
|
|
|
|
|
PREINIT: |
168
|
|
|
|
|
|
|
dMY_CXT; |
169
|
84
|
50
|
|
|
|
|
HV* const hinthv = GvHVn(PL_hintgv); |
170
|
|
|
|
|
|
|
HV* stash; |
171
|
|
|
|
|
|
|
MAGIC* mg; |
172
|
|
|
|
|
|
|
I32 i; |
173
|
|
|
|
|
|
|
PPCODE: |
174
|
84
|
|
|
|
|
|
mg = mg_find_by_vtbl((SV*)hinthv, &hook_scope_vtbl); |
175
|
84
|
100
|
|
|
|
|
if(!mg){ |
176
|
24
|
|
|
|
|
|
sv_magicext((SV*)hinthv, NULL, PERL_MAGIC_ext, &hook_scope_vtbl, NULL, 0); |
177
|
24
|
|
|
|
|
|
PL_hints |= HINT_LOCALIZE_HH; |
178
|
|
|
|
|
|
|
} |
179
|
84
|
|
|
|
|
|
stash = gv_stashsv(klass, TRUE); |
180
|
84
|
|
|
|
|
|
klass = sa_newSVsv_share(aTHX_ klass); |
181
|
|
|
|
|
|
|
|
182
|
172
|
100
|
|
|
|
|
for(i = 2; i < items; i++){ |
183
|
|
|
|
|
|
|
STRLEN attrlen; |
184
|
88
|
50
|
|
|
|
|
const char* const attr = SvPV_const(ST(i), attrlen); |
185
|
88
|
|
|
|
|
|
const char* data = strchr(attr, '('); |
186
|
88
|
|
|
|
|
|
STRLEN datalen = attrlen - (data - attr) - 2; |
187
|
88
|
100
|
|
|
|
|
STRLEN const namelen = data ? (STRLEN)(data - attr) : attrlen; |
188
|
|
|
|
|
|
|
GV* meth; |
189
|
|
|
|
|
|
|
|
190
|
88
|
100
|
|
|
|
|
if(data){ |
191
|
14
|
|
|
|
|
|
data++; /* skip '(' */ |
192
|
20
|
100
|
|
|
|
|
while(isSPACE(*data)){ |
193
|
6
|
|
|
|
|
|
data++; |
194
|
6
|
|
|
|
|
|
datalen--; |
195
|
|
|
|
|
|
|
} |
196
|
20
|
100
|
|
|
|
|
while(isSPACE(data[datalen-1])){ |
197
|
6
|
|
|
|
|
|
datalen--; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
|
201
|
88
|
100
|
|
|
|
|
if(strnEQ(attr, META_ATTR, sizeof(META_ATTR))){ /* meta attribute */ |
202
|
13
|
50
|
|
|
|
|
if(!MgFind((SV*)code, &attr_handler_vtbl)){ |
|
|
0
|
|
|
|
|
|
203
|
13
|
|
|
|
|
|
sv_magicext( |
204
|
|
|
|
|
|
|
(SV*)code, |
205
|
|
|
|
|
|
|
NULL, PERL_MAGIC_ext, &attr_handler_vtbl, |
206
|
|
|
|
|
|
|
PACKAGE, 0 |
207
|
|
|
|
|
|
|
); |
208
|
|
|
|
|
|
|
|
209
|
13
|
50
|
|
|
|
|
if(MY_CXT.debug){ |
210
|
0
|
|
|
|
|
|
warn("install attribute handler %"SVf"\n", PL_subname); |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
} |
213
|
13
|
|
|
|
|
|
continue; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
75
|
|
|
|
|
|
meth = gv_fetchmeth_autoload(stash, attr, namelen, 0 /* special zero */); |
217
|
146
|
100
|
|
|
|
|
if(meth && MgFind((SV*)GvCV(meth), &attr_handler_vtbl)){ |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
218
|
71
|
|
|
|
|
|
AV* const handler = newAV(); |
219
|
|
|
|
|
|
|
|
220
|
71
|
|
|
|
|
|
av_store(handler, SA_METHOD, SvREFCNT_inc_simple_NN((SV*)GvCV(meth))); |
221
|
71
|
|
|
|
|
|
av_store(handler, SA_KLASS, SvREFCNT_inc_simple_NN(klass)); |
222
|
71
|
|
|
|
|
|
av_store(handler, SA_CODE, newRV_inc((SV*)code)); |
223
|
71
|
|
|
|
|
|
av_store(handler, SA_NAME, newSVpvn_share(attr, namelen, 0U)); |
224
|
|
|
|
|
|
|
|
225
|
71
|
100
|
|
|
|
|
if(data){ |
226
|
13
|
|
|
|
|
|
av_store(handler, SA_DATA, newSVpvn(data, datalen)); |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
71
|
|
|
|
|
|
av_push(MY_CXT.queue, (SV*)handler); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
else{ |
232
|
4
|
50
|
|
|
|
|
if(MY_CXT.debug){ |
233
|
0
|
|
|
|
|
|
warn("ignore unrecognized attribute :%"SVf"\n", ST(i)); |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
#if PERL_BCDVERSION < 0x5008009 |
236
|
|
|
|
|
|
|
/* See RT #53420 */ |
237
|
|
|
|
|
|
|
{ |
238
|
|
|
|
|
|
|
const char* const a = SvPV_nolen_const(ST(i)); |
239
|
|
|
|
|
|
|
if( strEQ(a, "lvalue") |
240
|
|
|
|
|
|
|
|| strEQ(a, "method") |
241
|
|
|
|
|
|
|
|| strEQ(a, "locked") |
242
|
|
|
|
|
|
|
|| strEQ(a, "unique") |
243
|
|
|
|
|
|
|
|| strEQ(a, "shared") ){ |
244
|
|
|
|
|
|
|
continue; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
#endif |
248
|
75
|
50
|
|
|
|
|
XPUSHs(ST(i)); |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
} |