[perl-Glib-Object-Introspection] Move most code into separate files
- From: Torsten SchÃnfeld <tsch src gnome org>
- To: commits-list gnome org
- Cc:
- Subject: [perl-Glib-Object-Introspection] Move most code into separate files
- Date: Fri, 7 Oct 2011 21:54:06 +0000 (UTC)
commit 5e32a372ce18b352389f5d7b05846ca2bb851cd1
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date: Fri Oct 7 23:32:36 2011 +0200
Move most code into separate files
.gitignore | 2 +-
GObjectIntrospection.xs | 2855 ++--------------------------------------
MANIFEST | 24 +
MANIFEST.SKIP | 2 +-
gperl-i11n-callback.c | 82 ++
gperl-i11n-croak.c | 20 +
gperl-i11n-field.c | 131 ++
gperl-i11n-gvalue.c | 19 +
gperl-i11n-info.c | 111 ++
gperl-i11n-invoke-c.c | 238 ++++
gperl-i11n-invoke-info.c | 211 +++
gperl-i11n-invoke-perl.c | 222 ++++
gperl-i11n-marshal-arg.c | 232 ++++
gperl-i11n-marshal-array.c | 167 +++
gperl-i11n-marshal-callback.c | 82 ++
gperl-i11n-marshal-hash.c | 175 +++
gperl-i11n-marshal-interface.c | 205 +++
gperl-i11n-marshal-list.c | 120 ++
gperl-i11n-marshal-raw.c | 155 +++
gperl-i11n-marshal-struct.c | 142 ++
gperl-i11n-method.c | 120 ++
gperl-i11n-size.c | 152 +++
gperl-i11n-vfunc-interface.c | 50 +
gperl-i11n-vfunc-object.c | 40 +
24 files changed, 2803 insertions(+), 2754 deletions(-)
---
diff --git a/.gitignore b/.gitignore
index 617ebc1..4994ee1 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,4 +1,4 @@
-*.c
+GObjectIntrospection.c
*.o
*.bs
Makefile
diff --git a/GObjectIntrospection.xs b/GObjectIntrospection.xs
index 9124fdd..0caa674 100644
--- a/GObjectIntrospection.xs
+++ b/GObjectIntrospection.xs
@@ -1,6 +1,6 @@
/*
* Copyright (C) 2005 muppet
- * Copyright (C) 2005-2010 Torsten Schoenfeld <kaffeetisch gmx de>
+ * Copyright (C) 2005-2011 Torsten Schoenfeld <kaffeetisch gmx de>
*
* This library is free software; you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published by the
@@ -26,59 +26,6 @@
#include <girepository.h>
#include <girffi.h>
-/* #define NOISY */
-#ifdef NOISY
-# define dwarn(...) warn(__VA_ARGS__)
-#else
-# define dwarn(...)
-#endif
-
-/* ------------------------------------------------------------------------- */
-
-/* Call Carp's croak() so that errors are reported at their location in the
- * user's program, not in Introspection.pm. Adapted from
- * <http://www.perlmonks.org/?node_id=865159>. */
-#define ccroak(...) call_carp_croak (form (__VA_ARGS__));
-static void
-call_carp_croak (const char *msg)
-{
- dSP;
-
- ENTER;
- SAVETMPS;
-
- PUSHMARK (SP);
- XPUSHs (sv_2mortal (newSVpv(msg, PL_na)));
- PUTBACK;
-
- call_pv("Carp::croak", G_VOID | G_DISCARD);
-
- FREETMPS;
- LEAVE;
-}
-
-/* ------------------------------------------------------------------------- */
-
-/* Semi-private package for marshalling into GValues. */
-#define GVALUE_WRAPPER_PACKAGE "Glib::Object::Introspection::GValueWrapper"
-
-static GValue *
-SvGValueWrapper (SV *sv)
-{
- return sv_derived_from (sv, GVALUE_WRAPPER_PACKAGE)
- ? INT2PTR (GValue*, SvIV (SvRV (sv)))
- : NULL;
-}
-
-static SV *
-newSVGValueWrapper (GValue *v)
-{
- SV *sv;
- sv = newSV (0);
- sv_setref_pv (sv, GVALUE_WRAPPER_PACKAGE, v);
- return sv;
-}
-
/* ------------------------------------------------------------------------- */
typedef struct {
@@ -146,19 +93,53 @@ typedef struct {
GSList * array_infos;
} GPerlI11nInvocationInfo;
+/* callbacks */
static GPerlI11nCallbackInfo* create_callback_closure (GITypeInfo *cb_type, SV *code);
static void attach_callback_data (GPerlI11nCallbackInfo *info, SV *data);
-
-static void invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata);
+static GPerlI11nCallbackInfo * create_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name, gchar *package_name);
static void release_callback (gpointer data);
-static SV * arg_to_sv (GIArgument * arg,
- GITypeInfo * info,
- GITransfer transfer,
- GPerlI11nInvocationInfo * iinfo);
+/* invocation */
+static void invoke_callback (ffi_cif* cif,
+ gpointer resp,
+ gpointer* args,
+ gpointer userdata);
+
+void invoke_callable (GICallableInfo *info,
+ gpointer func_pointer,
+ SV **sp, I32 ax, SV **mark, I32 items, /* these correspond to dXSARGS */
+ UV internal_stack_offset);
+
+/* invocation info */
+static void prepare_invocation_info (GPerlI11nInvocationInfo *iinfo,
+ GICallableInfo *info,
+ IV items,
+ UV internal_stack_offset);
+static void clear_invocation_info (GPerlI11nInvocationInfo *iinfo);
+static gpointer allocate_out_mem (GITypeInfo *arg_type);
+static void handle_automatic_arg (guint pos,
+ GIArgument * arg,
+ GPerlI11nInvocationInfo * invocation_info);
+
+/* info finders */
+static GIFunctionInfo * get_function_info (GIRepository *repository,
+ const gchar *basename,
+ const gchar *namespace,
+ const gchar *method);
+static GIFieldInfo * get_field_info (GIBaseInfo *info,
+ const gchar *field_name);
+
+/* marshallers */
static SV * interface_to_sv (GITypeInfo* info,
GIArgument *arg,
gboolean own);
+static void sv_to_interface (GIArgInfo * arg_info,
+ GITypeInfo * type_info,
+ SV * sv,
+ GIArgument * arg,
+ GPerlI11nInvocationInfo * invocation_info);
+
+static gpointer instance_sv_to_pointer (GICallableInfo *info, SV *sv);
static void sv_to_arg (SV * sv,
GIArgument * arg,
@@ -167,2716 +148,86 @@ static void sv_to_arg (SV * sv,
GITransfer transfer,
gboolean may_be_null,
GPerlI11nInvocationInfo * invocation_info);
+static SV * arg_to_sv (GIArgument * arg,
+ GITypeInfo * info,
+ GITransfer transfer,
+ GPerlI11nInvocationInfo *iinfo);
-/* ------------------------------------------------------------------------- */
-
-/* Caller owns return value */
-static GIFunctionInfo *
-get_function_info (GIRepository *repository,
- const gchar *basename,
- const gchar *namespace,
- const gchar *method)
-{
- dwarn ("%s: %s, %s, %s\n", G_STRFUNC, basename, namespace, method);
-
- if (namespace) {
- GIFunctionInfo *function_info = NULL;
- GIBaseInfo *namespace_info = g_irepository_find_by_name (
- repository, basename, namespace);
- if (!namespace_info)
- ccroak ("Can't find information for namespace %s",
- namespace);
-
- switch (g_base_info_get_type (namespace_info)) {
- case GI_INFO_TYPE_OBJECT:
- function_info = g_object_info_find_method (
- (GIObjectInfo *) namespace_info,
- method);
- break;
- case GI_INFO_TYPE_INTERFACE:
- function_info = g_interface_info_find_method (
- (GIInterfaceInfo *) namespace_info,
- method);
- break;
- case GI_INFO_TYPE_BOXED:
- case GI_INFO_TYPE_STRUCT:
- function_info = g_struct_info_find_method (
- (GIStructInfo *) namespace_info,
- method);
- break;
- case GI_INFO_TYPE_UNION:
- function_info = g_union_info_find_method (
- (GIUnionInfo *) namespace_info,
- method);
- break;
- default:
- ccroak ("Base info for namespace %s has incorrect type",
- namespace);
- }
-
- if (!function_info)
- ccroak ("Can't find information for method "
- "%s::%s", namespace, method);
-
- g_base_info_unref (namespace_info);
-
- return function_info;
- } else {
- GIBaseInfo *method_info = g_irepository_find_by_name (
- repository, basename, method);
-
- if (!method_info)
- ccroak ("Can't find information for method %s", method);
-
- switch (g_base_info_get_type (method_info)) {
- case GI_INFO_TYPE_FUNCTION:
- return (GIFunctionInfo *) method_info;
- default:
- ccroak ("Base info for method %s has incorrect type",
- method);
- }
- }
-
- return NULL;
-}
-
-/* Caller owns return value */
-static GIFieldInfo *
-get_field_info (GIBaseInfo *info, const gchar *field_name)
-{
- GIInfoType info_type;
- info_type = g_base_info_get_type (info);
- switch (info_type) {
- case GI_INFO_TYPE_BOXED:
- case GI_INFO_TYPE_STRUCT:
- {
- gint n_fields, i;
- n_fields = g_struct_info_get_n_fields ((GIStructInfo *) info);
- for (i = 0; i < n_fields; i++) {
- GIFieldInfo *field_info;
- field_info = g_struct_info_get_field ((GIStructInfo *) info, i);
- if (0 == strcmp (field_name, g_base_info_get_name (field_info))) {
- return field_info;
- }
- g_base_info_unref (field_info);
- }
- break;
- }
- case GI_INFO_TYPE_UNION:
- {
- gint n_fields, i;
- n_fields = g_union_info_get_n_fields ((GIStructInfo *) info);
- for (i = 0; i < n_fields; i++) {
- GIFieldInfo *field_info;
- field_info = g_union_info_get_field ((GIStructInfo *) info, i);
- if (0 == strcmp (field_name, g_base_info_get_name (field_info))) {
- return field_info;
- }
- g_base_info_unref (field_info);
- }
- break;
- }
- default:
- break;
- }
- return NULL;
-}
-
-/* ------------------------------------------------------------------------- */
-
-static gpointer
-handle_callback_arg (GIArgInfo * arg_info,
- GITypeInfo * type_info,
- SV * sv,
- GPerlI11nInvocationInfo * invocation_info)
-{
- GPerlI11nCallbackInfo *callback_info;
-
- GSList *l;
- for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
- GPerlI11nCallbackInfo *callback_info = l->data;
- if (invocation_info->current_pos == callback_info->notify_pos) {
- dwarn (" destroy notify for callback %p\n",
- callback_info);
- /* Decrease the dynamic stack offset so that this
- * destroy notify callback doesn't consume any Perl
- * value from the stack. */
- invocation_info->dynamic_stack_offset--;
- return release_callback;
- }
- }
-
- callback_info = create_callback_closure (type_info, sv);
- callback_info->data_pos = g_arg_info_get_closure (arg_info);
- callback_info->notify_pos = g_arg_info_get_destroy (arg_info);
- callback_info->free_after_use = FALSE;
-
- dwarn (" callback data at %d, destroy at %d\n",
- callback_info->data_pos, callback_info->notify_pos);
-
- switch (g_arg_info_get_scope (arg_info)) {
- case GI_SCOPE_TYPE_CALL:
- dwarn (" callback has scope 'call'\n");
- invocation_info->free_after_call
- = g_slist_prepend (invocation_info->free_after_call,
- callback_info);
- break;
- case GI_SCOPE_TYPE_NOTIFIED:
- dwarn (" callback has scope 'notified'\n");
- /* This case is already taken care of by the notify
- * stuff above */
- break;
- case GI_SCOPE_TYPE_ASYNC:
- dwarn (" callback has scope 'async'\n");
- /* FIXME: callback_info->free_after_use = TRUE; */
- break;
- default:
- ccroak ("unhandled scope type %d encountered",
- g_arg_info_get_scope (arg_info));
- }
-
- invocation_info->callback_infos =
- g_slist_prepend (invocation_info->callback_infos,
- callback_info);
-
- dwarn (" returning closure %p from info %p\n",
- callback_info->closure, callback_info);
- return callback_info->closure;
-}
-
-static gpointer
-handle_void_arg (SV * sv,
- GPerlI11nInvocationInfo * invocation_info)
-{
- gpointer pointer = NULL;
- gboolean is_user_data = FALSE;
- GSList *l;
- for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
- GPerlI11nCallbackInfo *callback_info = l->data;
- if (callback_info->data_pos == invocation_info->current_pos) {
- is_user_data = TRUE;
- dwarn (" user data for callback %p\n",
- callback_info);
- attach_callback_data (callback_info, sv);
- pointer = callback_info;
- break; /* out of the for loop */
- }
- }
- if (!is_user_data)
- ccroak ("encountered void pointer that is not callback user data");
- return pointer;
-}
-
-/* ------------------------------------------------------------------------- */
-
-/* These three are basically copied from pygi's pygi-info.c. :-( */
-
-static gsize
-size_of_type_tag (GITypeTag type_tag)
-{
- switch(type_tag) {
- case GI_TYPE_TAG_BOOLEAN:
- return sizeof (gboolean);
- case GI_TYPE_TAG_INT8:
- case GI_TYPE_TAG_UINT8:
- return sizeof (gint8);
- case GI_TYPE_TAG_INT16:
- case GI_TYPE_TAG_UINT16:
- return sizeof (gint16);
- case GI_TYPE_TAG_INT32:
- case GI_TYPE_TAG_UINT32:
- return sizeof (gint32);
- case GI_TYPE_TAG_INT64:
- case GI_TYPE_TAG_UINT64:
- return sizeof (gint64);
- case GI_TYPE_TAG_FLOAT:
- return sizeof (gfloat);
- case GI_TYPE_TAG_DOUBLE:
- return sizeof (gdouble);
- case GI_TYPE_TAG_GTYPE:
- return sizeof (GType);
- case GI_TYPE_TAG_UNICHAR:
- return sizeof (gunichar);
-
- case GI_TYPE_TAG_VOID:
- case GI_TYPE_TAG_UTF8:
- case GI_TYPE_TAG_FILENAME:
- case GI_TYPE_TAG_ARRAY:
- case GI_TYPE_TAG_INTERFACE:
- case GI_TYPE_TAG_GLIST:
- case GI_TYPE_TAG_GSLIST:
- case GI_TYPE_TAG_GHASH:
- case GI_TYPE_TAG_ERROR:
- ccroak ("Unable to determine the size of '%s'",
- g_type_tag_to_string (type_tag));
- break;
- }
-
- return 0;
-}
-
-static gsize
-size_of_interface (GITypeInfo *type_info)
-{
- gsize size = 0;
-
- GIBaseInfo *info;
- GIInfoType info_type;
-
- info = g_type_info_get_interface (type_info);
- info_type = g_base_info_get_type (info);
-
- switch (info_type) {
- case GI_INFO_TYPE_STRUCT:
- if (g_type_info_is_pointer (type_info)) {
- size = sizeof (gpointer);
- } else {
- /* FIXME: Remove this workaround once
- * gobject-introspection is fixed:
- * <https://bugzilla.gnome.org/show_bug.cgi?id=657040>. */
- GType type = g_registered_type_info_get_g_type (info);
- if (type == G_TYPE_VALUE) {
- size = sizeof (GValue);
- } else {
- size = g_struct_info_get_size ((GIStructInfo *) info);
- }
- }
- break;
-
- case GI_INFO_TYPE_UNION:
- if (g_type_info_is_pointer (type_info)) {
- size = sizeof (gpointer);
- } else {
- size = g_union_info_get_size ((GIUnionInfo *) info);
- }
- break;
-
- case GI_INFO_TYPE_ENUM:
- case GI_INFO_TYPE_FLAGS:
- if (g_type_info_is_pointer (type_info)) {
- size = sizeof (gpointer);
- } else {
- GITypeTag type_tag;
- type_tag = g_enum_info_get_storage_type ((GIEnumInfo *) info);
- size = size_of_type_tag (type_tag);
- }
- break;
-
- case GI_INFO_TYPE_BOXED:
- case GI_INFO_TYPE_OBJECT:
- case GI_INFO_TYPE_INTERFACE:
- case GI_INFO_TYPE_CALLBACK:
- size = sizeof (gpointer);
- break;
-
- default:
- g_assert_not_reached ();
- break;
- }
-
- g_base_info_unref (info);
-
- return size;
-}
-
-static gsize
-size_of_type_info (GITypeInfo *type_info)
-{
- GITypeTag type_tag;
-
- type_tag = g_type_info_get_tag (type_info);
- switch (type_tag) {
- case GI_TYPE_TAG_BOOLEAN:
- case GI_TYPE_TAG_INT8:
- case GI_TYPE_TAG_UINT8:
- case GI_TYPE_TAG_INT16:
- case GI_TYPE_TAG_UINT16:
- case GI_TYPE_TAG_INT32:
- case GI_TYPE_TAG_UINT32:
- case GI_TYPE_TAG_INT64:
- case GI_TYPE_TAG_UINT64:
- case GI_TYPE_TAG_FLOAT:
- case GI_TYPE_TAG_DOUBLE:
- case GI_TYPE_TAG_GTYPE:
- case GI_TYPE_TAG_UNICHAR:
- if (g_type_info_is_pointer (type_info)) {
- return sizeof (gpointer);
- } else {
- return size_of_type_tag (type_tag);
- }
-
- case GI_TYPE_TAG_INTERFACE:
- return size_of_interface (type_info);
-
- case GI_TYPE_TAG_ARRAY:
- case GI_TYPE_TAG_VOID:
- case GI_TYPE_TAG_UTF8:
- case GI_TYPE_TAG_FILENAME:
- case GI_TYPE_TAG_GLIST:
- case GI_TYPE_TAG_GSLIST:
- case GI_TYPE_TAG_GHASH:
- case GI_TYPE_TAG_ERROR:
- return sizeof (gpointer);
- }
-
- return 0;
-}
-
-/* ------------------------------------------------------------------------- */
-
-static SV *
-get_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer)
-{
- GITypeInfo *field_type;
- GIBaseInfo *interface_info;
- GIArgument value;
- SV *sv = NULL;
-
- field_type = g_field_info_get_type (field_info);
- interface_info = g_type_info_get_interface (field_type);
-
- /* This case is not handled by g_field_info_set_field. */
- if (!g_type_info_is_pointer (field_type) &&
- g_type_info_get_tag (field_type) == GI_TYPE_TAG_INTERFACE &&
- g_base_info_get_type (interface_info) == GI_INFO_TYPE_STRUCT)
- {
- gsize offset;
- offset = g_field_info_get_offset (field_info);
- value.v_pointer = mem + offset;
- sv = arg_to_sv (&value,
- field_type,
- GI_TRANSFER_NOTHING,
- NULL);
- } else if (g_field_info_get_field (field_info, mem, &value)) {
- sv = arg_to_sv (&value,
- field_type,
- transfer,
- NULL);
- } else {
- ccroak ("Could not get field '%s'",
- g_base_info_get_name (field_info));
- }
-
- if (interface_info)
- g_base_info_unref (interface_info);
- g_base_info_unref ((GIBaseInfo *) field_type);
-
- return sv;
-}
-
-static void
-set_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer, SV *value)
-{
- GITypeInfo *field_type;
- GIBaseInfo *interface_info;
- GIArgument arg;
-
- field_type = g_field_info_get_type (field_info);
- interface_info = g_type_info_get_interface (field_type);
-
- /* FIXME: No GIArgInfo and no
- * GPerlI11nInvocationInfo here. What if the
- * struct contains an object pointer, or a
- * callback field? And is it OK to always
- * allow undef? */
-
- /* This case is not handled by g_field_info_set_field. */
- if (!g_type_info_is_pointer (field_type) &&
- g_type_info_get_tag (field_type) == GI_TYPE_TAG_INTERFACE &&
- g_base_info_get_type (interface_info) == GI_INFO_TYPE_STRUCT)
- {
- gsize offset;
- gssize size;
- /* Enforce GI_TRANSFER_NOTHING since we will copy into the
- * memory that has already been allocated inside 'mem' */
- sv_to_arg (value, &arg, NULL, field_type,
- GI_TRANSFER_NOTHING, TRUE, NULL);
- offset = g_field_info_get_offset (field_info);
- size = g_struct_info_get_size (interface_info);
- g_memmove (mem + offset, arg.v_pointer, size);
- } else {
- sv_to_arg (value, &arg, NULL, field_type,
- transfer, TRUE, NULL);
- if (!g_field_info_set_field (field_info, mem, &arg))
- ccroak ("Could not set field '%s'",
- g_base_info_get_name (field_info));
- }
-
- if (interface_info)
- g_base_info_unref (interface_info);
- g_base_info_unref (field_type);
-}
-
-static SV *
-struct_to_sv (GIBaseInfo* info,
- GIInfoType info_type,
- gpointer pointer,
- gboolean own)
-{
- HV *hv;
-
- dwarn ("%s: pointer %p\n", G_STRFUNC, pointer);
-
- if (pointer == NULL) {
- return &PL_sv_undef;
- }
-
- hv = newHV ();
-
- switch (info_type) {
- case GI_INFO_TYPE_BOXED:
- case GI_INFO_TYPE_STRUCT:
- {
- gint i, n_fields =
- g_struct_info_get_n_fields ((GIStructInfo *) info);
- for (i = 0; i < n_fields; i++) {
- GIFieldInfo *field_info;
- SV *sv;
- field_info =
- g_struct_info_get_field ((GIStructInfo *) info, i);
- /* FIXME: Check GIFieldInfoFlags. */
- /* FIXME: Is it right to use GI_TRANSFER_NOTHING
- * here? */
- sv = get_field (field_info, pointer,
- GI_TRANSFER_NOTHING);
- if (gperl_sv_is_defined (sv)) {
- const gchar *name;
- name = g_base_info_get_name (
- (GIBaseInfo *) field_info);
- gperl_hv_take_sv (hv, name, strlen (name), sv);
- }
- g_base_info_unref ((GIBaseInfo *) field_info);
- }
- break;
- }
-
- case GI_INFO_TYPE_UNION:
- ccroak ("%s: unions not handled yet", G_STRFUNC);
-
- default:
- ccroak ("%s: unhandled info type %d", G_STRFUNC, info_type);
- }
-
- if (own) {
- /* FIXME: Is it correct to just call g_free here? What if the
- * thing was allocated via GSlice? */
- g_free (pointer);
- }
-
- return newRV_noinc ((SV *) hv);
-}
-
-static gpointer
-sv_to_struct (GITransfer transfer,
- GIBaseInfo * info,
- GIInfoType info_type,
- SV * sv)
-{
- HV *hv;
- gsize size = 0;
- GITransfer field_transfer;
- gpointer pointer = NULL;
-
- dwarn ("%s: sv %p\n", G_STRFUNC, sv);
-
- if (!gperl_sv_is_hash_ref (sv))
- ccroak ("need a hash ref to convert to struct of type %s",
- g_base_info_get_name (info));
- hv = (HV *) SvRV (sv);
-
- switch (info_type) {
- case GI_INFO_TYPE_BOXED:
- case GI_INFO_TYPE_STRUCT:
- size = g_struct_info_get_size ((GIStructInfo *) info);
- break;
- case GI_INFO_TYPE_UNION:
- size = g_union_info_get_size ((GIStructInfo *) info);
- break;
- default:
- g_assert_not_reached ();
- }
-
- dwarn (" size: %d\n", size);
-
- field_transfer = GI_TRANSFER_NOTHING;
- dwarn (" transfer: %d\n", transfer);
- switch (transfer) {
- case GI_TRANSFER_EVERYTHING:
- field_transfer = GI_TRANSFER_EVERYTHING;
- /* fall through */
- case GI_TRANSFER_CONTAINER:
- /* FIXME: What if there's a special allocator for the record?
- * Like GSlice? */
- pointer = g_malloc0 (size);
- break;
-
- default:
- pointer = gperl_alloc_temp (size);
- break;
- }
-
- switch (info_type) {
- case GI_INFO_TYPE_BOXED:
- case GI_INFO_TYPE_STRUCT:
- {
- gint i, n_fields =
- g_struct_info_get_n_fields ((GIStructInfo *) info);
- for (i = 0; i < n_fields; i++) {
- GIFieldInfo *field_info;
- const gchar *field_name;
- SV **svp;
- field_info = g_struct_info_get_field (
- (GIStructInfo *) info, i);
- /* FIXME: Check GIFieldInfoFlags. */
- field_name = g_base_info_get_name (
- (GIBaseInfo *) field_info);
- svp = hv_fetch (hv, field_name, strlen (field_name), 0);
- if (svp && gperl_sv_is_defined (*svp)) {
- set_field (field_info, pointer,
- field_transfer, *svp);
- }
- g_base_info_unref ((GIBaseInfo *) field_info);
- }
- break;
- }
-
- case GI_INFO_TYPE_UNION:
- ccroak ("%s: unions not handled yet", G_STRFUNC);
-
- default:
- ccroak ("%s: unhandled info type %d", G_STRFUNC, info_type);
- }
-
- return pointer;
-}
-
-/* ------------------------------------------------------------------------- */
-
-static SV *
-array_to_sv (GITypeInfo *info,
- gpointer pointer,
- GITransfer transfer,
- GPerlI11nInvocationInfo *iinfo)
-{
- GITypeInfo *param_info;
- gboolean is_zero_terminated;
- gsize item_size;
- GITransfer item_transfer;
- gssize length, i;
- AV *av;
-
- if (pointer == NULL) {
- return &PL_sv_undef;
- }
-
- is_zero_terminated = g_type_info_is_zero_terminated (info);
- param_info = g_type_info_get_param_type (info, 0);
- item_size = size_of_type_info (param_info);
-
- /* FIXME: What about an array containing arrays of strings, where the
- * outer array is GI_TRANSFER_EVERYTHING but the inner arrays are
- * GI_TRANSFER_CONTAINER? */
- item_transfer = transfer == GI_TRANSFER_EVERYTHING
- ? GI_TRANSFER_EVERYTHING
- : GI_TRANSFER_NOTHING;
-
- if (is_zero_terminated) {
- length = g_strv_length (pointer);
- } else {
- length = g_type_info_get_array_fixed_size (info);
- if (length < 0) {
- guint length_pos = g_type_info_get_array_length (info);
- g_assert (iinfo != NULL);
- /* FIXME: Is it OK to always use v_size here? */
- length = iinfo->aux_args[length_pos].v_size;
- }
- }
-
- if (length < 0) {
- ccroak ("Could not determine the length of the array");
- }
-
- av = newAV ();
-
- dwarn (" C array: pointer %p, length %d, item size %d, "
- "param_info %p with type tag %d (%s)\n",
- pointer,
- length,
- item_size,
- param_info,
- g_type_info_get_tag (param_info),
- g_type_tag_to_string (g_type_info_get_tag (param_info)));
-
- for (i = 0; i < length; i++) {
- GIArgument *arg;
- SV *value;
- arg = pointer + i * item_size;
- value = arg_to_sv (arg, param_info, item_transfer, iinfo);
- if (value)
- av_push (av, value);
- }
-
- if (transfer >= GI_TRANSFER_CONTAINER)
- g_free (pointer);
-
- g_base_info_unref ((GIBaseInfo *) param_info);
-
- return newRV_noinc ((SV *) av);
-}
-
-static gpointer
-sv_to_array (GITransfer transfer,
- GITypeInfo *type_info,
- SV *sv,
- GPerlI11nInvocationInfo *iinfo)
-{
- AV *av;
- GITransfer item_transfer;
- GITypeInfo *param_info;
- GITypeTag param_tag;
- gint i, length, length_pos;
- GPerlI11nArrayInfo *array_info = NULL;
- GArray *array;
- gboolean is_zero_terminated = FALSE;
- gsize item_size;
- gboolean need_struct_value_semantics;
-
- dwarn ("%s: sv %p\n", G_STRFUNC, sv);
-
- /* Add an array info entry even before the undef check so that the
- * corresponding length arg is set to zero later by
- * handle_automatic_arg. */
- length_pos = g_type_info_get_array_length (type_info);
- if (length_pos >= 0) {
- array_info = g_new0 (GPerlI11nArrayInfo, 1);
- array_info->length_pos = length_pos;
- array_info->length = 0;
- iinfo->array_infos = g_slist_prepend (iinfo->array_infos, array_info);
- }
-
- if (sv == &PL_sv_undef)
- return NULL;
-
- if (!gperl_sv_is_array_ref (sv))
- ccroak ("need an array ref to convert to GArray");
-
- av = (AV *) SvRV (sv);
-
- item_transfer = transfer == GI_TRANSFER_CONTAINER
- ? GI_TRANSFER_NOTHING
- : transfer;
-
- param_info = g_type_info_get_param_type (type_info, 0);
- param_tag = g_type_info_get_tag (param_info);
- dwarn (" GArray: param_info %p with type tag %d (%s) and transfer %d\n",
- param_info, param_tag,
- g_type_tag_to_string (g_type_info_get_tag (param_info)),
- transfer);
-
- is_zero_terminated = g_type_info_is_zero_terminated (type_info);
- item_size = size_of_type_info (param_info);
- length = av_len (av) + 1;
- array = g_array_sized_new (is_zero_terminated, FALSE, item_size, length);
-
- /* Arrays containing non-basic types as non-pointers need to be treated
- * specially. Prime example: GValue *values = g_new0 (GValue, n);
- */
- need_struct_value_semantics =
- /* is a compound type, and... */
- !G_TYPE_TAG_IS_BASIC (param_tag) &&
- /* ... a non-pointer is wanted */
- !g_type_info_is_pointer (param_info);
- for (i = 0; i < length; i++) {
- SV **svp;
- svp = av_fetch (av, i, 0);
- if (svp && gperl_sv_is_defined (*svp)) {
- GIArgument arg;
-
- dwarn (" converting SV %p\n", *svp);
- /* FIXME: Is it OK to always allow undef here? */
- sv_to_arg (*svp, &arg, NULL, param_info,
- item_transfer, TRUE, NULL);
-
- if (need_struct_value_semantics) {
- /* Copy from the memory area pointed to by
- * arg.v_pointer. */
- g_array_insert_vals (array, i, arg.v_pointer, 1);
- } else {
- /* Copy from &arg, i.e. the memory area that is
- * arg. */
- g_array_insert_val (array, i, arg);
- }
- }
- }
+static gpointer handle_callback_arg (GIArgInfo * arg_info, GITypeInfo * type_info, SV * sv, GPerlI11nInvocationInfo * invocation_info);
+static gpointer handle_void_arg (SV * sv, GPerlI11nInvocationInfo * invocation_info);
- dwarn (" -> array %p of size %d\n", array, array->len);
+static SV * struct_to_sv (GIBaseInfo* info, GIInfoType info_type, gpointer pointer, gboolean own);
+static gpointer sv_to_struct (GITransfer transfer, GIBaseInfo * info, GIInfoType info_type, SV * sv);
- if (length_pos >= 0) {
- array_info->length = length;
- }
+static SV * array_to_sv (GITypeInfo *info, gpointer pointer, GITransfer transfer, GPerlI11nInvocationInfo *iinfo);
+static gpointer sv_to_array (GITransfer transfer, GITypeInfo *type_info, SV *sv, GPerlI11nInvocationInfo *iinfo);
- g_base_info_unref ((GIBaseInfo *) param_info);
+static SV * glist_to_sv (GITypeInfo* info, gpointer pointer, GITransfer transfer);
+static gpointer sv_to_glist (GITransfer transfer, GITypeInfo * type_info, SV * sv);
- return g_array_free (array, FALSE);
-}
+static SV * ghash_to_sv (GITypeInfo *info, gpointer pointer, GITransfer transfer);
+static gpointer sv_to_ghash (GITransfer transfer, GITypeInfo *type_info, SV *sv);
-/* ------------------------------------------------------------------------- */
+static void raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info);
+static void arg_to_raw (GIArgument *arg, gpointer raw, GITypeInfo *info);
-static SV *
-glist_to_sv (GITypeInfo* info,
- gpointer pointer,
- GITransfer transfer)
-{
- GITypeInfo *param_info;
- GITransfer item_transfer;
- gboolean is_slist;
- GSList *i;
- AV *av;
- SV *value;
-
- if (pointer == NULL) {
- return &PL_sv_undef;
- }
+/* sizes */
+static gsize size_of_type_tag (GITypeTag type_tag);
+static gsize size_of_interface (GITypeInfo *type_info);
+static gsize size_of_type_info (GITypeInfo *type_info);
- /* FIXME: What about an array containing arrays of strings, where the
- * outer array is GI_TRANSFER_EVERYTHING but the inner arrays are
- * GI_TRANSFER_CONTAINER? */
- item_transfer = transfer == GI_TRANSFER_EVERYTHING
- ? GI_TRANSFER_EVERYTHING
- : GI_TRANSFER_NOTHING;
-
- param_info = g_type_info_get_param_type (info, 0);
- dwarn (" G(S)List: pointer %p, param_info %p with type tag %d (%s)\n",
- pointer,
- param_info,
- g_type_info_get_tag (param_info),
- g_type_tag_to_string (g_type_info_get_tag (param_info)));
-
- is_slist = GI_TYPE_TAG_GSLIST == g_type_info_get_tag (info);
-
- av = newAV ();
- for (i = pointer; i; i = i->next) {
- GIArgument arg = {0,};
- dwarn (" converting pointer %p\n", i->data);
- arg.v_pointer = i->data;
- value = arg_to_sv (&arg, param_info, item_transfer, NULL);
- if (value)
- av_push (av, value);
- }
+/* fields */
+static void store_fields (HV *fields, GIBaseInfo *info, GIInfoType info_type);
+static SV * get_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer);
+static void set_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer, SV *value);
- if (transfer >= GI_TRANSFER_CONTAINER) {
- if (is_slist)
- g_slist_free (pointer);
- else
- g_list_free (pointer);
- }
+/* methods */
+static void store_methods (HV *namespaced_functions, GIBaseInfo *info, GIInfoType info_type);
- g_base_info_unref ((GIBaseInfo *) param_info);
-
- return newRV_noinc ((SV *) av);
-}
-
-static gpointer
-sv_to_glist (GITransfer transfer, GITypeInfo * type_info, SV * sv)
-{
- AV *av;
- GITransfer item_transfer;
- gpointer list = NULL;
- GITypeInfo *param_info;
- gboolean is_slist;
- gint i, length;
-
- dwarn ("%s: sv %p\n", G_STRFUNC, sv);
-
- if (sv == &PL_sv_undef)
- return NULL;
-
- if (!gperl_sv_is_array_ref (sv))
- ccroak ("need an array ref to convert to GList");
- av = (AV *) SvRV (sv);
-
- item_transfer = GI_TRANSFER_NOTHING;
- switch (transfer) {
- case GI_TRANSFER_EVERYTHING:
- item_transfer = GI_TRANSFER_EVERYTHING;
- break;
- case GI_TRANSFER_CONTAINER:
- /* nothing special to do */
- break;
- case GI_TRANSFER_NOTHING:
- /* FIXME: need to free list after call */
- break;
- }
+/* interface vfuncs */
+static void generic_interface_init (gpointer iface, gpointer data);
+static void generic_interface_finalize (gpointer iface, gpointer data);
- param_info = g_type_info_get_param_type (type_info, 0);
- dwarn (" G(S)List: param_info %p with type tag %d (%s) and transfer %d\n",
- param_info,
- g_type_info_get_tag (param_info),
- g_type_tag_to_string (g_type_info_get_tag (param_info)),
- transfer);
-
- is_slist = GI_TYPE_TAG_GSLIST == g_type_info_get_tag (type_info);
-
- length = av_len (av) + 1;
- for (i = 0; i < length; i++) {
- SV **svp;
- svp = av_fetch (av, i, 0);
- if (svp && gperl_sv_is_defined (*svp)) {
- GIArgument arg;
- dwarn (" converting SV %p\n", *svp);
- /* FIXME: Is it OK to always allow undef here? */
- sv_to_arg (*svp, &arg, NULL, param_info,
- item_transfer, TRUE, NULL);
- /* ENHANCEME: Could use g_[s]list_prepend and
- * later _reverse for efficiency. */
- if (is_slist)
- list = g_slist_append (list, arg.v_pointer);
- else
- list = g_list_append (list, arg.v_pointer);
- }
- }
-
- dwarn (" -> list %p of length %d\n", list, g_list_length (list));
-
- g_base_info_unref ((GIBaseInfo *) param_info);
+/* object vfuncs */
+static void generic_class_init (GIObjectInfo *info, const gchar *target_package, gpointer class);
- return list;
-}
-
-static SV *
-ghash_to_sv (GITypeInfo *info,
- gpointer pointer,
- GITransfer transfer)
-{
- GITypeInfo *key_param_info, *value_param_info;
-#ifdef NOISY
- GITypeTag key_type_tag, value_type_tag;
-#endif
- gpointer key_p, value_p;
- GITransfer item_transfer;
- GHashTableIter iter;
- HV *hv;
-
- if (pointer == NULL) {
- return &PL_sv_undef;
- }
-
- item_transfer = transfer == GI_TRANSFER_EVERYTHING
- ? GI_TRANSFER_EVERYTHING
- : GI_TRANSFER_NOTHING;
+/* FIXME: this is not safe if we want to support unloading G:O:I. */
+#define VFUNC_TARGET_PACKAGE_QUARK g_quark_from_static_string ("__gperl_vfunc_target_package")
+#define VFUNC_PERL_TYPE_QUARK g_quark_from_static_string ("__gperl_vfunc_perl_type")
- key_param_info = g_type_info_get_param_type (info, 0);
- value_param_info = g_type_info_get_param_type (info, 1);
+/* misc. */
+#define ccroak(...) call_carp_croak (form (__VA_ARGS__));
+static void call_carp_croak (const char *msg);
+/* #define NOISY */
#ifdef NOISY
- key_type_tag = g_type_info_get_tag (key_param_info);
- value_type_tag = g_type_info_get_tag (value_param_info);
-#endif
-
- dwarn (" GHashTable: pointer %p\n"
- " key type tag %d (%s)\n"
- " value type tag %d (%s)\n",
- pointer,
- key_type_tag, g_type_tag_to_string (key_type_tag),
- value_type_tag, g_type_tag_to_string (value_type_tag));
-
- hv = newHV ();
-
- g_hash_table_iter_init (&iter, pointer);
- while (g_hash_table_iter_next (&iter, &key_p, &value_p)) {
- GIArgument arg = { 0, };
- SV *key_sv, *value_sv;
-
- dwarn (" converting key pointer %p\n", key_p);
- arg.v_pointer = key_p;
- key_sv = arg_to_sv (&arg, key_param_info, item_transfer, NULL);
- if (key_sv == NULL)
- break;
-
- dwarn (" converting value pointer %p\n", value_p);
- arg.v_pointer = value_p;
- value_sv = arg_to_sv (&arg, value_param_info, item_transfer, NULL);
- if (value_sv == NULL)
- break;
-
- (void) hv_store_ent (hv, key_sv, value_sv, 0);
- }
-
- g_base_info_unref ((GIBaseInfo *) key_param_info);
- g_base_info_unref ((GIBaseInfo *) value_param_info);
-
- return newRV_noinc ((SV *) hv);
-}
-
-static gpointer
-sv_to_ghash (GITransfer transfer,
- GITypeInfo *type_info,
- SV *sv)
-{
- HV *hv;
- HE *he;
- GITransfer item_transfer;
- gpointer hash;
- GITypeInfo *key_param_info, *value_param_info;
- GITypeTag key_type_tag;
- GHashFunc hash_func;
- GEqualFunc equal_func;
- I32 n_keys;
-
- dwarn ("%s: sv %p\n", G_STRFUNC, sv);
-
- if (sv == &PL_sv_undef)
- return NULL;
-
- if (!gperl_sv_is_hash_ref (sv))
- ccroak ("need an hash ref to convert to GHashTable");
-
- hv = (HV *) SvRV (sv);
-
- item_transfer = GI_TRANSFER_NOTHING;
- switch (transfer) {
- case GI_TRANSFER_EVERYTHING:
- item_transfer = GI_TRANSFER_EVERYTHING;
- break;
- case GI_TRANSFER_CONTAINER:
- /* nothing special to do */
- break;
- case GI_TRANSFER_NOTHING:
- /* FIXME: need to free hash after call */
- break;
- }
-
- key_param_info = g_type_info_get_param_type (type_info, 0);
- value_param_info = g_type_info_get_param_type (type_info, 1);
-
- key_type_tag = g_type_info_get_tag (key_param_info);
-
- switch (key_type_tag)
- {
- case GI_TYPE_TAG_FILENAME:
- case GI_TYPE_TAG_UTF8:
- hash_func = g_str_hash;
- equal_func = g_str_equal;
- break;
-
- default:
- hash_func = NULL;
- equal_func = NULL;
- break;
- }
-
- dwarn (" GHashTable with transfer %d\n"
- " key_param_info %p with type tag %d (%s)\n"
- " value_param_info %p with type tag %d (%s)\n",
- transfer,
- key_param_info,
- g_type_info_get_tag (key_param_info),
- g_type_tag_to_string (g_type_info_get_tag (key_param_info)),
- value_param_info,
- g_type_info_get_tag (value_param_info),
- g_type_tag_to_string (g_type_info_get_tag (value_param_info)));
-
- hash = g_hash_table_new (hash_func, equal_func);
-
- n_keys = hv_iterinit (hv);
- if (n_keys == 0)
- goto out;
-
- while ((he = hv_iternext (hv)) != NULL) {
- SV *sv;
- GIArgument arg = { 0, };
- gpointer key_p, value_p;
-
- key_p = value_p = NULL;
-
- sv = hv_iterkeysv (he);
- if (sv && gperl_sv_is_defined (sv)) {
- dwarn (" converting key SV %p\n", sv);
- /* FIXME: Is it OK to always allow undef here? */
- sv_to_arg (sv, &arg, NULL, key_param_info,
- item_transfer, TRUE, NULL);
- key_p = arg.v_pointer;
- }
-
- sv = hv_iterval (hv, he);
- if (sv && gperl_sv_is_defined (sv)) {
- dwarn (" converting value SV %p\n", sv);
- sv_to_arg (sv, &arg, NULL, key_param_info,
- item_transfer, TRUE, NULL);
- value_p = arg.v_pointer;
- }
-
- if (key_p != NULL && value_p != NULL)
- g_hash_table_insert (hash, key_p, value_p);
- }
-
-out:
- dwarn (" -> hash %p of size %d\n", hash, g_hash_table_size (hash));
-
- g_base_info_unref ((GIBaseInfo *) key_param_info);
- g_base_info_unref ((GIBaseInfo *) value_param_info);
-
- return hash;
-}
-
-/* ------------------------------------------------------------------------- */
-
-static void
-sv_to_interface (GIArgInfo * arg_info,
- GITypeInfo * type_info,
- SV * sv,
- GIArgument * arg,
- GPerlI11nInvocationInfo * invocation_info)
-{
- GIBaseInfo *interface;
- GIInfoType info_type;
-
- interface = g_type_info_get_interface (type_info);
- if (!interface)
- ccroak ("Could not convert sv %p to pointer", sv);
- info_type = g_base_info_get_type (interface);
-
- dwarn (" interface %p (%s) of type %d\n",
- interface, g_base_info_get_name (interface), info_type);
-
- switch (info_type) {
- case GI_INFO_TYPE_OBJECT:
- case GI_INFO_TYPE_INTERFACE:
- /* FIXME: Check transfer setting. */
- arg->v_pointer = gperl_get_object (sv);
- break;
-
- case GI_INFO_TYPE_UNION:
- case GI_INFO_TYPE_STRUCT:
- case GI_INFO_TYPE_BOXED:
- {
- /* FIXME: What about pass-by-value here? */
- GType type = g_registered_type_info_get_g_type (
- (GIRegisteredTypeInfo *) interface);
- if (!type || type == G_TYPE_NONE) {
- GITransfer transfer = arg_info
- ? g_arg_info_get_ownership_transfer (arg_info)
- : GI_TRANSFER_NOTHING;
- dwarn (" unboxed type\n");
- arg->v_pointer = sv_to_struct (transfer,
- interface,
- info_type,
- sv);
- } else if (type == G_TYPE_CLOSURE) {
- /* FIXME: User cannot supply user data. */
- dwarn (" closure type\n");
- arg->v_pointer = gperl_closure_new (sv, NULL, FALSE);
- } else if (type == G_TYPE_VALUE) {
- dwarn (" value type\n");
- arg->v_pointer = SvGValueWrapper (sv);
- if (!arg->v_pointer)
- ccroak ("Cannot convert arbitrary SV to GValue");
- } else {
- dwarn (" boxed type: %s (%d)\n",
- g_type_name (type), type);
- /* FIXME: Check transfer setting. */
- arg->v_pointer = gperl_get_boxed_check (sv, type);
- }
- break;
- }
-
- case GI_INFO_TYPE_ENUM:
- {
- GType type = g_registered_type_info_get_g_type ((GIRegisteredTypeInfo *) interface);
- /* FIXME: Check storage type? */
- arg->v_long = gperl_convert_enum (type, sv);
- break;
- }
-
- case GI_INFO_TYPE_FLAGS:
- {
- GType type = g_registered_type_info_get_g_type ((GIRegisteredTypeInfo *) interface);
- /* FIXME: Check storage type? */
- arg->v_long = gperl_convert_flags (type, sv);
- break;
- }
-
- case GI_INFO_TYPE_CALLBACK:
- arg->v_pointer = handle_callback_arg (arg_info, type_info, sv,
- invocation_info);
- break;
-
- default:
- ccroak ("sv_to_interface: Don't know how to handle info type %d", info_type);
- }
-
- g_base_info_unref ((GIBaseInfo *) interface);
-}
-
-static SV *
-interface_to_sv (GITypeInfo* info, GIArgument *arg, gboolean own)
-{
- GIBaseInfo *interface;
- GIInfoType info_type;
- SV *sv = NULL;
-
- dwarn (" interface_to_sv: arg %p, info %p\n",
- arg, info);
-
- interface = g_type_info_get_interface (info);
- if (!interface)
- ccroak ("Could not convert arg %p to SV", arg);
- info_type = g_base_info_get_type (interface);
- dwarn (" info type: %d (%s)\n", info_type, g_info_type_to_string (info_type));
-
- switch (info_type) {
- case GI_INFO_TYPE_OBJECT:
- case GI_INFO_TYPE_INTERFACE:
- sv = gperl_new_object (arg->v_pointer, own);
- break;
-
- case GI_INFO_TYPE_UNION:
- case GI_INFO_TYPE_STRUCT:
- case GI_INFO_TYPE_BOXED:
- {
- /* FIXME: What about pass-by-value here? */
- GType type;
- type = g_registered_type_info_get_g_type (
- (GIRegisteredTypeInfo *) interface);
- if (!type || type == G_TYPE_NONE) {
- dwarn (" unboxed type\n");
- sv = struct_to_sv (interface, info_type, arg->v_pointer, own);
- } else if (type == G_TYPE_VALUE) {
- dwarn (" value type\n");
- sv = gperl_sv_from_value (arg->v_pointer);
- /* FIXME: Check 'own'. */
- } else {
- dwarn (" boxed type: %d (%s)\n",
- type, g_type_name (type));
- sv = gperl_new_boxed (arg->v_pointer, type, own);
- }
- break;
- }
-
- case GI_INFO_TYPE_ENUM:
- {
- GType type = g_registered_type_info_get_g_type ((GIRegisteredTypeInfo *) interface);
- /* FIXME: Is it right to just use v_long here? */
- sv = gperl_convert_back_enum (type, arg->v_long);
- break;
- }
-
- case GI_INFO_TYPE_FLAGS:
- {
- GType type = g_registered_type_info_get_g_type ((GIRegisteredTypeInfo *) interface);
- /* FIXME: Is it right to just use v_long here? */
- sv = gperl_convert_back_flags (type, arg->v_long);
- break;
- }
-
- default:
- ccroak ("interface_to_sv: Don't know how to handle info type %d", info_type);
- }
-
- g_base_info_unref ((GIBaseInfo *) interface);
-
- return sv;
-}
-
-static gpointer
-instance_sv_to_pointer (GICallableInfo *info, SV *sv)
-{
- // We do *not* own container.
- GIBaseInfo *container = g_base_info_get_container (info);
- GIInfoType info_type = g_base_info_get_type (container);
- gpointer pointer = NULL;
-
- /* FIXME: Much of this code is duplicated in sv_to_interface. */
-
- dwarn (" instance_sv_to_pointer: container name: %s, info type: %d\n",
- g_base_info_get_name (container),
- info_type);
-
- switch (info_type) {
- case GI_INFO_TYPE_OBJECT:
- case GI_INFO_TYPE_INTERFACE:
- pointer = gperl_get_object (sv);
- dwarn (" -> object pointer: %p\n", pointer);
- break;
-
- case GI_INFO_TYPE_BOXED:
- case GI_INFO_TYPE_STRUCT:
- case GI_INFO_TYPE_UNION:
- {
- GType type = g_registered_type_info_get_g_type (
- (GIRegisteredTypeInfo *) container);
- if (!type || type == G_TYPE_NONE) {
- dwarn (" unboxed type\n");
- pointer = sv_to_struct (GI_TRANSFER_NOTHING,
- container,
- info_type,
- sv);
- } else {
- dwarn (" boxed type: %s (%d)\n",
- g_type_name (type), type);
- pointer = gperl_get_boxed_check (sv, type);
- }
- dwarn (" -> boxed pointer: %p\n", pointer);
- break;
- }
-
- default:
- ccroak ("instance_sv_to_pointer: Don't know how to handle info type %d", info_type);
- }
-
- return pointer;
-}
-
-/* ------------------------------------------------------------------------- */
-
-/* transfer and may_be_null can be gotten from arg_info, but sv_to_arg is also
- * called from places which don't have access to a GIArgInfo. */
-static void
-sv_to_arg (SV * sv,
- GIArgument * arg,
- GIArgInfo * arg_info,
- GITypeInfo * type_info,
- GITransfer transfer,
- gboolean may_be_null,
- GPerlI11nInvocationInfo * invocation_info)
-{
- GITypeTag tag = g_type_info_get_tag (type_info);
-
- memset (arg, 0, sizeof (GIArgument));
-
- if (!gperl_sv_is_defined (sv))
- /* Interfaces and void types need to be able to handle undef
- * separately. */
- if (!may_be_null && tag != GI_TYPE_TAG_INTERFACE
- && tag != GI_TYPE_TAG_VOID)
- ccroak ("undefined value for mandatory argument '%s' encountered",
- g_base_info_get_name ((GIBaseInfo *) arg_info));
-
- switch (tag) {
- case GI_TYPE_TAG_VOID:
- arg->v_pointer = handle_void_arg (sv, invocation_info);
- break;
-
- case GI_TYPE_TAG_BOOLEAN:
- arg->v_boolean = SvTRUE (sv);
- break;
-
- case GI_TYPE_TAG_INT8:
- arg->v_int8 = (gint8) SvIV (sv);
- break;
-
- case GI_TYPE_TAG_UINT8:
- arg->v_uint8 = (guint8) SvUV (sv);
- break;
-
- case GI_TYPE_TAG_INT16:
- arg->v_int16 = (gint16) SvIV (sv);
- break;
-
- case GI_TYPE_TAG_UINT16:
- arg->v_uint16 = (guint16) SvUV (sv);
- break;
-
- case GI_TYPE_TAG_INT32:
- arg->v_int32 = (gint32) SvIV (sv);
- break;
-
- case GI_TYPE_TAG_UINT32:
- arg->v_uint32 = (guint32) SvUV (sv);
- break;
-
- case GI_TYPE_TAG_INT64:
- arg->v_int64 = SvGInt64 (sv);
- break;
-
- case GI_TYPE_TAG_UINT64:
- arg->v_uint64 = SvGUInt64 (sv);
- break;
-
- case GI_TYPE_TAG_FLOAT:
- arg->v_float = (gfloat) SvNV (sv);
- break;
-
- case GI_TYPE_TAG_DOUBLE:
- arg->v_double = SvNV (sv);
- break;
-
- case GI_TYPE_TAG_UNICHAR:
- arg->v_uint32 = g_utf8_get_char (SvGChar (sv));
- break;
-
- case GI_TYPE_TAG_GTYPE:
- /* GType == gsize */
- arg->v_size = gperl_type_from_package (SvPV_nolen (sv));
- if (!arg->v_size)
- arg->v_size = g_type_from_name (SvPV_nolen (sv));
- break;
-
- case GI_TYPE_TAG_ARRAY:
- arg->v_pointer = sv_to_array (transfer, type_info, sv, invocation_info);
- break;
-
- case GI_TYPE_TAG_INTERFACE:
- dwarn (" type %p -> interface\n", type_info);
- sv_to_interface (arg_info, type_info, sv, arg,
- invocation_info);
- break;
-
- case GI_TYPE_TAG_GLIST:
- case GI_TYPE_TAG_GSLIST:
- arg->v_pointer = sv_to_glist (transfer, type_info, sv);
- break;
-
- case GI_TYPE_TAG_GHASH:
- arg->v_pointer = sv_to_ghash (transfer, type_info, sv);
- break;
-
- case GI_TYPE_TAG_ERROR:
- ccroak ("FIXME - A GError as an in/inout arg? Should never happen!");
- break;
-
- case GI_TYPE_TAG_UTF8:
- arg->v_string = gperl_sv_is_defined (sv) ? SvGChar (sv) : NULL;
- if (transfer >= GI_TRANSFER_CONTAINER)
- arg->v_string = g_strdup (arg->v_string);
- break;
-
- case GI_TYPE_TAG_FILENAME:
- /* FIXME: Is it correct to use gperl_filename_from_sv here? */
- arg->v_string = gperl_sv_is_defined (sv) ? gperl_filename_from_sv (sv) : NULL;
- if (transfer >= GI_TRANSFER_CONTAINER)
- arg->v_string = g_strdup (arg->v_string);
- break;
-
- default:
- ccroak ("Unhandled info tag %d in sv_to_arg", tag);
- }
-}
-
-static SV *
-arg_to_sv (GIArgument * arg,
- GITypeInfo * info,
- GITransfer transfer,
- GPerlI11nInvocationInfo *iinfo)
-{
- GITypeTag tag = g_type_info_get_tag (info);
- gboolean own = transfer >= GI_TRANSFER_CONTAINER;
-
- dwarn (" arg_to_sv: info %p with type tag %d (%s)\n",
- info, tag, g_type_tag_to_string (tag));
-
- switch (tag) {
- case GI_TYPE_TAG_VOID:
- dwarn (" argument with no type information -> undef\n");
- return &PL_sv_undef;
-
- case GI_TYPE_TAG_BOOLEAN:
- return boolSV (arg->v_boolean);
-
- case GI_TYPE_TAG_INT8:
- return newSViv (arg->v_int8);
-
- case GI_TYPE_TAG_UINT8:
- return newSVuv (arg->v_uint8);
-
- case GI_TYPE_TAG_INT16:
- return newSViv (arg->v_int16);
-
- case GI_TYPE_TAG_UINT16:
- return newSVuv (arg->v_uint16);
-
- case GI_TYPE_TAG_INT32:
- return newSViv (arg->v_int32);
-
- case GI_TYPE_TAG_UINT32:
- return newSVuv (arg->v_uint32);
-
- case GI_TYPE_TAG_INT64:
- return newSVGInt64 (arg->v_int64);
-
- case GI_TYPE_TAG_UINT64:
- return newSVGUInt64 (arg->v_uint64);
-
- case GI_TYPE_TAG_FLOAT:
- return newSVnv (arg->v_float);
-
- case GI_TYPE_TAG_DOUBLE:
- return newSVnv (arg->v_double);
-
- case GI_TYPE_TAG_UNICHAR:
- {
- SV *sv;
- gchar buffer[6];
- gint length = g_unichar_to_utf8 (arg->v_uint32, buffer);
- sv = newSVpv (buffer, length);
- SvUTF8_on (sv);
- return sv;
- }
-
- case GI_TYPE_TAG_GTYPE: {
- /* GType == gsize */
- const char *package = gperl_package_from_type (arg->v_size);
- if (!package)
- package = g_type_name (arg->v_size);
- return newSVpv (package, PL_na);
- }
-
- case GI_TYPE_TAG_ARRAY:
- return array_to_sv (info, arg->v_pointer, transfer, iinfo);
-
- case GI_TYPE_TAG_INTERFACE:
- return interface_to_sv (info, arg, own);
-
- case GI_TYPE_TAG_GLIST:
- case GI_TYPE_TAG_GSLIST:
- return glist_to_sv (info, arg->v_pointer, transfer);
-
- case GI_TYPE_TAG_GHASH:
- return ghash_to_sv (info, arg->v_pointer, transfer);
-
- case GI_TYPE_TAG_ERROR:
- ccroak ("FIXME - GI_TYPE_TAG_ERROR");
- break;
-
- case GI_TYPE_TAG_UTF8:
- {
- SV *sv = newSVGChar (arg->v_string);
- if (own)
- g_free (arg->v_string);
- return sv;
- }
-
- case GI_TYPE_TAG_FILENAME:
- {
- /* FIXME: Is it correct to use gperl_sv_from_filename here? */
- SV *sv = gperl_sv_from_filename (arg->v_string);
- if (own)
- g_free (arg->v_string);
- return sv;
- }
-
- default:
- ccroak ("Unhandled info tag %d in arg_to_sv", tag);
- }
-
- return NULL;
-}
-
-/* ------------------------------------------------------------------------- */
-
-static void
-handle_automatic_arg (guint pos,
- GIArgument * arg,
- GPerlI11nInvocationInfo * invocation_info)
-{
- GSList *l;
-
- /* array length */
- for (l = invocation_info->array_infos; l != NULL; l = l->next) {
- GPerlI11nArrayInfo *ainfo = l->data;
- if (pos == ainfo->length_pos) {
- dwarn (" setting automatic arg %d (array length) to %d\n",
- pos, ainfo->length);
- /* FIXME: Is it OK to always use v_size here? */
- arg->v_size = ainfo->length;
- return;
- }
- }
-
- /* callback destroy notify */
- for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
- GPerlI11nCallbackInfo *cinfo = l->data;
- if (pos == cinfo->notify_pos) {
- dwarn (" setting automatic arg %d (destroy notify for calllback %p)\n",
- pos, cinfo);
- arg->v_pointer = release_callback;
- return;
- }
- }
-
- ccroak ("Could not handle automatic arg %d", pos);
-}
-
-/* ------------------------------------------------------------------------- */
-
-#define CAST_RAW(raw, type) (*((type *) raw))
-
-static void
-raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info)
-{
- GITypeTag tag = g_type_info_get_tag (info);
-
- switch (tag) {
- case GI_TYPE_TAG_VOID:
- /* do nothing */
- break;
-
- case GI_TYPE_TAG_BOOLEAN:
- arg->v_boolean = CAST_RAW (raw, gboolean);
- break;
-
- case GI_TYPE_TAG_INT8:
- arg->v_int8 = CAST_RAW (raw, gint8);
- break;
-
- case GI_TYPE_TAG_UINT8:
- arg->v_uint8 = CAST_RAW (raw, guint8);
- break;
-
- case GI_TYPE_TAG_INT16:
- arg->v_int16 = CAST_RAW (raw, gint16);
- break;
-
- case GI_TYPE_TAG_UINT16:
- arg->v_uint16 = CAST_RAW (raw, guint16);
- break;
-
- case GI_TYPE_TAG_INT32:
- arg->v_int32 = CAST_RAW (raw, gint32);
- break;
-
- case GI_TYPE_TAG_UINT32:
- arg->v_uint32 = CAST_RAW (raw, guint32);
- break;
-
- case GI_TYPE_TAG_INT64:
- arg->v_int64 = CAST_RAW (raw, gint64);
- break;
-
- case GI_TYPE_TAG_UINT64:
- arg->v_uint64 = CAST_RAW (raw, guint64);
- break;
-
- case GI_TYPE_TAG_FLOAT:
- arg->v_float = CAST_RAW (raw, gfloat);
- break;
-
- case GI_TYPE_TAG_DOUBLE:
- arg->v_double = CAST_RAW (raw, gdouble);
- break;
-
- case GI_TYPE_TAG_GTYPE:
- arg->v_size = CAST_RAW (raw, GType);
- break;
-
- case GI_TYPE_TAG_ARRAY:
- case GI_TYPE_TAG_INTERFACE:
- case GI_TYPE_TAG_GLIST:
- case GI_TYPE_TAG_GSLIST:
- case GI_TYPE_TAG_GHASH:
- case GI_TYPE_TAG_ERROR:
- arg->v_pointer = * (gpointer *) raw;
- break;
-
- case GI_TYPE_TAG_UTF8:
- case GI_TYPE_TAG_FILENAME:
- arg->v_string = * (gchar **) raw;
- break;
-
- default:
- ccroak ("Unhandled info tag %d in raw_to_arg", tag);
- }
-}
-
-static void
-arg_to_raw (GIArgument *arg, gpointer raw, GITypeInfo *info)
-{
- GITypeTag tag = g_type_info_get_tag (info);
-
- switch (tag) {
- case GI_TYPE_TAG_VOID:
- /* do nothing */
- break;
-
- case GI_TYPE_TAG_BOOLEAN:
- * (gboolean *) raw = arg->v_boolean;
- break;
-
- case GI_TYPE_TAG_INT8:
- * (gint8 *) raw = arg->v_int8;
- break;
-
- case GI_TYPE_TAG_UINT8:
- * (guint8 *) raw = arg->v_uint8;
- break;
-
- case GI_TYPE_TAG_INT16:
- * (gint16 *) raw = arg->v_int16;
- break;
-
- case GI_TYPE_TAG_UINT16:
- * (guint16 *) raw = arg->v_uint16;
- break;
-
- case GI_TYPE_TAG_INT32:
- * (gint32 *) raw = arg->v_int32;
- break;
-
- case GI_TYPE_TAG_UINT32:
- * (guint32 *) raw = arg->v_uint32;
- break;
-
- case GI_TYPE_TAG_INT64:
- * (gint64 *) raw = arg->v_int64;
- break;
-
- case GI_TYPE_TAG_UINT64:
- * (guint64 *) raw = arg->v_uint64;
- break;
-
- case GI_TYPE_TAG_FLOAT:
- * (gfloat *) raw = arg->v_float;
- break;
-
- case GI_TYPE_TAG_DOUBLE:
- * (gdouble *) raw = arg->v_double;
- break;
-
- case GI_TYPE_TAG_GTYPE:
- * (GType *) raw = arg->v_size;
- break;
-
- case GI_TYPE_TAG_ARRAY:
- case GI_TYPE_TAG_INTERFACE:
- case GI_TYPE_TAG_GLIST:
- case GI_TYPE_TAG_GSLIST:
- case GI_TYPE_TAG_GHASH:
- case GI_TYPE_TAG_ERROR:
- * (gpointer *) raw = arg->v_pointer;
- break;
-
- case GI_TYPE_TAG_UTF8:
- case GI_TYPE_TAG_FILENAME:
- * (gchar **) raw = arg->v_string;
- break;
-
- default:
- ccroak ("Unhandled info tag %d in arg_to_raw", tag);
- }
-}
-
-/* ------------------------------------------------------------------------- */
-
-/* FIXME: this is not safe if we want to support unloading G:O:I. */
-#define VFUNC_TARGET_PACKAGE_QUARK g_quark_from_static_string ("__gperl_vfunc_target_package")
-#define VFUNC_PERL_TYPE_QUARK g_quark_from_static_string ("__gperl_vfunc_perl_type")
-
-static GPerlI11nCallbackInfo *
-create_callback_closure (GITypeInfo *cb_type, SV *code)
-{
- GPerlI11nCallbackInfo *info;
-
- info = g_new0 (GPerlI11nCallbackInfo, 1);
- info->interface =
- (GICallableInfo *) g_type_info_get_interface (cb_type);
- info->cif = g_new0 (ffi_cif, 1);
- info->closure =
- g_callable_info_prepare_closure (info->interface, info->cif,
- invoke_callback, info);
- /* FIXME: This should most likely use SvREFCNT_inc instead of
- * newSVsv. */
- info->code = newSVsv (code);
- info->sub_name = NULL;
- info->package_name = NULL;
-
-#ifdef PERL_IMPLICIT_CONTEXT
- info->priv = aTHX;
-#endif
-
- return info;
-}
-
-static void
-attach_callback_data (GPerlI11nCallbackInfo *info, SV *data)
-{
- info->data = newSVsv (data);
-}
-
-/* assumes ownership of sub_name and package_name */
-static GPerlI11nCallbackInfo *
-create_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name, gchar *package_name)
-{
- GPerlI11nCallbackInfo *info;
-
- info = g_new0 (GPerlI11nCallbackInfo, 1);
- info->interface =
- (GICallableInfo *) g_type_info_get_interface (cb_type);
- info->cif = g_new0 (ffi_cif, 1);
- info->closure =
- g_callable_info_prepare_closure (info->interface, info->cif,
- invoke_callback, info);
- info->sub_name = sub_name;
- info->package_name = package_name;
- info->code = NULL;
- info->data = NULL;
-
-#ifdef PERL_IMPLICIT_CONTEXT
- info->priv = aTHX;
+# define dwarn(...) warn(__VA_ARGS__)
+#else
+# define dwarn(...)
#endif
- return info;
-}
-
-static void
-invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
-{
- GPerlI11nCallbackInfo *info;
- GICallableInfo *cb_interface;
- int n_args, i;
- int in_inout;
- GITypeInfo *return_type;
- gboolean have_return_type;
- int n_return_values, n_returned;
- I32 context;
- dGPERL_CALLBACK_MARSHAL_SP;
-
- PERL_UNUSED_VAR (cif);
-
- /* unwrap callback info struct from userdata */
- info = (GPerlI11nCallbackInfo *) userdata;
- cb_interface = (GICallableInfo *) info->interface;
-
- /* set perl context */
- GPERL_CALLBACK_MARSHAL_INIT (info);
-
- ENTER;
- SAVETMPS;
-
- PUSHMARK (SP);
-
- /* find arguments; use type information from interface to find in and
- * in-out args and their types, count in-out and out args, and find
- * suitable converters; push in and in-out arguments onto the perl
- * stack */
- in_inout = 0;
- n_args = g_callable_info_get_n_args (cb_interface);
- for (i = 0; i < n_args; i++) {
- GIArgInfo *arg_info = g_callable_info_get_arg (cb_interface, i);
- GITypeInfo *arg_type = g_arg_info_get_type (arg_info);
- GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
- GIDirection direction = g_arg_info_get_direction (arg_info);
-
- /* the closure argument, which we handle separately, is marked
- * by having get_closure == i */
- if (g_arg_info_get_closure (arg_info) == i) {
- g_base_info_unref ((GIBaseInfo *) arg_info);
- g_base_info_unref ((GIBaseInfo *) arg_type);
- continue;
- }
-
- dwarn ("arg info: %p\n"
- " direction: %d\n"
- " is return value: %d\n"
- " is optional: %d\n"
- " may be null: %d\n"
- " transfer: %d\n",
- arg_info,
- g_arg_info_get_direction (arg_info),
- g_arg_info_is_return_value (arg_info),
- g_arg_info_is_optional (arg_info),
- g_arg_info_may_be_null (arg_info),
- g_arg_info_get_ownership_transfer (arg_info));
-
- dwarn ("arg type: %p\n"
- " is pointer: %d\n"
- " tag: %d\n",
- arg_type,
- g_type_info_is_pointer (arg_type),
- g_type_info_get_tag (arg_type));
-
- if (direction == GI_DIRECTION_IN ||
- direction == GI_DIRECTION_INOUT)
- {
- GIArgument arg;
- raw_to_arg (args[i], &arg, arg_type);
- XPUSHs (sv_2mortal (arg_to_sv (&arg, arg_type, transfer, NULL)));
- }
-
- if (direction == GI_DIRECTION_INOUT ||
- direction == GI_DIRECTION_OUT)
- {
- in_inout++;
- }
-
- g_base_info_unref ((GIBaseInfo *) arg_info);
- g_base_info_unref ((GIBaseInfo *) arg_type);
- }
-
- /* push user data onto the Perl stack */
- if (info->data)
- XPUSHs (sv_2mortal (SvREFCNT_inc (info->data)));
-
- PUTBACK;
-
- /* put the target package name into the invocant so that the vfunc
- * fallback code knows whose parent to chain up to. */
- if (info->package_name) {
- GObject *object = * (GObject **) args[0];
- g_assert (G_IS_OBJECT (object));
- g_object_set_qdata (object, VFUNC_TARGET_PACKAGE_QUARK, info->package_name);
- }
-
- /* determine suitable Perl call context; return_type is freed further
- * below */
- return_type = g_callable_info_get_return_type (cb_interface);
- have_return_type =
- GI_TYPE_TAG_VOID != g_type_info_get_tag (return_type);
-
- context = G_VOID | G_DISCARD;
- if (have_return_type) {
- context = in_inout > 0
- ? G_ARRAY
- : G_SCALAR;
- } else {
- if (in_inout == 1) {
- context = G_SCALAR;
- } else if (in_inout > 1) {
- context = G_ARRAY;
- }
- }
-
- /* do the call, demand #in-out+#out+#return-value return values */
- n_return_values = have_return_type
- ? in_inout + 1
- : in_inout;
- n_returned = info->sub_name
- ? call_method (info->sub_name, context)
- : call_sv (info->code, context);
- if (n_return_values != 0 && n_returned != n_return_values) {
- ccroak ("callback returned %d values "
- "but is supposed to return %d values",
- n_returned, n_return_values);
- }
-
- if (info->package_name) {
- GObject *object = * (GObject **) args[0];
- g_assert (G_IS_OBJECT (object));
- g_object_set_qdata (object, VFUNC_TARGET_PACKAGE_QUARK, NULL);
- }
-
- SPAGAIN;
-
- /* convert in-out and out values and stuff them back into args */
- if (in_inout > 0) {
- SV **returned_values;
- int out_index;
-
- returned_values = g_new0 (SV *, in_inout);
-
- /* pop scalars off the stack and put them into the array;
- * reverse the order since POPs pops items off of the end of
- * the stack. */
- for (i = 0; i < in_inout; i++) {
- /* FIXME: Does this leak the sv? Should we check the
- * transfer setting? */
- returned_values[in_inout - i - 1] = newSVsv (POPs);
- }
-
- out_index = 0;
- for (i = 0; i < n_args; i++) {
- GIArgInfo *arg_info = g_callable_info_get_arg (cb_interface, i);
- GITypeInfo *arg_type = g_arg_info_get_type (arg_info);
- GIDirection direction = g_arg_info_get_direction (arg_info);
-
- if (direction == GI_DIRECTION_INOUT ||
- direction == GI_DIRECTION_OUT)
- {
- GIArgument tmp_arg;
- GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
- gboolean may_be_null = g_arg_info_may_be_null (arg_info);
- sv_to_arg (returned_values[out_index], &tmp_arg,
- arg_info, arg_type,
- transfer, may_be_null, NULL);
- arg_to_raw (&tmp_arg, args[i], arg_type);
- out_index++;
- }
- }
-
- g_free (returned_values);
- }
-
- /* store return value in resp, if any */
- if (have_return_type) {
- GIArgument arg;
- GITypeInfo *type_info;
- GITransfer transfer;
- gboolean may_be_null;
-
- type_info = g_callable_info_get_return_type (cb_interface);
- transfer = g_callable_info_get_caller_owns (cb_interface);
- may_be_null = g_callable_info_may_return_null (cb_interface);
-
- dwarn ("ret type: %p\n"
- " is pointer: %d\n"
- " tag: %d\n",
- type_info,
- g_type_info_is_pointer (type_info),
- g_type_info_get_tag (type_info));
-
- /* FIXME: Does this leak the sv? */
- sv_to_arg (newSVsv (POPs), &arg, NULL, type_info,
- transfer, may_be_null, NULL);
- arg_to_raw (&arg, resp, type_info);
-
- g_base_info_unref ((GIBaseInfo *) type_info);
- }
-
- PUTBACK;
-
- g_base_info_unref ((GIBaseInfo *) return_type);
-
- FREETMPS;
- LEAVE;
-
- /* FIXME: We can't just free everything here because ffi will use parts
- * of this after we've returned.
- *
- * if (info->free_after_use) {
- * release_callback (info);
- * }
- *
- * Gjs uses a global list of callback infos instead and periodically
- * frees unused ones.
- */
-}
-
-static void
-release_callback (gpointer data)
-{
- GPerlI11nCallbackInfo *info = data;
- dwarn ("releasing callback info %p\n", info);
-
- if (info->cif)
- g_free (info->cif);
-
- if (info->closure)
- g_callable_info_free_closure (info->interface, info->closure);
-
- if (info->interface)
- g_base_info_unref ((GIBaseInfo*) info->interface);
-
- if (info->code)
- SvREFCNT_dec (info->code);
- if (info->data)
- SvREFCNT_dec (info->data);
- if (info->sub_name)
- g_free (info->sub_name);
- if (info->package_name)
- g_free (info->package_name);
-
- g_free (info);
-}
-
-/* ------------------------------------------------------------------------- */
-
-static void
-store_methods (HV *namespaced_functions, GIBaseInfo *info, GIInfoType info_type)
-{
- const gchar *namespace;
- AV *av;
- gint i;
-
- namespace = g_base_info_get_name (info);
- av = newAV ();
-
- switch (info_type) {
- case GI_INFO_TYPE_OBJECT:
- {
- gint n_methods = g_object_info_get_n_methods (
- (GIObjectInfo *) info);
- for (i = 0; i < n_methods; i++) {
- GIFunctionInfo *function_info =
- g_object_info_get_method (
- (GIObjectInfo *) info, i);
- const gchar *function_name =
- g_base_info_get_name (
- (GIBaseInfo *) function_info);
- av_push (av, newSVpv (function_name, PL_na));
- g_base_info_unref ((GIBaseInfo *) function_info);
- }
- break;
- }
-
- case GI_INFO_TYPE_INTERFACE:
- {
- gint n_methods = g_interface_info_get_n_methods (
- (GIInterfaceInfo *) info);
- for (i = 0; i < n_methods; i++) {
- GIFunctionInfo *function_info =
- g_interface_info_get_method (
- (GIInterfaceInfo *) info, i);
- const gchar *function_name =
- g_base_info_get_name (
- (GIBaseInfo *) function_info);
- av_push (av, newSVpv (function_name, PL_na));
- g_base_info_unref ((GIBaseInfo *) function_info);
- }
- break;
- }
-
- case GI_INFO_TYPE_BOXED:
- case GI_INFO_TYPE_STRUCT:
- {
- gint n_methods = g_struct_info_get_n_methods (
- (GIStructInfo *) info);
- for (i = 0; i < n_methods; i++) {
- GIFunctionInfo *function_info =
- g_struct_info_get_method (
- (GIStructInfo *) info, i);
- const gchar *function_name =
- g_base_info_get_name (
- (GIBaseInfo *) function_info);
- av_push (av, newSVpv (function_name, PL_na));
- g_base_info_unref ((GIBaseInfo *) function_info);
- }
- break;
- }
-
- case GI_INFO_TYPE_UNION:
- {
- gint n_methods = g_union_info_get_n_methods ((GIUnionInfo *) info);
- for (i = 0; i < n_methods; i++) {
- GIFunctionInfo *function_info;
- const gchar *function_name;
-
- function_info = g_union_info_get_method ((GIUnionInfo *) info, i);
- function_name = g_base_info_get_name ((GIBaseInfo *) function_info);
-
- av_push (av, newSVpv (function_name, PL_na));
- g_base_info_unref ((GIBaseInfo *) function_info);
- }
- break;
- }
-
- default:
- ccroak ("store_methods: unsupported info type %d", info_type);
- }
-
- gperl_hv_take_sv (namespaced_functions, namespace, strlen (namespace),
- newRV_noinc ((SV *) av));
-}
-
-/* ------------------------------------------------------------------------- */
-
-static void
-store_vfuncs (HV *objects_with_vfuncs, GIObjectInfo *info)
-{
- const gchar *object_name;
- AV *vfuncs_av;
- gint n_vfuncs, i;
-
- n_vfuncs = g_object_info_get_n_vfuncs (info);
- if (n_vfuncs <= 0)
- return;
-
- object_name = g_base_info_get_name (info);
- vfuncs_av = newAV ();
-
- for (i = 0; i < n_vfuncs; i++) {
- GIVFuncInfo *vfunc_info =
- g_object_info_get_vfunc (info, i);
- const gchar *vfunc_name =
- g_base_info_get_name (vfunc_info);
- gchar *vfunc_perl_name = g_ascii_strup (vfunc_name, -1);
- AV *vfunc_av = newAV ();
- av_push (vfunc_av, newSVpv (vfunc_name, PL_na));
- av_push (vfunc_av, newSVpv (vfunc_perl_name, PL_na));
- av_push (vfuncs_av, newRV_noinc ((SV *) vfunc_av));
- g_free (vfunc_perl_name);
- g_base_info_unref (vfunc_info);
- }
-
- gperl_hv_take_sv (objects_with_vfuncs, object_name, strlen (object_name),
- newRV_noinc ((SV *) vfuncs_av));
-}
-
/* ------------------------------------------------------------------------- */
-static void
-store_fields (HV *fields, GIBaseInfo *info, GIInfoType info_type)
-{
- const gchar *namespace;
- AV *av;
- gint i;
-
- namespace = g_base_info_get_name (info);
- av = newAV ();
-
- switch (info_type) {
- case GI_INFO_TYPE_BOXED:
- case GI_INFO_TYPE_STRUCT:
- {
- gint n_fields = g_struct_info_get_n_fields (
- (GIStructInfo *) info);
- for (i = 0; i < n_fields; i++) {
- GIFieldInfo *field_info;
- const gchar *field_name;
- field_info = g_struct_info_get_field ((GIStructInfo *) info, i);
- field_name = g_base_info_get_name ((GIBaseInfo *) field_info);
- av_push (av, newSVpv (field_name, PL_na));
- g_base_info_unref ((GIBaseInfo *) field_info);
- }
- break;
- }
-
- case GI_INFO_TYPE_UNION:
- {
- gint n_fields = g_union_info_get_n_fields ((GIUnionInfo *) info);
- for (i = 0; i < n_fields; i++) {
- GIFieldInfo *field_info;
- const gchar *field_name;
- field_info = g_union_info_get_field ((GIUnionInfo *) info, i);
- field_name = g_base_info_get_name ((GIBaseInfo *) field_info);
- av_push (av, newSVpv (field_name, PL_na));
- g_base_info_unref ((GIBaseInfo *) field_info);
- }
- break;
- }
-
- default:
- ccroak ("store_fields: unsupported info type %d", info_type);
- }
-
- gperl_hv_take_sv (fields, namespace, strlen (namespace),
- newRV_noinc ((SV *) av));
-}
-
-/* ------------------------------------------------------------------------- */
-
-static void
-prepare_invocation_info (GPerlI11nInvocationInfo *iinfo,
- GICallableInfo *info,
- IV items,
- UV internal_stack_offset)
-{
- gboolean is_vfunc;
- guint i;
-
- is_vfunc = GI_IS_VFUNC_INFO (info);
-
- iinfo->stack_offset = internal_stack_offset;
-
- iinfo->is_constructor = is_vfunc
- ? FALSE
- : g_function_info_get_flags (info) & GI_FUNCTION_IS_CONSTRUCTOR;
- if (iinfo->is_constructor) {
- iinfo->stack_offset++;
- }
-
- iinfo->n_given_args = items - iinfo->stack_offset;
-
- iinfo->n_invoke_args = iinfo->n_args =
- g_callable_info_get_n_args ((GICallableInfo *) info);
-
- /* FIXME: can a vfunc not throw? */
- iinfo->throws = is_vfunc
- ? FALSE
- : g_function_info_get_flags (info) & GI_FUNCTION_THROWS;
- if (iinfo->throws) {
- iinfo->n_invoke_args++;
- }
-
- if (is_vfunc) {
- iinfo->is_method = TRUE;
- } else {
- iinfo->is_method =
- (g_function_info_get_flags (info) & GI_FUNCTION_IS_METHOD)
- && !iinfo->is_constructor;
- }
- if (iinfo->is_method) {
- iinfo->n_invoke_args++;
- }
-
- dwarn ("invoke: %s\n"
- " n_args: %d, n_invoke_args: %d, n_given_args: %d\n"
- " is_constructor: %d, is_method: %d\n",
- is_vfunc ? g_base_info_get_name (info) : g_function_info_get_symbol (info),
- iinfo->n_args, iinfo->n_invoke_args, iinfo->n_given_args,
- iinfo->is_constructor, iinfo->is_method);
-
- iinfo->return_type_info =
- g_callable_info_get_return_type ((GICallableInfo *) info);
- iinfo->has_return_value =
- GI_TYPE_TAG_VOID != g_type_info_get_tag (iinfo->return_type_info);
- iinfo->return_type_ffi = g_type_info_get_ffi_type (iinfo->return_type_info);
- iinfo->return_type_transfer = g_callable_info_get_caller_owns ((GICallableInfo *) info);
-
- /* allocate enough space for all args in both the out and in lists.
- * we'll only use as much as we need. since function argument lists
- * are typically small, this shouldn't be a big problem. */
- if (iinfo->n_invoke_args) {
- gint n = iinfo->n_invoke_args;
- iinfo->in_args = gperl_alloc_temp (sizeof (GIArgument) * n);
- iinfo->out_args = gperl_alloc_temp (sizeof (GIArgument) * n);
- iinfo->out_arg_infos = gperl_alloc_temp (sizeof (GITypeInfo*) * n);
- iinfo->arg_types = gperl_alloc_temp (sizeof (ffi_type *) * n);
- iinfo->args = gperl_alloc_temp (sizeof (gpointer) * n);
- iinfo->aux_args = gperl_alloc_temp (sizeof (GIArgument) * n);
- iinfo->is_automatic_arg = gperl_alloc_temp (sizeof (gboolean) * n);
- }
-
- iinfo->method_offset = iinfo->is_method ? 1 : 0;
- iinfo->dynamic_stack_offset = 0;
-
- /* Make a first pass to mark args that are filled in automatically, and
- * thus have no counterpart on the Perl side. */
- for (i = 0 ; i < iinfo->n_args ; i++) {
- GIArgInfo * arg_info =
- g_callable_info_get_arg ((GICallableInfo *) info, i);
- GITypeInfo * arg_type = g_arg_info_get_type (arg_info);
- GITypeTag arg_tag = g_type_info_get_tag (arg_type);
-
- if (arg_tag == GI_TYPE_TAG_ARRAY) {
- gint pos = g_type_info_get_array_length (arg_type);
- if (pos >= 0) {
- dwarn (" pos %d is automatic (array length)\n", pos);
- iinfo->is_automatic_arg[pos] = TRUE;
- }
- }
-
- else if (arg_tag == GI_TYPE_TAG_INTERFACE) {
- GIBaseInfo * interface = g_type_info_get_interface (arg_type);
- GIInfoType info_type = g_base_info_get_type (interface);
- if (info_type == GI_INFO_TYPE_CALLBACK) {
- gint pos = g_arg_info_get_destroy (arg_info);
- if (pos >= 0) {
- dwarn (" pos %d is automatic (callback destroy notify)\n", pos);
- iinfo->is_automatic_arg[pos] = TRUE;
- }
- }
- g_base_info_unref ((GIBaseInfo *) interface);
- }
-
- g_base_info_unref ((GIBaseInfo *) arg_type);
- g_base_info_unref ((GIBaseInfo *) arg_info);
- }
-
- /* If the return value is an array which comes with an outbound length
- * arg, then mark that length arg as automatic, too. */
- if (g_type_info_get_tag (iinfo->return_type_info) == GI_TYPE_TAG_ARRAY) {
- gint pos = g_type_info_get_array_length (iinfo->return_type_info);
- if (pos >= 0) {
- GIArgInfo * arg_info =
- g_callable_info_get_arg ((GICallableInfo *) info, pos);
- if (GI_DIRECTION_OUT == g_arg_info_get_direction (arg_info)) {
- dwarn (" pos %d is automatic (array length)\n", pos);
- iinfo->is_automatic_arg[pos] = TRUE;
- }
- }
- }
-
- /* We need to undo the special handling that GInitiallyUnowned
- * descendants receive from gobject-introspection: values of this type
- * are always marked transfer=none, even for constructors. */
- if (iinfo->is_constructor &&
- g_type_info_get_tag (iinfo->return_type_info) == GI_TYPE_TAG_INTERFACE)
- {
- GIBaseInfo * interface = g_type_info_get_interface (iinfo->return_type_info);
- if (GI_IS_REGISTERED_TYPE_INFO (interface) &&
- g_type_is_a (g_registered_type_info_get_g_type (interface),
- G_TYPE_INITIALLY_UNOWNED))
- {
- iinfo->return_type_transfer = GI_TRANSFER_EVERYTHING;
- }
- g_base_info_unref ((GIBaseInfo *) interface);
- }
-}
-
-static void
-clear_invocation_info (GPerlI11nInvocationInfo *iinfo)
-{
- g_slist_free (iinfo->free_after_call);
-
- /* The actual callback infos might be needed later, so we cannot free
- * them here. */
- g_slist_free (iinfo->callback_infos);
-
- g_slist_foreach (iinfo->array_infos, (GFunc) g_free, NULL);
- g_slist_free (iinfo->array_infos);
-
- g_base_info_unref ((GIBaseInfo *) iinfo->return_type_info);
-}
-
-/* ------------------------------------------------------------------------- */
-
-static gpointer
-allocate_out_mem (GITypeInfo *arg_type)
-{
- GIBaseInfo *interface_info;
- GIInfoType type;
-
- interface_info = g_type_info_get_interface (arg_type);
- g_assert (interface_info);
- type = g_base_info_get_type (interface_info);
- g_base_info_unref (interface_info);
-
- switch (type) {
- case GI_INFO_TYPE_STRUCT:
- {
- /* No plain g_struct_info_get_size (interface_info) here so
- * that we get the GValue override. */
- gsize size = size_of_interface (arg_type);
- return g_malloc0 (size);
- }
- default:
- g_assert_not_reached ();
- return NULL;
- }
-}
-
-/* ------------------------------------------------------------------------- */
-
-/* caller owns returned info */
-static GIFieldInfo *
-find_field (GIStructInfo *struct_info, const gchar *name)
-{
- gint n, i;
- n = g_struct_info_get_n_fields (struct_info);
- for (i = 0; i < n; i++) {
- GIFieldInfo *field_info =
- g_struct_info_get_field (struct_info, i);
- if (strEQ (g_base_info_get_name (field_info), name)) {
- return field_info;
- }
- g_base_info_unref (field_info);
- }
- return NULL;
-}
-
-/* ------------------------------------------------------------------------- */
-
-static void
-generic_interface_init (gpointer iface, gpointer data)
-{
- GIInterfaceInfo *info = data;
- GIStructInfo *struct_info;
- gint n, i;
- struct_info = g_interface_info_get_iface_struct (info);
- n = g_interface_info_get_n_vfuncs (info);
- for (i = 0; i < n; i++) {
- GIVFuncInfo *vfunc_info;
- const gchar *vfunc_name;
- GIFieldInfo *field_info;
- gint field_offset;
- GITypeInfo *field_type_info;
- gchar *perl_method_name;
- GPerlI11nCallbackInfo *callback_info;
-
- vfunc_info = g_interface_info_get_vfunc (info, i);
- vfunc_name = g_base_info_get_name (vfunc_info);
-
- /* FIXME: g_vfunc_info_get_offset does not seem to work here. */
- field_info = find_field (struct_info, vfunc_name);
- g_assert (field_info);
- field_offset = g_field_info_get_offset (field_info);
- field_type_info = g_field_info_get_type (field_info);
-
- perl_method_name = g_ascii_strup (vfunc_name, -1);
- callback_info = create_callback_closure_for_named_sub (
- field_type_info, perl_method_name, NULL);
- dwarn ("installing vfunc %s as %s at offset %d (vs. %d) inside %p\n",
- vfunc_name, perl_method_name,
- field_offset, g_vfunc_info_get_offset (vfunc_info),
- iface);
- G_STRUCT_MEMBER (gpointer, iface, field_offset) = callback_info->closure;
-
- g_base_info_unref (field_type_info);
- g_base_info_unref (field_info);
- g_base_info_unref (vfunc_info);
- }
- g_base_info_unref (struct_info);
-}
-
-static void
-generic_interface_finalize (gpointer iface, gpointer data)
-{
- GIInterfaceInfo *info = data;
- PERL_UNUSED_VAR (iface);
- dwarn ("releasing interface info\n");
- g_base_info_unref ((GIBaseInfo *) info);
-}
-
-/* ------------------------------------------------------------------------- */
-
-static void
-generic_class_init (GIObjectInfo *info, const gchar *target_package, gpointer class)
-{
- GIStructInfo *struct_info;
- gint n, i;
- struct_info = g_object_info_get_class_struct (info);
- n = g_object_info_get_n_vfuncs (info);
- for (i = 0; i < n; i++) {
- GIVFuncInfo *vfunc_info;
- const gchar *vfunc_name;
- GIFieldInfo *field_info;
- gint field_offset;
- GITypeInfo *field_type_info;
- gchar *perl_method_name;
- GPerlI11nCallbackInfo *callback_info;
-
- vfunc_info = g_object_info_get_vfunc (info, i);
- vfunc_name = g_base_info_get_name (vfunc_info);
-
- /* FIXME: g_vfunc_info_get_offset does not seem to work here. */
- field_info = find_field (struct_info, vfunc_name);
- g_assert (field_info);
- field_offset = g_field_info_get_offset (field_info);
- field_type_info = g_field_info_get_type (field_info);
-
- perl_method_name = g_ascii_strup (vfunc_name, -1);
- callback_info = create_callback_closure_for_named_sub (
- field_type_info, perl_method_name, g_strdup (target_package));
- dwarn ("installing vfunc %s as %s at offset %d (vs. %d) inside %p\n",
- vfunc_name, perl_method_name,
- field_offset, g_vfunc_info_get_offset (vfunc_info),
- class);
- G_STRUCT_MEMBER (gpointer, class, field_offset) = callback_info->closure;
-
- g_base_info_unref (field_type_info);
- g_base_info_unref (field_info);
- g_base_info_unref (vfunc_info);
- }
- g_base_info_unref (struct_info);
-}
-
-/* ------------------------------------------------------------------------- */
-
-void
-invoke_callable (GICallableInfo *info,
- gpointer func_pointer,
- SV **sp, I32 ax, SV **mark, I32 items, /* these correspond to dXSARGS */
- UV internal_stack_offset)
-{
- ffi_cif cif;
- gpointer instance = NULL;
- guint i;
- GPerlI11nInvocationInfo iinfo = {0,};
- guint n_return_values;
- GIArgument return_value;
- GError * local_error = NULL;
- gpointer local_error_address = &local_error;
-
- prepare_invocation_info (&iinfo, info, items, internal_stack_offset);
-
- if (iinfo.is_method) {
- instance = instance_sv_to_pointer (info, ST (0 + iinfo.stack_offset));
- iinfo.arg_types[0] = &ffi_type_pointer;
- iinfo.args[0] = &instance;
- }
-
- for (i = 0 ; i < iinfo.n_args ; i++) {
- GIArgInfo * arg_info;
- GITypeInfo * arg_type;
- GITransfer transfer;
- gboolean may_be_null;
- gint perl_stack_pos, ffi_stack_pos;
- SV *current_sv;
-
- arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i);
- /* In case of out and in-out args, arg_type is unref'ed after
- * the function has been invoked */
- arg_type = g_arg_info_get_type (arg_info);
- transfer = g_arg_info_get_ownership_transfer (arg_info);
- may_be_null = g_arg_info_may_be_null (arg_info);
- perl_stack_pos = i
- + iinfo.method_offset
- + iinfo.stack_offset
- + iinfo.dynamic_stack_offset;
- ffi_stack_pos = i
- + iinfo.method_offset;
-
- /* FIXME: Is this right? I'm confused about the relation of
- * the numbers in g_callable_info_get_arg and
- * g_arg_info_get_closure and g_arg_info_get_destroy. We used
- * to add method_offset, but that stopped being correct at some
- * point. */
- iinfo.current_pos = i; /* + method_offset; */
-
- dwarn (" arg %d, tag: %d (%s), is_pointer: %d, is_automatic: %d\n",
- i,
- g_type_info_get_tag (arg_type),
- g_type_tag_to_string (g_type_info_get_tag (arg_type)),
- g_type_info_is_pointer (arg_type),
- iinfo.is_automatic_arg[i]);
-
- /* FIXME: Generate a proper usage message if the user did not
- * supply enough arguments. */
- current_sv = perl_stack_pos < items ? ST (perl_stack_pos) : &PL_sv_undef;
-
- switch (g_arg_info_get_direction (arg_info)) {
- case GI_DIRECTION_IN:
- if (iinfo.is_automatic_arg[i]) {
- iinfo.dynamic_stack_offset--;
-#if GI_CHECK_VERSION (1, 29, 0)
- } else if (g_arg_info_is_skip (arg_info)) {
- iinfo.dynamic_stack_offset--;
-#endif
- } else {
- sv_to_arg (current_sv,
- &iinfo.in_args[i], arg_info, arg_type,
- transfer, may_be_null, &iinfo);
- }
- iinfo.arg_types[ffi_stack_pos] =
- g_type_info_get_ffi_type (arg_type);
- iinfo.args[ffi_stack_pos] = &iinfo.in_args[i];
- g_base_info_unref ((GIBaseInfo *) arg_type);
- break;
-
- case GI_DIRECTION_OUT:
- if (g_arg_info_is_caller_allocates (arg_info)) {
- iinfo.aux_args[i].v_pointer =
- allocate_out_mem (arg_type);
- iinfo.out_args[i].v_pointer = &iinfo.aux_args[i];
- iinfo.args[ffi_stack_pos] = &iinfo.aux_args[i];
- } else {
- iinfo.out_args[i].v_pointer = &iinfo.aux_args[i];
- iinfo.args[ffi_stack_pos] = &iinfo.out_args[i];
- }
- iinfo.out_arg_infos[i] = arg_type;
- iinfo.arg_types[ffi_stack_pos] = &ffi_type_pointer;
- /* Adjust the dynamic stack offset so that this out
- * argument doesn't inadvertedly eat up an in argument. */
- iinfo.dynamic_stack_offset--;
- break;
-
- case GI_DIRECTION_INOUT:
- iinfo.in_args[i].v_pointer =
- iinfo.out_args[i].v_pointer =
- &iinfo.aux_args[i];
- if (iinfo.is_automatic_arg[i]) {
- iinfo.dynamic_stack_offset--;
-#if GI_CHECK_VERSION (1, 29, 0)
- } else if (g_arg_info_is_skip (arg_info)) {
- iinfo.dynamic_stack_offset--;
-#endif
- } else {
- /* We pass iinfo.in_args[i].v_pointer here,
- * not &iinfo.in_args[i], so that the value
- * pointed to is filled from the SV. */
- sv_to_arg (current_sv,
- iinfo.in_args[i].v_pointer, arg_info, arg_type,
- transfer, may_be_null, &iinfo);
- }
- iinfo.out_arg_infos[i] = arg_type;
- iinfo.arg_types[ffi_stack_pos] = &ffi_type_pointer;
- iinfo.args[ffi_stack_pos] = &iinfo.in_args[i];
- break;
- }
-
- g_base_info_unref ((GIBaseInfo *) arg_info);
- }
-
- /* do another pass to handle automatic args */
- for (i = 0 ; i < iinfo.n_args ; i++) {
- GIArgInfo * arg_info;
- if (!iinfo.is_automatic_arg[i])
- continue;
- arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i);
- switch (g_arg_info_get_direction (arg_info)) {
- case GI_DIRECTION_IN:
- handle_automatic_arg (i, &iinfo.in_args[i], &iinfo);
- break;
- case GI_DIRECTION_INOUT:
- handle_automatic_arg (i, &iinfo.aux_args[i], &iinfo);
- break;
- case GI_DIRECTION_OUT:
- /* handled later */
- break;
- }
- g_base_info_unref ((GIBaseInfo *) arg_info);
- }
-
- if (iinfo.throws) {
- iinfo.args[iinfo.n_invoke_args - 1] = &local_error_address;
- iinfo.arg_types[iinfo.n_invoke_args - 1] = &ffi_type_pointer;
- }
-
- /* prepare and call the function */
- if (FFI_OK != ffi_prep_cif (&cif, FFI_DEFAULT_ABI, iinfo.n_invoke_args,
- iinfo.return_type_ffi, iinfo.arg_types))
- {
- clear_invocation_info (&iinfo);
- ccroak ("Could not prepare a call interface");
- }
-
- ffi_call (&cif, func_pointer, &return_value, iinfo.args);
-
- /* free call-scoped callback infos */
- g_slist_foreach (iinfo.free_after_call,
- (GFunc) release_callback, NULL);
-
- if (local_error) {
- gperl_croak_gerror (NULL, local_error);
- }
-
- /*
- * handle return values
- */
- n_return_values = 0;
-
- /* place return value and output args on the stack */
- if (iinfo.has_return_value
-#if GI_CHECK_VERSION (1, 29, 0)
- && !g_callable_info_skip_return ((GICallableInfo *) info)
-#endif
- )
- {
- SV *value = arg_to_sv (&return_value,
- iinfo.return_type_info,
- iinfo.return_type_transfer,
- &iinfo);
- if (value) {
- XPUSHs (sv_2mortal (value));
- n_return_values++;
- }
- }
-
- /* out args */
- for (i = 0 ; i < iinfo.n_args ; i++) {
- GIArgInfo * arg_info;
- if (iinfo.is_automatic_arg[i])
- continue;
- arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i);
-#if GI_CHECK_VERSION (1, 29, 0)
- if (g_arg_info_is_skip (arg_info)) {
- g_base_info_unref ((GIBaseInfo *) arg_info);
- continue;
- }
-#endif
- switch (g_arg_info_get_direction (arg_info)) {
- case GI_DIRECTION_OUT:
- case GI_DIRECTION_INOUT:
- {
- GITransfer transfer;
- SV *sv;
- /* If we allocated the memory ourselves, we always own it. */
- transfer = g_arg_info_is_caller_allocates (arg_info)
- ? GI_TRANSFER_CONTAINER
- : g_arg_info_get_ownership_transfer (arg_info);
- sv = arg_to_sv (iinfo.out_args[i].v_pointer,
- iinfo.out_arg_infos[i],
- transfer,
- &iinfo);
- if (sv) {
- XPUSHs (sv_2mortal (sv));
- n_return_values++;
- }
- g_base_info_unref ((GIBaseInfo*) iinfo.out_arg_infos[i]);
- break;
- }
-
- default:
- break;
- }
- g_base_info_unref ((GIBaseInfo *) arg_info);
- }
-
- clear_invocation_info (&iinfo);
-
- dwarn (" number of return values: %d\n", n_return_values);
-
- PUTBACK;
-}
+#include "gperl-i11n-callback.c"
+#include "gperl-i11n-croak.c"
+#include "gperl-i11n-field.c"
+#include "gperl-i11n-gvalue.c"
+#include "gperl-i11n-info.c"
+#include "gperl-i11n-invoke-c.c"
+#include "gperl-i11n-invoke-info.c"
+#include "gperl-i11n-invoke-perl.c"
+#include "gperl-i11n-marshal-arg.c"
+#include "gperl-i11n-marshal-array.c"
+#include "gperl-i11n-marshal-callback.c"
+#include "gperl-i11n-marshal-hash.c"
+#include "gperl-i11n-marshal-interface.c"
+#include "gperl-i11n-marshal-list.c"
+#include "gperl-i11n-marshal-raw.c"
+#include "gperl-i11n-marshal-struct.c"
+#include "gperl-i11n-method.c"
+#include "gperl-i11n-size.c"
+#include "gperl-i11n-vfunc-interface.c"
+#include "gperl-i11n-vfunc-object.c"
/* ------------------------------------------------------------------------- */
@@ -3230,7 +581,7 @@ _invoke_parent_vfunc (class, basename, object_name, vfunc_name, ...)
vfunc_info = g_object_info_find_vfunc (info, vfunc_name);
g_assert (vfunc_info);
/* FIXME: g_vfunc_info_get_offset does not seem to work here. */
- field_info = find_field (struct_info, vfunc_name);
+ field_info = get_field_info (struct_info, vfunc_name);
g_assert (field_info);
field_offset = g_field_info_get_offset (field_info);
func_pointer = G_STRUCT_MEMBER (gpointer, klass, field_offset);
diff --git a/MANIFEST b/MANIFEST
index 455d570..68b8646 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,4 +1,24 @@
GObjectIntrospection.xs
+gperl-i11n-callback.c
+gperl-i11n-croak.c
+gperl-i11n-field.c
+gperl-i11n-gvalue.c
+gperl-i11n-info.c
+gperl-i11n-invoke-c.c
+gperl-i11n-invoke-info.c
+gperl-i11n-invoke-perl.c
+gperl-i11n-marshal-arg.c
+gperl-i11n-marshal-array.c
+gperl-i11n-marshal-callback.c
+gperl-i11n-marshal-hash.c
+gperl-i11n-marshal-interface.c
+gperl-i11n-marshal-list.c
+gperl-i11n-marshal-raw.c
+gperl-i11n-marshal-struct.c
+gperl-i11n-method.c
+gperl-i11n-size.c
+gperl-i11n-vfunc-interface.c
+gperl-i11n-vfunc-object.c
lib/Glib/Object/Introspection.pm
LICENSE
Makefile.PL
@@ -9,6 +29,7 @@ perl-Glib-Object-Introspection.doap
README
t/00-basic-types.t
t/arrays.t
+t/boxed.t
t/cairo-integration.t
t/callbacks.t
t/closures.t
@@ -16,5 +37,8 @@ t/constants.t
t/enums.t
t/hashes.t
t/inc/setup.pl
+t/interface-implementation.t
t/objects.t
+t/structs.t
t/values.t
+t/vfunc-implementation.t
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
index 604bf16..3f775b6 100644
--- a/MANIFEST.SKIP
+++ b/MANIFEST.SKIP
@@ -8,5 +8,5 @@ build
Makefile$
Makefile\.old$
MYMETA\..*$
-\.c$
+GObjectIntrospection.c$
\.o$
diff --git a/gperl-i11n-callback.c b/gperl-i11n-callback.c
new file mode 100644
index 0000000..7b712c1
--- /dev/null
+++ b/gperl-i11n-callback.c
@@ -0,0 +1,82 @@
+static GPerlI11nCallbackInfo *
+create_callback_closure (GITypeInfo *cb_type, SV *code)
+{
+ GPerlI11nCallbackInfo *info;
+
+ info = g_new0 (GPerlI11nCallbackInfo, 1);
+ info->interface =
+ (GICallableInfo *) g_type_info_get_interface (cb_type);
+ info->cif = g_new0 (ffi_cif, 1);
+ info->closure =
+ g_callable_info_prepare_closure (info->interface, info->cif,
+ invoke_callback, info);
+ /* FIXME: This should most likely use SvREFCNT_inc instead of
+ * newSVsv. */
+ info->code = newSVsv (code);
+ info->sub_name = NULL;
+ info->package_name = NULL;
+
+#ifdef PERL_IMPLICIT_CONTEXT
+ info->priv = aTHX;
+#endif
+
+ return info;
+}
+
+static void
+attach_callback_data (GPerlI11nCallbackInfo *info, SV *data)
+{
+ info->data = newSVsv (data);
+}
+
+/* assumes ownership of sub_name and package_name */
+static GPerlI11nCallbackInfo *
+create_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name, gchar *package_name)
+{
+ GPerlI11nCallbackInfo *info;
+
+ info = g_new0 (GPerlI11nCallbackInfo, 1);
+ info->interface =
+ (GICallableInfo *) g_type_info_get_interface (cb_type);
+ info->cif = g_new0 (ffi_cif, 1);
+ info->closure =
+ g_callable_info_prepare_closure (info->interface, info->cif,
+ invoke_callback, info);
+ info->sub_name = sub_name;
+ info->package_name = package_name;
+ info->code = NULL;
+ info->data = NULL;
+
+#ifdef PERL_IMPLICIT_CONTEXT
+ info->priv = aTHX;
+#endif
+
+ return info;
+}
+
+static void
+release_callback (gpointer data)
+{
+ GPerlI11nCallbackInfo *info = data;
+ dwarn ("releasing callback info %p\n", info);
+
+ if (info->cif)
+ g_free (info->cif);
+
+ if (info->closure)
+ g_callable_info_free_closure (info->interface, info->closure);
+
+ if (info->interface)
+ g_base_info_unref ((GIBaseInfo*) info->interface);
+
+ if (info->code)
+ SvREFCNT_dec (info->code);
+ if (info->data)
+ SvREFCNT_dec (info->data);
+ if (info->sub_name)
+ g_free (info->sub_name);
+ if (info->package_name)
+ g_free (info->package_name);
+
+ g_free (info);
+}
diff --git a/gperl-i11n-croak.c b/gperl-i11n-croak.c
new file mode 100644
index 0000000..c2c7c04
--- /dev/null
+++ b/gperl-i11n-croak.c
@@ -0,0 +1,20 @@
+/* Call Carp's croak() so that errors are reported at their location in the
+ * user's program, not in Introspection.pm. Adapted from
+ * <http://www.perlmonks.org/?node_id=865159>. */
+static void
+call_carp_croak (const char *msg)
+{
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK (SP);
+ XPUSHs (sv_2mortal (newSVpv(msg, PL_na)));
+ PUTBACK;
+
+ call_pv("Carp::croak", G_VOID | G_DISCARD);
+
+ FREETMPS;
+ LEAVE;
+}
diff --git a/gperl-i11n-field.c b/gperl-i11n-field.c
new file mode 100644
index 0000000..12042f4
--- /dev/null
+++ b/gperl-i11n-field.c
@@ -0,0 +1,131 @@
+static void
+store_fields (HV *fields, GIBaseInfo *info, GIInfoType info_type)
+{
+ const gchar *namespace;
+ AV *av;
+ gint i;
+
+ namespace = g_base_info_get_name (info);
+ av = newAV ();
+
+ switch (info_type) {
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_STRUCT:
+ {
+ gint n_fields = g_struct_info_get_n_fields (
+ (GIStructInfo *) info);
+ for (i = 0; i < n_fields; i++) {
+ GIFieldInfo *field_info;
+ const gchar *field_name;
+ field_info = g_struct_info_get_field ((GIStructInfo *) info, i);
+ field_name = g_base_info_get_name ((GIBaseInfo *) field_info);
+ av_push (av, newSVpv (field_name, PL_na));
+ g_base_info_unref ((GIBaseInfo *) field_info);
+ }
+ break;
+ }
+
+ case GI_INFO_TYPE_UNION:
+ {
+ gint n_fields = g_union_info_get_n_fields ((GIUnionInfo *) info);
+ for (i = 0; i < n_fields; i++) {
+ GIFieldInfo *field_info;
+ const gchar *field_name;
+ field_info = g_union_info_get_field ((GIUnionInfo *) info, i);
+ field_name = g_base_info_get_name ((GIBaseInfo *) field_info);
+ av_push (av, newSVpv (field_name, PL_na));
+ g_base_info_unref ((GIBaseInfo *) field_info);
+ }
+ break;
+ }
+
+ default:
+ ccroak ("store_fields: unsupported info type %d", info_type);
+ }
+
+ gperl_hv_take_sv (fields, namespace, strlen (namespace),
+ newRV_noinc ((SV *) av));
+}
+
+static SV *
+get_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer)
+{
+ GITypeInfo *field_type;
+ GIBaseInfo *interface_info;
+ GIArgument value;
+ SV *sv = NULL;
+
+ field_type = g_field_info_get_type (field_info);
+ interface_info = g_type_info_get_interface (field_type);
+
+ /* This case is not handled by g_field_info_set_field. */
+ if (!g_type_info_is_pointer (field_type) &&
+ g_type_info_get_tag (field_type) == GI_TYPE_TAG_INTERFACE &&
+ g_base_info_get_type (interface_info) == GI_INFO_TYPE_STRUCT)
+ {
+ gsize offset;
+ offset = g_field_info_get_offset (field_info);
+ value.v_pointer = mem + offset;
+ sv = arg_to_sv (&value,
+ field_type,
+ GI_TRANSFER_NOTHING,
+ NULL);
+ } else if (g_field_info_get_field (field_info, mem, &value)) {
+ sv = arg_to_sv (&value,
+ field_type,
+ transfer,
+ NULL);
+ } else {
+ ccroak ("Could not get field '%s'",
+ g_base_info_get_name (field_info));
+ }
+
+ if (interface_info)
+ g_base_info_unref (interface_info);
+ g_base_info_unref ((GIBaseInfo *) field_type);
+
+ return sv;
+}
+
+static void
+set_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer, SV *value)
+{
+ GITypeInfo *field_type;
+ GIBaseInfo *interface_info;
+ GIArgument arg;
+
+ field_type = g_field_info_get_type (field_info);
+ interface_info = g_type_info_get_interface (field_type);
+
+ /* FIXME: No GIArgInfo and no
+ * GPerlI11nInvocationInfo here. What if the
+ * struct contains an object pointer, or a
+ * callback field? And is it OK to always
+ * allow undef? */
+
+ /* This case is not handled by g_field_info_set_field. */
+ if (!g_type_info_is_pointer (field_type) &&
+ g_type_info_get_tag (field_type) == GI_TYPE_TAG_INTERFACE &&
+ g_base_info_get_type (interface_info) == GI_INFO_TYPE_STRUCT)
+ {
+ gsize offset;
+ gssize size;
+ /* Enforce GI_TRANSFER_NOTHING since we will copy into the
+ * memory that has already been allocated inside 'mem' */
+ sv_to_arg (value, &arg, NULL, field_type,
+ GI_TRANSFER_NOTHING, TRUE, NULL);
+ offset = g_field_info_get_offset (field_info);
+ size = g_struct_info_get_size (interface_info);
+ g_memmove (mem + offset, arg.v_pointer, size);
+ } else {
+ sv_to_arg (value, &arg, NULL, field_type,
+ transfer, TRUE, NULL);
+ if (!g_field_info_set_field (field_info, mem, &arg))
+ ccroak ("Could not set field '%s'",
+ g_base_info_get_name (field_info));
+ }
+
+ if (interface_info)
+ g_base_info_unref (interface_info);
+ g_base_info_unref (field_type);
+}
diff --git a/gperl-i11n-gvalue.c b/gperl-i11n-gvalue.c
new file mode 100644
index 0000000..53ba10c
--- /dev/null
+++ b/gperl-i11n-gvalue.c
@@ -0,0 +1,19 @@
+/* Semi-private package for marshalling into GValues. */
+#define GVALUE_WRAPPER_PACKAGE "Glib::Object::Introspection::GValueWrapper"
+
+static GValue *
+SvGValueWrapper (SV *sv)
+{
+ return sv_derived_from (sv, GVALUE_WRAPPER_PACKAGE)
+ ? INT2PTR (GValue*, SvIV (SvRV (sv)))
+ : NULL;
+}
+
+static SV *
+newSVGValueWrapper (GValue *v)
+{
+ SV *sv;
+ sv = newSV (0);
+ sv_setref_pv (sv, GVALUE_WRAPPER_PACKAGE, v);
+ return sv;
+}
diff --git a/gperl-i11n-info.c b/gperl-i11n-info.c
new file mode 100644
index 0000000..cad4a59
--- /dev/null
+++ b/gperl-i11n-info.c
@@ -0,0 +1,111 @@
+/* Caller owns return value */
+static GIFunctionInfo *
+get_function_info (GIRepository *repository,
+ const gchar *basename,
+ const gchar *namespace,
+ const gchar *method)
+{
+ dwarn ("%s: %s, %s, %s\n", G_STRFUNC, basename, namespace, method);
+
+ if (namespace) {
+ GIFunctionInfo *function_info = NULL;
+ GIBaseInfo *namespace_info = g_irepository_find_by_name (
+ repository, basename, namespace);
+ if (!namespace_info)
+ ccroak ("Can't find information for namespace %s",
+ namespace);
+
+ switch (g_base_info_get_type (namespace_info)) {
+ case GI_INFO_TYPE_OBJECT:
+ function_info = g_object_info_find_method (
+ (GIObjectInfo *) namespace_info,
+ method);
+ break;
+ case GI_INFO_TYPE_INTERFACE:
+ function_info = g_interface_info_find_method (
+ (GIInterfaceInfo *) namespace_info,
+ method);
+ break;
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_STRUCT:
+ function_info = g_struct_info_find_method (
+ (GIStructInfo *) namespace_info,
+ method);
+ break;
+ case GI_INFO_TYPE_UNION:
+ function_info = g_union_info_find_method (
+ (GIUnionInfo *) namespace_info,
+ method);
+ break;
+ default:
+ ccroak ("Base info for namespace %s has incorrect type",
+ namespace);
+ }
+
+ if (!function_info)
+ ccroak ("Can't find information for method "
+ "%s::%s", namespace, method);
+
+ g_base_info_unref (namespace_info);
+
+ return function_info;
+ } else {
+ GIBaseInfo *method_info = g_irepository_find_by_name (
+ repository, basename, method);
+
+ if (!method_info)
+ ccroak ("Can't find information for method %s", method);
+
+ switch (g_base_info_get_type (method_info)) {
+ case GI_INFO_TYPE_FUNCTION:
+ return (GIFunctionInfo *) method_info;
+ default:
+ ccroak ("Base info for method %s has incorrect type",
+ method);
+ }
+ }
+
+ return NULL;
+}
+
+/* Caller owns return value */
+static GIFieldInfo *
+get_field_info (GIBaseInfo *info, const gchar *field_name)
+{
+ GIInfoType info_type;
+ info_type = g_base_info_get_type (info);
+ switch (info_type) {
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_STRUCT:
+ {
+ gint n_fields, i;
+ n_fields = g_struct_info_get_n_fields ((GIStructInfo *) info);
+ for (i = 0; i < n_fields; i++) {
+ GIFieldInfo *field_info;
+ field_info = g_struct_info_get_field ((GIStructInfo *) info, i);
+ if (0 == strcmp (field_name, g_base_info_get_name (field_info))) {
+ return field_info;
+ }
+ g_base_info_unref (field_info);
+ }
+ break;
+ }
+ case GI_INFO_TYPE_UNION:
+ {
+ gint n_fields, i;
+ n_fields = g_union_info_get_n_fields ((GIStructInfo *) info);
+ for (i = 0; i < n_fields; i++) {
+ GIFieldInfo *field_info;
+ field_info = g_union_info_get_field ((GIStructInfo *) info, i);
+ if (0 == strcmp (field_name, g_base_info_get_name (field_info))) {
+ return field_info;
+ }
+ g_base_info_unref (field_info);
+ }
+ break;
+ }
+ default:
+ break;
+ }
+ return NULL;
+}
diff --git a/gperl-i11n-invoke-c.c b/gperl-i11n-invoke-c.c
new file mode 100644
index 0000000..aa4c853
--- /dev/null
+++ b/gperl-i11n-invoke-c.c
@@ -0,0 +1,238 @@
+void
+invoke_callable (GICallableInfo *info,
+ gpointer func_pointer,
+ SV **sp, I32 ax, SV **mark, I32 items, /* these correspond to dXSARGS */
+ UV internal_stack_offset)
+{
+ ffi_cif cif;
+ gpointer instance = NULL;
+ guint i;
+ GPerlI11nInvocationInfo iinfo = {0,};
+ guint n_return_values;
+ GIArgument return_value;
+ GError * local_error = NULL;
+ gpointer local_error_address = &local_error;
+
+ PERL_UNUSED_VAR (mark);
+
+ prepare_invocation_info (&iinfo, info, items, internal_stack_offset);
+
+ if (iinfo.is_method) {
+ instance = instance_sv_to_pointer (info, ST (0 + iinfo.stack_offset));
+ iinfo.arg_types[0] = &ffi_type_pointer;
+ iinfo.args[0] = &instance;
+ }
+
+ for (i = 0 ; i < iinfo.n_args ; i++) {
+ GIArgInfo * arg_info;
+ GITypeInfo * arg_type;
+ GITransfer transfer;
+ gboolean may_be_null;
+ gint perl_stack_pos, ffi_stack_pos;
+ SV *current_sv;
+
+ arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i);
+ /* In case of out and in-out args, arg_type is unref'ed after
+ * the function has been invoked */
+ arg_type = g_arg_info_get_type (arg_info);
+ transfer = g_arg_info_get_ownership_transfer (arg_info);
+ may_be_null = g_arg_info_may_be_null (arg_info);
+ perl_stack_pos = i
+ + iinfo.method_offset
+ + iinfo.stack_offset
+ + iinfo.dynamic_stack_offset;
+ ffi_stack_pos = i
+ + iinfo.method_offset;
+
+ /* FIXME: Is this right? I'm confused about the relation of
+ * the numbers in g_callable_info_get_arg and
+ * g_arg_info_get_closure and g_arg_info_get_destroy. We used
+ * to add method_offset, but that stopped being correct at some
+ * point. */
+ iinfo.current_pos = i; /* + method_offset; */
+
+ dwarn (" arg %d, tag: %d (%s), is_pointer: %d, is_automatic: %d\n",
+ i,
+ g_type_info_get_tag (arg_type),
+ g_type_tag_to_string (g_type_info_get_tag (arg_type)),
+ g_type_info_is_pointer (arg_type),
+ iinfo.is_automatic_arg[i]);
+
+ /* FIXME: Generate a proper usage message if the user did not
+ * supply enough arguments. */
+ current_sv = perl_stack_pos < items ? ST (perl_stack_pos) : &PL_sv_undef;
+
+ switch (g_arg_info_get_direction (arg_info)) {
+ case GI_DIRECTION_IN:
+ if (iinfo.is_automatic_arg[i]) {
+ iinfo.dynamic_stack_offset--;
+#if GI_CHECK_VERSION (1, 29, 0)
+ } else if (g_arg_info_is_skip (arg_info)) {
+ iinfo.dynamic_stack_offset--;
+#endif
+ } else {
+ sv_to_arg (current_sv,
+ &iinfo.in_args[i], arg_info, arg_type,
+ transfer, may_be_null, &iinfo);
+ }
+ iinfo.arg_types[ffi_stack_pos] =
+ g_type_info_get_ffi_type (arg_type);
+ iinfo.args[ffi_stack_pos] = &iinfo.in_args[i];
+ g_base_info_unref ((GIBaseInfo *) arg_type);
+ break;
+
+ case GI_DIRECTION_OUT:
+ if (g_arg_info_is_caller_allocates (arg_info)) {
+ iinfo.aux_args[i].v_pointer =
+ allocate_out_mem (arg_type);
+ iinfo.out_args[i].v_pointer = &iinfo.aux_args[i];
+ iinfo.args[ffi_stack_pos] = &iinfo.aux_args[i];
+ } else {
+ iinfo.out_args[i].v_pointer = &iinfo.aux_args[i];
+ iinfo.args[ffi_stack_pos] = &iinfo.out_args[i];
+ }
+ iinfo.out_arg_infos[i] = arg_type;
+ iinfo.arg_types[ffi_stack_pos] = &ffi_type_pointer;
+ /* Adjust the dynamic stack offset so that this out
+ * argument doesn't inadvertedly eat up an in argument. */
+ iinfo.dynamic_stack_offset--;
+ break;
+
+ case GI_DIRECTION_INOUT:
+ iinfo.in_args[i].v_pointer =
+ iinfo.out_args[i].v_pointer =
+ &iinfo.aux_args[i];
+ if (iinfo.is_automatic_arg[i]) {
+ iinfo.dynamic_stack_offset--;
+#if GI_CHECK_VERSION (1, 29, 0)
+ } else if (g_arg_info_is_skip (arg_info)) {
+ iinfo.dynamic_stack_offset--;
+#endif
+ } else {
+ /* We pass iinfo.in_args[i].v_pointer here,
+ * not &iinfo.in_args[i], so that the value
+ * pointed to is filled from the SV. */
+ sv_to_arg (current_sv,
+ iinfo.in_args[i].v_pointer, arg_info, arg_type,
+ transfer, may_be_null, &iinfo);
+ }
+ iinfo.out_arg_infos[i] = arg_type;
+ iinfo.arg_types[ffi_stack_pos] = &ffi_type_pointer;
+ iinfo.args[ffi_stack_pos] = &iinfo.in_args[i];
+ break;
+ }
+
+ g_base_info_unref ((GIBaseInfo *) arg_info);
+ }
+
+ /* do another pass to handle automatic args */
+ for (i = 0 ; i < iinfo.n_args ; i++) {
+ GIArgInfo * arg_info;
+ if (!iinfo.is_automatic_arg[i])
+ continue;
+ arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i);
+ switch (g_arg_info_get_direction (arg_info)) {
+ case GI_DIRECTION_IN:
+ handle_automatic_arg (i, &iinfo.in_args[i], &iinfo);
+ break;
+ case GI_DIRECTION_INOUT:
+ handle_automatic_arg (i, &iinfo.aux_args[i], &iinfo);
+ break;
+ case GI_DIRECTION_OUT:
+ /* handled later */
+ break;
+ }
+ g_base_info_unref ((GIBaseInfo *) arg_info);
+ }
+
+ if (iinfo.throws) {
+ iinfo.args[iinfo.n_invoke_args - 1] = &local_error_address;
+ iinfo.arg_types[iinfo.n_invoke_args - 1] = &ffi_type_pointer;
+ }
+
+ /* prepare and call the function */
+ if (FFI_OK != ffi_prep_cif (&cif, FFI_DEFAULT_ABI, iinfo.n_invoke_args,
+ iinfo.return_type_ffi, iinfo.arg_types))
+ {
+ clear_invocation_info (&iinfo);
+ ccroak ("Could not prepare a call interface");
+ }
+
+ ffi_call (&cif, func_pointer, &return_value, iinfo.args);
+
+ /* free call-scoped callback infos */
+ g_slist_foreach (iinfo.free_after_call,
+ (GFunc) release_callback, NULL);
+
+ if (local_error) {
+ gperl_croak_gerror (NULL, local_error);
+ }
+
+ /*
+ * handle return values
+ */
+ n_return_values = 0;
+
+ /* place return value and output args on the stack */
+ if (iinfo.has_return_value
+#if GI_CHECK_VERSION (1, 29, 0)
+ && !g_callable_info_skip_return ((GICallableInfo *) info)
+#endif
+ )
+ {
+ SV *value = arg_to_sv (&return_value,
+ iinfo.return_type_info,
+ iinfo.return_type_transfer,
+ &iinfo);
+ if (value) {
+ XPUSHs (sv_2mortal (value));
+ n_return_values++;
+ }
+ }
+
+ /* out args */
+ for (i = 0 ; i < iinfo.n_args ; i++) {
+ GIArgInfo * arg_info;
+ if (iinfo.is_automatic_arg[i])
+ continue;
+ arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i);
+#if GI_CHECK_VERSION (1, 29, 0)
+ if (g_arg_info_is_skip (arg_info)) {
+ g_base_info_unref ((GIBaseInfo *) arg_info);
+ continue;
+ }
+#endif
+ switch (g_arg_info_get_direction (arg_info)) {
+ case GI_DIRECTION_OUT:
+ case GI_DIRECTION_INOUT:
+ {
+ GITransfer transfer;
+ SV *sv;
+ /* If we allocated the memory ourselves, we always own it. */
+ transfer = g_arg_info_is_caller_allocates (arg_info)
+ ? GI_TRANSFER_CONTAINER
+ : g_arg_info_get_ownership_transfer (arg_info);
+ sv = arg_to_sv (iinfo.out_args[i].v_pointer,
+ iinfo.out_arg_infos[i],
+ transfer,
+ &iinfo);
+ if (sv) {
+ XPUSHs (sv_2mortal (sv));
+ n_return_values++;
+ }
+ g_base_info_unref ((GIBaseInfo*) iinfo.out_arg_infos[i]);
+ break;
+ }
+
+ default:
+ break;
+ }
+ g_base_info_unref ((GIBaseInfo *) arg_info);
+ }
+
+ clear_invocation_info (&iinfo);
+
+ dwarn (" number of return values: %d\n", n_return_values);
+
+ PUTBACK;
+}
diff --git a/gperl-i11n-invoke-info.c b/gperl-i11n-invoke-info.c
new file mode 100644
index 0000000..1836733
--- /dev/null
+++ b/gperl-i11n-invoke-info.c
@@ -0,0 +1,211 @@
+static void
+prepare_invocation_info (GPerlI11nInvocationInfo *iinfo,
+ GICallableInfo *info,
+ IV items,
+ UV internal_stack_offset)
+{
+ gboolean is_vfunc;
+ guint i;
+
+ is_vfunc = GI_IS_VFUNC_INFO (info);
+
+ iinfo->stack_offset = internal_stack_offset;
+
+ iinfo->is_constructor = is_vfunc
+ ? FALSE
+ : g_function_info_get_flags (info) & GI_FUNCTION_IS_CONSTRUCTOR;
+ if (iinfo->is_constructor) {
+ iinfo->stack_offset++;
+ }
+
+ iinfo->n_given_args = items - iinfo->stack_offset;
+
+ iinfo->n_invoke_args = iinfo->n_args =
+ g_callable_info_get_n_args ((GICallableInfo *) info);
+
+ /* FIXME: can a vfunc not throw? */
+ iinfo->throws = is_vfunc
+ ? FALSE
+ : g_function_info_get_flags (info) & GI_FUNCTION_THROWS;
+ if (iinfo->throws) {
+ iinfo->n_invoke_args++;
+ }
+
+ if (is_vfunc) {
+ iinfo->is_method = TRUE;
+ } else {
+ iinfo->is_method =
+ (g_function_info_get_flags (info) & GI_FUNCTION_IS_METHOD)
+ && !iinfo->is_constructor;
+ }
+ if (iinfo->is_method) {
+ iinfo->n_invoke_args++;
+ }
+
+ dwarn ("invoke: %s\n"
+ " n_args: %d, n_invoke_args: %d, n_given_args: %d\n"
+ " is_constructor: %d, is_method: %d\n",
+ is_vfunc ? g_base_info_get_name (info) : g_function_info_get_symbol (info),
+ iinfo->n_args, iinfo->n_invoke_args, iinfo->n_given_args,
+ iinfo->is_constructor, iinfo->is_method);
+
+ iinfo->return_type_info =
+ g_callable_info_get_return_type ((GICallableInfo *) info);
+ iinfo->has_return_value =
+ GI_TYPE_TAG_VOID != g_type_info_get_tag (iinfo->return_type_info);
+ iinfo->return_type_ffi = g_type_info_get_ffi_type (iinfo->return_type_info);
+ iinfo->return_type_transfer = g_callable_info_get_caller_owns ((GICallableInfo *) info);
+
+ /* allocate enough space for all args in both the out and in lists.
+ * we'll only use as much as we need. since function argument lists
+ * are typically small, this shouldn't be a big problem. */
+ if (iinfo->n_invoke_args) {
+ gint n = iinfo->n_invoke_args;
+ iinfo->in_args = gperl_alloc_temp (sizeof (GIArgument) * n);
+ iinfo->out_args = gperl_alloc_temp (sizeof (GIArgument) * n);
+ iinfo->out_arg_infos = gperl_alloc_temp (sizeof (GITypeInfo*) * n);
+ iinfo->arg_types = gperl_alloc_temp (sizeof (ffi_type *) * n);
+ iinfo->args = gperl_alloc_temp (sizeof (gpointer) * n);
+ iinfo->aux_args = gperl_alloc_temp (sizeof (GIArgument) * n);
+ iinfo->is_automatic_arg = gperl_alloc_temp (sizeof (gboolean) * n);
+ }
+
+ iinfo->method_offset = iinfo->is_method ? 1 : 0;
+ iinfo->dynamic_stack_offset = 0;
+
+ /* Make a first pass to mark args that are filled in automatically, and
+ * thus have no counterpart on the Perl side. */
+ for (i = 0 ; i < iinfo->n_args ; i++) {
+ GIArgInfo * arg_info =
+ g_callable_info_get_arg ((GICallableInfo *) info, i);
+ GITypeInfo * arg_type = g_arg_info_get_type (arg_info);
+ GITypeTag arg_tag = g_type_info_get_tag (arg_type);
+
+ if (arg_tag == GI_TYPE_TAG_ARRAY) {
+ gint pos = g_type_info_get_array_length (arg_type);
+ if (pos >= 0) {
+ dwarn (" pos %d is automatic (array length)\n", pos);
+ iinfo->is_automatic_arg[pos] = TRUE;
+ }
+ }
+
+ else if (arg_tag == GI_TYPE_TAG_INTERFACE) {
+ GIBaseInfo * interface = g_type_info_get_interface (arg_type);
+ GIInfoType info_type = g_base_info_get_type (interface);
+ if (info_type == GI_INFO_TYPE_CALLBACK) {
+ gint pos = g_arg_info_get_destroy (arg_info);
+ if (pos >= 0) {
+ dwarn (" pos %d is automatic (callback destroy notify)\n", pos);
+ iinfo->is_automatic_arg[pos] = TRUE;
+ }
+ }
+ g_base_info_unref ((GIBaseInfo *) interface);
+ }
+
+ g_base_info_unref ((GIBaseInfo *) arg_type);
+ g_base_info_unref ((GIBaseInfo *) arg_info);
+ }
+
+ /* If the return value is an array which comes with an outbound length
+ * arg, then mark that length arg as automatic, too. */
+ if (g_type_info_get_tag (iinfo->return_type_info) == GI_TYPE_TAG_ARRAY) {
+ gint pos = g_type_info_get_array_length (iinfo->return_type_info);
+ if (pos >= 0) {
+ GIArgInfo * arg_info =
+ g_callable_info_get_arg ((GICallableInfo *) info, pos);
+ if (GI_DIRECTION_OUT == g_arg_info_get_direction (arg_info)) {
+ dwarn (" pos %d is automatic (array length)\n", pos);
+ iinfo->is_automatic_arg[pos] = TRUE;
+ }
+ }
+ }
+
+ /* We need to undo the special handling that GInitiallyUnowned
+ * descendants receive from gobject-introspection: values of this type
+ * are always marked transfer=none, even for constructors. */
+ if (iinfo->is_constructor &&
+ g_type_info_get_tag (iinfo->return_type_info) == GI_TYPE_TAG_INTERFACE)
+ {
+ GIBaseInfo * interface = g_type_info_get_interface (iinfo->return_type_info);
+ if (GI_IS_REGISTERED_TYPE_INFO (interface) &&
+ g_type_is_a (g_registered_type_info_get_g_type (interface),
+ G_TYPE_INITIALLY_UNOWNED))
+ {
+ iinfo->return_type_transfer = GI_TRANSFER_EVERYTHING;
+ }
+ g_base_info_unref ((GIBaseInfo *) interface);
+ }
+}
+
+static void
+clear_invocation_info (GPerlI11nInvocationInfo *iinfo)
+{
+ g_slist_free (iinfo->free_after_call);
+
+ /* The actual callback infos might be needed later, so we cannot free
+ * them here. */
+ g_slist_free (iinfo->callback_infos);
+
+ g_slist_foreach (iinfo->array_infos, (GFunc) g_free, NULL);
+ g_slist_free (iinfo->array_infos);
+
+ g_base_info_unref ((GIBaseInfo *) iinfo->return_type_info);
+}
+
+static gpointer
+allocate_out_mem (GITypeInfo *arg_type)
+{
+ GIBaseInfo *interface_info;
+ GIInfoType type;
+
+ interface_info = g_type_info_get_interface (arg_type);
+ g_assert (interface_info);
+ type = g_base_info_get_type (interface_info);
+ g_base_info_unref (interface_info);
+
+ switch (type) {
+ case GI_INFO_TYPE_STRUCT:
+ {
+ /* No plain g_struct_info_get_size (interface_info) here so
+ * that we get the GValue override. */
+ gsize size = size_of_interface (arg_type);
+ return g_malloc0 (size);
+ }
+ default:
+ g_assert_not_reached ();
+ return NULL;
+ }
+}
+
+static void
+handle_automatic_arg (guint pos,
+ GIArgument * arg,
+ GPerlI11nInvocationInfo * invocation_info)
+{
+ GSList *l;
+
+ /* array length */
+ for (l = invocation_info->array_infos; l != NULL; l = l->next) {
+ GPerlI11nArrayInfo *ainfo = l->data;
+ if (pos == ainfo->length_pos) {
+ dwarn (" setting automatic arg %d (array length) to %d\n",
+ pos, ainfo->length);
+ /* FIXME: Is it OK to always use v_size here? */
+ arg->v_size = ainfo->length;
+ return;
+ }
+ }
+
+ /* callback destroy notify */
+ for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
+ GPerlI11nCallbackInfo *cinfo = l->data;
+ if (pos == cinfo->notify_pos) {
+ dwarn (" setting automatic arg %d (destroy notify for calllback %p)\n",
+ pos, cinfo);
+ arg->v_pointer = release_callback;
+ return;
+ }
+ }
+
+ ccroak ("Could not handle automatic arg %d", pos);
+}
diff --git a/gperl-i11n-invoke-perl.c b/gperl-i11n-invoke-perl.c
new file mode 100644
index 0000000..a31a033
--- /dev/null
+++ b/gperl-i11n-invoke-perl.c
@@ -0,0 +1,222 @@
+static void
+invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
+{
+ GPerlI11nCallbackInfo *info;
+ GICallableInfo *cb_interface;
+ int n_args, i;
+ int in_inout;
+ GITypeInfo *return_type;
+ gboolean have_return_type;
+ int n_return_values, n_returned;
+ I32 context;
+ dGPERL_CALLBACK_MARSHAL_SP;
+
+ PERL_UNUSED_VAR (cif);
+
+ /* unwrap callback info struct from userdata */
+ info = (GPerlI11nCallbackInfo *) userdata;
+ cb_interface = (GICallableInfo *) info->interface;
+
+ /* set perl context */
+ GPERL_CALLBACK_MARSHAL_INIT (info);
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK (SP);
+
+ /* find arguments; use type information from interface to find in and
+ * in-out args and their types, count in-out and out args, and find
+ * suitable converters; push in and in-out arguments onto the perl
+ * stack */
+ in_inout = 0;
+ n_args = g_callable_info_get_n_args (cb_interface);
+ for (i = 0; i < n_args; i++) {
+ GIArgInfo *arg_info = g_callable_info_get_arg (cb_interface, i);
+ GITypeInfo *arg_type = g_arg_info_get_type (arg_info);
+ GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
+ GIDirection direction = g_arg_info_get_direction (arg_info);
+
+ /* the closure argument, which we handle separately, is marked
+ * by having get_closure == i */
+ if (g_arg_info_get_closure (arg_info) == i) {
+ g_base_info_unref ((GIBaseInfo *) arg_info);
+ g_base_info_unref ((GIBaseInfo *) arg_type);
+ continue;
+ }
+
+ dwarn ("arg info: %p\n"
+ " direction: %d\n"
+ " is return value: %d\n"
+ " is optional: %d\n"
+ " may be null: %d\n"
+ " transfer: %d\n",
+ arg_info,
+ g_arg_info_get_direction (arg_info),
+ g_arg_info_is_return_value (arg_info),
+ g_arg_info_is_optional (arg_info),
+ g_arg_info_may_be_null (arg_info),
+ g_arg_info_get_ownership_transfer (arg_info));
+
+ dwarn ("arg type: %p\n"
+ " is pointer: %d\n"
+ " tag: %d\n",
+ arg_type,
+ g_type_info_is_pointer (arg_type),
+ g_type_info_get_tag (arg_type));
+
+ if (direction == GI_DIRECTION_IN ||
+ direction == GI_DIRECTION_INOUT)
+ {
+ GIArgument arg;
+ raw_to_arg (args[i], &arg, arg_type);
+ XPUSHs (sv_2mortal (arg_to_sv (&arg, arg_type, transfer, NULL)));
+ }
+
+ if (direction == GI_DIRECTION_INOUT ||
+ direction == GI_DIRECTION_OUT)
+ {
+ in_inout++;
+ }
+
+ g_base_info_unref ((GIBaseInfo *) arg_info);
+ g_base_info_unref ((GIBaseInfo *) arg_type);
+ }
+
+ /* push user data onto the Perl stack */
+ if (info->data)
+ XPUSHs (sv_2mortal (SvREFCNT_inc (info->data)));
+
+ PUTBACK;
+
+ /* put the target package name into the invocant so that the vfunc
+ * fallback code knows whose parent to chain up to. */
+ if (info->package_name) {
+ GObject *object = * (GObject **) args[0];
+ g_assert (G_IS_OBJECT (object));
+ g_object_set_qdata (object, VFUNC_TARGET_PACKAGE_QUARK, info->package_name);
+ }
+
+ /* determine suitable Perl call context; return_type is freed further
+ * below */
+ return_type = g_callable_info_get_return_type (cb_interface);
+ have_return_type =
+ GI_TYPE_TAG_VOID != g_type_info_get_tag (return_type);
+
+ context = G_VOID | G_DISCARD;
+ if (have_return_type) {
+ context = in_inout > 0
+ ? G_ARRAY
+ : G_SCALAR;
+ } else {
+ if (in_inout == 1) {
+ context = G_SCALAR;
+ } else if (in_inout > 1) {
+ context = G_ARRAY;
+ }
+ }
+
+ /* do the call, demand #in-out+#out+#return-value return values */
+ n_return_values = have_return_type
+ ? in_inout + 1
+ : in_inout;
+ n_returned = info->sub_name
+ ? call_method (info->sub_name, context)
+ : call_sv (info->code, context);
+ if (n_return_values != 0 && n_returned != n_return_values) {
+ ccroak ("callback returned %d values "
+ "but is supposed to return %d values",
+ n_returned, n_return_values);
+ }
+
+ if (info->package_name) {
+ GObject *object = * (GObject **) args[0];
+ g_assert (G_IS_OBJECT (object));
+ g_object_set_qdata (object, VFUNC_TARGET_PACKAGE_QUARK, NULL);
+ }
+
+ SPAGAIN;
+
+ /* convert in-out and out values and stuff them back into args */
+ if (in_inout > 0) {
+ SV **returned_values;
+ int out_index;
+
+ returned_values = g_new0 (SV *, in_inout);
+
+ /* pop scalars off the stack and put them into the array;
+ * reverse the order since POPs pops items off of the end of
+ * the stack. */
+ for (i = 0; i < in_inout; i++) {
+ /* FIXME: Does this leak the sv? Should we check the
+ * transfer setting? */
+ returned_values[in_inout - i - 1] = newSVsv (POPs);
+ }
+
+ out_index = 0;
+ for (i = 0; i < n_args; i++) {
+ GIArgInfo *arg_info = g_callable_info_get_arg (cb_interface, i);
+ GITypeInfo *arg_type = g_arg_info_get_type (arg_info);
+ GIDirection direction = g_arg_info_get_direction (arg_info);
+
+ if (direction == GI_DIRECTION_INOUT ||
+ direction == GI_DIRECTION_OUT)
+ {
+ GIArgument tmp_arg;
+ GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
+ gboolean may_be_null = g_arg_info_may_be_null (arg_info);
+ sv_to_arg (returned_values[out_index], &tmp_arg,
+ arg_info, arg_type,
+ transfer, may_be_null, NULL);
+ arg_to_raw (&tmp_arg, args[i], arg_type);
+ out_index++;
+ }
+ }
+
+ g_free (returned_values);
+ }
+
+ /* store return value in resp, if any */
+ if (have_return_type) {
+ GIArgument arg;
+ GITypeInfo *type_info;
+ GITransfer transfer;
+ gboolean may_be_null;
+
+ type_info = g_callable_info_get_return_type (cb_interface);
+ transfer = g_callable_info_get_caller_owns (cb_interface);
+ may_be_null = g_callable_info_may_return_null (cb_interface);
+
+ dwarn ("ret type: %p\n"
+ " is pointer: %d\n"
+ " tag: %d\n",
+ type_info,
+ g_type_info_is_pointer (type_info),
+ g_type_info_get_tag (type_info));
+
+ /* FIXME: Does this leak the sv? */
+ sv_to_arg (newSVsv (POPs), &arg, NULL, type_info,
+ transfer, may_be_null, NULL);
+ arg_to_raw (&arg, resp, type_info);
+
+ g_base_info_unref ((GIBaseInfo *) type_info);
+ }
+
+ PUTBACK;
+
+ g_base_info_unref ((GIBaseInfo *) return_type);
+
+ FREETMPS;
+ LEAVE;
+
+ /* FIXME: We can't just free everything here because ffi will use parts
+ * of this after we've returned.
+ *
+ * if (info->free_after_use) {
+ * release_callback (info);
+ * }
+ *
+ * Gjs uses a global list of callback infos instead and periodically
+ * frees unused ones.
+ */
+}
diff --git a/gperl-i11n-marshal-arg.c b/gperl-i11n-marshal-arg.c
new file mode 100644
index 0000000..7bdd272
--- /dev/null
+++ b/gperl-i11n-marshal-arg.c
@@ -0,0 +1,232 @@
+/* transfer and may_be_null can be gotten from arg_info, but sv_to_arg is also
+ * called from places which don't have access to a GIArgInfo. */
+static void
+sv_to_arg (SV * sv,
+ GIArgument * arg,
+ GIArgInfo * arg_info,
+ GITypeInfo * type_info,
+ GITransfer transfer,
+ gboolean may_be_null,
+ GPerlI11nInvocationInfo * invocation_info)
+{
+ GITypeTag tag = g_type_info_get_tag (type_info);
+
+ memset (arg, 0, sizeof (GIArgument));
+
+ if (!gperl_sv_is_defined (sv))
+ /* Interfaces and void types need to be able to handle undef
+ * separately. */
+ if (!may_be_null && tag != GI_TYPE_TAG_INTERFACE
+ && tag != GI_TYPE_TAG_VOID)
+ ccroak ("undefined value for mandatory argument '%s' encountered",
+ g_base_info_get_name ((GIBaseInfo *) arg_info));
+
+ switch (tag) {
+ case GI_TYPE_TAG_VOID:
+ arg->v_pointer = handle_void_arg (sv, invocation_info);
+ break;
+
+ case GI_TYPE_TAG_BOOLEAN:
+ arg->v_boolean = SvTRUE (sv);
+ break;
+
+ case GI_TYPE_TAG_INT8:
+ arg->v_int8 = (gint8) SvIV (sv);
+ break;
+
+ case GI_TYPE_TAG_UINT8:
+ arg->v_uint8 = (guint8) SvUV (sv);
+ break;
+
+ case GI_TYPE_TAG_INT16:
+ arg->v_int16 = (gint16) SvIV (sv);
+ break;
+
+ case GI_TYPE_TAG_UINT16:
+ arg->v_uint16 = (guint16) SvUV (sv);
+ break;
+
+ case GI_TYPE_TAG_INT32:
+ arg->v_int32 = (gint32) SvIV (sv);
+ break;
+
+ case GI_TYPE_TAG_UINT32:
+ arg->v_uint32 = (guint32) SvUV (sv);
+ break;
+
+ case GI_TYPE_TAG_INT64:
+ arg->v_int64 = SvGInt64 (sv);
+ break;
+
+ case GI_TYPE_TAG_UINT64:
+ arg->v_uint64 = SvGUInt64 (sv);
+ break;
+
+ case GI_TYPE_TAG_FLOAT:
+ arg->v_float = (gfloat) SvNV (sv);
+ break;
+
+ case GI_TYPE_TAG_DOUBLE:
+ arg->v_double = SvNV (sv);
+ break;
+
+ case GI_TYPE_TAG_UNICHAR:
+ arg->v_uint32 = g_utf8_get_char (SvGChar (sv));
+ break;
+
+ case GI_TYPE_TAG_GTYPE:
+ /* GType == gsize */
+ arg->v_size = gperl_type_from_package (SvPV_nolen (sv));
+ if (!arg->v_size)
+ arg->v_size = g_type_from_name (SvPV_nolen (sv));
+ break;
+
+ case GI_TYPE_TAG_ARRAY:
+ arg->v_pointer = sv_to_array (transfer, type_info, sv, invocation_info);
+ break;
+
+ case GI_TYPE_TAG_INTERFACE:
+ dwarn (" type %p -> interface\n", type_info);
+ sv_to_interface (arg_info, type_info, sv, arg,
+ invocation_info);
+ break;
+
+ case GI_TYPE_TAG_GLIST:
+ case GI_TYPE_TAG_GSLIST:
+ arg->v_pointer = sv_to_glist (transfer, type_info, sv);
+ break;
+
+ case GI_TYPE_TAG_GHASH:
+ arg->v_pointer = sv_to_ghash (transfer, type_info, sv);
+ break;
+
+ case GI_TYPE_TAG_ERROR:
+ ccroak ("FIXME - A GError as an in/inout arg? Should never happen!");
+ break;
+
+ case GI_TYPE_TAG_UTF8:
+ arg->v_string = gperl_sv_is_defined (sv) ? SvGChar (sv) : NULL;
+ if (transfer >= GI_TRANSFER_CONTAINER)
+ arg->v_string = g_strdup (arg->v_string);
+ break;
+
+ case GI_TYPE_TAG_FILENAME:
+ /* FIXME: Is it correct to use gperl_filename_from_sv here? */
+ arg->v_string = gperl_sv_is_defined (sv) ? gperl_filename_from_sv (sv) : NULL;
+ if (transfer >= GI_TRANSFER_CONTAINER)
+ arg->v_string = g_strdup (arg->v_string);
+ break;
+
+ default:
+ ccroak ("Unhandled info tag %d in sv_to_arg", tag);
+ }
+}
+
+static SV *
+arg_to_sv (GIArgument * arg,
+ GITypeInfo * info,
+ GITransfer transfer,
+ GPerlI11nInvocationInfo *iinfo)
+{
+ GITypeTag tag = g_type_info_get_tag (info);
+ gboolean own = transfer >= GI_TRANSFER_CONTAINER;
+
+ dwarn (" arg_to_sv: info %p with type tag %d (%s)\n",
+ info, tag, g_type_tag_to_string (tag));
+
+ switch (tag) {
+ case GI_TYPE_TAG_VOID:
+ dwarn (" argument with no type information -> undef\n");
+ return &PL_sv_undef;
+
+ case GI_TYPE_TAG_BOOLEAN:
+ return boolSV (arg->v_boolean);
+
+ case GI_TYPE_TAG_INT8:
+ return newSViv (arg->v_int8);
+
+ case GI_TYPE_TAG_UINT8:
+ return newSVuv (arg->v_uint8);
+
+ case GI_TYPE_TAG_INT16:
+ return newSViv (arg->v_int16);
+
+ case GI_TYPE_TAG_UINT16:
+ return newSVuv (arg->v_uint16);
+
+ case GI_TYPE_TAG_INT32:
+ return newSViv (arg->v_int32);
+
+ case GI_TYPE_TAG_UINT32:
+ return newSVuv (arg->v_uint32);
+
+ case GI_TYPE_TAG_INT64:
+ return newSVGInt64 (arg->v_int64);
+
+ case GI_TYPE_TAG_UINT64:
+ return newSVGUInt64 (arg->v_uint64);
+
+ case GI_TYPE_TAG_FLOAT:
+ return newSVnv (arg->v_float);
+
+ case GI_TYPE_TAG_DOUBLE:
+ return newSVnv (arg->v_double);
+
+ case GI_TYPE_TAG_UNICHAR:
+ {
+ SV *sv;
+ gchar buffer[6];
+ gint length = g_unichar_to_utf8 (arg->v_uint32, buffer);
+ sv = newSVpv (buffer, length);
+ SvUTF8_on (sv);
+ return sv;
+ }
+
+ case GI_TYPE_TAG_GTYPE: {
+ /* GType == gsize */
+ const char *package = gperl_package_from_type (arg->v_size);
+ if (!package)
+ package = g_type_name (arg->v_size);
+ return newSVpv (package, PL_na);
+ }
+
+ case GI_TYPE_TAG_ARRAY:
+ return array_to_sv (info, arg->v_pointer, transfer, iinfo);
+
+ case GI_TYPE_TAG_INTERFACE:
+ return interface_to_sv (info, arg, own);
+
+ case GI_TYPE_TAG_GLIST:
+ case GI_TYPE_TAG_GSLIST:
+ return glist_to_sv (info, arg->v_pointer, transfer);
+
+ case GI_TYPE_TAG_GHASH:
+ return ghash_to_sv (info, arg->v_pointer, transfer);
+
+ case GI_TYPE_TAG_ERROR:
+ ccroak ("FIXME - GI_TYPE_TAG_ERROR");
+ break;
+
+ case GI_TYPE_TAG_UTF8:
+ {
+ SV *sv = newSVGChar (arg->v_string);
+ if (own)
+ g_free (arg->v_string);
+ return sv;
+ }
+
+ case GI_TYPE_TAG_FILENAME:
+ {
+ /* FIXME: Is it correct to use gperl_sv_from_filename here? */
+ SV *sv = gperl_sv_from_filename (arg->v_string);
+ if (own)
+ g_free (arg->v_string);
+ return sv;
+ }
+
+ default:
+ ccroak ("Unhandled info tag %d in arg_to_sv", tag);
+ }
+
+ return NULL;
+}
diff --git a/gperl-i11n-marshal-array.c b/gperl-i11n-marshal-array.c
new file mode 100644
index 0000000..15405f7
--- /dev/null
+++ b/gperl-i11n-marshal-array.c
@@ -0,0 +1,167 @@
+static SV *
+array_to_sv (GITypeInfo *info,
+ gpointer pointer,
+ GITransfer transfer,
+ GPerlI11nInvocationInfo *iinfo)
+{
+ GITypeInfo *param_info;
+ gboolean is_zero_terminated;
+ gsize item_size;
+ GITransfer item_transfer;
+ gssize length, i;
+ AV *av;
+
+ if (pointer == NULL) {
+ return &PL_sv_undef;
+ }
+
+ is_zero_terminated = g_type_info_is_zero_terminated (info);
+ param_info = g_type_info_get_param_type (info, 0);
+ item_size = size_of_type_info (param_info);
+
+ /* FIXME: What about an array containing arrays of strings, where the
+ * outer array is GI_TRANSFER_EVERYTHING but the inner arrays are
+ * GI_TRANSFER_CONTAINER? */
+ item_transfer = transfer == GI_TRANSFER_EVERYTHING
+ ? GI_TRANSFER_EVERYTHING
+ : GI_TRANSFER_NOTHING;
+
+ if (is_zero_terminated) {
+ length = g_strv_length (pointer);
+ } else {
+ length = g_type_info_get_array_fixed_size (info);
+ if (length < 0) {
+ guint length_pos = g_type_info_get_array_length (info);
+ g_assert (iinfo != NULL);
+ /* FIXME: Is it OK to always use v_size here? */
+ length = iinfo->aux_args[length_pos].v_size;
+ }
+ }
+
+ if (length < 0) {
+ ccroak ("Could not determine the length of the array");
+ }
+
+ av = newAV ();
+
+ dwarn (" C array: pointer %p, length %d, item size %d, "
+ "param_info %p with type tag %d (%s)\n",
+ pointer,
+ length,
+ item_size,
+ param_info,
+ g_type_info_get_tag (param_info),
+ g_type_tag_to_string (g_type_info_get_tag (param_info)));
+
+ for (i = 0; i < length; i++) {
+ GIArgument *arg;
+ SV *value;
+ arg = pointer + i * item_size;
+ value = arg_to_sv (arg, param_info, item_transfer, iinfo);
+ if (value)
+ av_push (av, value);
+ }
+
+ if (transfer >= GI_TRANSFER_CONTAINER)
+ g_free (pointer);
+
+ g_base_info_unref ((GIBaseInfo *) param_info);
+
+ return newRV_noinc ((SV *) av);
+}
+
+static gpointer
+sv_to_array (GITransfer transfer,
+ GITypeInfo *type_info,
+ SV *sv,
+ GPerlI11nInvocationInfo *iinfo)
+{
+ AV *av;
+ GITransfer item_transfer;
+ GITypeInfo *param_info;
+ GITypeTag param_tag;
+ gint i, length, length_pos;
+ GPerlI11nArrayInfo *array_info = NULL;
+ GArray *array;
+ gboolean is_zero_terminated = FALSE;
+ gsize item_size;
+ gboolean need_struct_value_semantics;
+
+ dwarn ("%s: sv %p\n", G_STRFUNC, sv);
+
+ /* Add an array info entry even before the undef check so that the
+ * corresponding length arg is set to zero later by
+ * handle_automatic_arg. */
+ length_pos = g_type_info_get_array_length (type_info);
+ if (length_pos >= 0) {
+ array_info = g_new0 (GPerlI11nArrayInfo, 1);
+ array_info->length_pos = length_pos;
+ array_info->length = 0;
+ iinfo->array_infos = g_slist_prepend (iinfo->array_infos, array_info);
+ }
+
+ if (sv == &PL_sv_undef)
+ return NULL;
+
+ if (!gperl_sv_is_array_ref (sv))
+ ccroak ("need an array ref to convert to GArray");
+
+ av = (AV *) SvRV (sv);
+
+ item_transfer = transfer == GI_TRANSFER_CONTAINER
+ ? GI_TRANSFER_NOTHING
+ : transfer;
+
+ param_info = g_type_info_get_param_type (type_info, 0);
+ param_tag = g_type_info_get_tag (param_info);
+ dwarn (" GArray: param_info %p with type tag %d (%s) and transfer %d\n",
+ param_info, param_tag,
+ g_type_tag_to_string (g_type_info_get_tag (param_info)),
+ transfer);
+
+ is_zero_terminated = g_type_info_is_zero_terminated (type_info);
+ item_size = size_of_type_info (param_info);
+ length = av_len (av) + 1;
+ array = g_array_sized_new (is_zero_terminated, FALSE, item_size, length);
+
+ /* Arrays containing non-basic types as non-pointers need to be treated
+ * specially. Prime example: GValue *values = g_new0 (GValue, n);
+ */
+ need_struct_value_semantics =
+ /* is a compound type, and... */
+ !G_TYPE_TAG_IS_BASIC (param_tag) &&
+ /* ... a non-pointer is wanted */
+ !g_type_info_is_pointer (param_info);
+ for (i = 0; i < length; i++) {
+ SV **svp;
+ svp = av_fetch (av, i, 0);
+ if (svp && gperl_sv_is_defined (*svp)) {
+ GIArgument arg;
+
+ dwarn (" converting SV %p\n", *svp);
+ /* FIXME: Is it OK to always allow undef here? */
+ sv_to_arg (*svp, &arg, NULL, param_info,
+ item_transfer, TRUE, NULL);
+
+ if (need_struct_value_semantics) {
+ /* Copy from the memory area pointed to by
+ * arg.v_pointer. */
+ g_array_insert_vals (array, i, arg.v_pointer, 1);
+ } else {
+ /* Copy from &arg, i.e. the memory area that is
+ * arg. */
+ g_array_insert_val (array, i, arg);
+ }
+ }
+ }
+
+ dwarn (" -> array %p of size %d\n", array, array->len);
+
+ if (length_pos >= 0) {
+ array_info->length = length;
+ }
+
+ g_base_info_unref ((GIBaseInfo *) param_info);
+
+ return g_array_free (array, FALSE);
+}
diff --git a/gperl-i11n-marshal-callback.c b/gperl-i11n-marshal-callback.c
new file mode 100644
index 0000000..4759a9c
--- /dev/null
+++ b/gperl-i11n-marshal-callback.c
@@ -0,0 +1,82 @@
+static gpointer
+handle_callback_arg (GIArgInfo * arg_info,
+ GITypeInfo * type_info,
+ SV * sv,
+ GPerlI11nInvocationInfo * invocation_info)
+{
+ GPerlI11nCallbackInfo *callback_info;
+
+ GSList *l;
+ for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
+ GPerlI11nCallbackInfo *callback_info = l->data;
+ if (invocation_info->current_pos == callback_info->notify_pos) {
+ dwarn (" destroy notify for callback %p\n",
+ callback_info);
+ /* Decrease the dynamic stack offset so that this
+ * destroy notify callback doesn't consume any Perl
+ * value from the stack. */
+ invocation_info->dynamic_stack_offset--;
+ return release_callback;
+ }
+ }
+
+ callback_info = create_callback_closure (type_info, sv);
+ callback_info->data_pos = g_arg_info_get_closure (arg_info);
+ callback_info->notify_pos = g_arg_info_get_destroy (arg_info);
+ callback_info->free_after_use = FALSE;
+
+ dwarn (" callback data at %d, destroy at %d\n",
+ callback_info->data_pos, callback_info->notify_pos);
+
+ switch (g_arg_info_get_scope (arg_info)) {
+ case GI_SCOPE_TYPE_CALL:
+ dwarn (" callback has scope 'call'\n");
+ invocation_info->free_after_call
+ = g_slist_prepend (invocation_info->free_after_call,
+ callback_info);
+ break;
+ case GI_SCOPE_TYPE_NOTIFIED:
+ dwarn (" callback has scope 'notified'\n");
+ /* This case is already taken care of by the notify
+ * stuff above */
+ break;
+ case GI_SCOPE_TYPE_ASYNC:
+ dwarn (" callback has scope 'async'\n");
+ /* FIXME: callback_info->free_after_use = TRUE; */
+ break;
+ default:
+ ccroak ("unhandled scope type %d encountered",
+ g_arg_info_get_scope (arg_info));
+ }
+
+ invocation_info->callback_infos =
+ g_slist_prepend (invocation_info->callback_infos,
+ callback_info);
+
+ dwarn (" returning closure %p from info %p\n",
+ callback_info->closure, callback_info);
+ return callback_info->closure;
+}
+
+static gpointer
+handle_void_arg (SV * sv,
+ GPerlI11nInvocationInfo * invocation_info)
+{
+ gpointer pointer = NULL;
+ gboolean is_user_data = FALSE;
+ GSList *l;
+ for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
+ GPerlI11nCallbackInfo *callback_info = l->data;
+ if (callback_info->data_pos == invocation_info->current_pos) {
+ is_user_data = TRUE;
+ dwarn (" user data for callback %p\n",
+ callback_info);
+ attach_callback_data (callback_info, sv);
+ pointer = callback_info;
+ break; /* out of the for loop */
+ }
+ }
+ if (!is_user_data)
+ ccroak ("encountered void pointer that is not callback user data");
+ return pointer;
+}
diff --git a/gperl-i11n-marshal-hash.c b/gperl-i11n-marshal-hash.c
new file mode 100644
index 0000000..bd664f2
--- /dev/null
+++ b/gperl-i11n-marshal-hash.c
@@ -0,0 +1,175 @@
+static SV *
+ghash_to_sv (GITypeInfo *info,
+ gpointer pointer,
+ GITransfer transfer)
+{
+ GITypeInfo *key_param_info, *value_param_info;
+#ifdef NOISY
+ GITypeTag key_type_tag, value_type_tag;
+#endif
+ gpointer key_p, value_p;
+ GITransfer item_transfer;
+ GHashTableIter iter;
+ HV *hv;
+
+ if (pointer == NULL) {
+ return &PL_sv_undef;
+ }
+
+ item_transfer = transfer == GI_TRANSFER_EVERYTHING
+ ? GI_TRANSFER_EVERYTHING
+ : GI_TRANSFER_NOTHING;
+
+ key_param_info = g_type_info_get_param_type (info, 0);
+ value_param_info = g_type_info_get_param_type (info, 1);
+
+#ifdef NOISY
+ key_type_tag = g_type_info_get_tag (key_param_info);
+ value_type_tag = g_type_info_get_tag (value_param_info);
+#endif
+
+ dwarn (" GHashTable: pointer %p\n"
+ " key type tag %d (%s)\n"
+ " value type tag %d (%s)\n",
+ pointer,
+ key_type_tag, g_type_tag_to_string (key_type_tag),
+ value_type_tag, g_type_tag_to_string (value_type_tag));
+
+ hv = newHV ();
+
+ g_hash_table_iter_init (&iter, pointer);
+ while (g_hash_table_iter_next (&iter, &key_p, &value_p)) {
+ GIArgument arg = { 0, };
+ SV *key_sv, *value_sv;
+
+ dwarn (" converting key pointer %p\n", key_p);
+ arg.v_pointer = key_p;
+ key_sv = arg_to_sv (&arg, key_param_info, item_transfer, NULL);
+ if (key_sv == NULL)
+ break;
+
+ dwarn (" converting value pointer %p\n", value_p);
+ arg.v_pointer = value_p;
+ value_sv = arg_to_sv (&arg, value_param_info, item_transfer, NULL);
+ if (value_sv == NULL)
+ break;
+
+ (void) hv_store_ent (hv, key_sv, value_sv, 0);
+ }
+
+ g_base_info_unref ((GIBaseInfo *) key_param_info);
+ g_base_info_unref ((GIBaseInfo *) value_param_info);
+
+ return newRV_noinc ((SV *) hv);
+}
+
+static gpointer
+sv_to_ghash (GITransfer transfer,
+ GITypeInfo *type_info,
+ SV *sv)
+{
+ HV *hv;
+ HE *he;
+ GITransfer item_transfer;
+ gpointer hash;
+ GITypeInfo *key_param_info, *value_param_info;
+ GITypeTag key_type_tag;
+ GHashFunc hash_func;
+ GEqualFunc equal_func;
+ I32 n_keys;
+
+ dwarn ("%s: sv %p\n", G_STRFUNC, sv);
+
+ if (sv == &PL_sv_undef)
+ return NULL;
+
+ if (!gperl_sv_is_hash_ref (sv))
+ ccroak ("need an hash ref to convert to GHashTable");
+
+ hv = (HV *) SvRV (sv);
+
+ item_transfer = GI_TRANSFER_NOTHING;
+ switch (transfer) {
+ case GI_TRANSFER_EVERYTHING:
+ item_transfer = GI_TRANSFER_EVERYTHING;
+ break;
+ case GI_TRANSFER_CONTAINER:
+ /* nothing special to do */
+ break;
+ case GI_TRANSFER_NOTHING:
+ /* FIXME: need to free hash after call */
+ break;
+ }
+
+ key_param_info = g_type_info_get_param_type (type_info, 0);
+ value_param_info = g_type_info_get_param_type (type_info, 1);
+
+ key_type_tag = g_type_info_get_tag (key_param_info);
+
+ switch (key_type_tag)
+ {
+ case GI_TYPE_TAG_FILENAME:
+ case GI_TYPE_TAG_UTF8:
+ hash_func = g_str_hash;
+ equal_func = g_str_equal;
+ break;
+
+ default:
+ hash_func = NULL;
+ equal_func = NULL;
+ break;
+ }
+
+ dwarn (" GHashTable with transfer %d\n"
+ " key_param_info %p with type tag %d (%s)\n"
+ " value_param_info %p with type tag %d (%s)\n",
+ transfer,
+ key_param_info,
+ g_type_info_get_tag (key_param_info),
+ g_type_tag_to_string (g_type_info_get_tag (key_param_info)),
+ value_param_info,
+ g_type_info_get_tag (value_param_info),
+ g_type_tag_to_string (g_type_info_get_tag (value_param_info)));
+
+ hash = g_hash_table_new (hash_func, equal_func);
+
+ n_keys = hv_iterinit (hv);
+ if (n_keys == 0)
+ goto out;
+
+ while ((he = hv_iternext (hv)) != NULL) {
+ SV *sv;
+ GIArgument arg = { 0, };
+ gpointer key_p, value_p;
+
+ key_p = value_p = NULL;
+
+ sv = hv_iterkeysv (he);
+ if (sv && gperl_sv_is_defined (sv)) {
+ dwarn (" converting key SV %p\n", sv);
+ /* FIXME: Is it OK to always allow undef here? */
+ sv_to_arg (sv, &arg, NULL, key_param_info,
+ item_transfer, TRUE, NULL);
+ key_p = arg.v_pointer;
+ }
+
+ sv = hv_iterval (hv, he);
+ if (sv && gperl_sv_is_defined (sv)) {
+ dwarn (" converting value SV %p\n", sv);
+ sv_to_arg (sv, &arg, NULL, key_param_info,
+ item_transfer, TRUE, NULL);
+ value_p = arg.v_pointer;
+ }
+
+ if (key_p != NULL && value_p != NULL)
+ g_hash_table_insert (hash, key_p, value_p);
+ }
+
+out:
+ dwarn (" -> hash %p of size %d\n", hash, g_hash_table_size (hash));
+
+ g_base_info_unref ((GIBaseInfo *) key_param_info);
+ g_base_info_unref ((GIBaseInfo *) value_param_info);
+
+ return hash;
+}
diff --git a/gperl-i11n-marshal-interface.c b/gperl-i11n-marshal-interface.c
new file mode 100644
index 0000000..db76fea
--- /dev/null
+++ b/gperl-i11n-marshal-interface.c
@@ -0,0 +1,205 @@
+static gpointer
+instance_sv_to_pointer (GICallableInfo *info, SV *sv)
+{
+ // We do *not* own container.
+ GIBaseInfo *container = g_base_info_get_container (info);
+ GIInfoType info_type = g_base_info_get_type (container);
+ gpointer pointer = NULL;
+
+ /* FIXME: Much of this code is duplicated in sv_to_interface. */
+
+ dwarn (" instance_sv_to_pointer: container name: %s, info type: %d\n",
+ g_base_info_get_name (container),
+ info_type);
+
+ switch (info_type) {
+ case GI_INFO_TYPE_OBJECT:
+ case GI_INFO_TYPE_INTERFACE:
+ pointer = gperl_get_object (sv);
+ dwarn (" -> object pointer: %p\n", pointer);
+ break;
+
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_STRUCT:
+ case GI_INFO_TYPE_UNION:
+ {
+ GType type = g_registered_type_info_get_g_type (
+ (GIRegisteredTypeInfo *) container);
+ if (!type || type == G_TYPE_NONE) {
+ dwarn (" unboxed type\n");
+ pointer = sv_to_struct (GI_TRANSFER_NOTHING,
+ container,
+ info_type,
+ sv);
+ } else {
+ dwarn (" boxed type: %s (%d)\n",
+ g_type_name (type), type);
+ pointer = gperl_get_boxed_check (sv, type);
+ }
+ dwarn (" -> boxed pointer: %p\n", pointer);
+ break;
+ }
+
+ default:
+ ccroak ("instance_sv_to_pointer: Don't know how to handle info type %d", info_type);
+ }
+
+ return pointer;
+}
+
+static void
+sv_to_interface (GIArgInfo * arg_info,
+ GITypeInfo * type_info,
+ SV * sv,
+ GIArgument * arg,
+ GPerlI11nInvocationInfo * invocation_info)
+{
+ GIBaseInfo *interface;
+ GIInfoType info_type;
+
+ interface = g_type_info_get_interface (type_info);
+ if (!interface)
+ ccroak ("Could not convert sv %p to pointer", sv);
+ info_type = g_base_info_get_type (interface);
+
+ dwarn (" interface %p (%s) of type %d\n",
+ interface, g_base_info_get_name (interface), info_type);
+
+ switch (info_type) {
+ case GI_INFO_TYPE_OBJECT:
+ case GI_INFO_TYPE_INTERFACE:
+ /* FIXME: Check transfer setting. */
+ arg->v_pointer = gperl_get_object (sv);
+ break;
+
+ case GI_INFO_TYPE_UNION:
+ case GI_INFO_TYPE_STRUCT:
+ case GI_INFO_TYPE_BOXED:
+ {
+ /* FIXME: What about pass-by-value here? */
+ GType type = g_registered_type_info_get_g_type (
+ (GIRegisteredTypeInfo *) interface);
+ if (!type || type == G_TYPE_NONE) {
+ GITransfer transfer = arg_info
+ ? g_arg_info_get_ownership_transfer (arg_info)
+ : GI_TRANSFER_NOTHING;
+ dwarn (" unboxed type\n");
+ arg->v_pointer = sv_to_struct (transfer,
+ interface,
+ info_type,
+ sv);
+ } else if (type == G_TYPE_CLOSURE) {
+ /* FIXME: User cannot supply user data. */
+ dwarn (" closure type\n");
+ arg->v_pointer = gperl_closure_new (sv, NULL, FALSE);
+ } else if (type == G_TYPE_VALUE) {
+ dwarn (" value type\n");
+ arg->v_pointer = SvGValueWrapper (sv);
+ if (!arg->v_pointer)
+ ccroak ("Cannot convert arbitrary SV to GValue");
+ } else {
+ dwarn (" boxed type: %s (%d)\n",
+ g_type_name (type), type);
+ /* FIXME: Check transfer setting. */
+ arg->v_pointer = gperl_get_boxed_check (sv, type);
+ }
+ break;
+ }
+
+ case GI_INFO_TYPE_ENUM:
+ {
+ GType type = g_registered_type_info_get_g_type ((GIRegisteredTypeInfo *) interface);
+ /* FIXME: Check storage type? */
+ arg->v_long = gperl_convert_enum (type, sv);
+ break;
+ }
+
+ case GI_INFO_TYPE_FLAGS:
+ {
+ GType type = g_registered_type_info_get_g_type ((GIRegisteredTypeInfo *) interface);
+ /* FIXME: Check storage type? */
+ arg->v_long = gperl_convert_flags (type, sv);
+ break;
+ }
+
+ case GI_INFO_TYPE_CALLBACK:
+ arg->v_pointer = handle_callback_arg (arg_info, type_info, sv,
+ invocation_info);
+ break;
+
+ default:
+ ccroak ("sv_to_interface: Don't know how to handle info type %d", info_type);
+ }
+
+ g_base_info_unref ((GIBaseInfo *) interface);
+}
+
+static SV *
+interface_to_sv (GITypeInfo* info, GIArgument *arg, gboolean own)
+{
+ GIBaseInfo *interface;
+ GIInfoType info_type;
+ SV *sv = NULL;
+
+ dwarn (" interface_to_sv: arg %p, info %p\n",
+ arg, info);
+
+ interface = g_type_info_get_interface (info);
+ if (!interface)
+ ccroak ("Could not convert arg %p to SV", arg);
+ info_type = g_base_info_get_type (interface);
+ dwarn (" info type: %d (%s)\n", info_type, g_info_type_to_string (info_type));
+
+ switch (info_type) {
+ case GI_INFO_TYPE_OBJECT:
+ case GI_INFO_TYPE_INTERFACE:
+ sv = gperl_new_object (arg->v_pointer, own);
+ break;
+
+ case GI_INFO_TYPE_UNION:
+ case GI_INFO_TYPE_STRUCT:
+ case GI_INFO_TYPE_BOXED:
+ {
+ /* FIXME: What about pass-by-value here? */
+ GType type;
+ type = g_registered_type_info_get_g_type (
+ (GIRegisteredTypeInfo *) interface);
+ if (!type || type == G_TYPE_NONE) {
+ dwarn (" unboxed type\n");
+ sv = struct_to_sv (interface, info_type, arg->v_pointer, own);
+ } else if (type == G_TYPE_VALUE) {
+ dwarn (" value type\n");
+ sv = gperl_sv_from_value (arg->v_pointer);
+ /* FIXME: Check 'own'. */
+ } else {
+ dwarn (" boxed type: %d (%s)\n",
+ type, g_type_name (type));
+ sv = gperl_new_boxed (arg->v_pointer, type, own);
+ }
+ break;
+ }
+
+ case GI_INFO_TYPE_ENUM:
+ {
+ GType type = g_registered_type_info_get_g_type ((GIRegisteredTypeInfo *) interface);
+ /* FIXME: Is it right to just use v_long here? */
+ sv = gperl_convert_back_enum (type, arg->v_long);
+ break;
+ }
+
+ case GI_INFO_TYPE_FLAGS:
+ {
+ GType type = g_registered_type_info_get_g_type ((GIRegisteredTypeInfo *) interface);
+ /* FIXME: Is it right to just use v_long here? */
+ sv = gperl_convert_back_flags (type, arg->v_long);
+ break;
+ }
+
+ default:
+ ccroak ("interface_to_sv: Don't know how to handle info type %d", info_type);
+ }
+
+ g_base_info_unref ((GIBaseInfo *) interface);
+
+ return sv;
+}
diff --git a/gperl-i11n-marshal-list.c b/gperl-i11n-marshal-list.c
new file mode 100644
index 0000000..fdc1fb5
--- /dev/null
+++ b/gperl-i11n-marshal-list.c
@@ -0,0 +1,120 @@
+static SV *
+glist_to_sv (GITypeInfo* info,
+ gpointer pointer,
+ GITransfer transfer)
+{
+ GITypeInfo *param_info;
+ GITransfer item_transfer;
+ gboolean is_slist;
+ GSList *i;
+ AV *av;
+ SV *value;
+
+ if (pointer == NULL) {
+ return &PL_sv_undef;
+ }
+
+ /* FIXME: What about an array containing arrays of strings, where the
+ * outer array is GI_TRANSFER_EVERYTHING but the inner arrays are
+ * GI_TRANSFER_CONTAINER? */
+ item_transfer = transfer == GI_TRANSFER_EVERYTHING
+ ? GI_TRANSFER_EVERYTHING
+ : GI_TRANSFER_NOTHING;
+
+ param_info = g_type_info_get_param_type (info, 0);
+ dwarn (" G(S)List: pointer %p, param_info %p with type tag %d (%s)\n",
+ pointer,
+ param_info,
+ g_type_info_get_tag (param_info),
+ g_type_tag_to_string (g_type_info_get_tag (param_info)));
+
+ is_slist = GI_TYPE_TAG_GSLIST == g_type_info_get_tag (info);
+
+ av = newAV ();
+ for (i = pointer; i; i = i->next) {
+ GIArgument arg = {0,};
+ dwarn (" converting pointer %p\n", i->data);
+ arg.v_pointer = i->data;
+ value = arg_to_sv (&arg, param_info, item_transfer, NULL);
+ if (value)
+ av_push (av, value);
+ }
+
+ if (transfer >= GI_TRANSFER_CONTAINER) {
+ if (is_slist)
+ g_slist_free (pointer);
+ else
+ g_list_free (pointer);
+ }
+
+ g_base_info_unref ((GIBaseInfo *) param_info);
+
+ return newRV_noinc ((SV *) av);
+}
+
+static gpointer
+sv_to_glist (GITransfer transfer, GITypeInfo * type_info, SV * sv)
+{
+ AV *av;
+ GITransfer item_transfer;
+ gpointer list = NULL;
+ GITypeInfo *param_info;
+ gboolean is_slist;
+ gint i, length;
+
+ dwarn ("%s: sv %p\n", G_STRFUNC, sv);
+
+ if (sv == &PL_sv_undef)
+ return NULL;
+
+ if (!gperl_sv_is_array_ref (sv))
+ ccroak ("need an array ref to convert to GList");
+ av = (AV *) SvRV (sv);
+
+ item_transfer = GI_TRANSFER_NOTHING;
+ switch (transfer) {
+ case GI_TRANSFER_EVERYTHING:
+ item_transfer = GI_TRANSFER_EVERYTHING;
+ break;
+ case GI_TRANSFER_CONTAINER:
+ /* nothing special to do */
+ break;
+ case GI_TRANSFER_NOTHING:
+ /* FIXME: need to free list after call */
+ break;
+ }
+
+ param_info = g_type_info_get_param_type (type_info, 0);
+ dwarn (" G(S)List: param_info %p with type tag %d (%s) and transfer %d\n",
+ param_info,
+ g_type_info_get_tag (param_info),
+ g_type_tag_to_string (g_type_info_get_tag (param_info)),
+ transfer);
+
+ is_slist = GI_TYPE_TAG_GSLIST == g_type_info_get_tag (type_info);
+
+ length = av_len (av) + 1;
+ for (i = 0; i < length; i++) {
+ SV **svp;
+ svp = av_fetch (av, i, 0);
+ if (svp && gperl_sv_is_defined (*svp)) {
+ GIArgument arg;
+ dwarn (" converting SV %p\n", *svp);
+ /* FIXME: Is it OK to always allow undef here? */
+ sv_to_arg (*svp, &arg, NULL, param_info,
+ item_transfer, TRUE, NULL);
+ /* ENHANCEME: Could use g_[s]list_prepend and
+ * later _reverse for efficiency. */
+ if (is_slist)
+ list = g_slist_append (list, arg.v_pointer);
+ else
+ list = g_list_append (list, arg.v_pointer);
+ }
+ }
+
+ dwarn (" -> list %p of length %d\n", list, g_list_length (list));
+
+ g_base_info_unref ((GIBaseInfo *) param_info);
+
+ return list;
+}
diff --git a/gperl-i11n-marshal-raw.c b/gperl-i11n-marshal-raw.c
new file mode 100644
index 0000000..5c9e05d
--- /dev/null
+++ b/gperl-i11n-marshal-raw.c
@@ -0,0 +1,155 @@
+#define CAST_RAW(raw, type) (*((type *) raw))
+
+static void
+raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info)
+{
+ GITypeTag tag = g_type_info_get_tag (info);
+
+ switch (tag) {
+ case GI_TYPE_TAG_VOID:
+ /* do nothing */
+ break;
+
+ case GI_TYPE_TAG_BOOLEAN:
+ arg->v_boolean = CAST_RAW (raw, gboolean);
+ break;
+
+ case GI_TYPE_TAG_INT8:
+ arg->v_int8 = CAST_RAW (raw, gint8);
+ break;
+
+ case GI_TYPE_TAG_UINT8:
+ arg->v_uint8 = CAST_RAW (raw, guint8);
+ break;
+
+ case GI_TYPE_TAG_INT16:
+ arg->v_int16 = CAST_RAW (raw, gint16);
+ break;
+
+ case GI_TYPE_TAG_UINT16:
+ arg->v_uint16 = CAST_RAW (raw, guint16);
+ break;
+
+ case GI_TYPE_TAG_INT32:
+ arg->v_int32 = CAST_RAW (raw, gint32);
+ break;
+
+ case GI_TYPE_TAG_UINT32:
+ arg->v_uint32 = CAST_RAW (raw, guint32);
+ break;
+
+ case GI_TYPE_TAG_INT64:
+ arg->v_int64 = CAST_RAW (raw, gint64);
+ break;
+
+ case GI_TYPE_TAG_UINT64:
+ arg->v_uint64 = CAST_RAW (raw, guint64);
+ break;
+
+ case GI_TYPE_TAG_FLOAT:
+ arg->v_float = CAST_RAW (raw, gfloat);
+ break;
+
+ case GI_TYPE_TAG_DOUBLE:
+ arg->v_double = CAST_RAW (raw, gdouble);
+ break;
+
+ case GI_TYPE_TAG_GTYPE:
+ arg->v_size = CAST_RAW (raw, GType);
+ break;
+
+ case GI_TYPE_TAG_ARRAY:
+ case GI_TYPE_TAG_INTERFACE:
+ case GI_TYPE_TAG_GLIST:
+ case GI_TYPE_TAG_GSLIST:
+ case GI_TYPE_TAG_GHASH:
+ case GI_TYPE_TAG_ERROR:
+ arg->v_pointer = * (gpointer *) raw;
+ break;
+
+ case GI_TYPE_TAG_UTF8:
+ case GI_TYPE_TAG_FILENAME:
+ arg->v_string = * (gchar **) raw;
+ break;
+
+ default:
+ ccroak ("Unhandled info tag %d in raw_to_arg", tag);
+ }
+}
+
+static void
+arg_to_raw (GIArgument *arg, gpointer raw, GITypeInfo *info)
+{
+ GITypeTag tag = g_type_info_get_tag (info);
+
+ switch (tag) {
+ case GI_TYPE_TAG_VOID:
+ /* do nothing */
+ break;
+
+ case GI_TYPE_TAG_BOOLEAN:
+ * (gboolean *) raw = arg->v_boolean;
+ break;
+
+ case GI_TYPE_TAG_INT8:
+ * (gint8 *) raw = arg->v_int8;
+ break;
+
+ case GI_TYPE_TAG_UINT8:
+ * (guint8 *) raw = arg->v_uint8;
+ break;
+
+ case GI_TYPE_TAG_INT16:
+ * (gint16 *) raw = arg->v_int16;
+ break;
+
+ case GI_TYPE_TAG_UINT16:
+ * (guint16 *) raw = arg->v_uint16;
+ break;
+
+ case GI_TYPE_TAG_INT32:
+ * (gint32 *) raw = arg->v_int32;
+ break;
+
+ case GI_TYPE_TAG_UINT32:
+ * (guint32 *) raw = arg->v_uint32;
+ break;
+
+ case GI_TYPE_TAG_INT64:
+ * (gint64 *) raw = arg->v_int64;
+ break;
+
+ case GI_TYPE_TAG_UINT64:
+ * (guint64 *) raw = arg->v_uint64;
+ break;
+
+ case GI_TYPE_TAG_FLOAT:
+ * (gfloat *) raw = arg->v_float;
+ break;
+
+ case GI_TYPE_TAG_DOUBLE:
+ * (gdouble *) raw = arg->v_double;
+ break;
+
+ case GI_TYPE_TAG_GTYPE:
+ * (GType *) raw = arg->v_size;
+ break;
+
+ case GI_TYPE_TAG_ARRAY:
+ case GI_TYPE_TAG_INTERFACE:
+ case GI_TYPE_TAG_GLIST:
+ case GI_TYPE_TAG_GSLIST:
+ case GI_TYPE_TAG_GHASH:
+ case GI_TYPE_TAG_ERROR:
+ * (gpointer *) raw = arg->v_pointer;
+ break;
+
+ case GI_TYPE_TAG_UTF8:
+ case GI_TYPE_TAG_FILENAME:
+ * (gchar **) raw = arg->v_string;
+ break;
+
+ default:
+ ccroak ("Unhandled info tag %d in arg_to_raw", tag);
+ }
+}
diff --git a/gperl-i11n-marshal-struct.c b/gperl-i11n-marshal-struct.c
new file mode 100644
index 0000000..04a9b61
--- /dev/null
+++ b/gperl-i11n-marshal-struct.c
@@ -0,0 +1,142 @@
+static SV *
+struct_to_sv (GIBaseInfo* info,
+ GIInfoType info_type,
+ gpointer pointer,
+ gboolean own)
+{
+ HV *hv;
+
+ dwarn ("%s: pointer %p\n", G_STRFUNC, pointer);
+
+ if (pointer == NULL) {
+ return &PL_sv_undef;
+ }
+
+ hv = newHV ();
+
+ switch (info_type) {
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_STRUCT:
+ {
+ gint i, n_fields =
+ g_struct_info_get_n_fields ((GIStructInfo *) info);
+ for (i = 0; i < n_fields; i++) {
+ GIFieldInfo *field_info;
+ SV *sv;
+ field_info =
+ g_struct_info_get_field ((GIStructInfo *) info, i);
+ /* FIXME: Check GIFieldInfoFlags. */
+ /* FIXME: Is it right to use GI_TRANSFER_NOTHING
+ * here? */
+ sv = get_field (field_info, pointer,
+ GI_TRANSFER_NOTHING);
+ if (gperl_sv_is_defined (sv)) {
+ const gchar *name;
+ name = g_base_info_get_name (
+ (GIBaseInfo *) field_info);
+ gperl_hv_take_sv (hv, name, strlen (name), sv);
+ }
+ g_base_info_unref ((GIBaseInfo *) field_info);
+ }
+ break;
+ }
+
+ case GI_INFO_TYPE_UNION:
+ ccroak ("%s: unions not handled yet", G_STRFUNC);
+
+ default:
+ ccroak ("%s: unhandled info type %d", G_STRFUNC, info_type);
+ }
+
+ if (own) {
+ /* FIXME: Is it correct to just call g_free here? What if the
+ * thing was allocated via GSlice? */
+ g_free (pointer);
+ }
+
+ return newRV_noinc ((SV *) hv);
+}
+
+static gpointer
+sv_to_struct (GITransfer transfer,
+ GIBaseInfo * info,
+ GIInfoType info_type,
+ SV * sv)
+{
+ HV *hv;
+ gsize size = 0;
+ GITransfer field_transfer;
+ gpointer pointer = NULL;
+
+ dwarn ("%s: sv %p\n", G_STRFUNC, sv);
+
+ if (!gperl_sv_is_hash_ref (sv))
+ ccroak ("need a hash ref to convert to struct of type %s",
+ g_base_info_get_name (info));
+ hv = (HV *) SvRV (sv);
+
+ switch (info_type) {
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_STRUCT:
+ size = g_struct_info_get_size ((GIStructInfo *) info);
+ break;
+ case GI_INFO_TYPE_UNION:
+ size = g_union_info_get_size ((GIStructInfo *) info);
+ break;
+ default:
+ g_assert_not_reached ();
+ }
+
+ dwarn (" size: %d\n", size);
+
+ field_transfer = GI_TRANSFER_NOTHING;
+ dwarn (" transfer: %d\n", transfer);
+ switch (transfer) {
+ case GI_TRANSFER_EVERYTHING:
+ field_transfer = GI_TRANSFER_EVERYTHING;
+ /* fall through */
+ case GI_TRANSFER_CONTAINER:
+ /* FIXME: What if there's a special allocator for the record?
+ * Like GSlice? */
+ pointer = g_malloc0 (size);
+ break;
+
+ default:
+ pointer = gperl_alloc_temp (size);
+ break;
+ }
+
+ switch (info_type) {
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_STRUCT:
+ {
+ gint i, n_fields =
+ g_struct_info_get_n_fields ((GIStructInfo *) info);
+ for (i = 0; i < n_fields; i++) {
+ GIFieldInfo *field_info;
+ const gchar *field_name;
+ SV **svp;
+ field_info = g_struct_info_get_field (
+ (GIStructInfo *) info, i);
+ /* FIXME: Check GIFieldInfoFlags. */
+ field_name = g_base_info_get_name (
+ (GIBaseInfo *) field_info);
+ svp = hv_fetch (hv, field_name, strlen (field_name), 0);
+ if (svp && gperl_sv_is_defined (*svp)) {
+ set_field (field_info, pointer,
+ field_transfer, *svp);
+ }
+ g_base_info_unref ((GIBaseInfo *) field_info);
+ }
+ break;
+ }
+
+ case GI_INFO_TYPE_UNION:
+ ccroak ("%s: unions not handled yet", G_STRFUNC);
+
+ default:
+ ccroak ("%s: unhandled info type %d", G_STRFUNC, info_type);
+ }
+
+ return pointer;
+}
diff --git a/gperl-i11n-method.c b/gperl-i11n-method.c
new file mode 100644
index 0000000..d8d0d77
--- /dev/null
+++ b/gperl-i11n-method.c
@@ -0,0 +1,120 @@
+static void
+store_methods (HV *namespaced_functions, GIBaseInfo *info, GIInfoType info_type)
+{
+ const gchar *namespace;
+ AV *av;
+ gint i;
+
+ namespace = g_base_info_get_name (info);
+ av = newAV ();
+
+ switch (info_type) {
+ case GI_INFO_TYPE_OBJECT:
+ {
+ gint n_methods = g_object_info_get_n_methods (
+ (GIObjectInfo *) info);
+ for (i = 0; i < n_methods; i++) {
+ GIFunctionInfo *function_info =
+ g_object_info_get_method (
+ (GIObjectInfo *) info, i);
+ const gchar *function_name =
+ g_base_info_get_name (
+ (GIBaseInfo *) function_info);
+ av_push (av, newSVpv (function_name, PL_na));
+ g_base_info_unref ((GIBaseInfo *) function_info);
+ }
+ break;
+ }
+
+ case GI_INFO_TYPE_INTERFACE:
+ {
+ gint n_methods = g_interface_info_get_n_methods (
+ (GIInterfaceInfo *) info);
+ for (i = 0; i < n_methods; i++) {
+ GIFunctionInfo *function_info =
+ g_interface_info_get_method (
+ (GIInterfaceInfo *) info, i);
+ const gchar *function_name =
+ g_base_info_get_name (
+ (GIBaseInfo *) function_info);
+ av_push (av, newSVpv (function_name, PL_na));
+ g_base_info_unref ((GIBaseInfo *) function_info);
+ }
+ break;
+ }
+
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_STRUCT:
+ {
+ gint n_methods = g_struct_info_get_n_methods (
+ (GIStructInfo *) info);
+ for (i = 0; i < n_methods; i++) {
+ GIFunctionInfo *function_info =
+ g_struct_info_get_method (
+ (GIStructInfo *) info, i);
+ const gchar *function_name =
+ g_base_info_get_name (
+ (GIBaseInfo *) function_info);
+ av_push (av, newSVpv (function_name, PL_na));
+ g_base_info_unref ((GIBaseInfo *) function_info);
+ }
+ break;
+ }
+
+ case GI_INFO_TYPE_UNION:
+ {
+ gint n_methods = g_union_info_get_n_methods ((GIUnionInfo *) info);
+ for (i = 0; i < n_methods; i++) {
+ GIFunctionInfo *function_info;
+ const gchar *function_name;
+
+ function_info = g_union_info_get_method ((GIUnionInfo *) info, i);
+ function_name = g_base_info_get_name ((GIBaseInfo *) function_info);
+
+ av_push (av, newSVpv (function_name, PL_na));
+ g_base_info_unref ((GIBaseInfo *) function_info);
+ }
+ break;
+ }
+
+ default:
+ ccroak ("store_methods: unsupported info type %d", info_type);
+ }
+
+ gperl_hv_take_sv (namespaced_functions, namespace, strlen (namespace),
+ newRV_noinc ((SV *) av));
+}
+
+/* ------------------------------------------------------------------------- */
+
+static void
+store_vfuncs (HV *objects_with_vfuncs, GIObjectInfo *info)
+{
+ const gchar *object_name;
+ AV *vfuncs_av;
+ gint n_vfuncs, i;
+
+ n_vfuncs = g_object_info_get_n_vfuncs (info);
+ if (n_vfuncs <= 0)
+ return;
+
+ object_name = g_base_info_get_name (info);
+ vfuncs_av = newAV ();
+
+ for (i = 0; i < n_vfuncs; i++) {
+ GIVFuncInfo *vfunc_info =
+ g_object_info_get_vfunc (info, i);
+ const gchar *vfunc_name =
+ g_base_info_get_name (vfunc_info);
+ gchar *vfunc_perl_name = g_ascii_strup (vfunc_name, -1);
+ AV *vfunc_av = newAV ();
+ av_push (vfunc_av, newSVpv (vfunc_name, PL_na));
+ av_push (vfunc_av, newSVpv (vfunc_perl_name, PL_na));
+ av_push (vfuncs_av, newRV_noinc ((SV *) vfunc_av));
+ g_free (vfunc_perl_name);
+ g_base_info_unref (vfunc_info);
+ }
+
+ gperl_hv_take_sv (objects_with_vfuncs, object_name, strlen (object_name),
+ newRV_noinc ((SV *) vfuncs_av));
+}
diff --git a/gperl-i11n-size.c b/gperl-i11n-size.c
new file mode 100644
index 0000000..11068be
--- /dev/null
+++ b/gperl-i11n-size.c
@@ -0,0 +1,152 @@
+/* These three are basically copied from pygi's pygi-info.c. :-( */
+
+static gsize
+size_of_type_tag (GITypeTag type_tag)
+{
+ switch(type_tag) {
+ case GI_TYPE_TAG_BOOLEAN:
+ return sizeof (gboolean);
+ case GI_TYPE_TAG_INT8:
+ case GI_TYPE_TAG_UINT8:
+ return sizeof (gint8);
+ case GI_TYPE_TAG_INT16:
+ case GI_TYPE_TAG_UINT16:
+ return sizeof (gint16);
+ case GI_TYPE_TAG_INT32:
+ case GI_TYPE_TAG_UINT32:
+ return sizeof (gint32);
+ case GI_TYPE_TAG_INT64:
+ case GI_TYPE_TAG_UINT64:
+ return sizeof (gint64);
+ case GI_TYPE_TAG_FLOAT:
+ return sizeof (gfloat);
+ case GI_TYPE_TAG_DOUBLE:
+ return sizeof (gdouble);
+ case GI_TYPE_TAG_GTYPE:
+ return sizeof (GType);
+ case GI_TYPE_TAG_UNICHAR:
+ return sizeof (gunichar);
+
+ case GI_TYPE_TAG_VOID:
+ case GI_TYPE_TAG_UTF8:
+ case GI_TYPE_TAG_FILENAME:
+ case GI_TYPE_TAG_ARRAY:
+ case GI_TYPE_TAG_INTERFACE:
+ case GI_TYPE_TAG_GLIST:
+ case GI_TYPE_TAG_GSLIST:
+ case GI_TYPE_TAG_GHASH:
+ case GI_TYPE_TAG_ERROR:
+ ccroak ("Unable to determine the size of '%s'",
+ g_type_tag_to_string (type_tag));
+ break;
+ }
+
+ return 0;
+}
+
+static gsize
+size_of_interface (GITypeInfo *type_info)
+{
+ gsize size = 0;
+
+ GIBaseInfo *info;
+ GIInfoType info_type;
+
+ info = g_type_info_get_interface (type_info);
+ info_type = g_base_info_get_type (info);
+
+ switch (info_type) {
+ case GI_INFO_TYPE_STRUCT:
+ if (g_type_info_is_pointer (type_info)) {
+ size = sizeof (gpointer);
+ } else {
+ /* FIXME: Remove this workaround once
+ * gobject-introspection is fixed:
+ * <https://bugzilla.gnome.org/show_bug.cgi?id=657040>. */
+ GType type = g_registered_type_info_get_g_type (info);
+ if (type == G_TYPE_VALUE) {
+ size = sizeof (GValue);
+ } else {
+ size = g_struct_info_get_size ((GIStructInfo *) info);
+ }
+ }
+ break;
+
+ case GI_INFO_TYPE_UNION:
+ if (g_type_info_is_pointer (type_info)) {
+ size = sizeof (gpointer);
+ } else {
+ size = g_union_info_get_size ((GIUnionInfo *) info);
+ }
+ break;
+
+ case GI_INFO_TYPE_ENUM:
+ case GI_INFO_TYPE_FLAGS:
+ if (g_type_info_is_pointer (type_info)) {
+ size = sizeof (gpointer);
+ } else {
+ GITypeTag type_tag;
+ type_tag = g_enum_info_get_storage_type ((GIEnumInfo *) info);
+ size = size_of_type_tag (type_tag);
+ }
+ break;
+
+ case GI_INFO_TYPE_BOXED:
+ case GI_INFO_TYPE_OBJECT:
+ case GI_INFO_TYPE_INTERFACE:
+ case GI_INFO_TYPE_CALLBACK:
+ size = sizeof (gpointer);
+ break;
+
+ default:
+ g_assert_not_reached ();
+ break;
+ }
+
+ g_base_info_unref (info);
+
+ return size;
+}
+
+static gsize
+size_of_type_info (GITypeInfo *type_info)
+{
+ GITypeTag type_tag;
+
+ type_tag = g_type_info_get_tag (type_info);
+ switch (type_tag) {
+ case GI_TYPE_TAG_BOOLEAN:
+ case GI_TYPE_TAG_INT8:
+ case GI_TYPE_TAG_UINT8:
+ case GI_TYPE_TAG_INT16:
+ case GI_TYPE_TAG_UINT16:
+ case GI_TYPE_TAG_INT32:
+ case GI_TYPE_TAG_UINT32:
+ case GI_TYPE_TAG_INT64:
+ case GI_TYPE_TAG_UINT64:
+ case GI_TYPE_TAG_FLOAT:
+ case GI_TYPE_TAG_DOUBLE:
+ case GI_TYPE_TAG_GTYPE:
+ case GI_TYPE_TAG_UNICHAR:
+ if (g_type_info_is_pointer (type_info)) {
+ return sizeof (gpointer);
+ } else {
+ return size_of_type_tag (type_tag);
+ }
+
+ case GI_TYPE_TAG_INTERFACE:
+ return size_of_interface (type_info);
+
+ case GI_TYPE_TAG_ARRAY:
+ case GI_TYPE_TAG_VOID:
+ case GI_TYPE_TAG_UTF8:
+ case GI_TYPE_TAG_FILENAME:
+ case GI_TYPE_TAG_GLIST:
+ case GI_TYPE_TAG_GSLIST:
+ case GI_TYPE_TAG_GHASH:
+ case GI_TYPE_TAG_ERROR:
+ return sizeof (gpointer);
+ }
+
+ return 0;
+}
diff --git a/gperl-i11n-vfunc-interface.c b/gperl-i11n-vfunc-interface.c
new file mode 100644
index 0000000..dfa456f
--- /dev/null
+++ b/gperl-i11n-vfunc-interface.c
@@ -0,0 +1,50 @@
+static void
+generic_interface_init (gpointer iface, gpointer data)
+{
+ GIInterfaceInfo *info = data;
+ GIStructInfo *struct_info;
+ gint n, i;
+ struct_info = g_interface_info_get_iface_struct (info);
+ n = g_interface_info_get_n_vfuncs (info);
+ for (i = 0; i < n; i++) {
+ GIVFuncInfo *vfunc_info;
+ const gchar *vfunc_name;
+ GIFieldInfo *field_info;
+ gint field_offset;
+ GITypeInfo *field_type_info;
+ gchar *perl_method_name;
+ GPerlI11nCallbackInfo *callback_info;
+
+ vfunc_info = g_interface_info_get_vfunc (info, i);
+ vfunc_name = g_base_info_get_name (vfunc_info);
+
+ /* FIXME: g_vfunc_info_get_offset does not seem to work here. */
+ field_info = get_field_info (struct_info, vfunc_name);
+ g_assert (field_info);
+ field_offset = g_field_info_get_offset (field_info);
+ field_type_info = g_field_info_get_type (field_info);
+
+ perl_method_name = g_ascii_strup (vfunc_name, -1);
+ callback_info = create_callback_closure_for_named_sub (
+ field_type_info, perl_method_name, NULL);
+ dwarn ("installing vfunc %s as %s at offset %d (vs. %d) inside %p\n",
+ vfunc_name, perl_method_name,
+ field_offset, g_vfunc_info_get_offset (vfunc_info),
+ iface);
+ G_STRUCT_MEMBER (gpointer, iface, field_offset) = callback_info->closure;
+
+ g_base_info_unref (field_type_info);
+ g_base_info_unref (field_info);
+ g_base_info_unref (vfunc_info);
+ }
+ g_base_info_unref (struct_info);
+}
+
+static void
+generic_interface_finalize (gpointer iface, gpointer data)
+{
+ GIInterfaceInfo *info = data;
+ PERL_UNUSED_VAR (iface);
+ dwarn ("releasing interface info\n");
+ g_base_info_unref ((GIBaseInfo *) info);
+}
diff --git a/gperl-i11n-vfunc-object.c b/gperl-i11n-vfunc-object.c
new file mode 100644
index 0000000..ab1adee
--- /dev/null
+++ b/gperl-i11n-vfunc-object.c
@@ -0,0 +1,40 @@
+static void
+generic_class_init (GIObjectInfo *info, const gchar *target_package, gpointer class)
+{
+ GIStructInfo *struct_info;
+ gint n, i;
+ struct_info = g_object_info_get_class_struct (info);
+ n = g_object_info_get_n_vfuncs (info);
+ for (i = 0; i < n; i++) {
+ GIVFuncInfo *vfunc_info;
+ const gchar *vfunc_name;
+ GIFieldInfo *field_info;
+ gint field_offset;
+ GITypeInfo *field_type_info;
+ gchar *perl_method_name;
+ GPerlI11nCallbackInfo *callback_info;
+
+ vfunc_info = g_object_info_get_vfunc (info, i);
+ vfunc_name = g_base_info_get_name (vfunc_info);
+
+ /* FIXME: g_vfunc_info_get_offset does not seem to work here. */
+ field_info = get_field_info (struct_info, vfunc_name);
+ g_assert (field_info);
+ field_offset = g_field_info_get_offset (field_info);
+ field_type_info = g_field_info_get_type (field_info);
+
+ perl_method_name = g_ascii_strup (vfunc_name, -1);
+ callback_info = create_callback_closure_for_named_sub (
+ field_type_info, perl_method_name, g_strdup (target_package));
+ dwarn ("installing vfunc %s as %s at offset %d (vs. %d) inside %p\n",
+ vfunc_name, perl_method_name,
+ field_offset, g_vfunc_info_get_offset (vfunc_info),
+ class);
+ G_STRUCT_MEMBER (gpointer, class, field_offset) = callback_info->closure;
+
+ g_base_info_unref (field_type_info);
+ g_base_info_unref (field_info);
+ g_base_info_unref (vfunc_info);
+ }
+ g_base_info_unref (struct_info);
+}
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
