1 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */
2
3 static void _prepare_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo,
4 GICallableInfo *info,
5 gpointer *args);
6 static void _clear_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo);
7 static void _fill_ffi_return_value (GITypeInfo *return_info,
8 gpointer resp,
9 GIArgument *arg);
10
11
12 static void
invoke_perl_code(ffi_cif * cif,gpointer resp,gpointer * args,gpointer userdata)13 invoke_perl_code (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
14 {
15 GPerlI11nPerlCallbackInfo *info;
16 GICallableInfo *cb_interface;
17 GPerlI11nPerlInvocationInfo iinfo;
18 guint args_offset = 0, i;
19 guint in_inout;
20 guint n_return_values;
21 I32 n_returned;
22 I32 context;
23 SV *first_sv = NULL, *last_sv = NULL;
24 dGPERL_CALLBACK_MARSHAL_SP;
25
26 PERL_UNUSED_VAR (cif);
27
28 /* unwrap callback info struct from userdata */
29 info = (GPerlI11nPerlCallbackInfo *) userdata;
30 cb_interface = (GICallableInfo *) info->interface;
31
32 _prepare_perl_invocation_info (&iinfo, cb_interface, args);
33
34 /* set perl context */
35 GPERL_CALLBACK_MARSHAL_INIT (info);
36
37 ENTER;
38 SAVETMPS;
39
40 PUSHMARK (SP);
41
42 if (info->args_converter) {
43 /* if we are given an args converter, we will call it directly
44 * after we pushed the original args onto the stack. we then
45 * want to invoke the Perl code with whatever the args
46 * converter returned. to achieve this, we do a double
47 * PUSHMARK, which puts on the markstack two pointers to the
48 * same place on the stack. after the args converter returns,
49 * the markstack pointer is decremented, and the invocation of
50 * the normal Perl code then sees the other entry we put on the
51 * markstack. */
52 PUSHMARK (SP);
53 }
54
55 /* convert the implicit instance argument and push the first SV onto
56 * the stack; depending on the "swap" setting, this might be the
57 * instance or the user data. this is only relevant for signals. */
58 if (iinfo.base.is_signal) {
59 SV *instance_sv, *data_sv;
60 args_offset = 1;
61 instance_sv = SAVED_STACK_SV (instance_pointer_to_sv (
62 cb_interface,
63 CAST_RAW (args[0], gpointer)));
64 data_sv = info->data ? SvREFCNT_inc (info->data) : NULL;
65 first_sv = info->swap_data ? data_sv : instance_sv;
66 last_sv = info->swap_data ? instance_sv : data_sv;
67 dwarn ("info->data = %p, info->swap_data = %d\n",
68 info->data, info->swap_data);
69 dwarn ("instance = %p, data = %p, first = %p, last = %p\n",
70 instance_sv, data_sv, first_sv, last_sv);
71 if (first_sv)
72 XPUSHs (sv_2mortal (first_sv));
73 }
74
75 /* find arguments; use type information from interface to find in and
76 * in-out args and their types, count in-out and out args, and find
77 * suitable converters; push in and in-out arguments onto the perl
78 * stack */
79 in_inout = 0;
80 for (i = 0; i < iinfo.base.n_args; i++) {
81 GIArgInfo *arg_info = &(iinfo.base.arg_infos[i]);
82 GITypeInfo *arg_type = &(iinfo.base.arg_types[i]);
83 GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
84 GIDirection direction = g_arg_info_get_direction (arg_info);
85
86 iinfo.base.current_pos = i;
87
88 dwarn ("arg %d: info = %p (%s)\n",
89 i, arg_info, g_base_info_get_name (arg_info));
90 dwarn (" dir = %d, is retval = %d, is optional = %d, may be null = %d, transfer = %d\n",
91 direction,
92 g_arg_info_is_return_value (arg_info),
93 g_arg_info_is_optional (arg_info),
94 g_arg_info_may_be_null (arg_info),
95 transfer);
96 dwarn (" arg type = %p, is pointer = %d, tag = %d (%s)\n",
97 arg_type,
98 g_type_info_is_pointer (arg_type),
99 g_type_info_get_tag (arg_type),
100 g_type_tag_to_string (g_type_info_get_tag (arg_type)));
101
102 if (direction == GI_DIRECTION_IN ||
103 direction == GI_DIRECTION_INOUT)
104 {
105 gpointer raw;
106 GIArgument arg;
107 SV *sv;
108 /* If the arg is in-out, then the ffi arg is a pointer
109 * to a pointer to a value, so we need to dereference
110 * it once. */
111 raw = direction == GI_DIRECTION_INOUT
112 ? *((gpointer *) args[i+args_offset])
113 : args[i+args_offset];
114 raw_to_arg (raw, &arg, arg_type);
115 sv = SAVED_STACK_SV (arg_to_sv (&arg,
116 arg_type,
117 transfer,
118 GPERL_I11N_MEMORY_SCOPE_IRRELEVANT,
119 &iinfo.base));
120 /* If arg_to_sv returns NULL, we take that as 'skip
121 * this argument'; happens for GDestroyNotify, for
122 * example. */
123 if (sv)
124 XPUSHs (sv_2mortal (sv));
125 }
126
127 if (direction == GI_DIRECTION_INOUT ||
128 direction == GI_DIRECTION_OUT)
129 {
130 in_inout++;
131 }
132 }
133
134 /* push the last SV onto the stack; this might be the user data or the
135 * instance. this is only relevant for signals. */
136 if (last_sv)
137 XPUSHs (sv_2mortal (last_sv));
138
139 PUTBACK;
140
141 /* invoke the args converter with the original args on the stack.
142 * since we created two identical entries on the markstack, the
143 * call_method or call_sv below will invoke the Perl code with whatever
144 * the args converter returned. */
145 if (info->args_converter) {
146 call_sv (info->args_converter, G_ARRAY);
147 SPAGAIN;
148 }
149
150 /* determine suitable Perl call context */
151 context = G_VOID | G_DISCARD;
152 if (iinfo.base.has_return_value) {
153 context = in_inout > 0
154 ? G_ARRAY
155 : G_SCALAR;
156 } else {
157 if (in_inout == 1) {
158 context = G_SCALAR;
159 } else if (in_inout > 1) {
160 context = G_ARRAY;
161 }
162 }
163
164 /* do the call, demand #in-out+#out+#return-value return values */
165 n_return_values = iinfo.base.has_return_value
166 ? in_inout + 1
167 : in_inout;
168 n_returned = info->sub_name
169 ? call_method (info->sub_name, context)
170 : call_sv (info->code, context);
171 if (n_return_values != 0 && (n_returned < 0 || ((guint) n_returned) != n_return_values)) {
172 ccroak ("callback returned %d values "
173 "but is supposed to return %u values",
174 n_returned, n_return_values);
175 }
176
177 /* call-scoped callback infos are freed by
178 * Glib::Object::Introspection::_FuncWrapper::DESTROY */
179
180 SPAGAIN;
181
182 /* convert in-out and out values and stuff them back into args */
183 if (in_inout > 0) {
184 SV **returned_values;
185 int out_index;
186
187 returned_values = g_new0 (SV *, in_inout);
188
189 /* pop scalars off the stack and put them into the array;
190 * reverse the order since POPs pops items off of the end of
191 * the stack. */
192 for (i = 0; i < in_inout; i++) {
193 returned_values[in_inout - i - 1] = POPs;
194 }
195
196 out_index = 0;
197 for (i = 0; i < iinfo.base.n_args; i++) {
198 GIArgInfo *arg_info = &(iinfo.base.arg_infos[i]);
199 GITypeInfo *arg_type = &(iinfo.base.arg_types[i]);
200 GIDirection direction = g_arg_info_get_direction (arg_info);
201 gpointer out_pointer = * (gpointer *) args[i+args_offset];
202
203 if (!out_pointer) {
204 dwarn ("skipping out arg %d\n", i);
205 continue;
206 }
207
208 if (direction == GI_DIRECTION_INOUT ||
209 direction == GI_DIRECTION_OUT)
210 {
211 GIArgument tmp_arg;
212 GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
213 /* g_arg_info_may_be_null (arg_info) is not
214 * appropriate here as it describes whether the
215 * out/inout arg itself may be NULL. But we're
216 * asking here whether it is OK store NULL
217 * inside the out/inout arg. This information
218 * does not seem to be present in the typelib
219 * (nor is there an annotation for it). */
220 gboolean may_be_null = TRUE;
221 gboolean is_caller_allocated = g_arg_info_is_caller_allocates (arg_info);
222 dwarn ("out/inout arg, pos = %d, is_caller_allocated = %d\n",
223 i, is_caller_allocated);
224 if (is_caller_allocated) {
225 tmp_arg.v_pointer = out_pointer;
226 }
227 sv_to_arg (returned_values[out_index], &tmp_arg,
228 arg_info, arg_type,
229 transfer, may_be_null, &iinfo.base);
230 if (!is_caller_allocated) {
231 arg_to_raw (&tmp_arg, out_pointer, arg_type);
232 }
233 out_index++;
234 }
235 }
236
237 g_free (returned_values);
238 }
239
240 /* store return value in resp, if any */
241 if (iinfo.base.has_return_value) {
242 GIArgument arg;
243 GITypeInfo *type_info;
244 GITransfer transfer;
245 gboolean may_be_null;
246
247 type_info = &iinfo.base.return_type_info;
248 transfer = iinfo.base.return_type_transfer;
249 may_be_null = g_callable_info_may_return_null (cb_interface); /* FIXME */
250
251 dwarn ("return value: type = %p\n", type_info);
252 dwarn (" is pointer = %d, tag = %d (%s), transfer = %d\n",
253 g_type_info_is_pointer (type_info),
254 g_type_info_get_tag (type_info),
255 g_type_tag_to_string (g_type_info_get_tag (type_info)),
256 transfer);
257
258 sv_to_arg (POPs, &arg, NULL, type_info,
259 transfer, may_be_null, &iinfo.base);
260 _fill_ffi_return_value (type_info, resp, &arg);
261 }
262
263 PUTBACK;
264
265 _clear_perl_invocation_info (&iinfo);
266
267 FREETMPS;
268 LEAVE;
269
270 /* FIXME: We can't just free everything here because ffi will use parts
271 * of this after we've returned.
272 *
273 * if (info->free_after_use) {
274 * release_callback (info);
275 * }
276 *
277 * Gjs uses a global list of callback infos instead and periodically
278 * frees unused ones.
279 */
280 }
281
282 /* ------------------------------------------------------------------------- */
283
284 #if GI_CHECK_VERSION (1, 33, 10)
285
286 static void
invoke_perl_signal_handler(ffi_cif * cif,gpointer resp,gpointer * args,gpointer userdata)287 invoke_perl_signal_handler (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
288 {
289 GClosure *closure = CAST_RAW (args[0], GClosure*);
290 GValue *return_value = CAST_RAW (args[1], GValue*);
291 guint n_param_values = CAST_RAW (args[2], guint);
292 const GValue *param_values = CAST_RAW (args[3], const GValue*);
293 gpointer invocation_hint = CAST_RAW (args[4], gpointer);
294 gpointer marshal_data = CAST_RAW (args[5], gpointer);
295
296 GPerlI11nPerlSignalInfo *signal_info = userdata;
297
298 GPerlClosure *perl_closure = (GPerlClosure *) closure;
299 GPerlI11nPerlCallbackInfo *cb_info;
300 GCClosure c_closure;
301
302 PERL_UNUSED_VAR (cif);
303 PERL_UNUSED_VAR (resp);
304 PERL_UNUSED_VAR (marshal_data);
305
306 dwarn ("%s, n_args = %d\n",
307 g_base_info_get_name (signal_info->interface),
308 g_callable_info_get_n_args (signal_info->interface));
309
310 cb_info = create_perl_callback_closure (signal_info->interface,
311 perl_closure->callback);
312 attach_perl_callback_data (cb_info, perl_closure->data);
313 cb_info->swap_data = GPERL_CLOSURE_SWAP_DATA (perl_closure);
314 if (signal_info->args_converter)
315 cb_info->args_converter = SvREFCNT_inc (signal_info->args_converter);
316
317 c_closure.closure = *closure;
318 c_closure.callback = cb_info->closure;
319 /* If marshal_data is non-NULL, gi_cclosure_marshal_generic uses it as
320 * the callback. Hence we pass NULL so that c_closure.callback is
321 * used. */
322 gi_cclosure_marshal_generic ((GClosure *) &c_closure,
323 return_value,
324 n_param_values, param_values,
325 invocation_hint,
326 NULL /* instead of marshal_data */);
327
328 release_perl_callback (cb_info);
329 }
330
331 #endif
332
333 /* -------------------------------------------------------------------------- */
334
335 static void
_prepare_perl_invocation_info(GPerlI11nPerlInvocationInfo * iinfo,GICallableInfo * info,gpointer * args)336 _prepare_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo,
337 GICallableInfo *info,
338 gpointer *args)
339 {
340 guint i;
341
342 prepare_invocation_info ((GPerlI11nInvocationInfo *) iinfo, info);
343
344 dwarn ("%s, n_args = %d\n",
345 g_base_info_get_name (info),
346 g_callable_info_get_n_args (info));
347
348 /* When invoking Perl code, we currently always use a complete
349 * description of the callable (from a record field or some callback
350 * typedef) for functions, vfuncs and calllbacks. This implies that
351 * there is no implicit invocant; it always appears explicitly in the
352 * arg list. For signals, however, the invocant is implicit. */
353
354 /* FIXME: 'throws'? */
355
356 /* Find array length arguments and store their value in aux_args so
357 * that array_to_sv can later fetch them. */
358 for (i = 0 ; i < iinfo->base.n_args ; i++) {
359 GITypeInfo *arg_type = &(iinfo->base.arg_types[i]);
360 GITypeTag arg_tag = g_type_info_get_tag (arg_type);
361
362 if (arg_tag == GI_TYPE_TAG_ARRAY) {
363 gint pos = g_type_info_get_array_length (arg_type);
364 if (pos >= 0) {
365 GITypeInfo *length_arg_type;
366 guint args_pos = iinfo->base.is_signal ? pos+1 : pos;
367 length_arg_type = &(iinfo->base.arg_types[pos]);
368 raw_to_arg (args[args_pos], &iinfo->base.aux_args[pos], length_arg_type);
369 dwarn (" pos %d is array length => %"G_GSIZE_FORMAT"\n",
370 pos, iinfo->base.aux_args[pos].v_size);
371 }
372 }
373 }
374 }
375
376 static void
_clear_perl_invocation_info(GPerlI11nPerlInvocationInfo * iinfo)377 _clear_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo)
378 {
379 clear_invocation_info ((GPerlI11nInvocationInfo *) iinfo);
380 }
381
382 /* ------------------------------------------------------------------------- */
383
384 /* Copied from pygobject's pygi-closure.c. */
385 static void
_fill_ffi_return_value(GITypeInfo * return_info,gpointer resp,GIArgument * arg)386 _fill_ffi_return_value (GITypeInfo *return_info,
387 gpointer resp,
388 GIArgument *arg)
389 {
390 if (!resp)
391 return;
392 switch (g_type_info_get_tag (return_info)) {
393 case GI_TYPE_TAG_BOOLEAN:
394 *((ffi_sarg *) resp) = arg->v_boolean;
395 break;
396 case GI_TYPE_TAG_INT8:
397 *((ffi_sarg *) resp) = arg->v_int8;
398 break;
399 case GI_TYPE_TAG_UINT8:
400 *((ffi_arg *) resp) = arg->v_uint8;
401 break;
402 case GI_TYPE_TAG_INT16:
403 *((ffi_sarg *) resp) = arg->v_int16;
404 break;
405 case GI_TYPE_TAG_UINT16:
406 *((ffi_arg *) resp) = arg->v_uint16;
407 break;
408 case GI_TYPE_TAG_INT32:
409 *((ffi_sarg *) resp) = arg->v_int32;
410 break;
411 case GI_TYPE_TAG_UINT32:
412 *((ffi_arg *) resp) = arg->v_uint32;
413 break;
414 case GI_TYPE_TAG_INT64:
415 *((ffi_sarg *) resp) = arg->v_int64;
416 break;
417 case GI_TYPE_TAG_UINT64:
418 *((ffi_arg *) resp) = arg->v_uint64;
419 break;
420 case GI_TYPE_TAG_FLOAT:
421 *((gfloat *) resp) = arg->v_float;
422 break;
423 case GI_TYPE_TAG_DOUBLE:
424 *((gdouble *) resp) = arg->v_double;
425 break;
426 case GI_TYPE_TAG_GTYPE:
427 *((ffi_arg *) resp) = arg->v_size;
428 break;
429 case GI_TYPE_TAG_UNICHAR:
430 *((ffi_arg *) resp) = arg->v_uint32;
431 break;
432 case GI_TYPE_TAG_INTERFACE:
433 {
434 GIBaseInfo *interface_info;
435 interface_info = g_type_info_get_interface (return_info);
436 switch (g_base_info_get_type (interface_info)) {
437 case GI_INFO_TYPE_ENUM:
438 *(ffi_sarg *) resp = arg->v_int;
439 break;
440 case GI_INFO_TYPE_FLAGS:
441 *(ffi_arg *) resp = arg->v_uint;
442 break;
443 default:
444 *(ffi_arg *) resp = (ffi_arg) arg->v_pointer;
445 break;
446 }
447 break;
448 }
449 default:
450 *(ffi_arg *) resp = (ffi_arg) arg->v_pointer;
451 break;
452 }
453 }
454