1 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */
2
3 static gpointer _sv_to_class_struct_pointer (SV *sv, GPerlI11nInvocationInfo *iinfo);
4 static void _store_enum (GIEnumInfo * info, gint value, GIArgument * arg);
5 static gint _retrieve_enum (GIEnumInfo * info, GIArgument * arg);
6
7 static gpointer
instance_sv_to_pointer(GICallableInfo * info,SV * sv,GPerlI11nInvocationInfo * iinfo)8 instance_sv_to_pointer (GICallableInfo *info, SV *sv, GPerlI11nInvocationInfo *iinfo)
9 {
10 // We do *not* own container.
11 GIBaseInfo *container = g_base_info_get_container (info);
12 GIInfoType info_type = g_base_info_get_type (container);
13 gpointer pointer = NULL;
14
15 /* FIXME: Much of this code is duplicated in sv_to_interface. */
16
17 dwarn ("container name = %s, info type = %d (%s)\n",
18 g_base_info_get_name (container),
19 info_type, g_info_type_to_string (info_type));
20
21 switch (info_type) {
22 case GI_INFO_TYPE_OBJECT:
23 case GI_INFO_TYPE_INTERFACE:
24 pointer = gperl_get_object (sv);
25 dwarn (" -> object pointer: %p\n", pointer);
26 break;
27
28 case GI_INFO_TYPE_BOXED:
29 case GI_INFO_TYPE_STRUCT:
30 case GI_INFO_TYPE_UNION:
31 {
32 GType type = get_gtype ((GIRegisteredTypeInfo *) container);
33 if (!type || type == G_TYPE_NONE) {
34 if (g_struct_info_is_gtype_struct (container)) {
35 pointer = _sv_to_class_struct_pointer (sv, iinfo);
36 }
37 if (!pointer) {
38 dwarn (" -> untyped record\n");
39 pointer = sv_to_struct (GI_TRANSFER_NOTHING,
40 container,
41 info_type,
42 sv);
43 }
44 } else {
45 dwarn (" -> boxed: type=%s (%"G_GSIZE_FORMAT")\n",
46 g_type_name (type), type);
47 pointer = gperl_get_boxed_check (sv, type);
48 }
49 dwarn (" -> record pointer: %p\n", pointer);
50 break;
51 }
52
53 default:
54 ccroak ("Don't know how to handle info type %d for instance SV", info_type);
55 }
56
57 return pointer;
58 }
59
60 /* This may call Perl code (via gperl_new_boxed, gperl_sv_from_value,
61 * struct_to_sv), so it needs to be wrapped with PUTBACK/SPAGAIN by the
62 * caller. */
63 static SV *
instance_pointer_to_sv(GICallableInfo * info,gpointer pointer)64 instance_pointer_to_sv (GICallableInfo *info, gpointer pointer)
65 {
66 // We do *not* own container.
67 GIBaseInfo *container = g_base_info_get_container (info);
68 GIInfoType info_type = g_base_info_get_type (container);
69 SV *sv = NULL;
70
71 /* FIXME: Much of this code is duplicated in interface_to_sv. */
72
73 dwarn ("container name = %s, info type = %d (%s)\n",
74 g_base_info_get_name (container),
75 info_type, g_info_type_to_string (info_type));
76
77 switch (info_type) {
78 case GI_INFO_TYPE_OBJECT:
79 case GI_INFO_TYPE_INTERFACE:
80 sv = gperl_new_object (pointer, FALSE);
81 dwarn (" -> object SV: %p\n", sv);
82 break;
83
84 case GI_INFO_TYPE_BOXED:
85 case GI_INFO_TYPE_STRUCT:
86 case GI_INFO_TYPE_UNION:
87 {
88 GType type = get_gtype ((GIRegisteredTypeInfo *) container);
89 if (!type || type == G_TYPE_NONE) {
90 dwarn (" -> untyped record\n");
91 sv = struct_to_sv (container, info_type, pointer, FALSE);
92 } else {
93 dwarn (" -> boxed: type=%s (%"G_GSIZE_FORMAT")\n",
94 g_type_name (type), type);
95 sv = gperl_new_boxed (pointer, type, FALSE);
96 }
97 dwarn (" -> record pointer: %p\n", pointer);
98 break;
99 }
100
101 default:
102 ccroak ("Don't know how to handle info type %d for instance pointer", info_type);
103 }
104
105 return sv;
106 }
107
108 static void
sv_to_interface(GIArgInfo * arg_info,GITypeInfo * type_info,GITransfer transfer,gboolean may_be_null,SV * sv,GIArgument * arg,GPerlI11nInvocationInfo * invocation_info)109 sv_to_interface (GIArgInfo * arg_info,
110 GITypeInfo * type_info,
111 GITransfer transfer,
112 gboolean may_be_null,
113 SV * sv,
114 GIArgument * arg,
115 GPerlI11nInvocationInfo * invocation_info)
116 {
117 GIBaseInfo *interface;
118 GIInfoType info_type;
119
120 interface = g_type_info_get_interface (type_info);
121 if (!interface)
122 ccroak ("Could not convert sv %p to pointer", sv);
123 info_type = g_base_info_get_type (interface);
124
125 dwarn ("interface = %p (%s), type = %d (%s)\n",
126 interface, g_base_info_get_name (interface),
127 info_type, g_info_type_to_string (info_type));
128
129 switch (info_type) {
130 case GI_INFO_TYPE_OBJECT:
131 case GI_INFO_TYPE_INTERFACE:
132 if (may_be_null && !gperl_sv_is_defined (sv)) {
133 arg->v_pointer = NULL;
134 } else {
135 /* GParamSpecs are represented as classes of
136 * fundamental type, but gperl_get_object_check cannot
137 * handle this. So we do it here. */
138 if (info_type == GI_INFO_TYPE_OBJECT &&
139 g_object_info_get_fundamental (interface))
140 {
141 GType type = G_TYPE_FUNDAMENTAL (get_gtype (interface));
142 switch (type) {
143 case G_TYPE_PARAM:
144 arg->v_pointer = SvGParamSpec (sv);
145 break;
146 default:
147 ccroak ("sv_to_interface: Don't know how to handle fundamental type %s (%lu)\n",
148 g_type_name (type), type);
149 }
150 } else {
151 arg->v_pointer = gperl_get_object_check (sv, get_gtype (interface));
152 if (arg->v_pointer && transfer == GI_TRANSFER_NOTHING &&
153 ((GObject *) arg->v_pointer)->ref_count == 1 &&
154 SvTEMP (sv) && SvREFCNT (SvRV (sv)) == 1)
155 {
156 cwarn ("*** Asked to hand out object without ownership transfer, "
157 "but object is about to be destroyed; "
158 "adding an additional reference for safety");
159 transfer = GI_TRANSFER_EVERYTHING;
160 }
161 if (transfer >= GI_TRANSFER_CONTAINER) {
162 g_object_ref (arg->v_pointer);
163 }
164 }
165 }
166 break;
167
168 case GI_INFO_TYPE_UNION:
169 case GI_INFO_TYPE_STRUCT:
170 case GI_INFO_TYPE_BOXED:
171 {
172 gboolean need_value_semantics =
173 arg_info && g_arg_info_is_caller_allocates (arg_info)
174 && !g_type_info_is_pointer (type_info);
175 GType type = get_gtype ((GIRegisteredTypeInfo *) interface);
176 if (!type || type == G_TYPE_NONE) {
177 dwarn (" -> untyped record\n");
178 g_assert (!need_value_semantics);
179 if (g_struct_info_is_gtype_struct (interface)) {
180 arg->v_pointer = _sv_to_class_struct_pointer (sv, invocation_info);
181 } else {
182 const gchar *namespace, *name, *package;
183 GType parent_type;
184 /* Find out whether this untyped record is a member of
185 * a boxed union before using raw hash-to-struct
186 * conversion. */
187 name = g_base_info_get_name (interface);
188 namespace = g_base_info_get_namespace (interface);
189 package = get_package_for_basename (namespace);
190 parent_type = package ? find_union_member_gtype (package, name) : 0;
191 if (parent_type && parent_type != G_TYPE_NONE) {
192 arg->v_pointer = gperl_get_boxed_check (
193 sv, parent_type);
194 if (GI_TRANSFER_EVERYTHING == transfer)
195 arg->v_pointer =
196 g_boxed_copy (parent_type,
197 arg->v_pointer);
198 } else {
199 arg->v_pointer = sv_to_struct (transfer,
200 interface,
201 info_type,
202 sv);
203 }
204 }
205 }
206
207 else if (type == G_TYPE_CLOSURE) {
208 /* FIXME: User cannot supply user data. */
209 dwarn (" -> closure\n");
210 g_assert (!need_value_semantics);
211 arg->v_pointer = gperl_closure_new (sv, NULL, FALSE);
212 }
213
214 else if (type == G_TYPE_VALUE) {
215 GValue *gvalue = SvGValueWrapper (sv);
216 dwarn (" -> value\n");
217 if (!gvalue)
218 ccroak ("Cannot convert arbitrary SV to GValue");
219 if (need_value_semantics) {
220 g_value_init (arg->v_pointer, G_VALUE_TYPE (gvalue));
221 g_value_copy (gvalue, arg->v_pointer);
222 } else {
223 if (GI_TRANSFER_EVERYTHING == transfer) {
224 arg->v_pointer = g_new0 (GValue, 1);
225 g_value_init (arg->v_pointer, G_VALUE_TYPE (gvalue));
226 g_value_copy (gvalue, arg->v_pointer);
227 } else {
228 arg->v_pointer = gvalue;
229 }
230 }
231 }
232
233 else if (g_type_is_a (type, G_TYPE_BOXED)) {
234 dwarn (" -> boxed: type=%s, name=%s, caller-allocates=%d, is-pointer=%d\n",
235 g_type_name (type),
236 g_base_info_get_name (interface),
237 (arg_info ? g_arg_info_is_caller_allocates (arg_info) : INT_MAX),
238 g_type_info_is_pointer (type_info));
239 if (need_value_semantics) {
240 if (may_be_null && !gperl_sv_is_defined (sv)) {
241 /* Do nothing. */
242 } else {
243 gsize n_bytes = g_struct_info_get_size (interface);
244 gpointer mem = gperl_get_boxed_check (sv, type);
245 memmove (arg->v_pointer, mem, n_bytes);
246 }
247 } else {
248 if (may_be_null && !gperl_sv_is_defined (sv)) {
249 arg->v_pointer = NULL;
250 } else {
251 arg->v_pointer = gperl_get_boxed_check (sv, type);
252 if (GI_TRANSFER_EVERYTHING == transfer)
253 arg->v_pointer = g_boxed_copy (
254 type, arg->v_pointer);
255 }
256 }
257 }
258
259 #if GLIB_CHECK_VERSION (2, 24, 0)
260 else if (g_type_is_a (type, G_TYPE_VARIANT)) {
261 dwarn (" -> variant type\n");
262 g_assert (!need_value_semantics);
263 arg->v_pointer = SvGVariant (sv);
264 if (GI_TRANSFER_EVERYTHING == transfer)
265 g_variant_ref (arg->v_pointer);
266 }
267 #endif
268
269 else {
270 ccroak ("Cannot convert SV to record value of unknown type %s (%" G_GSIZE_FORMAT ")",
271 g_type_name (type), type);
272 }
273 break;
274 }
275
276 case GI_INFO_TYPE_ENUM:
277 {
278 gint value;
279 GType type = get_gtype ((GIRegisteredTypeInfo *) interface);
280 if (G_TYPE_NONE == type) {
281 ccroak ("Could not handle unknown enum type %s",
282 g_base_info_get_name (interface));
283 }
284 value = gperl_convert_enum (type, sv);
285 _store_enum (interface, value, arg);
286 break;
287 }
288
289 case GI_INFO_TYPE_FLAGS:
290 {
291 gint value;
292 GType type = get_gtype ((GIRegisteredTypeInfo *) interface);
293 if (G_TYPE_NONE == type) {
294 ccroak ("Could not handle unknown flags type %s",
295 g_base_info_get_name (interface));
296 }
297 value = gperl_convert_flags (type, sv);
298 _store_enum (interface, value, arg);
299 break;
300 }
301
302 case GI_INFO_TYPE_CALLBACK:
303 arg->v_pointer = sv_to_callback (arg_info, type_info, sv,
304 invocation_info);
305 break;
306
307 default:
308 ccroak ("sv_to_interface: Could not handle info type %s (%d)",
309 g_info_type_to_string (info_type),
310 info_type);
311 }
312
313 g_base_info_unref ((GIBaseInfo *) interface);
314 }
315
316 /* This may call Perl code (via gperl_new_boxed, gperl_sv_from_value,
317 * struct_to_sv), so it needs to be wrapped with PUTBACK/SPAGAIN by the
318 * caller. */
319 static SV *
interface_to_sv(GITypeInfo * info,GIArgument * arg,gboolean own,GPerlI11nMemoryScope mem_scope,GPerlI11nInvocationInfo * iinfo)320 interface_to_sv (GITypeInfo* info,
321 GIArgument *arg,
322 gboolean own,
323 GPerlI11nMemoryScope mem_scope,
324 GPerlI11nInvocationInfo *iinfo)
325 {
326 GIBaseInfo *interface;
327 GIInfoType info_type;
328 SV *sv = NULL;
329
330 dwarn ("arg %p, info %p\n", arg, info);
331 dwarn (" is pointer: %d\n", g_type_info_is_pointer (info));
332
333 interface = g_type_info_get_interface (info);
334 if (!interface)
335 ccroak ("Could not convert arg %p to SV", arg);
336 info_type = g_base_info_get_type (interface);
337 dwarn (" info type: %d (%s)\n",
338 info_type, g_info_type_to_string (info_type));
339
340 switch (info_type) {
341 case GI_INFO_TYPE_OBJECT:
342 /* GParamSpecs are represented as classes of fundamental type,
343 * but gperl_new_object cannot handle this. So we do it
344 * here. */
345 if (g_object_info_get_fundamental (interface)) {
346 GType type = G_TYPE_FUNDAMENTAL (get_gtype (interface));
347 switch (type) {
348 case G_TYPE_PARAM:
349 sv = newSVGParamSpec (arg->v_pointer); /* does ref & sink */
350 /* FIXME: What if own=true and the pspec is not
351 * floating? Then we would leak. We do not
352 * have the API to detect this. But it is
353 * probably also quite rare. */
354 break;
355 default:
356 ccroak ("interface_to_sv: Don't know how to handle fundamental type %s (%lu)\n",
357 g_type_name (type), type);
358 }
359 } else {
360 sv = gperl_new_object (arg->v_pointer, own);
361 }
362 break;
363
364 case GI_INFO_TYPE_INTERFACE:
365 sv = gperl_new_object (arg->v_pointer, own);
366 break;
367
368 case GI_INFO_TYPE_UNION:
369 case GI_INFO_TYPE_STRUCT:
370 case GI_INFO_TYPE_BOXED:
371 {
372 /* FIXME: What about pass-by-value here? */
373 GType type;
374 type = get_gtype ((GIRegisteredTypeInfo *) interface);
375 if (!type || type == G_TYPE_NONE) {
376 dwarn (" -> untyped record\n");
377 sv = struct_to_sv (interface, info_type, arg->v_pointer, own);
378 }
379
380 else if (type == G_TYPE_VALUE) {
381 dwarn (" -> value\n");
382 sv = gperl_sv_from_value (arg->v_pointer);
383 if (own)
384 g_boxed_free (type, arg->v_pointer);
385 }
386
387 else if (g_type_is_a (type, G_TYPE_BOXED)) {
388 dwarn (" -> boxed: pointer=%p, type=%"G_GSIZE_FORMAT" (%s), own=%d\n",
389 arg->v_pointer, type, g_type_name (type), own);
390 switch (mem_scope) {
391 case GPERL_I11N_MEMORY_SCOPE_TEMPORARY:
392 g_assert (own == TRUE);
393 sv = gperl_new_boxed_copy (arg->v_pointer, type);
394 break;
395 default:
396 sv = gperl_new_boxed (arg->v_pointer, type, own);
397 }
398 }
399
400 #if GLIB_CHECK_VERSION (2, 24, 0)
401 else if (g_type_is_a (type, G_TYPE_VARIANT)) {
402 dwarn (" -> variant\n");
403 sv = own ? newSVGVariant_noinc (arg->v_pointer)
404 : newSVGVariant (arg->v_pointer);
405 }
406 #endif
407
408 else {
409 ccroak ("Cannot convert record value of unknown type %s (%" G_GSIZE_FORMAT ") to SV",
410 g_type_name (type), type);
411 }
412 break;
413 }
414
415 case GI_INFO_TYPE_ENUM:
416 {
417 gint value;
418 GType type = get_gtype ((GIRegisteredTypeInfo *) interface);
419 if (G_TYPE_NONE == type) {
420 ccroak ("Could not handle unknown enum type %s",
421 g_base_info_get_name (interface));
422 }
423 value = _retrieve_enum (interface, arg);
424 sv = gperl_convert_back_enum (type, value);
425 break;
426 }
427
428 case GI_INFO_TYPE_FLAGS:
429 {
430 gint value;
431 GType type = get_gtype ((GIRegisteredTypeInfo *) interface);
432 if (G_TYPE_NONE == type) {
433 ccroak ("Could not handle unknown flags type %s",
434 g_base_info_get_name (interface));
435 }
436 value = _retrieve_enum (interface, arg);
437 sv = gperl_convert_back_flags (type, value);
438 break;
439 }
440
441 case GI_INFO_TYPE_CALLBACK:
442 sv = callback_to_sv (interface, arg->v_pointer, iinfo);
443 break;
444
445 default:
446 ccroak ("interface_to_sv: Don't know how to handle info type %s (%d)",
447 g_info_type_to_string (info_type),
448 info_type);
449 }
450
451 g_base_info_unref ((GIBaseInfo *) interface);
452
453 return sv;
454 }
455
456 /* ------------------------------------------------------------------------- */
457
458 static gpointer
_sv_to_class_struct_pointer(SV * sv,GPerlI11nInvocationInfo * iinfo)459 _sv_to_class_struct_pointer (SV *sv, GPerlI11nInvocationInfo *iinfo)
460 {
461 gpointer pointer = NULL;
462 GType class_type = 0;
463 dwarn (" -> gtype struct?\n");
464 if (gperl_sv_is_ref (sv)) { /* instance? */
465 const char *package = sv_reftype (SvRV (sv), TRUE);
466 class_type = gperl_type_from_package (package);
467 } else { /* package? */
468 class_type = gperl_type_from_package (SvPV_nolen (sv));
469 }
470 dwarn (" class_type = %s (%lu), is_classed = %d\n",
471 g_type_name (class_type), class_type, G_TYPE_IS_CLASSED (class_type));
472 if (G_TYPE_IS_CLASSED (class_type)) {
473 pointer = g_type_class_peek (class_type);
474 if (!pointer) {
475 /* If peek() produced NULL, the class has not been
476 * instantiated yet and needs to be created. */
477 pointer = g_type_class_ref (class_type);
478 free_after_call (iinfo, g_type_class_unref, pointer);
479 }
480 dwarn (" type class = %p\n", pointer);
481 }
482 return pointer;
483 }
484
485 /* ------------------------------------------------------------------------- */
486
487 void
_store_enum(GIEnumInfo * info,gint value,GIArgument * arg)488 _store_enum (GIEnumInfo * info, gint value, GIArgument * arg)
489 {
490 GITypeTag tag = g_enum_info_get_storage_type (info);
491 switch (tag) {
492 case GI_TYPE_TAG_BOOLEAN:
493 arg->v_boolean = (gboolean) value;
494 break;
495
496 case GI_TYPE_TAG_INT8:
497 arg->v_int8 = (gint8) value;
498 break;
499
500 case GI_TYPE_TAG_UINT8:
501 arg->v_uint8 = (guint8) value;
502 break;
503
504 case GI_TYPE_TAG_INT16:
505 arg->v_int16 = (gint16) value;
506 break;
507
508 case GI_TYPE_TAG_UINT16:
509 arg->v_uint16 = (guint16) value;
510 break;
511
512 case GI_TYPE_TAG_INT32:
513 arg->v_int32 = (gint32) value;
514 break;
515
516 case GI_TYPE_TAG_UINT32:
517 arg->v_uint32 = (guint32) value;
518 break;
519
520 case GI_TYPE_TAG_INT64:
521 arg->v_int64 = (gint64) value;
522 break;
523
524 case GI_TYPE_TAG_UINT64:
525 arg->v_uint64 = (guint64) value;
526 break;
527
528 default:
529 ccroak ("Unhandled enumeration type %s (%d) encountered",
530 g_type_tag_to_string (tag), tag);
531 }
532 }
533
534 gint
_retrieve_enum(GIEnumInfo * info,GIArgument * arg)535 _retrieve_enum (GIEnumInfo * info, GIArgument * arg)
536 {
537 GITypeTag tag = g_enum_info_get_storage_type (info);
538 switch (tag) {
539 case GI_TYPE_TAG_BOOLEAN:
540 return (gint) arg->v_boolean;
541
542 case GI_TYPE_TAG_INT8:
543 return (gint) arg->v_int8;
544
545 case GI_TYPE_TAG_UINT8:
546 return (gint) arg->v_uint8;
547
548 case GI_TYPE_TAG_INT16:
549 return (gint) arg->v_int16;
550
551 case GI_TYPE_TAG_UINT16:
552 return (gint) arg->v_uint16;
553
554 case GI_TYPE_TAG_INT32:
555 return (gint) arg->v_int32;
556
557 case GI_TYPE_TAG_UINT32:
558 return (gint) arg->v_uint32;
559
560 case GI_TYPE_TAG_INT64:
561 return (gint) arg->v_int64;
562
563 case GI_TYPE_TAG_UINT64:
564 return (gint) arg->v_uint64;
565
566 default:
567 ccroak ("Unhandled enumeration type %s (%d) encountered",
568 g_type_tag_to_string (tag), tag);
569 return 0;
570 }
571 }
572