[perl-Glib] Add Glib::Param::GType support

[Torsten Schönfeld <tsch src gnome org>]

commit 2b1a35b9d5fdaaf0f8b361ab1c6a7e662f081998
Author: Torsten Schönfeld <kaffeetisch gmx de>
Date:   Thu Jan 7 21:38:34 2010 +0100

    Add Glib::Param::GType support
    
    This involves providing Glib::ParamSpec->gtype and
    Glib::Param::GType->is_a_type in addition to necessary conversion
    machinery in our GValue handling.
    
    The patch was mostly written by muppet.

 GParamSpec.xs |   53 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 GValue.xs     |   25 +++++++++++++++++++++++--
 t/e.t         |   52 +++++++++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 127 insertions(+), 3 deletions(-)
---
diff --git a/GParamSpec.xs b/GParamSpec.xs
index 5c7e200..61dbea4 100644
--- a/GParamSpec.xs
+++ b/GParamSpec.xs
@@ -263,6 +263,9 @@ BOOT:
 #if GLIB_CHECK_VERSION(2,4,0)
 	gperl_register_param_spec (G_TYPE_PARAM_OVERRIDE, "Glib::Param::Override");
 #endif
+#if GLIB_CHECK_VERSION(2,10,0)
+	gperl_register_param_spec (G_TYPE_PARAM_GTYPE, "Glib::Param::GType");
+#endif
 
 =for enum Glib::ParamFlags
 =cut
@@ -569,6 +572,23 @@ scalar (class, name, nick, blurb, flags)
 ###  GParamSpec* g_param_spec_value_array (const gchar *name, const gchar *nick, const gchar *blurb, GParamSpec *element_spec, GParamFlags flags) 
 
 
+#if GLIB_CHECK_VERSION(2, 10, 0)
+
+=for apidoc
+=for arg is_a_type  The name of a class whose subtypes are allowed as values of the property.  Use C<undef> to allow any type.
+=cut
+GParamSpec*
+g_param_spec_gtype (class, name, nick, blurb, is_a_type, flags)
+	const gchar *name
+	const gchar *nick
+	const gchar *blurb
+	const gchar_ornull *is_a_type
+	GParamFlags flags
+    C_ARGS:
+	name, nick, blurb, is_a_type ? gperl_type_from_package (is_a_type) : G_TYPE_NONE, flags
+
+#endif
+
 
 ####
 #### accessors
@@ -1198,3 +1218,36 @@ get_default_value (GParamSpec * pspec_unichar)
 ## G_TYPE_PARAM_POINTER, "Glib::Param::Pointer" -- no members
 ## G_TYPE_PARAM_OBJECT, "Glib::Param::Object" -- no members
 ## G_TYPE_PARAM_OVERRIDE, "Glib::Param::Override" -- no public members
+
+
+MODULE = Glib::ParamSpec	PACKAGE = Glib::Param::GType
+
+#if GLIB_CHECK_VERSION(2, 10, 0)
+
+=for section DESCRIPTION
+
+=head1 DESCRIPTION
+
+This object describes a parameter which holds the name of a class known to the
+GLib type system.  The name of the class is considered to be the common
+ancestor for valid values.  To create a param that allows any type name,
+specify C<undef> for the package name.  Beware, however, that although
+we say "any type name", this actually refers to any type registered
+with Glib; normal Perl packages will not work.
+
+=cut
+
+=for apidoc
+If C<undef>, then any class is allowed.
+=cut
+const gchar_ornull *
+is_a_type (GParamSpec * pspec_gtype)
+    CODE:
+	GParamSpecGType * p = G_PARAM_SPEC_GTYPE (pspec_gtype);
+	RETVAL = p->is_a_type == G_TYPE_NONE
+		? NULL
+		: gperl_package_from_type (p->is_a_type);
+    OUTPUT:
+	RETVAL
+
+#endif
diff --git a/GValue.xs b/GValue.xs
index c278cc4..c1dfed0 100644
--- a/GValue.xs
+++ b/GValue.xs
@@ -1,6 +1,6 @@
 /*
- * Copyright (C) 2003-2005 by the gtk2-perl team (see the file AUTHORS for
- * the full list)
+ * Copyright (C) 2003-2009 by the gtk2-perl team (see the file AUTHORS for the
+ * full list)
  *
  * This library is free software; you can redistribute it and/or modify it
  * under the terms of the GNU Library General Public License as published by
@@ -114,6 +114,15 @@ gperl_value_from_sv (GValue * value,
 			g_value_set_string(value, SvGChar(sv));
 			break;
 		case G_TYPE_POINTER:
+#if GLIB_CHECK_VERSION(2, 10, 0)
+			/* The fundamental type for G_TYPE_GTYPE is
+			 * G_TYPE_POINTER, so we have to treat this
+			 * specially. */
+			if (G_VALUE_TYPE (value) == G_TYPE_GTYPE) {
+				g_value_set_gtype (value, gperl_type_from_package (SvGChar (sv)));
+				break;
+			}
+#endif
 			g_value_set_pointer (value,
 			                     INT2PTR (gpointer, SvIV (sv)));
 			break;
@@ -222,6 +231,18 @@ _gperl_sv_from_value_internal (const GValue * value,
 			return newSVGChar (g_value_get_string (value));
 
 		case G_TYPE_POINTER:
+#if GLIB_CHECK_VERSION(2, 10, 0)
+			/* The fundamental type for G_TYPE_GTYPE is
+			 * G_TYPE_POINTER, so we have to treat this
+			 * specially. */
+			if (G_VALUE_TYPE (value) == G_TYPE_GTYPE) {
+				GType gtype = g_value_get_gtype (value);
+				return newSVGChar (
+				  gtype == G_TYPE_NONE
+				         ? NULL
+				         : gperl_package_from_type (gtype));
+			}
+#endif
 			return newSViv (PTR2IV (g_value_get_pointer (value)));
 
 		case G_TYPE_BOXED:
diff --git a/t/e.t b/t/e.t
index 0e65423..3e024e1 100644
--- a/t/e.t
+++ b/t/e.t
@@ -5,7 +5,7 @@
 use strict;
 use utf8;
 use Glib ':constants';
-use Test::More tests => 243;
+use Test::More tests => 259;
 
 # first register some types with which to play below.
 
@@ -210,6 +210,56 @@ foreach (@params) {
 
 
 #
+# Since this is conditional on version, we don't want to overcomplicate
+# the testing logic above.
+#
+SKIP: {
+	skip "GParamSpecGType is new in glib 2.10.0", 16
+		unless Glib->CHECK_VERSION (2, 10, 0);
+	@params = ();
+
+	$pspec = Glib::ParamSpec->gtype ('object', 'Object Type',
+					 "Any object type",
+					 Glib::Object::,
+					 G_PARAM_READWRITE);
+	isa_ok ($pspec, 'Glib::Param::GType');
+	isa_ok ($pspec, 'Glib::ParamSpec');
+	is ($pspec->is_a_type, 'Glib::Object');
+	push @params, $pspec;
+
+	$pspec = Glib::ParamSpec->gtype ('type', 'Any type', "Any type",
+					 undef, G_PARAM_READWRITE);
+	isa_ok ($pspec, 'Glib::Param::GType');
+	isa_ok ($pspec, 'Glib::ParamSpec');
+	is ($pspec->is_a_type, undef);
+	push @params, $pspec;
+
+	Glib::Type->register ('Glib::Object' => 'Baz', properties => \ params);
+
+	my $baz = Glib::Object::new ('Baz');
+	isa_ok ($baz, 'Glib::Object');
+	is ($baz->get ('object'), undef);
+	is ($baz->get ('type'), undef);
+
+	$baz = Glib::Object::new ('Baz', object => 'Bar', type => 'Glib::ParamSpec');
+	isa_ok ($baz, 'Glib::Object');
+	is ($baz->get ('object'), 'Bar');
+	is ($baz->get ('type'), 'Glib::ParamSpec');
+
+	$baz->set (type => 'Bar');
+	is ($baz->get ('type'), 'Bar');
+	$baz->set (type => 'Glib::ParamSpec');
+	is ($baz->get ('type'), 'Glib::ParamSpec');
+
+        $baz->set (object => 'Glib::Object');
+	is ($baz->get ('object'), 'Glib::Object');
+        $baz->set (object => 'Glib::InitiallyUnowned');
+	is ($baz->get ('object'), 'Glib::InitiallyUnowned');
+}
+
+
+
+#
 # verify that NULL param specs are handled gracefully
 #