line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
/* You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
* or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
* |
4
|
|
|
|
|
|
|
* (C) Paul Evans, 2011 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
*/ |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
#define PERL_NO_GET_CONTEXT |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
#include "EXTERN.h" |
10
|
|
|
|
|
|
|
#include "perl.h" |
11
|
|
|
|
|
|
|
#include "XSUB.h" |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
#ifndef G_METHOD_NAMED |
14
|
|
|
|
|
|
|
#define G_METHOD_NAMED G_METHOD |
15
|
|
|
|
|
|
|
#endif |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
#include |
18
|
|
|
|
|
|
|
#define streq(a,b) (strcmp((a),(b)) == 0) |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
enum { |
21
|
|
|
|
|
|
|
CTX_GET_CB, |
22
|
|
|
|
|
|
|
CTX_SET_CB, |
23
|
|
|
|
|
|
|
CTX_OBJ, |
24
|
|
|
|
|
|
|
}; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
typedef SV *sentinel_ctx; |
27
|
|
|
|
|
|
|
|
28
|
16
|
|
|
|
|
|
static int magic_get(pTHX_ SV *sv, MAGIC *mg) |
29
|
|
|
|
|
|
|
{ |
30
|
16
|
|
|
|
|
|
dSP; |
31
|
16
|
|
|
|
|
|
sentinel_ctx *ctx = (sentinel_ctx*)AvARRAY(mg->mg_obj); |
32
|
|
|
|
|
|
|
|
33
|
16
|
100
|
|
|
|
|
if(ctx[CTX_GET_CB]) { |
34
|
|
|
|
|
|
|
int count; |
35
|
|
|
|
|
|
|
|
36
|
13
|
|
|
|
|
|
ENTER; |
37
|
13
|
|
|
|
|
|
SAVETMPS; |
38
|
|
|
|
|
|
|
|
39
|
13
|
50
|
|
|
|
|
PUSHMARK(SP); |
40
|
13
|
100
|
|
|
|
|
if(ctx[CTX_OBJ]) { |
41
|
7
|
50
|
|
|
|
|
EXTEND(SP, 1); |
42
|
7
|
|
|
|
|
|
PUSHs(ctx[CTX_OBJ]); |
43
|
|
|
|
|
|
|
} |
44
|
13
|
|
|
|
|
|
PUTBACK; |
45
|
|
|
|
|
|
|
|
46
|
13
|
100
|
|
|
|
|
if(ctx[CTX_OBJ] && SvPOK(ctx[CTX_GET_CB])) |
|
|
100
|
|
|
|
|
|
47
|
|
|
|
|
|
|
// Calling method by name |
48
|
2
|
|
|
|
|
|
count = call_sv(ctx[CTX_GET_CB], G_SCALAR | G_METHOD_NAMED); |
49
|
|
|
|
|
|
|
else |
50
|
11
|
|
|
|
|
|
count = call_sv(ctx[CTX_GET_CB], G_SCALAR); |
51
|
|
|
|
|
|
|
assert(count == 1); |
52
|
|
|
|
|
|
|
|
53
|
13
|
|
|
|
|
|
SPAGAIN; |
54
|
13
|
|
|
|
|
|
sv_setsv_nomg(sv, POPs); |
55
|
|
|
|
|
|
|
|
56
|
13
|
|
|
|
|
|
PUTBACK; |
57
|
13
|
50
|
|
|
|
|
FREETMPS; |
58
|
13
|
|
|
|
|
|
LEAVE; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
16
|
|
|
|
|
|
return 1; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
10
|
|
|
|
|
|
static int magic_set(pTHX_ SV *sv, MAGIC *mg) |
65
|
|
|
|
|
|
|
{ |
66
|
10
|
|
|
|
|
|
dSP; |
67
|
10
|
|
|
|
|
|
sentinel_ctx *ctx = (sentinel_ctx*)AvARRAY(mg->mg_obj); |
68
|
|
|
|
|
|
|
|
69
|
10
|
50
|
|
|
|
|
if(ctx[CTX_SET_CB]) { |
70
|
10
|
|
|
|
|
|
ENTER; |
71
|
10
|
|
|
|
|
|
SAVETMPS; |
72
|
|
|
|
|
|
|
|
73
|
10
|
50
|
|
|
|
|
PUSHMARK(SP); |
74
|
10
|
100
|
|
|
|
|
if(ctx[CTX_OBJ]) { |
75
|
5
|
50
|
|
|
|
|
EXTEND(SP, 2); |
76
|
5
|
|
|
|
|
|
PUSHs(ctx[CTX_OBJ]); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
else { |
79
|
5
|
50
|
|
|
|
|
EXTEND(SP, 1); |
80
|
|
|
|
|
|
|
} |
81
|
10
|
|
|
|
|
|
PUSHs(sv); |
82
|
10
|
|
|
|
|
|
PUTBACK; |
83
|
|
|
|
|
|
|
|
84
|
10
|
100
|
|
|
|
|
if(ctx[CTX_OBJ] && SvPOK(ctx[CTX_SET_CB])) |
|
|
100
|
|
|
|
|
|
85
|
|
|
|
|
|
|
// Calling method by name |
86
|
2
|
|
|
|
|
|
call_sv(ctx[CTX_SET_CB], G_VOID | G_METHOD_NAMED); |
87
|
|
|
|
|
|
|
else |
88
|
8
|
|
|
|
|
|
call_sv(ctx[CTX_SET_CB], G_VOID); |
89
|
|
|
|
|
|
|
|
90
|
10
|
50
|
|
|
|
|
FREETMPS; |
91
|
10
|
|
|
|
|
|
LEAVE; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
10
|
|
|
|
|
|
return 1; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
static MGVTBL vtbl = { |
98
|
|
|
|
|
|
|
&magic_get, |
99
|
|
|
|
|
|
|
&magic_set, |
100
|
|
|
|
|
|
|
}; |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
MODULE = Sentinel PACKAGE = Sentinel |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
SV * |
105
|
|
|
|
|
|
|
sentinel(...) |
106
|
|
|
|
|
|
|
PREINIT: |
107
|
|
|
|
|
|
|
int i; |
108
|
|
|
|
|
|
|
SV *value = NULL; |
109
|
|
|
|
|
|
|
SV *get_cb = NULL; |
110
|
|
|
|
|
|
|
SV *set_cb = NULL; |
111
|
|
|
|
|
|
|
SV *obj = NULL; |
112
|
|
|
|
|
|
|
SV *retval; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
PPCODE: |
115
|
|
|
|
|
|
|
/* Parse name => value argument pairs */ |
116
|
63
|
100
|
|
|
|
|
for(i = 0; i < items; i += 2) { |
117
|
43
|
50
|
|
|
|
|
char *argname = SvPV_nolen(ST(i)); |
118
|
43
|
|
|
|
|
|
SV *argvalue = ST(i+1); |
119
|
|
|
|
|
|
|
|
120
|
43
|
100
|
|
|
|
|
if(streq(argname, "value")) { |
121
|
|
|
|
|
|
|
value = argvalue; |
122
|
|
|
|
|
|
|
} |
123
|
38
|
100
|
|
|
|
|
else if(streq(argname, "get")) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
124
|
|
|
|
|
|
|
get_cb = argvalue; |
125
|
|
|
|
|
|
|
} |
126
|
25
|
100
|
|
|
|
|
else if(streq(argname, "set")) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
127
|
|
|
|
|
|
|
set_cb = argvalue; |
128
|
|
|
|
|
|
|
} |
129
|
10
|
50
|
|
|
|
|
else if(streq(argname, "obj")) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
130
|
|
|
|
|
|
|
obj = argvalue; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
else { |
133
|
0
|
|
|
|
|
|
fprintf(stderr, "Argument %s at %p\n", argname, argvalue); |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
20
|
|
|
|
|
|
retval = sv_newmortal(); |
138
|
|
|
|
|
|
|
/** |
139
|
|
|
|
|
|
|
* Perl 5.14 allows any TEMP scalar to be returned in LVALUE context provided |
140
|
|
|
|
|
|
|
* it is magical. Perl versions before this only accept magic for being a tied |
141
|
|
|
|
|
|
|
* array or hash element. Rather than try to hack this magic type, we'll just |
142
|
|
|
|
|
|
|
* pretend the SV isn't a TEMP |
143
|
|
|
|
|
|
|
* The following workaround is known to work on Perl 5.12.4. |
144
|
|
|
|
|
|
|
*/ |
145
|
|
|
|
|
|
|
#if (PERL_REVISION == 5) && (PERL_VERSION < 14) |
146
|
|
|
|
|
|
|
SvFLAGS(retval) &= ~SVs_TEMP; |
147
|
|
|
|
|
|
|
#endif |
148
|
|
|
|
|
|
|
|
149
|
20
|
100
|
|
|
|
|
if(value) |
150
|
5
|
|
|
|
|
|
sv_setsv(retval, value); |
151
|
|
|
|
|
|
|
|
152
|
20
|
100
|
|
|
|
|
if(get_cb || set_cb) { |
153
|
|
|
|
|
|
|
sentinel_ctx *ctx; |
154
|
17
|
|
|
|
|
|
AV* payload = newAV(); |
155
|
17
|
|
|
|
|
|
av_extend(payload, 2); |
156
|
17
|
|
|
|
|
|
AvFILLp(payload) = 2; |
157
|
|
|
|
|
|
|
|
158
|
17
|
|
|
|
|
|
ctx = (sentinel_ctx*)AvARRAY(payload); |
159
|
|
|
|
|
|
|
|
160
|
17
|
100
|
|
|
|
|
ctx[CTX_GET_CB] = get_cb ? newSVsv(get_cb) : NULL; |
161
|
17
|
100
|
|
|
|
|
ctx[CTX_SET_CB] = set_cb ? newSVsv(set_cb) : NULL; |
162
|
17
|
100
|
|
|
|
|
ctx[CTX_OBJ] = obj ? newSVsv(obj) : NULL; |
163
|
|
|
|
|
|
|
|
164
|
17
|
|
|
|
|
|
sv_magicext(retval, (SV*)payload, PERL_MAGIC_ext, &vtbl, NULL, 0); |
165
|
|
|
|
|
|
|
SvREFCNT_dec(payload); |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
20
|
50
|
|
|
|
|
if (!items) |
169
|
0
|
0
|
|
|
|
|
EXTEND(SP, 1); |
170
|
20
|
|
|
|
|
|
PUSHs(retval); |
171
|
20
|
|
|
|
|
|
XSRETURN(1); |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
BOOT: |
174
|
8
|
|
|
|
|
|
CvLVALUE_on(get_cv("Sentinel::sentinel", 0)); |