static gpointer
sv_to_callback_data (SV * sv,
GPerlI11nInvocationInfo * invocation_info)
{
GSList *l;
if (!invocation_info)
return NULL;
for (l = invocation_info->callback_infos; l != NULL; l = l->next) {
GPerlI11nPerlCallbackInfo *callback_info = l->data;
if (callback_info->data_pos == ((gint) invocation_info->current_pos)) {
dwarn (" user data for Perl callback %p\n",
callback_info);
attach_perl_callback_data (callback_info, sv);
/* If the user did not specify any code and data and if
* there is no destroy notify function, then there is
* no need for us to pass on our callback info struct
* as C user data. Some libraries (e.g., vte) even
* assert that the C user data be NULL if the C
* function pointer is NULL. */
if (!gperl_sv_is_defined (callback_info->code) &&
!gperl_sv_is_defined (callback_info->data) &&
-1 == callback_info->destroy_pos)
{
dwarn (" handing over NULL");
return NULL;
}
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;
}
static GPerlI11nPerlCallbackInfo *
create_perl_callback_closure (GICallableInfo *cb_info, SV *code)
{
GPerlI11nPerlCallbackInfo *info;
info = g_new0 (GPerlI11nPerlCallbackInfo, 1);
if (!gperl_sv_is_defined (code))
return info;
info->interface = g_base_info_ref (cb_info);
info->cif = g_new0 (ffi_cif, 1);
info->closure =
g_callable_info_prepare_closure (info->interface, info->cif,
invoke_perl_code, info);
/* FIXME: This should most likely use SvREFCNT_inc instead of
* newSVsv. */
info->code = newSVsv (code);
info->sub_name = NULL;
/* These are only relevant for signal marshalling; if needed, they get
* set in invoke_perl_signal_handler. */
info->swap_data = FALSE;
info->args_converter = NULL;
#ifdef PERL_IMPLICIT_CONTEXT
info->priv = aTHX;
#endif
return info;
}
static gpointer
sv_to_callback (GIArgInfo * arg_info,
GITypeInfo * type_info,
SV * sv,
GPerlI11nInvocationInfo * invocation_info)
{
GIBaseInfo *callback_interface_info;
GPerlI11nPerlCallbackInfo *callback_info;
GIScopeType scope;
/* 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_interface_info = g_type_info_get_interface (type_info);
callback_info = create_perl_callback_closure (callback_interface_info, sv);
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;
g_base_info_unref (callback_interface_info);
dwarn (" Perl callback data at %d, destroy at %d\n",
callback_info->data_pos, callback_info->destroy_pos);
scope = (!gperl_sv_is_defined (sv))
? GI_SCOPE_TYPE_CALL
: g_arg_info_get_scope (arg_info);
switch (scope) {
case GI_SCOPE_TYPE_CALL:
dwarn (" Perl callback has scope 'call'\n");
free_after_call (invocation_info,
(GFunc) release_perl_callback, callback_info);
break;
case GI_SCOPE_TYPE_NOTIFIED:
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 (" Perl 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 Perl closure %p from info %p\n",
callback_info->closure, callback_info);
return callback_info->closure;
}
/* 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);
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) {
if (arg_info) {
ccroak ("undefined value for mandatory argument '%s' encountered",
g_base_info_get_name ((GIBaseInfo *) arg_info));
} else {
ccroak ("undefined value encountered");
}
}
switch (tag) {
case GI_TYPE_TAG_VOID:
/* returns NULL if no match is found */
arg->v_pointer = sv_to_callback_data (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, transfer, may_be_null,
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: Should we use SvPVbyte_nolen here? */
arg->v_string = gperl_sv_is_defined (sv) ? SvPV_nolen (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 GtkWidget *
gtk2perl_toolbar_insert_internal (GtkToolbar * toolbar,
SV * type,
SV * widget,
SV * text,
SV * tooltip_text,
SV * tooltip_private_text,
SV * icon,
SV * callback,
SV * user_data,
SV * position,
WhichInsert which,
WhichOp op)
{
GtkWidget * w = NULL;
const char * real_tooltip_text = NULL;
const char * real_tooltip_private_text = NULL;
/* _ornull is not always right for text, but is for the others. */
real_tooltip_text = SvGChar_ornull (tooltip_text);
real_tooltip_private_text = SvGChar_ornull (tooltip_private_text);
switch (which) {
case STOCK:
/* stock with NULL text (the stock id) makes no sense,
* so let's make sure perl will issue an uninitialized
* value warning for undef passed here for text. */
w = gtk_toolbar_insert_stock (toolbar, SvGChar (text),
real_tooltip_text,
real_tooltip_private_text,
NULL, NULL,
SvIV (position));
break;
case ITEM:
{
const gchar * real_text = SvGChar_ornull (text);
GtkWidget * real_icon = SvGtkWidget_ornull (icon);
switch (op) {
case PREPEND:
w = gtk_toolbar_prepend_item (toolbar, real_text,
real_tooltip_text,
real_tooltip_private_text,
real_icon, NULL, NULL);
break;
case APPEND:
w = gtk_toolbar_append_item (toolbar, real_text,
real_tooltip_text,
real_tooltip_private_text,
real_icon, NULL, NULL);
break;
case INSERT:
w = gtk_toolbar_insert_item (toolbar, real_text,
real_tooltip_text,
real_tooltip_private_text,
real_icon, NULL, NULL,
SvIV (position));
break;
default:
g_assert_not_reached ();
}
}
break;
case ELEMENT:
{
GtkToolbarChildType real_type = SvGtkToolbarChildType(type);
const gchar * real_text = SvGChar_ornull (text);
GtkWidget * real_widget = SvGtkWidget_ornull (widget);
GtkWidget * real_icon = SvGtkWidget_ornull (icon);
switch (op) {
case PREPEND:
w = gtk_toolbar_prepend_element (toolbar, real_type,
real_widget,
real_text,
real_tooltip_text,
real_tooltip_private_text,
real_icon,
NULL, NULL);
break;
case APPEND:
w = gtk_toolbar_append_element (toolbar, real_type,
real_widget,
real_text,
real_tooltip_text,
real_tooltip_private_text,
real_icon,
NULL, NULL);
break;
case INSERT:
w = gtk_toolbar_insert_element (toolbar, real_type,
real_widget,
real_text,
real_tooltip_text,
real_tooltip_private_text,
real_icon,
NULL, NULL,
SvIV (position));
break;
default:
g_assert_not_reached ();
}
}
break;
case WIDGET:
{
w = SvGtkWidget (widget);
switch (op) {
case PREPEND:
gtk_toolbar_prepend_widget (toolbar, w,
real_tooltip_text,
real_tooltip_private_text);
break;
case APPEND:
gtk_toolbar_append_widget (toolbar, w,
real_tooltip_text,
real_tooltip_private_text);
break;
case INSERT:
gtk_toolbar_insert_widget (toolbar, w,
real_tooltip_text,
real_tooltip_private_text,
SvIV (position));
break;
default:
g_assert_not_reached ();
}
}
break;
default:
g_assert_not_reached ();
}
if (gperl_sv_is_defined (callback))
gperl_signal_connect (newSVGtkWidget (w), "clicked",
callback, user_data, 0);
return w;
}
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 (!gperl_sv_is_defined (sv))
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 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 ("sv = %p\n", sv);
if (!gperl_sv_is_defined (sv))
return NULL;
if (is_struct_disguised (info)) {
gchar *package;
dwarn (" disguised struct\n");
package = get_struct_package (info);
g_assert (package);
if (!gperl_sv_is_ref (sv) || !sv_derived_from (sv, package))
ccroak ("Cannot convert scalar %p to an object of type %s",
sv, package);
g_free (package);
return INT2PTR (void *, SvIV ((SV *) SvRV (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 = %"G_GSIZE_FORMAT"\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);
dwarn (" field %d (%s)\n", i, field_name);
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;
}
/* This may call Perl code (via get_field), so it needs to be wrapped with
* PUTBACK/SPAGAIN by the caller. */
static SV *
struct_to_sv (GIBaseInfo* info,
GIInfoType info_type,
gpointer pointer,
gboolean own)
{
HV *hv;
dwarn ("pointer = %p\n", pointer);
if (pointer == NULL) {
return &PL_sv_undef;
}
if (is_struct_disguised (info)) {
SV *sv;
gchar *package;
dwarn (" disguised struct\n");
g_assert (!own);
package = get_struct_package (info);
g_assert (package);
sv = newSV (0);
sv_setref_pv (sv, package, pointer);
g_free (package);
return sv;
}
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);
dwarn (" field %d (%s)\n", i, g_base_info_get_name (field_info));
/* 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);
}