GNOME.org
 

[perl-Glib-Object-Introspection] Improve handling of boxed unions

commit d384bc44b1104e0075910bf4967036353c42af16
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date:   Fri Jun 29 22:03:13 2012 +0200

    Improve handling of boxed unions
    
    Present the struct members of boxed unions as being of the same type as the
    union.  This makes field access and function invocation work as intended.

 GObjectIntrospection.xs          |   61 +++++++++++++++++++++++------
 MANIFEST                         |    1 +
 NEWS                             |    5 ++
 gperl-i11n-info.c                |   12 ++++++
 gperl-i11n-marshal-interface.c   |   23 +++++++++--
 gperl-i11n-union.c               |   79 ++++++++++++++++++++++++++++++++++++++
 lib/Glib/Object/Introspection.pm |   30 ++++++++++-----
 7 files changed, 185 insertions(+), 26 deletions(-)
---
diff --git a/GObjectIntrospection.xs b/GObjectIntrospection.xs
index 6979913..c41e301 100644
--- a/GObjectIntrospection.xs
+++ b/GObjectIntrospection.xs
@@ -26,6 +26,13 @@
 #include <girepository.h>
 #include <girffi.h>
 
+/* #define NOISY */
+#ifdef NOISY
+# define dwarn(...) warn(__VA_ARGS__)
+#else
+# define dwarn(...)
+#endif
+
 /* ------------------------------------------------------------------------- */
 
 typedef struct {
@@ -151,6 +158,7 @@ static GIFunctionInfo * get_function_info (GIRepository *repository,
 static GIFieldInfo * get_field_info (GIBaseInfo *info,
                                      const gchar *field_name);
 static GType get_gtype (GIRegisteredTypeInfo *info);
+static const gchar * get_package_for_basename (const gchar *basename);
 
 
 /* marshallers */
@@ -211,6 +219,11 @@ 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);
 
+/* unions */
+static SV * rebless_union_sv (GType type, const char *package, gpointer mem, gboolean own);
+static void associate_union_members_with_gtype (GIUnionInfo *info, const gchar *package, GType type);
+static GType find_union_member_gtype (const gchar *package, const gchar *namespace);
+
 /* methods */
 static void store_methods (HV *namespaced_functions, GIBaseInfo *info, GIInfoType info_type);
 
@@ -236,13 +249,6 @@ static void call_carp_croak (const char *msg);
 		_saved_stack_sv;		\
 	})
 
-/* #define NOISY */
-#ifdef NOISY
-# define dwarn(...) warn(__VA_ARGS__)
-#else
-# define dwarn(...)
-#endif
-
 /* ------------------------------------------------------------------------- */
 
 #include "gperl-i11n-callback.c"
@@ -263,6 +269,7 @@ static void call_carp_croak (const char *msg);
 #include "gperl-i11n-marshal-struct.c"
 #include "gperl-i11n-method.c"
 #include "gperl-i11n-size.c"
+#include "gperl-i11n-union.c"
 #include "gperl-i11n-vfunc-interface.c"
 #include "gperl-i11n-vfunc-object.c"
 
@@ -390,10 +397,26 @@ _register_types (class, namespace, package)
 
 		    case GI_INFO_TYPE_BOXED:
 		    case GI_INFO_TYPE_STRUCT:
-		    case GI_INFO_TYPE_UNION:
 			gperl_register_boxed (type, full_package, NULL);
 			break;
 
+		    case GI_INFO_TYPE_UNION:
+		    {
+			GPerlBoxedWrapperClass *my_wrapper_class;
+			GPerlBoxedWrapperClass *default_wrapper_class;
+			default_wrapper_class = gperl_default_boxed_wrapper_class ();
+			/* FIXME: We leak my_wrapper_class here.  The problem
+			 * is that gperl_register_boxed does not copy the
+			 * contents of the wrapper class but instead assumes
+			 * that the memory passed in will always be valid. */
+			my_wrapper_class = g_new (GPerlBoxedWrapperClass, 1);
+			*my_wrapper_class = *default_wrapper_class;
+			my_wrapper_class->wrap = rebless_union_sv;
+			gperl_register_boxed (type, full_package, my_wrapper_class);
+			associate_union_members_with_gtype (info, package, type);
+			break;
+		    }
+
 		    case GI_INFO_TYPE_ENUM:
 		    case GI_INFO_TYPE_FLAGS:
 			gperl_register_fundamental (type, full_package);
@@ -468,9 +491,16 @@ _get_field (class, basename, namespace, field, invocant)
 		ccroak ("Could not find field '%s' in namespace '%s'",
 		        field, namespace)
 	invocant_type = get_gtype (namespace_info);
+	if (invocant_type == G_TYPE_NONE) {
+		/* If the invocant has no associated GType, try to look at the
+		 * {$package}::_i11n_gtype SV.  It gets set for members of
+		 * boxed unions. */
+		const gchar *package = get_package_for_basename (basename);
+		invocant_type = find_union_member_gtype (package, namespace);
+	}
 	if (!g_type_is_a (invocant_type, G_TYPE_BOXED))
-		ccroak ("Unable to handle field access for type '%s'",
-		        g_type_name (invocant_type));
+		ccroak ("Unable to handle access to field '%s' for type '%s'",
+		        field, g_type_name (invocant_type));
 	boxed_mem = gperl_get_boxed_check (invocant, invocant_type);
 	/* No PUTBACK/SPAGAIN needed here. */
 	RETVAL = get_field (field_info, boxed_mem, GI_TRANSFER_NOTHING);
@@ -503,9 +533,16 @@ _set_field (class, basename, namespace, field, invocant, new_value)
 		ccroak ("Could not find field '%s' in namespace '%s'",
 		        field, namespace)
 	invocant_type = get_gtype (namespace_info);
+	if (invocant_type == G_TYPE_NONE) {
+		/* If the invocant has no associated GType, try to look at the
+		 * {$package}::_i11n_gtype SV.  It gets set for members of
+		 * boxed unions. */
+		const gchar *package = get_package_for_basename (basename);
+		invocant_type = find_union_member_gtype (package, namespace);
+	}
 	if (!g_type_is_a (invocant_type, G_TYPE_BOXED))
-		ccroak ("Unable to handle field access for type '%s'",
-		        g_type_name (invocant_type));
+		ccroak ("Unable to handle access to field '%s' for type '%s'",
+		        field, g_type_name (invocant_type));
 	boxed_mem = gperl_get_boxed_check (invocant, invocant_type);
 	/* Conceptually, we need to always transfer ownership to the boxed
 	 * object for things like strings.  The memory would then be freed by
diff --git a/MANIFEST b/MANIFEST
index 68b8646..da96661 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -17,6 +17,7 @@ gperl-i11n-marshal-raw.c
 gperl-i11n-marshal-struct.c
 gperl-i11n-method.c
 gperl-i11n-size.c
+gperl-i11n-union.c
 gperl-i11n-vfunc-interface.c
 gperl-i11n-vfunc-object.c
 lib/Glib/Object/Introspection.pm
diff --git a/NEWS b/NEWS
index af75fbc..1dc7b91 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,8 @@
+Overview of changes in Glib::Object::Introspection <next>
+========================================================
+
+* Improve handling of boxed unions, like GdkEvent.
+
 Overview of changes in Glib::Object::Introspection 0.010
 ========================================================
 
diff --git a/gperl-i11n-info.c b/gperl-i11n-info.c
index d4fa498..84f102b 100644
--- a/gperl-i11n-info.c
+++ b/gperl-i11n-info.c
@@ -138,3 +138,15 @@ get_gtype (GIRegisteredTypeInfo *info)
 	}
 	return gtype;
 }
+
+static const gchar *
+get_package_for_basename (const gchar *basename)
+{
+	SV **svp;
+	HV *basename_to_package =
+		get_hv ("Glib::Object::Introspection::_BASENAME_TO_PACKAGE", 0);
+	g_assert (basename_to_package);
+	svp = hv_fetch (basename_to_package, basename, strlen (basename), 0);
+	g_assert (svp && gperl_sv_is_defined (*svp));
+	return SvPV_nolen (*svp);
+}
diff --git a/gperl-i11n-marshal-interface.c b/gperl-i11n-marshal-interface.c
index 7d399f5..3dc4bb8 100644
--- a/gperl-i11n-marshal-interface.c
+++ b/gperl-i11n-marshal-interface.c
@@ -89,12 +89,27 @@ sv_to_interface (GIArgInfo * arg_info,
 			&& !g_type_info_is_pointer (type_info);
 		GType type = get_gtype ((GIRegisteredTypeInfo *) interface);
 		if (!type || type == G_TYPE_NONE) {
+			const gchar *namespace, *name, *package;
+			GType parent_type;
 			dwarn ("    unboxed type\n");
 			g_assert (!need_value_semantics);
-			arg->v_pointer = sv_to_struct (transfer,
-			                               interface,
-			                               info_type,
-			                               sv);
+			/* Find out whether this untyped struct is a member of
+			 * a boxed union before using raw hash-to-struct
+			 * conversion. */
+			name = g_base_info_get_name (interface);
+			namespace = g_base_info_get_namespace (interface);
+			package = get_package_for_basename (namespace);
+			parent_type = find_union_member_gtype (package, name);
+			if (parent_type && parent_type != G_TYPE_NONE) {
+				/* FIXME: Check transfer setting. */
+				arg->v_pointer = gperl_get_boxed_check (
+				                   sv, parent_type);
+			} else {
+				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");
diff --git a/gperl-i11n-union.c b/gperl-i11n-union.c
new file mode 100644
index 0000000..2442144
--- /dev/null
+++ b/gperl-i11n-union.c
@@ -0,0 +1,79 @@
+/* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */
+
+#define UNION_REBLESSERS_HV "Glib::Object::Introspection::_REBLESSERS"
+#define UNION_MEMBER_TYPE_SUFFIX "::_i11n_gtype"
+
+static SV *
+rebless_union_sv (GType type, const char *package, gpointer mem, gboolean own)
+{
+	SV *sv, **reblesser_p;
+	HV *reblessers;
+
+	sv = gperl_default_boxed_wrapper_class ()->wrap (type, package, mem, own);
+
+	reblessers = get_hv (UNION_REBLESSERS_HV, 0);
+	g_assert (reblessers);
+	reblesser_p = hv_fetch (reblessers, package, strlen (package), 0);
+	if (reblesser_p && gperl_sv_is_defined (*reblesser_p)) {
+		dSP;
+		ENTER;
+		SAVETMPS;
+		PUSHMARK (SP);
+		XPUSHs (sv_2mortal (SvREFCNT_inc (sv)));
+		PUTBACK;
+		call_sv (*reblesser_p, G_DISCARD);
+		FREETMPS;
+		LEAVE;
+	}
+
+	return sv;
+}
+
+static void
+associate_union_members_with_gtype (GIUnionInfo *info, const gchar *package, GType type)
+{
+	gint i, n_fields;
+	n_fields = g_union_info_get_n_fields (info);
+	for (i = 0; i < n_fields; i++) {
+		GIFieldInfo *field_info;
+		GITypeInfo *field_type;
+		GIBaseInfo *field_interface;
+		const gchar *type_name;
+		gchar *full_name;
+		SV *sv;
+
+		field_info = g_union_info_get_field (info, i);
+		field_type = g_field_info_get_type (field_info);
+		field_interface = g_type_info_get_interface (field_type);
+		/* If this field has a basic type, then we cannot associate its
+		 * parent's GType with it. */
+		if (!field_interface) {
+			g_base_info_unref ((GIBaseInfo *) field_type);
+			g_base_info_unref ((GIBaseInfo *) field_info);
+			continue;
+		}
+
+		type_name = g_base_info_get_name (field_interface);
+		full_name = g_strconcat (package, "::", type_name, UNION_MEMBER_TYPE_SUFFIX, NULL);
+		dwarn ("associating %s with GType %d\n", type_name, type);
+		sv = get_sv (full_name, GV_ADD);
+		sv_setuv (sv, type);
+		g_free (full_name);
+
+		g_base_info_unref ((GIBaseInfo *) field_interface);
+		g_base_info_unref ((GIBaseInfo *) field_type);
+		g_base_info_unref ((GIBaseInfo *) field_info);
+	}
+}
+
+static GType
+find_union_member_gtype (const gchar *package, const gchar *namespace)
+{
+	gchar *type_sv_name;
+	SV *type_sv;
+	type_sv_name = g_strconcat (package, "::", namespace,
+	                            UNION_MEMBER_TYPE_SUFFIX, NULL);
+	type_sv = get_sv (type_sv_name, 0);
+	g_free (type_sv_name);
+	return type_sv ? SvUV (type_sv) : G_TYPE_NONE;
+}
diff --git a/lib/Glib/Object/Introspection.pm b/lib/Glib/Object/Introspection.pm
index 2a25d31..ad29920 100644
--- a/lib/Glib/Object/Introspection.pm
+++ b/lib/Glib/Object/Introspection.pm
@@ -30,7 +30,10 @@ XSLoader::load(__PACKAGE__, $VERSION);
 
 my %FORBIDDEN_SUB_NAMES = map { $_ => 1 } qw/AUTOLOAD CLONE DESTROY BEGIN
                                              UNITCHECK CHECK INIT END/;
-my @_OBJECT_PACKAGES_WITH_VFUNCS = ();
+my @OBJECT_PACKAGES_WITH_VFUNCS;
+
+our %_BASENAME_TO_PACKAGE;
+our %_REBLESSERS;
 
 sub _create_invoker_sub {
   my ($basename, $namespace, $name,
@@ -67,6 +70,8 @@ sub setup {
   my $search_path = $params{search_path} || undef;
   my $name_corrections = $params{name_corrections} || {};
 
+  $_BASENAME_TO_PACKAGE{$basename} = $package;
+
   local $@;
   my %shift_package_name_for = eval {
     map { $_ => 1 } @{$params{class_static_methods}} };
@@ -75,6 +80,11 @@ sub setup {
   my %handle_sentinel_boolean_for = eval {
     map { $_ => 1 } @{$params{handle_sentinel_boolean_for}} };
 
+  if (exists $params{reblessers}) {
+    $_REBLESSERS{$_} = $params{reblessers}->{$_}
+      for keys %{$params{reblessers}}
+  }
+
   __PACKAGE__->_load_library($basename, $version, $search_path);
 
   my ($functions, $constants, $fields, $interfaces, $objects_with_vfuncs) =
@@ -121,19 +131,19 @@ sub setup {
   }
 
   foreach my $namespace (keys %{$fields}) {
-    foreach my $name (@{$fields->{$namespace}}) {
-      my $auto_name = $package . '::' . $namespace . '::' . $name;
+    foreach my $field_name (@{$fields->{$namespace}}) {
+      my $auto_name = $package . '::' . $namespace . '::' . $field_name;
       my $corrected_name = exists $name_corrections->{$auto_name}
         ? $name_corrections->{$auto_name}
         : $auto_name;
       *{$corrected_name} = sub {
         my ($invocant, $new_value) = @_;
-        my $old_value = __PACKAGE__->_get_field($basename, $namespace, $name,
-                                                $invocant);
+        my $old_value = __PACKAGE__->_get_field($basename, $namespace,
+                                                $field_name, $invocant);
         # If a new value is provided, even if it is undef, update the field.
         if (scalar @_ > 1) {
-          __PACKAGE__->_set_field($basename, $namespace, $name,
-                                  $invocant, $new_value);
+          __PACKAGE__->_set_field($basename, $namespace,
+                                  $field_name, $invocant, $new_value);
         }
         return $old_value;
       };
@@ -185,7 +195,7 @@ sub setup {
 
       # Delay hooking up the vfuncs until INIT so that we can see whether the
       # package defines the relevant subs or not.
-      push @_OBJECT_PACKAGES_WITH_VFUNCS,
+      push @OBJECT_PACKAGES_WITH_VFUNCS,
            [$basename, $object_name, $target_package];
     };
   }
@@ -193,11 +203,11 @@ sub setup {
 
 sub INIT {
   no strict qw(refs);
-  foreach my $target (@_OBJECT_PACKAGES_WITH_VFUNCS) {
+  foreach my $target (@OBJECT_PACKAGES_WITH_VFUNCS) {
     my ($basename, $object_name, $target_package) = @{$target};
     __PACKAGE__->_install_overrides($basename, $object_name, $target_package);
   }
-  @_OBJECT_PACKAGES_WITH_VFUNCS = ();
+  @OBJECT_PACKAGES_WITH_VFUNCS = ();
 }
 
 package Glib::Object::Introspection::_FuncWrapper;
[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]