1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
#include "PerlOGRECallback.h"
PerlOGRECallback::PerlOGRECallback(SV *pobj)
{
if (pobj != (SV *)NULL && sv_isobject(pobj)) {
mPerlObj = newSVsv(pobj); // copy the SV*
} else {
croak("Argument isn't an object, so Perl callback can't be set.\n");
}
}
PerlOGRECallback::~PerlOGRECallback()
{
if (mPerlObj != (SV *)NULL && SvREFCNT(mPerlObj)) {
SvREFCNT_dec(mPerlObj); // delete our copy
}
}
// check whether the Perl object has a callback method implemented
// (xxx: is there a perl API method or something easier than this?)
bool PerlOGRECallback::perlCallbackCan(string const &cbmeth)
{
int count;
SV *methret;
bool can;
dSP;
ENTER;
SAVETMPS;
// call `can' to see if they implemented the callback
PUSHMARK(SP);
XPUSHs(mPerlObj);
XPUSHs(sv_2mortal(newSVpv(cbmeth.c_str(), 0)));
PUTBACK;
count = call_method("can", G_SCALAR);
SPAGAIN;
if (count != 1) {
croak("can (%s) didn't return a single value?", cbmeth.c_str());
}
methret = POPs;
PUTBACK;
can = SvTRUE(methret);
FREETMPS;
LEAVE;
return can;
}
// before calling this, push the callback args onto the mCallbackArgs vector
bool PerlOGRECallback::callPerlCallback(string const &cbmeth) const
{
int count;
SV *methret;
bool retval = true;
if (mCanMap[cbmeth] == false) {
// method not implemented, just return true
return retval;
}
dSP;
ENTER;
SAVETMPS;
// call the callback
PUSHMARK(SP);
XPUSHs(mPerlObj);
for (CBArgList::iterator it = mCallbackArgs.begin(); it != mCallbackArgs.end(); ++it) {
XPUSHs(sv_2mortal(*it));
}
PUTBACK;
count = call_method(cbmeth.c_str(), G_SCALAR);
SPAGAIN;
if (count != 1) {
croak("Callback must return a single (boolean) value");
}
methret = POPs;
PUTBACK;
retval = SvTRUE(methret) ? true : false;
FREETMPS;
LEAVE;
mCallbackArgs.clear();
return retval;
}
// xxx: dumb how much copy/paste the next two methods have
// before calling this, push the callback args onto the mCallbackArgs vector
Ogre::Real PerlOGRECallback::callPerlCallbackReal(string const &cbmeth) const
{
int count;
SV *methret;
Ogre::Real retval = 0;
if (mCanMap[cbmeth] == false) {
// method not implemented, just return 0
return retval;
}
dSP;
ENTER;
SAVETMPS;
// call the callback
PUSHMARK(SP);
XPUSHs(mPerlObj);
for (CBArgList::iterator it = mCallbackArgs.begin(); it != mCallbackArgs.end(); ++it) {
XPUSHs(sv_2mortal(*it));
}
PUTBACK;
count = call_method(cbmeth.c_str(), G_SCALAR);
SPAGAIN;
if (count != 1) {
croak("Callback must return a single (Real) value");
}
methret = POPs;
PUTBACK;
retval = (Ogre::Real)SvNV(methret);
FREETMPS;
LEAVE;
mCallbackArgs.clear();
return retval;
}
// before calling this, push the callback args onto the mCallbackArgs vector
void PerlOGRECallback::callPerlCallbackVoid(string const &cbmeth) const
{
int count;
if (mCanMap[cbmeth] == false) {
// method not implemented, just return
return;
}
dSP;
ENTER;
SAVETMPS;
// call the callback
PUSHMARK(SP);
XPUSHs(mPerlObj);
for (CBArgList::iterator it = mCallbackArgs.begin(); it != mCallbackArgs.end(); ++it) {
XPUSHs(sv_2mortal(*it));
}
PUTBACK;
count = call_method(cbmeth.c_str(), G_SCALAR);
SPAGAIN;
if (count != 0) {
croak("Callback must not return a value");
}
FREETMPS;
LEAVE;
mCallbackArgs.clear();
}
|
