[perl-Glib-Object-Introspection] Add support for callbacks in callbacks
- From: Torsten SchÃnfeld <tsch src gnome org>
- To: commits-list gnome org
- Cc:
- Subject: [perl-Glib-Object-Introspection] Add support for callbacks in callbacks
- Date: Thu, 13 Oct 2011 20:42:26 +0000 (UTC)
commit de18ea0a0fdc7b7b7394772e99846b1917f7f2d8
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date: Thu Oct 13 21:22:32 2011 +0200
Add support for callbacks in callbacks
As in GtkCellLayout.set_cell_data_func, for example.
GObjectIntrospection.xs | 92 ++++++++++++++++++----
Makefile.PL | 2 +-
gperl-i11n-callback.c | 71 ++++++++++++++----
gperl-i11n-invoke-c.c | 66 +++++++++++++++-
gperl-i11n-invoke-info.c | 149 ++++++++++++++++++++---------------
gperl-i11n-invoke-perl.c | 88 +++++++++------------
gperl-i11n-marshal-arg.c | 13 ++-
gperl-i11n-marshal-callback.c | 160 +++++++++++++++++++++++++++++++------
gperl-i11n-marshal-interface.c | 14 +++-
gperl-i11n-marshal-raw.c | 10 ++-
gperl-i11n-vfunc-interface.c | 4 +-
gperl-i11n-vfunc-object.c | 4 +-
lib/Glib/Object/Introspection.pm | 13 +++-
13 files changed, 495 insertions(+), 191 deletions(-)
---
diff --git a/GObjectIntrospection.xs b/GObjectIntrospection.xs
index 4cc9722..e918282 100644
--- a/GObjectIntrospection.xs
+++ b/GObjectIntrospection.xs
@@ -42,21 +42,42 @@ typedef struct {
gchar *sub_name;
guint data_pos;
- guint notify_pos;
+ guint destroy_pos;
gboolean free_after_use;
gpointer priv; /* perl context */
-} GPerlI11nCallbackInfo;
+} GPerlI11nPerlCallbackInfo;
+
+typedef struct {
+ GICallableInfo *interface;
+
+ gpointer func;
+ gpointer data;
+ GDestroyNotify destroy;
+
+ guint data_pos;
+ guint destroy_pos;
+
+ SV *data_sv;
+
+ gboolean free_after_use;
+} GPerlI11nCCallbackInfo;
typedef struct {
gsize length;
guint length_pos;
} GPerlI11nArrayInfo;
-/* This stores information that one call to sv_to_arg needs to make available
- * to later calls of sv_to_arg. */
+/* This stores information that the different marshallers might need to
+ * communicate to each other. */
typedef struct {
+ GICallableInfo *interface;
+
+ gboolean is_function;
+ gboolean is_vfunc;
+ gboolean is_callback;
+
guint n_args;
guint n_invoke_args;
guint n_given_args;
@@ -89,10 +110,14 @@ typedef struct {
} GPerlI11nInvocationInfo;
/* callbacks */
-static GPerlI11nCallbackInfo* create_callback_closure (GITypeInfo *cb_type, SV *code);
-static void attach_callback_data (GPerlI11nCallbackInfo *info, SV *data);
-static GPerlI11nCallbackInfo * create_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name);
-static void release_callback (gpointer data);
+static GPerlI11nPerlCallbackInfo * create_perl_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name);
+static GPerlI11nPerlCallbackInfo * create_perl_callback_closure (GITypeInfo *cb_type, SV *code);
+static void attach_perl_callback_data (GPerlI11nPerlCallbackInfo *info, SV *data);
+static void release_perl_callback (gpointer data);
+
+static GPerlI11nCCallbackInfo * create_c_callback_closure (GIBaseInfo *interface, gpointer func);
+static void attach_c_callback_data (GPerlI11nCCallbackInfo *info, gpointer data);
+static void release_c_callback (gpointer data);
/* invocation */
static void invoke_callback (ffi_cif* cif,
@@ -104,18 +129,22 @@ static 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);
+/* invocation info */
+static void prepare_c_invocation_info (GPerlI11nInvocationInfo *iinfo,
+ GICallableInfo *info,
+ IV items,
+ UV internal_stack_offset);
+static void clear_c_invocation_info (GPerlI11nInvocationInfo *iinfo);
+
+static void prepare_perl_invocation_info (GPerlI11nInvocationInfo *iinfo,
+ GICallableInfo *info);
+static void clear_perl_invocation_info (GPerlI11nInvocationInfo *iinfo);
+
/* info finders */
static GIFunctionInfo * get_function_info (GIRepository *repository,
const gchar *basename,
@@ -127,7 +156,8 @@ static GIFieldInfo * get_field_info (GIBaseInfo *info,
/* marshallers */
static SV * interface_to_sv (GITypeInfo* info,
GIArgument *arg,
- gboolean own);
+ gboolean own,
+ GPerlI11nInvocationInfo *iinfo);
static void sv_to_interface (GIArgInfo * arg_info,
GITypeInfo * type_info,
GITransfer transfer,
@@ -152,6 +182,9 @@ static SV * arg_to_sv (GIArgument * arg,
static gpointer sv_to_callback (GIArgInfo * arg_info, GITypeInfo * type_info, SV * sv, GPerlI11nInvocationInfo * invocation_info);
static gpointer sv_to_callback_data (SV * sv, GPerlI11nInvocationInfo * invocation_info);
+static SV * callback_to_sv (GICallableInfo *interface, gpointer func, GPerlI11nInvocationInfo *invocation_info);
+static SV * callback_data_to_sv (gpointer data, GPerlI11nInvocationInfo * invocation_info);
+
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);
@@ -640,3 +673,30 @@ DESTROY (SV *sv)
v = SvGValueWrapper (sv);
g_value_unset (v);
g_free (v);
+
+# --------------------------------------------------------------------------- #
+
+MODULE = Glib::Object::Introspection PACKAGE = Glib::Object::Introspection::_FuncWrapper
+
+void
+_invoke (SV *code, ...)
+ PREINIT:
+ GPerlI11nCCallbackInfo *wrapper;
+ UV internal_stack_offset = 1;
+ CODE:
+ wrapper = INT2PTR (GPerlI11nCCallbackInfo*, SvIV (SvRV (code)));
+ if (!wrapper || !wrapper->func)
+ ccroak ("invalid reference encountered");
+ invoke_callable (wrapper->interface, wrapper->func,
+ sp, ax, mark, items,
+ internal_stack_offset);
+ /* wrapper->func (cell_layout, cell, tree_model, iter, wrapper->data); */
+
+void
+DESTROY (SV *code)
+ PREINIT:
+ GPerlI11nCCallbackInfo *info;
+ CODE:
+ info = INT2PTR (GPerlI11nCCallbackInfo*, SvIV (SvRV (code)));
+ if (info)
+ release_c_callback (info);
diff --git a/Makefile.PL b/Makefile.PL
index 7cca5b6..6233f1e 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -93,7 +93,7 @@ WriteMakefile(
configure_requires => \%PREREQ_PM,
no_index => {
file => \ xs_files,
- package => 'MY',
+ package => [ 'MY', 'Glib::Object::Introspection::_FuncWrapper' ],
},
},
diff --git a/gperl-i11n-callback.c b/gperl-i11n-callback.c
index 455033e..50ab579 100644
--- a/gperl-i11n-callback.c
+++ b/gperl-i11n-callback.c
@@ -1,11 +1,14 @@
/* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */
-static GPerlI11nCallbackInfo *
-create_callback_closure (GITypeInfo *cb_type, SV *code)
+static GPerlI11nPerlCallbackInfo *
+create_perl_callback_closure (GITypeInfo *cb_type, SV *code)
{
- GPerlI11nCallbackInfo *info;
+ GPerlI11nPerlCallbackInfo *info;
+
+ info = g_new0 (GPerlI11nPerlCallbackInfo, 1);
+ if (code == &PL_sv_undef)
+ return info;
- info = g_new0 (GPerlI11nCallbackInfo, 1);
info->interface =
(GICallableInfo *) g_type_info_get_interface (cb_type);
info->cif = g_new0 (ffi_cif, 1);
@@ -25,18 +28,19 @@ create_callback_closure (GITypeInfo *cb_type, SV *code)
}
static void
-attach_callback_data (GPerlI11nCallbackInfo *info, SV *data)
+attach_perl_callback_data (GPerlI11nPerlCallbackInfo *info, SV *data)
{
+ /* FIXME: SvREFCNT_inc? */
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)
+/* assumes ownership of sub_name */
+static GPerlI11nPerlCallbackInfo *
+create_perl_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name)
{
- GPerlI11nCallbackInfo *info;
+ GPerlI11nPerlCallbackInfo *info;
- info = g_new0 (GPerlI11nCallbackInfo, 1);
+ info = g_new0 (GPerlI11nPerlCallbackInfo, 1);
info->interface =
(GICallableInfo *) g_type_info_get_interface (cb_type);
info->cif = g_new0 (ffi_cif, 1);
@@ -55,14 +59,13 @@ create_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name)
}
static void
-release_callback (gpointer data)
+release_perl_callback (gpointer data)
{
- GPerlI11nCallbackInfo *info = data;
- dwarn ("releasing callback info %p\n", info);
+ GPerlI11nPerlCallbackInfo *info = data;
+ dwarn ("releasing Perl callback info %p\n", info);
if (info->cif)
g_free (info->cif);
-
if (info->closure)
g_callable_info_free_closure (info->interface, info->closure);
@@ -78,3 +81,43 @@ release_callback (gpointer data)
g_free (info);
}
+
+static GPerlI11nCCallbackInfo *
+create_c_callback_closure (GIBaseInfo *interface, gpointer func)
+{
+ GPerlI11nCCallbackInfo *info;
+
+ info = g_new0 (GPerlI11nCCallbackInfo, 1);
+ if (!func)
+ return info;
+
+ info->interface = interface;
+ g_base_info_ref (interface);
+ info->func = func;
+
+ return info;
+}
+
+static void
+attach_c_callback_data (GPerlI11nCCallbackInfo *info, gpointer data)
+{
+ info->data = data;
+}
+
+static void
+release_c_callback (gpointer data)
+{
+ GPerlI11nCCallbackInfo *info = data;
+ dwarn ("releasing C callback info %p\n", info);
+
+ /* FIXME: we cannot call the destroy notify here because it might be
+ * our own release_perl_callback which would try to free the ffi stuff
+ * that is currently running. */
+ /* if (info->destroy) */
+ /* info->destroy (info->data); */
+
+ if (info->interface)
+ g_base_info_unref (info->interface);
+
+ g_free (info);
+}
diff --git a/gperl-i11n-invoke-c.c b/gperl-i11n-invoke-c.c
index cee57e1..fb2921c 100644
--- a/gperl-i11n-invoke-c.c
+++ b/gperl-i11n-invoke-c.c
@@ -17,7 +17,7 @@ invoke_callable (GICallableInfo *info,
PERL_UNUSED_VAR (mark);
- prepare_invocation_info (&iinfo, info, items, internal_stack_offset);
+ prepare_c_invocation_info (&iinfo, info, items, internal_stack_offset);
if (iinfo.is_method) {
instance = instance_sv_to_pointer (info, ST (0 + iinfo.stack_offset));
@@ -156,7 +156,7 @@ invoke_callable (GICallableInfo *info,
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);
+ clear_c_invocation_info (&iinfo);
ccroak ("Could not prepare a call interface");
}
@@ -164,7 +164,7 @@ invoke_callable (GICallableInfo *info,
/* free call-scoped callback infos */
g_slist_foreach (iinfo.free_after_call,
- (GFunc) release_callback, NULL);
+ (GFunc) release_perl_callback, NULL);
if (local_error) {
gperl_croak_gerror (NULL, local_error);
@@ -232,9 +232,67 @@ invoke_callable (GICallableInfo *info,
g_base_info_unref ((GIBaseInfo *) arg_info);
}
- clear_invocation_info (&iinfo);
+ clear_c_invocation_info (&iinfo);
dwarn (" number of return values: %d\n", n_return_values);
PUTBACK;
}
+
+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) {
+ GPerlI11nPerlCallbackInfo *cinfo = l->data;
+ if (pos == cinfo->destroy_pos) {
+ dwarn (" setting automatic arg %d (destroy notify for calllback %p)\n",
+ pos, cinfo);
+ arg->v_pointer = release_perl_callback;
+ return;
+ }
+ }
+
+ ccroak ("Could not handle automatic arg %d", pos);
+}
+
+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;
+ }
+}
diff --git a/gperl-i11n-invoke-info.c b/gperl-i11n-invoke-info.c
index f9dca94..86fb5ea 100644
--- a/gperl-i11n-invoke-info.c
+++ b/gperl-i11n-invoke-info.c
@@ -1,21 +1,33 @@
/* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */
static void
-prepare_invocation_info (GPerlI11nInvocationInfo *iinfo,
- GICallableInfo *info,
- IV items,
- UV internal_stack_offset)
+prepare_c_invocation_info (GPerlI11nInvocationInfo *iinfo,
+ GICallableInfo *info,
+ IV items,
+ UV internal_stack_offset)
{
- gboolean is_vfunc;
guint i;
- is_vfunc = GI_IS_VFUNC_INFO (info);
+ dwarn ("C invoke: %s\n"
+ " n_args: %d\n",
+ g_base_info_get_name (info),
+ g_callable_info_get_n_args (info));
+
+ iinfo->interface = info;
+
+ iinfo->is_function = GI_IS_FUNCTION_INFO (info);
+ iinfo->is_vfunc = GI_IS_VFUNC_INFO (info);
+ iinfo->is_callback = (g_base_info_get_type (info) == GI_INFO_TYPE_CALLBACK);
+ dwarn (" is_function = %d, is_vfunc = %d, is_callback = %d\n",
+ iinfo->is_function, iinfo->is_vfunc, iinfo->is_callback);
iinfo->stack_offset = internal_stack_offset;
- iinfo->is_constructor = is_vfunc
- ? FALSE
- : g_function_info_get_flags (info) & GI_FUNCTION_IS_CONSTRUCTOR;
+ iinfo->is_constructor = FALSE;
+ if (iinfo->is_function) {
+ iinfo->is_constructor =
+ g_function_info_get_flags (info) & GI_FUNCTION_IS_CONSTRUCTOR;
+ }
if (iinfo->is_constructor) {
iinfo->stack_offset++;
}
@@ -26,15 +38,19 @@ prepare_invocation_info (GPerlI11nInvocationInfo *iinfo,
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;
+ iinfo->throws = FALSE;
+ if (iinfo->is_function) {
+ iinfo->throws =
+ g_function_info_get_flags (info) & GI_FUNCTION_THROWS;
+ }
if (iinfo->throws) {
iinfo->n_invoke_args++;
}
- if (is_vfunc) {
+ if (iinfo->is_vfunc) {
iinfo->is_method = TRUE;
+ } else if (iinfo->is_callback) {
+ iinfo->is_method = FALSE;
} else {
iinfo->is_method =
(g_function_info_get_flags (info) & GI_FUNCTION_IS_METHOD)
@@ -44,7 +60,7 @@ prepare_invocation_info (GPerlI11nInvocationInfo *iinfo,
iinfo->n_invoke_args++;
}
- dwarn ("invoke: %s\n"
+ dwarn ("C 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),
@@ -140,7 +156,7 @@ prepare_invocation_info (GPerlI11nInvocationInfo *iinfo,
}
static void
-clear_invocation_info (GPerlI11nInvocationInfo *iinfo)
+clear_c_invocation_info (GPerlI11nInvocationInfo *iinfo)
{
g_slist_free (iinfo->free_after_call);
@@ -154,60 +170,67 @@ clear_invocation_info (GPerlI11nInvocationInfo *iinfo)
g_base_info_unref ((GIBaseInfo *) iinfo->return_type_info);
}
-static gpointer
-allocate_out_mem (GITypeInfo *arg_type)
+/* -------------------------------------------------------------------------- */
+
+static void
+prepare_perl_invocation_info (GPerlI11nInvocationInfo *iinfo,
+ GICallableInfo *info)
{
- 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;
+ /* when invoking Perl code, we currently always use a complete
+ * description of the callable (from a record field or some callback
+ * typedef). this implies that there is no implicit invocant; it
+ * always appears explicitly in the arg list. */
+
+ dwarn ("Perl invoke: %s\n"
+ " n_args: %d\n",
+ g_base_info_get_name (info),
+ g_callable_info_get_n_args (info));
+
+ iinfo->interface = info;
+
+ iinfo->is_function = GI_IS_FUNCTION_INFO (info);
+ iinfo->is_vfunc = GI_IS_VFUNC_INFO (info);
+ iinfo->is_callback = (g_base_info_get_type (info) == GI_INFO_TYPE_CALLBACK);
+ dwarn (" is_function = %d, is_vfunc = %d, is_callback = %d\n",
+ iinfo->is_function, iinfo->is_vfunc, iinfo->is_callback);
+
+ iinfo->n_args = g_callable_info_get_n_args (info);
+
+ /* FIXME: 'throws'? */
+
+ iinfo->return_type_info = g_callable_info_get_return_type (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 (info);
+
+ iinfo->dynamic_stack_offset = 0;
+
+ /* If the callback is supposed to return a GInitiallyUnowned object
+ * then we must enforce GI_TRANSFER_EVERYTHING. Otherwise, if the Perl
+ * code returns a newly created object, FREETMPS would finalize it. */
+ if (g_type_info_get_tag (iinfo->return_type_info) == GI_TYPE_TAG_INTERFACE &&
+ iinfo->return_type_transfer == GI_TRANSFER_NOTHING)
+ {
+ 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 (interface);
}
}
static void
-handle_automatic_arg (guint pos,
- GIArgument * arg,
- GPerlI11nInvocationInfo * invocation_info)
+clear_perl_invocation_info (GPerlI11nInvocationInfo *iinfo)
{
- 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;
- }
- }
+ g_slist_free (iinfo->free_after_call);
- /* 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;
- }
- }
+ /* The actual callback infos might be needed later, so we cannot free
+ * them here. */
+ g_slist_free (iinfo->callback_infos);
- ccroak ("Could not handle automatic arg %d", pos);
+ g_base_info_unref ((GIBaseInfo *) iinfo->return_type_info);
}
diff --git a/gperl-i11n-invoke-perl.c b/gperl-i11n-invoke-perl.c
index 94b02ba..f718fa8 100644
--- a/gperl-i11n-invoke-perl.c
+++ b/gperl-i11n-invoke-perl.c
@@ -3,22 +3,23 @@
static void
invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
{
- GPerlI11nCallbackInfo *info;
+ GPerlI11nPerlCallbackInfo *info;
GICallableInfo *cb_interface;
- int n_args, i;
- int in_inout;
- GITypeInfo *return_type;
- gboolean have_return_type;
- int n_return_values, n_returned;
+ GPerlI11nInvocationInfo iinfo = {0,};
+ guint i;
+ guint in_inout;
+ guint n_return_values, n_returned;
I32 context;
dGPERL_CALLBACK_MARSHAL_SP;
PERL_UNUSED_VAR (cif);
/* unwrap callback info struct from userdata */
- info = (GPerlI11nCallbackInfo *) userdata;
+ info = (GPerlI11nPerlCallbackInfo *) userdata;
cb_interface = (GICallableInfo *) info->interface;
+ prepare_perl_invocation_info (&iinfo, cb_interface);
+
/* set perl context */
GPERL_CALLBACK_MARSHAL_INIT (info);
@@ -32,28 +33,29 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
* 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++) {
+ for (i = 0; i < iinfo.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);
+ iinfo.current_pos = i;
+
/* the closure argument, which we handle separately, is marked
* by having get_closure == i */
- if (g_arg_info_get_closure (arg_info) == i) {
+ if (g_arg_info_get_closure (arg_info) == (gint) i) {
g_base_info_unref ((GIBaseInfo *) arg_info);
g_base_info_unref ((GIBaseInfo *) arg_type);
continue;
}
- dwarn ("arg info: %p\n"
+ dwarn ("arg info: %s (%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_base_info_get_name (arg_info), arg_info,
g_arg_info_get_direction (arg_info),
g_arg_info_is_return_value (arg_info),
g_arg_info_is_optional (arg_info),
@@ -62,17 +64,23 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
dwarn ("arg type: %p\n"
" is pointer: %d\n"
- " tag: %d\n",
+ " tag: %s (%d)\n",
arg_type,
g_type_info_is_pointer (arg_type),
- g_type_info_get_tag (arg_type));
+ g_type_tag_to_string (g_type_info_get_tag (arg_type)), g_type_info_get_tag (arg_type));
if (direction == GI_DIRECTION_IN ||
direction == GI_DIRECTION_INOUT)
{
GIArgument arg;
+ SV *sv;
raw_to_arg (args[i], &arg, arg_type);
- XPUSHs (sv_2mortal (arg_to_sv (&arg, arg_type, transfer, NULL)));
+ sv = arg_to_sv (&arg, arg_type, transfer, &iinfo);
+ /* If arg_to_sv returns NULL, we take that as 'skip
+ * this argument'; happens for GDestroyNotify, for
+ * example. */
+ if (sv)
+ XPUSHs (sv_2mortal (sv));
}
if (direction == GI_DIRECTION_INOUT ||
@@ -91,14 +99,9 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
PUTBACK;
- /* 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);
-
+ /* determine suitable Perl call context */
context = G_VOID | G_DISCARD;
- if (have_return_type) {
+ if (iinfo.has_return_value) {
context = in_inout > 0
? G_ARRAY
: G_SCALAR;
@@ -111,7 +114,7 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
}
/* do the call, demand #in-out+#out+#return-value return values */
- n_return_values = have_return_type
+ n_return_values = iinfo.has_return_value
? in_inout + 1
: in_inout;
n_returned = info->sub_name
@@ -123,6 +126,10 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
n_returned, n_return_values);
}
+ /* free call-scoped callback infos */
+ g_slist_foreach (iinfo.free_after_call,
+ (GFunc) release_c_callback, NULL);
+
SPAGAIN;
/* convert in-out and out values and stuff them back into args */
@@ -140,7 +147,7 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
}
out_index = 0;
- for (i = 0; i < n_args; i++) {
+ for (i = 0; i < iinfo.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);
@@ -165,7 +172,7 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
}
sv_to_arg (returned_values[out_index], &tmp_arg,
arg_info, arg_type,
- transfer, may_be_null, NULL);
+ transfer, may_be_null, &iinfo);
if (!is_caller_allocated) {
arg_to_raw (&tmp_arg, out_pointer, arg_type);
}
@@ -180,15 +187,15 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
}
/* store return value in resp, if any */
- if (have_return_type) {
+ if (iinfo.has_return_value) {
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);
+ type_info = iinfo.return_type_info;
+ transfer = iinfo.return_type_transfer;
+ may_be_null = g_callable_info_may_return_null (cb_interface); /* FIXME */
dwarn ("ret type: %p\n"
" is pointer: %d\n"
@@ -197,33 +204,14 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
g_type_info_is_pointer (type_info),
g_type_info_get_tag (type_info));
- /* If the callback is supposed to return a GInitiallyUnowned
- * object then we must enforce GI_TRANSFER_EVERYTHING.
- * Otherwise, if the Perl code returns a newly created object,
- * FREETMPS below would finalize it. */
- if (g_type_info_get_tag (type_info) == GI_TYPE_TAG_INTERFACE &&
- transfer == GI_TRANSFER_NOTHING)
- {
- GIBaseInfo *interface = g_type_info_get_interface (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))
- {
- transfer = GI_TRANSFER_EVERYTHING;
- }
- g_base_info_unref (interface);
- }
-
sv_to_arg (POPs, &arg, NULL, type_info,
- transfer, may_be_null, NULL);
+ transfer, may_be_null, &iinfo);
arg_to_raw (&arg, resp, type_info);
-
- g_base_info_unref ((GIBaseInfo *) type_info);
}
PUTBACK;
- g_base_info_unref ((GIBaseInfo *) return_type);
+ clear_perl_invocation_info (&iinfo);
FREETMPS;
LEAVE;
diff --git a/gperl-i11n-marshal-arg.c b/gperl-i11n-marshal-arg.c
index 7a0e835..46719a2 100644
--- a/gperl-i11n-marshal-arg.c
+++ b/gperl-i11n-marshal-arg.c
@@ -23,9 +23,8 @@ sv_to_arg (SV * sv,
switch (tag) {
case GI_TYPE_TAG_VOID:
+ /* returns NULL if no match is found */
arg->v_pointer = sv_to_callback_data (sv, invocation_info);
- if (!arg->v_pointer)
- ccroak ("encountered void pointer that is not callback user data");
break;
case GI_TYPE_TAG_BOOLEAN:
@@ -138,8 +137,12 @@ arg_to_sv (GIArgument * arg,
switch (tag) {
case GI_TYPE_TAG_VOID:
- dwarn (" argument with no type information -> undef\n");
- return &PL_sv_undef;
+ {
+ SV *sv = callback_data_to_sv (arg->v_pointer, iinfo);
+ dwarn (" argument with no type information -> %s\n",
+ sv ? "callback data" : "undef");
+ return sv ? SvREFCNT_inc (sv) : &PL_sv_undef;
+ }
case GI_TYPE_TAG_BOOLEAN:
return boolSV (arg->v_boolean);
@@ -196,7 +199,7 @@ arg_to_sv (GIArgument * arg,
return array_to_sv (info, arg->v_pointer, transfer, iinfo);
case GI_TYPE_TAG_INTERFACE:
- return interface_to_sv (info, arg, own);
+ return interface_to_sv (info, arg, own, iinfo);
case GI_TYPE_TAG_GLIST:
case GI_TYPE_TAG_GSLIST:
diff --git a/gperl-i11n-marshal-callback.c b/gperl-i11n-marshal-callback.c
index d9f359a..43ce193 100644
--- a/gperl-i11n-marshal-callback.c
+++ b/gperl-i11n-marshal-callback.c
@@ -6,44 +6,40 @@ sv_to_callback (GIArgInfo * arg_info,
SV * sv,
GPerlI11nInvocationInfo * invocation_info)
{
- GPerlI11nCallbackInfo *callback_info;
+ GPerlI11nPerlCallbackInfo *callback_info;
+ GIScopeType scope;
- 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;
- }
- }
+ /* the destroy notify func is handled by handle_automatic_arg */
+
+ dwarn (" Perl callback at %d (%s)\n",
+ invocation_info->current_pos,
+ g_base_info_get_name (arg_info));
- callback_info = create_callback_closure (type_info, sv);
+ callback_info = create_perl_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->destroy_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);
+ dwarn (" Perl callback data at %d, destroy at %d\n",
+ callback_info->data_pos, callback_info->destroy_pos);
- switch (g_arg_info_get_scope (arg_info)) {
+ scope = (sv == &PL_sv_undef)
+ ? GI_SCOPE_TYPE_CALL
+ : g_arg_info_get_scope (arg_info);
+ switch (scope) {
case GI_SCOPE_TYPE_CALL:
- dwarn (" callback has scope 'call'\n");
+ dwarn (" Perl 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");
+ dwarn (" Perl 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");
+ dwarn (" Perl callback has scope 'async'\n");
/* FIXME: callback_info->free_after_use = TRUE; */
break;
default:
@@ -55,7 +51,7 @@ sv_to_callback (GIArgInfo * arg_info,
g_slist_prepend (invocation_info->callback_infos,
callback_info);
- dwarn (" returning closure %p from info %p\n",
+ dwarn (" returning Perl closure %p from info %p\n",
callback_info->closure, callback_info);
return callback_info->closure;
}
@@ -68,13 +64,125 @@ sv_to_callback_data (SV * sv,
if (!invocation_info)
return NULL;
for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
- GPerlI11nCallbackInfo *callback_info = l->data;
+ GPerlI11nPerlCallbackInfo *callback_info = l->data;
if (callback_info->data_pos == invocation_info->current_pos) {
- dwarn (" user data for callback %p\n",
+ dwarn (" user data for Perl callback %p\n",
callback_info);
- attach_callback_data (callback_info, sv);
+ attach_perl_callback_data (callback_info, sv);
return callback_info;
}
}
+ if (invocation_info->is_callback) {
+ GPerlI11nCCallbackInfo *wrapper = INT2PTR (GPerlI11nCCallbackInfo*, SvIV (sv));
+ dwarn (" user data for C callback %p\n", wrapper);
+ return wrapper->data;
+ }
+ return NULL;
+}
+
+static SV *
+callback_to_sv (GICallableInfo *interface, gpointer func, GPerlI11nInvocationInfo *invocation_info)
+{
+ GIArgInfo *arg_info;
+ GPerlI11nCCallbackInfo *callback_info;
+ HV *stash;
+ SV *code_sv, *data_sv;
+ GIScopeType scope;
+
+ GSList *l;
+ for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
+ GPerlI11nCCallbackInfo *callback_info = l->data;
+ if (invocation_info->current_pos == callback_info->destroy_pos) {
+ dwarn (" destroy notify for C callback %p\n",
+ callback_info);
+ callback_info->destroy = func;
+ /* release_c_callback is called from
+ * Glib::Object::Introspection::_FuncWrapper::DESTROY */
+ return NULL;
+ }
+ }
+
+ arg_info = g_callable_info_get_arg (invocation_info->interface,
+ invocation_info->current_pos);
+
+ dwarn (" C callback at %d (%s)\n",
+ invocation_info->current_pos,
+ g_base_info_get_name (arg_info));
+
+ callback_info = create_c_callback_closure (interface, func);
+ callback_info->data_pos = g_arg_info_get_closure (arg_info);
+ callback_info->destroy_pos = g_arg_info_get_destroy (arg_info);
+ callback_info->free_after_use = FALSE;
+
+ if (func) {
+ data_sv = newSViv (PTR2IV (callback_info));
+ stash = gv_stashpv ("Glib::Object::Introspection::_FuncWrapper", TRUE);
+ code_sv = sv_bless (newRV_noinc (data_sv), stash);
+ } else {
+ data_sv = code_sv = &PL_sv_undef;
+ }
+ callback_info->data_sv = data_sv;
+
+ dwarn (" C callback data at %d, destroy at %d\n",
+ callback_info->data_pos, callback_info->destroy_pos);
+
+ scope = func
+ ? g_arg_info_get_scope (arg_info)
+ : GI_SCOPE_TYPE_CALL;
+ switch (scope) {
+ case GI_SCOPE_TYPE_CALL:
+ dwarn (" C 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 (" C callback has scope 'notified'\n");
+ /* This case is already taken care of by the notify
+ * stuff above */
+ break;
+ case GI_SCOPE_TYPE_ASYNC:
+ dwarn (" C 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));
+ }
+
+ g_base_info_unref (arg_info);
+
+ invocation_info->callback_infos =
+ g_slist_prepend (invocation_info->callback_infos,
+ callback_info);
+
+ dwarn (" returning C closure %p from info %p\n",
+ code_sv, callback_info);
+ return code_sv;
+}
+
+static SV *
+callback_data_to_sv (gpointer data,
+ GPerlI11nInvocationInfo * invocation_info)
+{
+ GSList *l;
+ if (!data)
+ return NULL;
+ if (!invocation_info)
+ return NULL;
+ for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
+ GPerlI11nCCallbackInfo *callback_info = l->data;
+ if (callback_info->data_pos == invocation_info->current_pos) {
+ dwarn (" user data for C callback %p\n",
+ callback_info);
+ attach_c_callback_data (callback_info, data);
+ return callback_info->data_sv;
+ }
+ }
+ if (invocation_info->is_callback) {
+ GPerlI11nPerlCallbackInfo *wrapper = data;
+ dwarn (" user data for Perl callback %p\n", wrapper);
+ return wrapper->data;
+ }
return NULL;
}
diff --git a/gperl-i11n-marshal-interface.c b/gperl-i11n-marshal-interface.c
index 1054def..cbf8d36 100644
--- a/gperl-i11n-marshal-interface.c
+++ b/gperl-i11n-marshal-interface.c
@@ -147,14 +147,16 @@ sv_to_interface (GIArgInfo * arg_info,
break;
default:
- ccroak ("sv_to_interface: Don't know how to handle info type %d", info_type);
+ ccroak ("sv_to_interface: Don't know how to handle info type %s (%d)",
+ g_info_type_to_string (info_type),
+ info_type);
}
g_base_info_unref ((GIBaseInfo *) interface);
}
static SV *
-interface_to_sv (GITypeInfo* info, GIArgument *arg, gboolean own)
+interface_to_sv (GITypeInfo* info, GIArgument *arg, gboolean own, GPerlI11nInvocationInfo *iinfo)
{
GIBaseInfo *interface;
GIInfoType info_type;
@@ -214,8 +216,14 @@ interface_to_sv (GITypeInfo* info, GIArgument *arg, gboolean own)
break;
}
+ case GI_INFO_TYPE_CALLBACK:
+ sv = callback_to_sv (interface, arg->v_pointer, iinfo);
+ break;
+
default:
- ccroak ("interface_to_sv: Don't know how to handle info type %d", info_type);
+ ccroak ("interface_to_sv: Don't know how to handle info type %s (%d)",
+ g_info_type_to_string (info_type),
+ info_type);
}
g_base_info_unref ((GIBaseInfo *) interface);
diff --git a/gperl-i11n-marshal-raw.c b/gperl-i11n-marshal-raw.c
index 276abc1..67e560a 100644
--- a/gperl-i11n-marshal-raw.c
+++ b/gperl-i11n-marshal-raw.c
@@ -9,7 +9,11 @@ raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info)
switch (tag) {
case GI_TYPE_TAG_VOID:
- /* do nothing */
+ if (g_type_info_is_pointer (info)) {
+ arg->v_pointer = CAST_RAW (raw, gpointer);
+ } else {
+ /* do nothing */
+ }
break;
case GI_TYPE_TAG_BOOLEAN:
@@ -66,12 +70,12 @@ raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info)
case GI_TYPE_TAG_GSLIST:
case GI_TYPE_TAG_GHASH:
case GI_TYPE_TAG_ERROR:
- arg->v_pointer = * (gpointer *) raw;
+ arg->v_pointer = CAST_RAW (raw, gpointer);
break;
case GI_TYPE_TAG_UTF8:
case GI_TYPE_TAG_FILENAME:
- arg->v_string = * (gchar **) raw;
+ arg->v_string = CAST_RAW (raw, gchar*);
break;
default:
diff --git a/gperl-i11n-vfunc-interface.c b/gperl-i11n-vfunc-interface.c
index 4f40843..4b82b90 100644
--- a/gperl-i11n-vfunc-interface.c
+++ b/gperl-i11n-vfunc-interface.c
@@ -15,7 +15,7 @@ generic_interface_init (gpointer iface, gpointer data)
gint field_offset;
GITypeInfo *field_type_info;
gchar *perl_method_name;
- GPerlI11nCallbackInfo *callback_info;
+ GPerlI11nPerlCallbackInfo *callback_info;
vfunc_info = g_interface_info_get_vfunc (info, i);
vfunc_name = g_base_info_get_name (vfunc_info);
@@ -27,7 +27,7 @@ generic_interface_init (gpointer iface, gpointer data)
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 (
+ callback_info = create_perl_callback_closure_for_named_sub (
field_type_info, perl_method_name);
dwarn ("installing vfunc %s as %s at offset %d (vs. %d) inside %p\n",
vfunc_name, perl_method_name,
diff --git a/gperl-i11n-vfunc-object.c b/gperl-i11n-vfunc-object.c
index 4ac53d3..46ad0ef 100644
--- a/gperl-i11n-vfunc-object.c
+++ b/gperl-i11n-vfunc-object.c
@@ -14,7 +14,7 @@ generic_class_init (GIObjectInfo *info, gpointer class)
gint field_offset;
GITypeInfo *field_type_info;
gchar *perl_method_name;
- GPerlI11nCallbackInfo *callback_info;
+ GPerlI11nPerlCallbackInfo *callback_info;
vfunc_info = g_object_info_get_vfunc (info, i);
vfunc_name = g_base_info_get_name (vfunc_info);
@@ -26,7 +26,7 @@ generic_class_init (GIObjectInfo *info, gpointer class)
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 (
+ callback_info = create_perl_callback_closure_for_named_sub (
field_type_info, perl_method_name);
dwarn ("installing vfunc %s as %s at offset %d (vs. %d) inside %p\n",
vfunc_name, perl_method_name,
diff --git a/lib/Glib/Object/Introspection.pm b/lib/Glib/Object/Introspection.pm
index f7eec4d..d74b395 100644
--- a/lib/Glib/Object/Introspection.pm
+++ b/lib/Glib/Object/Introspection.pm
@@ -176,6 +176,17 @@ sub setup {
}
}
+package Glib::Object::Introspection::_FuncWrapper;
+
+use overload
+ '&{}' => sub {
+ my ($func) = @_;
+ return sub { Glib::Object::Introspection::_FuncWrapper::_invoke($func, @_) }
+ },
+ fallback => 1;
+
+package Glib::Object::Introspection;
+
1;
__END__
@@ -277,8 +288,6 @@ flattened so that they return plain lists. For example
The function names refer to those after name corrections. Functions occuring
in C<flatten_array_ref_return_for> may also occur in C<class_static_methods>.
-=back
-
=item handle_sentinel_boolean_for => [ function1, ... ]
An array ref of function names that return multiple values, the first of which
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
