1 /*
2 * Copyright (C) 2005 muppet
3 * Copyright (C) 2005-2013 Torsten Schoenfeld <kaffeetisch@gmx.de>
4 *
5 * This library is free software; you can redistribute it and/or modify it
6 * under the terms of the GNU Lesser General Public License as published by the
7 * Free Software Foundation; either version 2.1 of the License, or (at your
8 * option) any later version.
9 *
10 * This library is distributed in the hope that it will be useful, but WITHOUT
11 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12 * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License
13 * for more details.
14 *
15 * See the LICENSE file in the top-level directory of this distribution for the
16 * full license terms.
17 *
18 */
19
20 #include <gperl.h>
21 #include <gperl_marshal.h>
22
23 #include <girepository.h>
24 #include <girffi.h>
25
26 #ifndef GI_CHECK_VERSION
27 # include "build/gi-version.h"
28 #endif
29
30 /* #define NOISY */
31 #ifdef NOISY
32 # define dwarn(msg...) G_STMT_START { \
33 g_printerr ("%s: ", G_STRFUNC); \
34 g_printerr (msg); \
35 } G_STMT_END
36 #else
37 # define dwarn(...)
38 #endif
39
40 /* ------------------------------------------------------------------------- */
41
42 typedef struct {
43 ffi_cif *cif;
44 ffi_closure *closure;
45
46 GICallableInfo *interface;
47
48 /* either we have a code and data pair, ... */
49 SV *code;
50 SV *data;
51
52 /* ... or a sub name to be called as a method on the invocant. */
53 gchar *sub_name;
54
55 /* these are currently only used for signal handler invocation. */
56 gboolean swap_data;
57 SV *args_converter;
58
59 gint data_pos;
60 gint destroy_pos;
61
62 gboolean free_after_use;
63
64 gpointer priv; /* perl context */
65 } GPerlI11nPerlCallbackInfo;
66
67 typedef struct {
68 GISignalInfo *interface;
69 SV *args_converter;
70 } GPerlI11nPerlSignalInfo;
71
72 typedef struct {
73 GICallableInfo *interface;
74
75 gpointer func;
76 gpointer data;
77 GDestroyNotify destroy;
78
79 gint data_pos;
80 gint destroy_pos;
81
82 SV *data_sv;
83 } GPerlI11nCCallbackInfo;
84
85 typedef struct {
86 gsize length;
87 gint length_pos;
88 } GPerlI11nArrayInfo;
89
90 /* The next three structs store information that the different marshallers
91 * might need to communicate to each other. This struct is the basis used for
92 * invoking C and Perl code. */
93 typedef struct {
94 GICallableInfo *interface;
95
96 gboolean is_function;
97 gboolean is_vfunc;
98 gboolean is_callback;
99 gboolean is_signal;
100
101 /* The number of args described by the typelib. */
102 guint n_args;
103
104 /* The current position under investigation in the list of typelib
105 * args. */
106 guint current_pos;
107
108 /* Information about the args from the typelib. */
109 GIArgInfo * arg_infos;
110 GITypeInfo * arg_types;
111
112 /* An array of places for storing out out/in-out or automatic args. */
113 GIArgument * aux_args;
114
115 gboolean has_return_value;
116 ffi_type * return_type_ffi;
117 GITypeInfo return_type_info;
118 GITransfer return_type_transfer;
119
120 GSList * callback_infos;
121 GSList * array_infos;
122
123 GSList * free_after_call;
124 } GPerlI11nInvocationInfo;
125
126 /* This struct is used when invoking C code. */
127 typedef struct {
128 GPerlI11nInvocationInfo base;
129
130 const gchar *target_package;
131 const gchar *target_namespace;
132 const gchar *target_function;
133
134 gboolean is_constructor;
135 gboolean is_method;
136 gboolean throws;
137
138 /* The number of args that need to be given to the C function. */
139 guint n_invoke_args;
140 /* The number of args for which no value is required. */
141 guint n_nullable_args;
142 /* The number of necessary args, i.e. those that are not automatic or
143 * nullable. */
144 guint n_expected_args;
145 /* The number of args given by the caller. */
146 guint n_given_args;
147
148 gpointer * args;
149 ffi_type ** arg_types_ffi;
150 GIArgument * in_args;
151 GIArgument * out_args;
152 gboolean * is_automatic_arg;
153
154 guint constructor_offset;
155 guint method_offset;
156 guint stack_offset;
157 gint dynamic_stack_offset;
158 } GPerlI11nCInvocationInfo;
159
160 /* This struct is used when invoking Perl code. */
161 typedef struct {
162 GPerlI11nInvocationInfo base;
163 } GPerlI11nPerlInvocationInfo;
164
165 typedef enum {
166 GPERL_I11N_MEMORY_SCOPE_IRRELEVANT,
167 GPERL_I11N_MEMORY_SCOPE_TEMPORARY,
168 } GPerlI11nMemoryScope;
169
170 /* callbacks */
171 static GPerlI11nPerlCallbackInfo * create_perl_callback_closure_for_named_sub (GIBaseInfo *cb_info, gchar *sub_name);
172 static GPerlI11nPerlCallbackInfo * create_perl_callback_closure (GIBaseInfo *cb_info, SV *code);
173 static void attach_perl_callback_data (GPerlI11nPerlCallbackInfo *info, SV *data);
174 static void release_perl_callback (gpointer data);
175
176 static GPerlI11nCCallbackInfo * create_c_callback_closure (GIBaseInfo *interface, gpointer func);
177 static void attach_c_callback_data (GPerlI11nCCallbackInfo *info, gpointer data);
178 static void release_c_callback (gpointer data);
179
180 /* invocation */
181 static void prepare_invocation_info (GPerlI11nInvocationInfo *iinfo,
182 GICallableInfo *info);
183 static void clear_invocation_info (GPerlI11nInvocationInfo *iinfo);
184
185 static void free_after_call (GPerlI11nInvocationInfo *iinfo,
186 GDestroyNotify func, gpointer data);
187 static void invoke_free_after_call_handlers (GPerlI11nInvocationInfo *iinfo);
188
189 #if GI_CHECK_VERSION (1, 33, 10)
190 static void invoke_perl_signal_handler (ffi_cif* cif,
191 gpointer resp,
192 gpointer* args,
193 gpointer userdata);
194 #endif
195
196 static void invoke_perl_code (ffi_cif* cif,
197 gpointer resp,
198 gpointer* args,
199 gpointer userdata);
200
201 static void invoke_c_code (GICallableInfo *info,
202 gpointer func_pointer,
203 SV **sp, I32 ax, SV **mark, I32 items, /* these correspond to dXSARGS */
204 UV internal_stack_offset,
205 const gchar *package,
206 const gchar *namespace,
207 const gchar *function);
208
209 /* info finders */
210 static GIFunctionInfo * get_function_info (GIRepository *repository,
211 const gchar *basename,
212 const gchar *namespace,
213 const gchar *method);
214 static GIFieldInfo * get_field_info (GIBaseInfo *info,
215 const gchar *field_name);
216 static GISignalInfo * get_signal_info (GIBaseInfo *container_info,
217 const gchar *signal_name);
218
219 static gchar * synthesize_gtype_name (GIBaseInfo *info);
220 static gchar * synthesize_prefixed_gtype_name (GIBaseInfo *info);
221 static GType get_gtype (GIRegisteredTypeInfo *info);
222
223 static const gchar * get_package_for_basename (const gchar *basename);
224 static gboolean is_forbidden_sub_name (const gchar *name);
225
226 /* marshallers */
227 static SV * interface_to_sv (GITypeInfo* info,
228 GIArgument *arg,
229 gboolean own,
230 GPerlI11nMemoryScope mem_scope,
231 GPerlI11nInvocationInfo *iinfo);
232 static void sv_to_interface (GIArgInfo * arg_info,
233 GITypeInfo * type_info,
234 GITransfer transfer,
235 gboolean may_be_null,
236 SV * sv,
237 GIArgument * arg,
238 GPerlI11nInvocationInfo * invocation_info);
239
240 static SV * instance_pointer_to_sv (GICallableInfo *info, gpointer pointer);
241 static gpointer instance_sv_to_pointer (GICallableInfo *info, SV *sv, GPerlI11nInvocationInfo *iinfo);
242
243 static void sv_to_arg (SV * sv,
244 GIArgument * arg,
245 GIArgInfo * arg_info,
246 GITypeInfo * type_info,
247 GITransfer transfer,
248 gboolean may_be_null,
249 GPerlI11nInvocationInfo * invocation_info);
250 static SV * arg_to_sv (GIArgument * arg,
251 GITypeInfo * info,
252 GITransfer transfer,
253 GPerlI11nMemoryScope mem_scope,
254 GPerlI11nInvocationInfo *iinfo);
255
256 static gpointer sv_to_callback (GIArgInfo * arg_info, GITypeInfo * type_info, SV * sv, GPerlI11nInvocationInfo * invocation_info);
257 static gpointer sv_to_callback_data (SV * sv, GPerlI11nInvocationInfo * invocation_info);
258
259 static SV * callback_to_sv (GICallableInfo *interface, gpointer func, GPerlI11nInvocationInfo *invocation_info);
260 static SV * callback_data_to_sv (gpointer data, GPerlI11nInvocationInfo * invocation_info);
261
262 static SV * struct_to_sv (GIBaseInfo* info, GIInfoType info_type, gpointer pointer, gboolean own);
263 static gpointer sv_to_struct (GITransfer transfer, GIBaseInfo * info, GIInfoType info_type, SV * sv);
264
265 static SV * array_to_sv (GITypeInfo *info, gpointer pointer, GITransfer transfer, GPerlI11nInvocationInfo *iinfo);
266 static gpointer sv_to_array (GITransfer transfer, GITypeInfo *type_info, SV *sv, GPerlI11nInvocationInfo *iinfo);
267
268 static SV * glist_to_sv (GITypeInfo* info, gpointer pointer, GITransfer transfer);
269 static gpointer sv_to_glist (GITransfer transfer, GITypeInfo * type_info, SV * sv, GPerlI11nInvocationInfo *iinfo);
270
271 static SV * ghash_to_sv (GITypeInfo *info, gpointer pointer, GITransfer transfer);
272 static gpointer sv_to_ghash (GITransfer transfer, GITypeInfo *type_info, SV *sv);
273
274 #define CAST_RAW(raw, type) (*((type *) raw))
275 static void raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info);
276 static void arg_to_raw (GIArgument *arg, gpointer raw, GITypeInfo *info);
277
278 /* sizes */
279 static gsize size_of_type_tag (GITypeTag type_tag);
280 static gsize size_of_interface (GITypeInfo *type_info);
281 static gsize size_of_type_info (GITypeInfo *type_info);
282
283 /* enums/flags */
284 static GType register_unregistered_enum (GIEnumInfo *info);
285
286 /* fields */
287 static void store_fields (HV *fields, GIBaseInfo *info, GIInfoType info_type);
288 static SV * get_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer);
289 static void set_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer, SV *value);
290
291 /* unions */
292 static SV * rebless_union_sv (GType type, const char *package, gpointer mem, gboolean own);
293 static void associate_union_members_with_gtype (GIUnionInfo *info, const gchar *package, GType type);
294 static GType find_union_member_gtype (const gchar *package, const gchar *namespace);
295
296 /* methods */
297 static void store_methods (HV *namespaced_functions, GIBaseInfo *info, GIInfoType info_type);
298
299 /* object vfuncs */
300 static void store_objects_with_vfuncs (AV *objects_with_vfuncs, GIObjectInfo *info);
301 static void generic_class_init (GIObjectInfo *info, const gchar *target_package, gpointer class);
302
303 /* interface vfuncs */
304 static void generic_interface_init (gpointer iface, gpointer data);
305 static void generic_interface_finalize (gpointer iface, gpointer data);
306
307 /* misc. */
308 static void call_carp_croak (const char *msg);
309 static void call_carp_carp (const char *msg);
310 #define ccroak(...) call_carp_croak (form (__VA_ARGS__));
311 #define cwarn(...) call_carp_carp (form (__VA_ARGS__));
312
313 /* interface_to_sv and its callers might invoke Perl code, so any xsub invoking
314 * them needs to save the stack. this wrapper does this automatically. */
315 #define SAVED_STACK_SV(expr) \
316 ({ \
317 SV *_saved_stack_sv; \
318 PUTBACK; \
319 _saved_stack_sv = expr; \
320 SPAGAIN; \
321 _saved_stack_sv; \
322 })
323
324 /* ------------------------------------------------------------------------- */
325
326 #include "gperl-i11n-callback.c"
327 #include "gperl-i11n-croak.c"
328 #include "gperl-i11n-enums.c"
329 #include "gperl-i11n-field.c"
330 #include "gperl-i11n-gvalue.c"
331 #include "gperl-i11n-info.c"
332 #include "gperl-i11n-invoke.c"
333 #include "gperl-i11n-invoke-c.c"
334 #include "gperl-i11n-invoke-perl.c"
335 #include "gperl-i11n-marshal-arg.c"
336 #include "gperl-i11n-marshal-array.c"
337 #include "gperl-i11n-marshal-callback.c"
338 #include "gperl-i11n-marshal-hash.c"
339 #include "gperl-i11n-marshal-interface.c"
340 #include "gperl-i11n-marshal-list.c"
341 #include "gperl-i11n-marshal-raw.c"
342 #include "gperl-i11n-marshal-struct.c"
343 #include "gperl-i11n-method.c"
344 #include "gperl-i11n-size.c"
345 #include "gperl-i11n-union.c"
346 #include "gperl-i11n-vfunc-interface.c"
347 #include "gperl-i11n-vfunc-object.c"
348
349 /* ------------------------------------------------------------------------- */
350
351 MODULE = Glib::Object::Introspection PACKAGE = Glib::Object::Introspection
352
353 gboolean
354 CHECK_VERSION (class, gint major, gint minor, gint micro)
355 CODE:
356 RETVAL = GI_CHECK_VERSION (major, minor, micro);
357 OUTPUT:
358 RETVAL
359
360 void
361 _load_library (class, namespace, version, search_path=NULL)
362 const gchar *namespace
363 const gchar *version
364 const gchar_ornull *search_path
365 PREINIT:
366 GIRepository *repository;
367 GError *error = NULL;
368 CODE:
369 if (search_path)
370 g_irepository_prepend_search_path (search_path);
371 repository = g_irepository_get_default ();
372 g_irepository_require (repository, namespace, version, 0, &error);
373 if (error) {
374 gperl_croak_gerror (NULL, error);
375 }
376
377 void
378 _register_types (class, namespace, package)
379 const gchar *namespace
380 const gchar *package
381 PREINIT:
382 GIRepository *repository;
383 gint number, i;
384 AV *constants;
385 AV *global_functions;
386 HV *namespaced_functions;
387 HV *fields;
388 AV *interfaces;
389 AV *objects_with_vfuncs;
390 PPCODE:
391 repository = g_irepository_get_default ();
392
393 constants = newAV ();
394 global_functions = newAV ();
395 namespaced_functions = newHV ();
396 fields = newHV ();
397 interfaces = newAV ();
398 objects_with_vfuncs = newAV ();
399
400 number = g_irepository_get_n_infos (repository, namespace);
401 for (i = 0; i < number; i++) {
402 GIBaseInfo *info;
403 GIInfoType info_type;
404 const gchar *name;
405 gchar *full_package;
406 GType type;
407
408 info = g_irepository_get_info (repository, namespace, i);
409 info_type = g_base_info_get_type (info);
410 name = g_base_info_get_name (info);
411
412 dwarn ("setting up %s.%s\n", namespace, name);
413
414 if (info_type == GI_INFO_TYPE_CONSTANT) {
415 dwarn (" -> constant\n");
416 av_push (constants, newSVpv (name, 0));
417 }
418
419 if (info_type == GI_INFO_TYPE_FUNCTION) {
420 dwarn (" -> global function\n");
421 av_push (global_functions, newSVpv (name, 0));
422 }
423
424 if (info_type == GI_INFO_TYPE_INTERFACE) {
425 dwarn (" -> interface\n");
426 av_push (interfaces, newSVpv (name, 0));
427 }
428
429 if (info_type == GI_INFO_TYPE_OBJECT ||
430 info_type == GI_INFO_TYPE_INTERFACE ||
431 info_type == GI_INFO_TYPE_BOXED ||
432 info_type == GI_INFO_TYPE_STRUCT ||
433 info_type == GI_INFO_TYPE_UNION ||
434 info_type == GI_INFO_TYPE_ENUM ||
435 info_type == GI_INFO_TYPE_FLAGS)
436 {
437 dwarn (" looking for methods\n");
438 store_methods (namespaced_functions, info, info_type);
439 }
440
441 if (info_type == GI_INFO_TYPE_BOXED ||
442 info_type == GI_INFO_TYPE_STRUCT ||
443 info_type == GI_INFO_TYPE_UNION)
444 {
445 dwarn (" looking for fields\n");
446 store_fields (fields, info, info_type);
447 }
448
449 if (info_type == GI_INFO_TYPE_OBJECT) {
450 dwarn (" looking for vfuncs\n");
451 store_objects_with_vfuncs (objects_with_vfuncs, info);
452 }
453
454 /* These are the types that we want to register with perl-Glib. */
455 if (info_type != GI_INFO_TYPE_OBJECT &&
456 info_type != GI_INFO_TYPE_INTERFACE &&
457 info_type != GI_INFO_TYPE_BOXED &&
458 info_type != GI_INFO_TYPE_STRUCT &&
459 info_type != GI_INFO_TYPE_UNION &&
460 info_type != GI_INFO_TYPE_ENUM &&
461 info_type != GI_INFO_TYPE_FLAGS)
462 {
463 g_base_info_unref ((GIBaseInfo *) info);
464 continue;
465 }
466
467 type = get_gtype ((GIRegisteredTypeInfo *) info);
468 if (!type) {
469 ccroak ("Could not find GType for type %s%s",
470 namespace, name);
471 }
472 if (type == G_TYPE_NONE) {
473 /* Try registering unregistered enums/flags. */
474 if (info_type == GI_INFO_TYPE_ENUM || info_type == GI_INFO_TYPE_FLAGS) {
475 type = register_unregistered_enum (info);
476 }
477 /* If there is still no GType, stop this iteration and
478 * go to the next item. */
479 if (!type || type == G_TYPE_NONE) {
480 g_base_info_unref ((GIBaseInfo *) info);
481 continue;
482 }
483 }
484
485 full_package = g_strconcat (package, "::", name, NULL);
486 dwarn (" registering as %s\n", full_package);
487
488 switch (info_type) {
489 case GI_INFO_TYPE_OBJECT:
490 case GI_INFO_TYPE_INTERFACE:
491 gperl_register_object (type, full_package);
492 break;
493
494 case GI_INFO_TYPE_BOXED:
495 case GI_INFO_TYPE_STRUCT:
496 gperl_register_boxed (type, full_package, NULL);
497 break;
498
499 case GI_INFO_TYPE_UNION:
500 {
501 GPerlBoxedWrapperClass *my_wrapper_class;
502 GPerlBoxedWrapperClass *default_wrapper_class;
503 default_wrapper_class = gperl_default_boxed_wrapper_class ();
504 /* FIXME: We leak my_wrapper_class here. The problem
505 * is that gperl_register_boxed does not copy the
506 * contents of the wrapper class but instead assumes
507 * that the memory passed in will always be valid. */
508 my_wrapper_class = g_new (GPerlBoxedWrapperClass, 1);
509 *my_wrapper_class = *default_wrapper_class;
510 my_wrapper_class->wrap = rebless_union_sv;
511 gperl_register_boxed (type, full_package, my_wrapper_class);
512 associate_union_members_with_gtype (info, package, type);
513 break;
514 }
515
516 case GI_INFO_TYPE_ENUM:
517 case GI_INFO_TYPE_FLAGS:
518 gperl_register_fundamental (type, full_package);
519 #if GI_CHECK_VERSION (1, 29, 17)
520 {
521 const gchar *domain = g_enum_info_get_error_domain (info);
522 if (domain) {
523 gperl_register_error_domain (g_quark_from_string (domain),
524 type, full_package);
525 }
526 }
527 #endif
528 break;
529
530 default:
531 break;
532 }
533
534 g_free (full_package);
535 g_base_info_unref ((GIBaseInfo *) info);
536 }
537
538 /* Use the empty string as the key to indicate "no namespace". */
539 gperl_hv_take_sv (namespaced_functions, "", 0,
540 newRV_noinc ((SV *) global_functions));
541
542 EXTEND (SP, 5);
543 PUSHs (sv_2mortal (newRV_noinc ((SV *) namespaced_functions)));
544 PUSHs (sv_2mortal (newRV_noinc ((SV *) constants)));
545 PUSHs (sv_2mortal (newRV_noinc ((SV *) fields)));
546 PUSHs (sv_2mortal (newRV_noinc ((SV *) interfaces)));
547 PUSHs (sv_2mortal (newRV_noinc ((SV *) objects_with_vfuncs)));
548
549 # This is only semi-private, as Gtk3 needs it. But it doesn't seem generally
550 # applicable, so it doesn't get an import() API.
551 void
552 _register_boxed_synonym (class, const gchar *reg_basename, const gchar *reg_name, const gchar *syn_gtype_function)
553 PREINIT:
554 GIRepository *repository;
555 GIBaseInfo *reg_info;
556 GModule *module;
557 GType (*syn_gtype_function_pointer) (void) = NULL;
558 GType reg_type, syn_type;
559 CODE:
560 repository = g_irepository_get_default ();
561 reg_info = g_irepository_find_by_name (repository, reg_basename, reg_name);
562 reg_type = reg_info ? get_gtype (reg_info) : 0;
563 if (!reg_type)
564 ccroak ("Could not lookup GType for type %s%s",
565 reg_basename, reg_name);
566
567 /* The GType in question (e.g., GdkRectangle) hasn't been loaded yet,
568 * so we cannot use g_type_name. It's also absent from the typelib, so
569 * we cannot use g_irepository_find_by_name. Hence, use the name of
570 * the GType creation function, look it up and call it. */
571 module = g_module_open (NULL, 0);
572 g_module_symbol (module, syn_gtype_function,
573 (gpointer *) &syn_gtype_function_pointer);
574 syn_type = syn_gtype_function_pointer ? syn_gtype_function_pointer () : 0;
575 g_module_close (module);
576 if (!syn_type)
577 ccroak ("Could not lookup GType from function %s",
578 syn_gtype_function);
579
580 dwarn ("%s => %s",
581 g_type_name (reg_type),
582 g_type_name (syn_type));
583 gperl_register_boxed_synonym (reg_type, syn_type);
584 g_base_info_unref (reg_info);
585
586 SV *
_fetch_constant(class,basename,constant)587 _fetch_constant (class, basename, constant)
588 const gchar *basename
589 const gchar *constant
590 PREINIT:
591 GIRepository *repository;
592 GIConstantInfo *info;
593 GITypeInfo *type_info;
594 GIArgument value = {0,};
595 CODE:
596 repository = g_irepository_get_default ();
597 info = g_irepository_find_by_name (repository, basename, constant);
598 if (!GI_IS_CONSTANT_INFO (info))
599 ccroak ("not a constant");
600 type_info = g_constant_info_get_type (info);
601 /* FIXME: What am I suppossed to do with the return value? */
602 g_constant_info_get_value (info, &value);
603 /* No PUTBACK/SPAGAIN needed here. */
604 RETVAL = arg_to_sv (&value,
605 type_info,
606 GI_TRANSFER_NOTHING,
607 GPERL_I11N_MEMORY_SCOPE_IRRELEVANT,
608 NULL);
609 #if GI_CHECK_VERSION (1, 30, 1)
610 g_constant_info_free_value (info, &value);
611 #endif
612 g_base_info_unref ((GIBaseInfo *) type_info);
613 g_base_info_unref ((GIBaseInfo *) info);
614 OUTPUT:
615 RETVAL
616
617 SV *
618 _construct_boxed (class, package)
619 const gchar *package
620 PREINIT:
621 GIRepository *repository;
622 GType gtype;
623 GIBaseInfo *info;
624 gsize size;
625 gpointer tmp_mem;
626 CODE:
627 gtype = gperl_boxed_type_from_package (package);
628 if (!gtype)
629 ccroak ("Could not find GType for package %s", package);
630 repository = g_irepository_get_default ();
631 info = g_irepository_find_by_gtype (repository, gtype);
632 if (!info) {
633 ccroak ("Could not fetch information for package %s; "
634 "perhaps it has not been loaded via "
635 "Glib::Object::Introspection?",
636 package);
637 }
638 size = g_struct_info_get_size (info);
639 if (!size) {
640 g_base_info_unref (info);
641 ccroak ("Cannot create boxed struct of unknown size for package %s",
642 package);
643 }
644 /* We allocate memory for the boxed type here with malloc(), but then
645 * take a copy of it and discard the original so that the memory we
646 * hand out is always allocated with the allocator used for the boxed
647 * type. Maybe we should use g_alloca? */
648 tmp_mem = g_malloc0 (size);
649 /* No PUTBACK/SPAGAIN needed here since the code that xsubpp generates
650 * for OUTPUT does not refer to our local copy of the stack pointer
651 * (but uses the ST macro). */
652 RETVAL = gperl_new_boxed_copy (tmp_mem, gtype);
653 g_free (tmp_mem);
654 g_base_info_unref (info);
655 OUTPUT:
656 RETVAL
657
658 SV *
659 _get_field (class, basename, namespace, field, invocant)
660 const gchar *basename
661 const gchar *namespace
662 const gchar *field
663 SV *invocant
664 PREINIT:
665 GIRepository *repository;
666 GIBaseInfo *namespace_info;
667 GIFieldInfo *field_info;
668 GType invocant_type;
669 gpointer boxed_mem;
670 CODE:
671 repository = g_irepository_get_default ();
672 namespace_info = g_irepository_find_by_name (repository, basename, namespace);
673 if (!namespace_info)
674 ccroak ("Could not find information for namespace '%s'",
675 namespace);
676 field_info = get_field_info (namespace_info, field);
677 if (!field_info)
678 ccroak ("Could not find field '%s' in namespace '%s'",
679 field, namespace)
680 invocant_type = get_gtype (namespace_info);
681 if (invocant_type == G_TYPE_NONE) {
682 /* If the invocant has no associated GType, try to look at the
683 * {$package}::_i11n_gtype SV. It gets set for members of
684 * boxed unions. */
685 const gchar *package = get_package_for_basename (basename);
686 if (package)
687 invocant_type = find_union_member_gtype (package, namespace);
688 }
689 if (!g_type_is_a (invocant_type, G_TYPE_BOXED))
690 ccroak ("Unable to handle access to field '%s' for type '%s'",
691 field, g_type_name (invocant_type));
692 boxed_mem = gperl_get_boxed_check (invocant, invocant_type);
693 /* No PUTBACK/SPAGAIN needed here. */
694 RETVAL = get_field (field_info, boxed_mem, GI_TRANSFER_NOTHING);
695 g_base_info_unref (field_info);
696 g_base_info_unref (namespace_info);
697 OUTPUT:
698 RETVAL
699
700 void
701 _set_field (class, basename, namespace, field, invocant, new_value)
702 const gchar *basename
703 const gchar *namespace
704 const gchar *field
705 SV *invocant
706 SV *new_value
707 PREINIT:
708 GIRepository *repository;
709 GIBaseInfo *namespace_info;
710 GIFieldInfo *field_info;
711 GType invocant_type;
712 gpointer boxed_mem;
713 CODE:
714 repository = g_irepository_get_default ();
715 namespace_info = g_irepository_find_by_name (repository, basename, namespace);
716 if (!namespace_info)
717 ccroak ("Could not find information for namespace '%s'",
718 namespace);
719 field_info = get_field_info (namespace_info, field);
720 if (!field_info)
721 ccroak ("Could not find field '%s' in namespace '%s'",
722 field, namespace)
723 invocant_type = get_gtype (namespace_info);
724 if (invocant_type == G_TYPE_NONE) {
725 /* If the invocant has no associated GType, try to look at the
726 * {$package}::_i11n_gtype SV. It gets set for members of
727 * boxed unions. */
728 const gchar *package = get_package_for_basename (basename);
729 if (package)
730 invocant_type = find_union_member_gtype (package, namespace);
731 }
732 if (!g_type_is_a (invocant_type, G_TYPE_BOXED))
733 ccroak ("Unable to handle access to field '%s' for type '%s'",
734 field, g_type_name (invocant_type));
735 boxed_mem = gperl_get_boxed_check (invocant, invocant_type);
736 /* Conceptually, we need to always transfer ownership to the boxed
737 * object for things like strings. The memory would then be freed by
738 * the boxed free func. But to do this correctly, we would need to
739 * free the memory that we are about to abandon by installing a new
740 * pointer. We can't know what free function to use, though. So
741 * g_field_info_set_field, and by extension set_field, simply refuse to
742 * set any member that would require such memory management. */
743 set_field (field_info, boxed_mem, GI_TRANSFER_EVERYTHING, new_value);
744 g_base_info_unref (field_info);
745 g_base_info_unref (namespace_info);
746
747 void
748 _add_interface (class, basename, interface_name, target_package)
749 const gchar *basename
750 const gchar *interface_name
751 const gchar *target_package
752 PREINIT:
753 GIRepository *repository;
754 GIInterfaceInfo *info;
755 GInterfaceInfo iface_info;
756 GType gtype;
757 CODE:
758 repository = g_irepository_get_default ();
759 info = g_irepository_find_by_name (repository, basename, interface_name);
760 if (!GI_IS_INTERFACE_INFO (info))
761 ccroak ("not an interface");
762 iface_info.interface_init = generic_interface_init;
763 iface_info.interface_finalize = generic_interface_finalize,
764 iface_info.interface_data = info;
765 gtype = gperl_object_type_from_package (target_package);
766 if (!gtype)
767 ccroak ("package '%s' is not registered with Glib-Perl",
768 target_package);
769 g_type_add_interface_static (gtype, get_gtype (info), &iface_info);
770 /* info is unref'd in generic_interface_finalize */
771
772 void
773 _install_overrides (class, basename, object_name, target_package)
774 const gchar *basename
775 const gchar *object_name
776 const gchar *target_package
777 PREINIT:
778 GIRepository *repository;
779 GIObjectInfo *info;
780 GType gtype;
781 gpointer klass;
782 CODE:
783 dwarn ("%s.%s for %s\n",
784 basename, object_name, target_package);
785 repository = g_irepository_get_default ();
786 info = g_irepository_find_by_name (repository, basename, object_name);
787 if (!GI_IS_OBJECT_INFO (info))
788 ccroak ("not an object");
789 gtype = gperl_object_type_from_package (target_package);
790 if (!gtype)
791 ccroak ("package '%s' is not registered with Glib-Perl",
792 target_package);
793 klass = g_type_class_peek (gtype);
794 if (!klass)
795 ccroak ("internal problem: can't peek at type class for %s (%" G_GSIZE_FORMAT ")",
796 g_type_name (gtype), gtype);
797 generic_class_init (info, target_package, klass);
798 g_base_info_unref (info);
799
800 void
801 _find_non_perl_parents (class, basename, object_name, target_package)
802 const gchar *basename
803 const gchar *object_name
804 const gchar *target_package
805 PREINIT:
806 GIRepository *repository;
807 GIObjectInfo *info;
808 GType gtype, object_gtype;
809 /* FIXME: we should export gperl_type_reg_quark from Glib */
810 GQuark reg_quark = g_quark_from_static_string ("__gperl_type_reg");
811 PPCODE:
812 repository = g_irepository_get_default ();
813 info = g_irepository_find_by_name (repository, basename, object_name);
814 g_assert (info && GI_IS_OBJECT_INFO (info));
815 gtype = gperl_object_type_from_package (target_package);
816 object_gtype = get_gtype (info);
817 /* find all non-Perl parents up to and including the object type */
818 while ((gtype = g_type_parent (gtype))) {
819 if (!g_type_get_qdata (gtype, reg_quark)) {
820 const gchar *package = gperl_object_package_from_type (gtype);
821 XPUSHs (sv_2mortal (newSVpv (package, 0)));
822 }
823 if (gtype == object_gtype) {
824 break;
825 }
826 }
827 g_base_info_unref (info);
828
829 void
830 _find_vfuncs_with_implementation (class, object_package, target_package)
831 const gchar *object_package
832 const gchar *target_package
833 PREINIT:
834 GIRepository *repository;
835 GType object_gtype, target_gtype;
836 gpointer object_klass, target_klass;
837 GIObjectInfo *object_info;
838 gint n_vfuncs, i;
839 PPCODE:
840 repository = g_irepository_get_default ();
841 target_gtype = gperl_object_type_from_package (target_package);
842 object_gtype = gperl_object_type_from_package (object_package);
843 g_assert (target_gtype && object_gtype);
844 target_klass = g_type_class_peek (target_gtype);
845 object_klass = g_type_class_peek (object_gtype);
846 g_assert (target_klass && object_klass);
847 object_info = g_irepository_find_by_gtype (repository, object_gtype);
848 g_assert (object_info && GI_IS_OBJECT_INFO (object_info));
849 n_vfuncs = g_object_info_get_n_vfuncs (object_info);
850 for (i = 0; i < n_vfuncs; i++) {
851 GIVFuncInfo *vfunc_info;
852 const gchar *vfunc_name;
853 gint field_offset;
854 vfunc_info = g_object_info_get_vfunc (object_info, i);
855 vfunc_name = g_base_info_get_name (vfunc_info);
856 /* FIXME: g_vfunc_info_get_offset does not seem to work here. */
857 field_offset = get_vfunc_offset (object_info, vfunc_name);
858 if (G_STRUCT_MEMBER (gpointer, target_klass, field_offset)) {
859 XPUSHs (sv_2mortal (newSVpv (vfunc_name, 0)));
860 }
861 g_base_info_unref (vfunc_info);
862 }
863 g_base_info_unref (object_info);
864
865 void
866 _invoke_fallback_vfunc (class, vfunc_package, vfunc_name, target_package, ...)
867 const gchar *vfunc_package
868 const gchar *vfunc_name
869 const gchar *target_package
870 PREINIT:
871 UV internal_stack_offset = 4;
872 GIRepository *repository;
873 GIObjectInfo *info;
874 GType gtype;
875 gpointer klass;
876 GIVFuncInfo *vfunc_info;
877 gint field_offset;
878 gpointer func_pointer;
879 PPCODE:
880 dwarn ("%s::%s, target = %s\n",
881 vfunc_package, vfunc_name, target_package);
882 gtype = gperl_object_type_from_package (target_package);
883 klass = g_type_class_peek (gtype);
884 g_assert (klass);
885 repository = g_irepository_get_default ();
886 info = g_irepository_find_by_gtype (
887 repository, gperl_object_type_from_package (vfunc_package));
888 g_assert (info && GI_IS_OBJECT_INFO (info));
889 vfunc_info = g_object_info_find_vfunc (info, vfunc_name);
890 g_assert (vfunc_info);
891 /* FIXME: g_vfunc_info_get_offset does not seem to work here. */
892 field_offset = get_vfunc_offset (info, vfunc_name);
893 func_pointer = G_STRUCT_MEMBER (gpointer, klass, field_offset);
894 g_assert (func_pointer);
895 invoke_c_code (vfunc_info, func_pointer,
896 sp, ax, mark, items,
897 internal_stack_offset,
898 NULL, NULL, NULL);
899 /* SPAGAIN since invoke_c_code probably modified the stack
900 * pointer. so we need to make sure that our local variable
901 * 'sp' is correct before the implicit PUTBACK happens. */
902 SPAGAIN;
903 g_base_info_unref (vfunc_info);
904 g_base_info_unref (info);
905
906 void
907 _use_generic_signal_marshaller_for (class, const gchar *package, const gchar *signal, SV *args_converter=NULL)
908 CODE:
909 #if GI_CHECK_VERSION (1, 33, 10)
910 {
911 GType gtype;
912 GIRepository *repository;
913 GIBaseInfo *container_info;
914 GPerlI11nPerlSignalInfo *signal_info;
915 ffi_cif *cif;
916 ffi_closure *closure;
917 GIBaseInfo *closure_marshal_info;
918
919 gtype = gperl_type_from_package (package);
920 if (!gtype)
921 ccroak ("Could not find GType for package %s", package);
922
923 repository = g_irepository_get_default ();
924 container_info = g_irepository_find_by_gtype (repository, gtype);
925 if (!container_info ||
926 !(GI_IS_OBJECT_INFO (container_info) ||
927 GI_IS_INTERFACE_INFO (container_info)))
928 ccroak ("Could not find object/interface info for package %s",
929 package);
930
931 signal_info = g_new0 (GPerlI11nPerlSignalInfo, 1); // FIXME: ctor?
932 signal_info->interface = get_signal_info (container_info, signal);
933 if (args_converter)
934 signal_info->args_converter = SvREFCNT_inc (args_converter);
935 if (!signal_info)
936 ccroak ("Could not find signal %s for package %s",
937 signal, package);
938
939 closure_marshal_info = g_irepository_find_by_name (repository,
940 "GObject",
941 "ClosureMarshal");
942 g_assert (closure_marshal_info);
943 cif = g_new0 (ffi_cif, 1);
944 closure = g_callable_info_prepare_closure (closure_marshal_info,
945 cif,
946 invoke_perl_signal_handler,
947 signal_info);
948 g_base_info_unref (closure_marshal_info);
949
950 dwarn ("package = %s, signal = %s => closure = %p\n",
951 package, signal, closure);
952 gperl_signal_set_marshaller_for (gtype, (gchar*) signal, (GClosureMarshal) closure);
953
954 /* These should be freed when the signal marshaller is not needed
955 * anymore. But gperl_signal_set_marshaller_for does not provide a
956 * hook for resource freeing.
957 *
958 * g_callable_info_free_closure (signal_info, closure);
959 * g_free (cif);
960 * g_base_info_unref (signal_info->interface);
961 * if (signal_info->args_converter)
962 * SvREFCNT_dec (signal_info->args_converter);
963 * g_free (signal_info);
964 */
965
966 g_base_info_unref (container_info);
967 }
968 #else
969 {
970 PERL_UNUSED_VAR (args_converter);
971 /* g_callable_info_prepare_closure, and thus
972 * create_perl_callback_closure and invoke_perl_signal_handler, did not
973 * work correctly for signals prior to commit
974 * d8970fbc500a8b20853b564536251315587450d9 in
975 * gobject-introspection. */
976 warn ("*** Cannot use generic signal marshallers for signal '%s' of %s "
977 "unless gobject-introspection >= 1.33.10; "
978 "any handlers connected to the signal "
979 "might thus be invoked incorrectly\n",
980 signal, package);
981 }
982 #endif
983
984 void
985 invoke (class, basename, namespace, function, ...)
986 const gchar *basename
987 const gchar_ornull *namespace
988 const gchar *function
989 PREINIT:
990 UV internal_stack_offset = 4;
991 GIRepository *repository;
992 GIFunctionInfo *info;
993 gpointer func_pointer = NULL;
994 const gchar *symbol = NULL;
995 PPCODE:
996 repository = g_irepository_get_default ();
997 info = get_function_info (repository, basename, namespace, function);
998 symbol = g_function_info_get_symbol (info);
999 if (!g_typelib_symbol (g_base_info_get_typelib((GIBaseInfo *) info),
1000 symbol, &func_pointer))
1001 {
1002 g_base_info_unref ((GIBaseInfo *) info);
1003 ccroak ("Could not locate symbol %s", symbol);
1004 }
1005 invoke_c_code (info, func_pointer,
1006 sp, ax, mark, items,
1007 internal_stack_offset,
1008 get_package_for_basename (basename), namespace, function);
1009 /* SPAGAIN since invoke_c_code probably modified the stack pointer.
1010 * so we need to make sure that our implicit local variable 'sp' is
1011 * correct before the implicit PUTBACK happens. */
1012 SPAGAIN;
1013 g_base_info_unref ((GIBaseInfo *) info);
1014
1015 gint
1016 convert_sv_to_enum (class, const gchar *package, SV *sv)
1017 PREINIT:
1018 GType gtype;
1019 CODE:
1020 gtype = gperl_type_from_package (package);
1021 RETVAL = gperl_convert_enum (gtype, sv);
1022 OUTPUT:
1023 RETVAL
1024
1025 SV *
1026 convert_enum_to_sv (class, const gchar *package, gint n)
1027 PREINIT:
1028 GType gtype;
1029 CODE:
1030 gtype = gperl_type_from_package (package);
1031 RETVAL = gperl_convert_back_enum (gtype, n);
1032 OUTPUT:
1033 RETVAL
1034
1035 gint
1036 convert_sv_to_flags (class, const gchar *package, SV *sv)
1037 PREINIT:
1038 GType gtype;
1039 CODE:
1040 gtype = gperl_type_from_package (package);
1041 RETVAL = gperl_convert_flags (gtype, sv);
1042 OUTPUT:
1043 RETVAL
1044
1045 SV *
1046 convert_flags_to_sv (class, const gchar *package, gint n)
1047 PREINIT:
1048 GType gtype;
1049 CODE:
1050 gtype = gperl_type_from_package (package);
1051 RETVAL = gperl_convert_back_flags (gtype, n);
1052 OUTPUT:
1053 RETVAL
1054
1055 # --------------------------------------------------------------------------- #
1056
1057 MODULE = Glib::Object::Introspection PACKAGE = Glib::Object::Introspection::GValueWrapper
1058
1059 SV *
1060 new (class, const gchar *type_package, SV *perl_value)
1061 PREINIT:
1062 GType type;
1063 GValue *v;
1064 CODE:
1065 type = gperl_type_from_package (type_package);
1066 if (!type)
1067 ccroak ("Could not find GType for '%s'", type_package);
1068 v = g_new0 (GValue, 1);
1069 g_value_init (v, type);
1070 gperl_value_from_sv (v, perl_value);
1071 RETVAL = newSVGValueWrapper (v);
1072 OUTPUT:
1073 RETVAL
1074
1075 SV *
1076 get_value (SV *sv)
1077 PREINIT:
1078 GValue *v;
1079 CODE:
1080 v = SvGValueWrapper (sv);
1081 RETVAL = gperl_sv_from_value (v);
1082 OUTPUT:
1083 RETVAL
1084
1085 void
1086 DESTROY (SV *sv)
1087 PREINIT:
1088 GValue *v;
1089 CODE:
1090 v = SvGValueWrapper (sv);
1091 g_value_unset (v);
1092 g_free (v);
1093
1094 # --------------------------------------------------------------------------- #
1095
1096 MODULE = Glib::Object::Introspection PACKAGE = Glib::Object::Introspection::_FuncWrapper
1097
1098 void
1099 _invoke (SV *code, ...)
1100 PREINIT:
1101 GPerlI11nCCallbackInfo *wrapper;
1102 UV internal_stack_offset = 1;
1103 PPCODE:
1104 wrapper = INT2PTR (GPerlI11nCCallbackInfo*, SvIV (SvRV (code)));
1105 if (!wrapper || !wrapper->func)
1106 ccroak ("invalid reference encountered");
1107 invoke_c_code (wrapper->interface, wrapper->func,
1108 sp, ax, mark, items,
1109 internal_stack_offset,
1110 NULL, NULL, NULL);
1111 /* SPAGAIN since invoke_c_code probably modified the stack
1112 * pointer. so we need to make sure that our local variable
1113 * 'sp' is correct before the implicit PUTBACK happens. */
1114 SPAGAIN;
1115
1116 void
1117 DESTROY (SV *code)
1118 PREINIT:
1119 GPerlI11nCCallbackInfo *info;
1120 CODE:
1121 info = INT2PTR (GPerlI11nCCallbackInfo*, SvIV (SvRV (code)));
1122 if (info)
1123 release_c_callback (info);
1124