GNOME.org
 

[perl-Glib-Object-Introspection] Use a different approach to invoking fallback vfuncs

commit 9daa7a96bb83a96a9d248e007ff51c4bc3fdf2f4
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date:   Tue Oct 11 00:12:10 2011 +0200

    Use a different approach to invoking fallback vfuncs
    
    Instead of having one Perl fallback vfunc in the common ancestor package and
    let it try to determine which class' vfunc to actually invoke, put a separate
    Perl fallback vfunc into each parent package with implicit knowledge of which
    class' vfunc to invoke.
    
    Thanks for Kevin Ryde for suggesting this approach.

 GObjectIntrospection.xs          |   55 +++++++++++++------------------------
 gperl-i11n-callback.c            |    6 +---
 gperl-i11n-invoke-perl.c         |   14 ---------
 gperl-i11n-vfunc-interface.c     |    2 +-
 gperl-i11n-vfunc-object.c        |    4 +-
 lib/Glib/Object/Introspection.pm |   33 ++++++++++++++--------
 6 files changed, 44 insertions(+), 70 deletions(-)
---
diff --git a/GObjectIntrospection.xs b/GObjectIntrospection.xs
index 8453d52..dfc47d5 100644
--- a/GObjectIntrospection.xs
+++ b/GObjectIntrospection.xs
@@ -38,13 +38,8 @@ typedef struct {
 	SV *code;
 	SV *data;
 
-	/* ... or a sub name to be called as a method on the invocant, plus the
-	 * name of the package that is the originator of the sub.  we will use
-	 * call_method so that Perl subclasses can override.  but we still need
-	 * the package name so that we can chain up properly in the fallback
-	 * implementations. */
+	/* ... or a sub name to be called as a method on the invocant. */
 	gchar *sub_name;
-	gchar *package_name;
 
 	guint data_pos;
 	guint notify_pos;
@@ -96,7 +91,7 @@ typedef struct {
 /* 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, gchar *package_name);
+static GPerlI11nCallbackInfo * create_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name);
 static void release_callback (gpointer data);
 
 /* invocation */
@@ -189,11 +184,7 @@ static void generic_interface_init (gpointer iface, gpointer data);
 static void generic_interface_finalize (gpointer iface, gpointer data);
 
 /* object vfuncs */
-static void generic_class_init (GIObjectInfo *info, const gchar *target_package, gpointer class);
-
-/* 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 void generic_class_init (GIObjectInfo *info, gpointer class);
 
 /* misc. */
 #define ccroak(...) call_carp_croak (form (__VA_ARGS__));
@@ -511,7 +502,7 @@ _install_overrides (class, basename, object_name, target_package)
     PREINIT:
 	GIRepository *repository;
 	GIObjectInfo *info;
-	GType gtype;
+	GType gtype, object_gtype;
 	gpointer klass;
     PPCODE:
 	dwarn ("_install_overrides: %s.%s for %s\n", basename, object_name, target_package);
@@ -527,22 +518,29 @@ _install_overrides (class, basename, object_name, target_package)
 	if (!klass)
 		ccroak ("internal problem: can't peek at type class for %s (%d)",
 		        g_type_name (gtype), gtype);
-	/* mark the type as belonging to us */
-	g_type_set_qdata (gtype, VFUNC_PERL_TYPE_QUARK, (gpointer) TRUE);
-	generic_class_init (info, target_package, klass);
+	generic_class_init (info, klass);
+	/* find all non-Perl parents up to and including the object type */
+	object_gtype = g_registered_type_info_get_g_type (info);
+	while ((gtype = g_type_parent (gtype))) {
+		if (!g_type_get_qdata (gtype, g_quark_from_static_string ("__gperl_type_reg"))) {
+			XPUSHs (sv_2mortal (newSVpv (gperl_object_package_from_type (gtype), PL_na)));
+		}
+		if (gtype == object_gtype) {
+			break;
+		}
+	}
 	g_base_info_unref (info);
 
 void
-_invoke_parent_vfunc (class, basename, object_name, vfunc_name, ...)
+_invoke_fallback_vfunc (class, basename, object_name, vfunc_name, target_package, ...)
 	const gchar *basename
 	const gchar *object_name
 	const gchar *vfunc_name
+	const gchar *target_package
     PREINIT:
-	UV internal_stack_offset = 4;
+	UV internal_stack_offset = 5;
 	GIRepository *repository;
 	GIObjectInfo *info;
-	GObject *object;
-	const gchar *target_package;
 	GType gtype;
 	gpointer klass;
 	GIStructInfo *struct_info;
@@ -554,24 +552,9 @@ _invoke_parent_vfunc (class, basename, object_name, vfunc_name, ...)
 	dwarn ("_invoke_parent_vfunc: %s\n", vfunc_name);
 	repository = g_irepository_get_default ();
 	info = g_irepository_find_by_name (repository, basename, object_name);
-	if (!GI_IS_OBJECT_INFO (info))
-		ccroak ("not an object");
-	object = gperl_get_object (ST (internal_stack_offset));
-	g_assert (G_IS_OBJECT (object));
-	target_package = g_object_get_qdata (object, VFUNC_TARGET_PACKAGE_QUARK);
-	g_assert (target_package);
+	g_assert (info);
 	gtype = gperl_object_type_from_package (target_package);
 	dwarn ("  target: %s\n", target_package);
-	/* find the first non-Perl parent of this type */
-	while ((gtype = g_type_parent (gtype))) {
-		if (!g_type_get_qdata (gtype, VFUNC_PERL_TYPE_QUARK)) {
-			break;
-		}
-	}
-	if (!gtype)
-		ccroak ("package '%s' is not registered with Glib-Perl",
-		        target_package);
-	dwarn ("  parent: %s\n", g_type_name (gtype));
 	klass = g_type_class_peek (gtype);
 	if (!klass)
 		ccroak ("internal problem: can't peek at type class for %s (%d)",
diff --git a/gperl-i11n-callback.c b/gperl-i11n-callback.c
index 7b712c1..04eb5c3 100644
--- a/gperl-i11n-callback.c
+++ b/gperl-i11n-callback.c
@@ -14,7 +14,6 @@ create_callback_closure (GITypeInfo *cb_type, SV *code)
 	 * newSVsv. */
 	info->code = newSVsv (code);
 	info->sub_name = NULL;
-	info->package_name = NULL;
 
 #ifdef PERL_IMPLICIT_CONTEXT
 	info->priv = aTHX;
@@ -31,7 +30,7 @@ attach_callback_data (GPerlI11nCallbackInfo *info, SV *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)
+create_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name)
 {
 	GPerlI11nCallbackInfo *info;
 
@@ -43,7 +42,6 @@ create_callback_closure_for_named_sub (GITypeInfo *cb_type, gchar *sub_name, gch
 		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;
 
@@ -75,8 +73,6 @@ release_callback (gpointer 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-invoke-perl.c b/gperl-i11n-invoke-perl.c
index a31a033..47b39f2 100644
--- a/gperl-i11n-invoke-perl.c
+++ b/gperl-i11n-invoke-perl.c
@@ -89,14 +89,6 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
 
 	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);
@@ -129,12 +121,6 @@ invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
 		        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 */
diff --git a/gperl-i11n-vfunc-interface.c b/gperl-i11n-vfunc-interface.c
index dfa456f..79a46c0 100644
--- a/gperl-i11n-vfunc-interface.c
+++ b/gperl-i11n-vfunc-interface.c
@@ -26,7 +26,7 @@ generic_interface_init (gpointer iface, gpointer data)
 
 		perl_method_name = g_ascii_strup (vfunc_name, -1);
 		callback_info = create_callback_closure_for_named_sub (
-		                  field_type_info, perl_method_name, NULL);
+		                  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,
 		       field_offset, g_vfunc_info_get_offset (vfunc_info),
diff --git a/gperl-i11n-vfunc-object.c b/gperl-i11n-vfunc-object.c
index ab1adee..750dbe2 100644
--- a/gperl-i11n-vfunc-object.c
+++ b/gperl-i11n-vfunc-object.c
@@ -1,5 +1,5 @@
 static void
-generic_class_init (GIObjectInfo *info, const gchar *target_package, gpointer class)
+generic_class_init (GIObjectInfo *info, gpointer class)
 {
 	GIStructInfo *struct_info;
 	gint n, i;
@@ -25,7 +25,7 @@ generic_class_init (GIObjectInfo *info, const gchar *target_package, gpointer cl
 
 		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));
+		                  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,
 		       field_offset, g_vfunc_info_get_offset (vfunc_info),
diff --git a/lib/Glib/Object/Introspection.pm b/lib/Glib/Object/Introspection.pm
index c3ab9bb..f7eec4d 100644
--- a/lib/Glib/Object/Introspection.pm
+++ b/lib/Glib/Object/Introspection.pm
@@ -151,19 +151,28 @@ sub setup {
     my $installer_name = $object_package . '::_INSTALL_OVERRIDES';
     *{$installer_name} = sub {
       my ($target_package) = @_;
-      __PACKAGE__->_install_overrides($basename, $object_name, $target_package);
-    };
-    foreach my $vfunc_names (@{$objects_with_vfuncs->{$object_name}}) {
-      my $vfunc_name = $vfunc_names->[0];
-      my $perl_vfunc_name = $vfunc_names->[1];
-      if (exists $forbidden_sub_names{$perl_vfunc_name}) {
-        $perl_vfunc_name .= '_VFUNC';
-      }
-      my $full_perl_vfunc_name = $object_package . '::' . $perl_vfunc_name;
-      *{$full_perl_vfunc_name} = sub {
-        __PACKAGE__->_invoke_parent_vfunc($basename, $object_name, $vfunc_name, @_);
+      my @non_perl_parent_packages =
+        __PACKAGE__->_install_overrides($basename, $object_name,
+                                        $target_package);
+      foreach my $parent_package (@non_perl_parent_packages) {
+        VFUNC:
+        foreach my $vfunc_names (@{$objects_with_vfuncs->{$object_name}}) {
+          my $vfunc_name = $vfunc_names->[0];
+          my $perl_vfunc_name = $vfunc_names->[1];
+          if (exists $forbidden_sub_names{$perl_vfunc_name}) {
+            $perl_vfunc_name .= '_VFUNC';
+          }
+          my $full_perl_vfunc_name = $parent_package . '::' . $perl_vfunc_name;
+          if (defined &{$full_perl_vfunc_name}) {
+            next VFUNC;
+          }
+          *{$full_perl_vfunc_name} = sub {
+            __PACKAGE__->_invoke_fallback_vfunc($basename, $object_name, $vfunc_name,
+                                                $parent_package, @_);
+          }
+        }
       }
-    }
+    };
   }
 }
[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]