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);
	}
}
Пример #5
0
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;
}
Пример #7
0
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;
}
Пример #8
0
/* 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);
}