[perl-Gtk2] Add Gtk2::Widget->find_style_property and list_style_properties

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

commit 4d20b6012eaa7093affd0bdc59bf7bbedfa6d630
Author: Kevin Ryde <user42 zip com au>
Date:   Sat Oct 30 11:09:15 2010 +1100

    Add Gtk2::Widget->find_style_property and list_style_properties
    
    https://bugzilla.gnome.org/show_bug.cgi?id=633519

 t/GtkWidget.t   |   29 ++++++++++++++++--
 xs/GtkWidget.xs |   91 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 116 insertions(+), 4 deletions(-)
---
diff --git a/t/GtkWidget.t b/t/GtkWidget.t
index ccd44d4..aefb9b8 100644
--- a/t/GtkWidget.t
+++ b/t/GtkWidget.t
@@ -6,7 +6,7 @@
 
 use warnings;
 use strict;
-use Gtk2::TestHelper tests => 135;
+use Gtk2::TestHelper tests => 140;
 
 # we can't instantiate Gtk2::Widget, it's abstract.  use a button instead.
 
@@ -378,7 +378,7 @@ $widget->shape_combine_mask ($bitmap, 5, 5);
 $widget->shape_combine_mask (undef, 5, 5);
 
 SKIP: {
-	skip "stuff that's new in 2.2", 5
+	skip "stuff that's new in 2.2", 10
 		unless Gtk2->CHECK_VERSION (2, 2, 0);
 
 	isa_ok ($widget->get_clipboard, "Gtk2::Clipboard");
@@ -387,6 +387,29 @@ SKIP: {
 	isa_ok ($widget->get_screen, "Gtk2::Gdk::Screen");
 
 	is ($widget->has_screen, 1);
+
+	# not sure it's wise to enquire into what properties exist, but
+	# let's assume there's at least 1
+	{ my @pspecs = $widget->list_style_properties;
+	  cmp_ok (scalar(@pspecs), '>', 0); }
+	{ my @pspecs = Gtk2::Widget->list_style_properties;
+	  cmp_ok (scalar(@pspecs), '>', 0); }
+
+	is ($widget->find_style_property('no-such-style-property-of-this-name'),
+	    undef,
+	    "find_style_property() no such name, on object");
+	is (Gtk2::Widget->find_style_property('no-such-style-property-of-this-name'),
+	    undef,
+	    "find_style_property() no such name, on class");
+	is (Gtk2::Label->find_style_property('no-such-style-property-of-this-name'),
+	    undef,
+	    "find_style_property() no such name, on label class");
+
+	# not sure it's wise to depend on properties exist, but at least
+	# exercise the code on "interior-focus" which exists in 2.2 up
+	$widget->find_style_property('interior-focus');
+	Gtk2::Widget->find_style_property('interior-focus');
+	Gtk2::Label->find_style_property('interior-focus');
 }
 
 SKIP: {
@@ -481,5 +504,5 @@ SKIP: {
 
 __END__
 
-Copyright (C) 2003-2006 by the gtk2-perl team (see the file AUTHORS for the
+Copyright (C) 2003-2006, 2010 by the gtk2-perl team (see the file AUTHORS for the
 full list).  See LICENSE for more information.
diff --git a/xs/GtkWidget.xs b/xs/GtkWidget.xs
index 8e13de7..c2a06e1 100644
--- a/xs/GtkWidget.xs
+++ b/xs/GtkWidget.xs
@@ -1,5 +1,5 @@
 /*
- * Copyright (c) 2003-2006, 2009 by the gtk2-perl team (see the file AUTHORS)
+ * Copyright (c) 2003-2006, 2009, 2010 by the gtk2-perl team (see the file AUTHORS)
  *
  * Licensed under the LGPL, see LICENSE file for more information.
  *
@@ -1150,6 +1150,95 @@ gtk_widget_path (GtkWidget *widget)
 #	GtkWidgetClass * klass
 #	guint          * n_properties
 
+=for apidoc Gtk2::Widget::list_style_properties
+=for signature list = $widget_or_class_name->list_style_properties
+=for arg ... (__hide__)
+Return a list of C<Glib::ParamSpec> objects which are the style
+properties available on C<$widget_or_class_name>.  See L<Glib::Object>
+C<list_properties> for the fields in a ParamSpec.
+=cut
+=for apidoc Gtk2::Widget::find_style_property
+=for signature pspec or undef = $widget_or_class_name->find_style_property ($name)
+=for arg name (string)
+=for arg ... (__hide__)
+Return a C<Glib::ParamSpec> for style property C<$name> on widget
+C<$widget_or_class_name>.  If there's no property C<$name> then return
+C<undef>.  See L<Glib::Object> C<list_properties> for the fields in a
+ParamSpec.
+=cut
+void
+find_style_property (widget_or_class_name, ...)
+	SV * widget_or_class_name
+    ALIAS:
+        Gtk2::Widget::list_style_properties = 1
+    PREINIT:
+	GType type;
+	gchar *name = NULL;
+	GtkWidgetClass *widget_class;
+    PPCODE:
+	/* ENHANCE-ME: share this SV to GType lookup code with
+	   Glib::Object::find_property and Gtk2::Container::find_child_property
+	   and probably other places.  Might pass GTK_TYPE_WIDGET to say it
+	   should be a widget. */
+	if (gperl_sv_is_defined (widget_or_class_name) &&
+	    SvROK (widget_or_class_name)) {
+		GtkWidget * widget = SvGtkWidget (widget_or_class_name);
+		if (!widget)
+			croak ("wha?  NULL widget in list_style_properties");
+		type = G_OBJECT_TYPE (widget);
+	} else {
+		type = gperl_object_type_from_package
+			(SvPV_nolen (widget_or_class_name));
+		if (!type)
+			croak ("package %s is not registered with GPerl",
+			       SvPV_nolen (widget_or_class_name));
+	}
+
+	switch (ix) {
+	case 0:
+		if (items != 2)
+			croak ("Usage: Gtk2::Widget::find_style_property (class, name)");
+		name = SvGChar (ST (1));
+		break;
+	default: /* ix==1 */
+		if (items != 1)
+			croak ("Usage: Gtk2::Widget::list_style_properties (class)");
+		break;
+	}
+	if (! g_type_is_a (type, GTK_TYPE_WIDGET))
+		croak ("Not a Gtk2::Widget");
+
+	/* classes registered by perl are kept alive by the bindings.
+	 * those coming straight from C are not.  if we had an actual
+	 * widget, the class will be alive, but if we just had a
+	 * package, the class may not exist yet.  thus, we'll have to
+	 * do an honest ref here, rather than a peek.
+	 */
+	widget_class = g_type_class_ref (type);
+
+	if (ix == 0) {
+		GParamSpec *pspec
+		  = gtk_widget_class_find_style_property
+		      (widget_class, name);
+		XPUSHs (pspec
+			? sv_2mortal (newSVGParamSpec (pspec))
+			: &PL_sv_undef);
+	}
+	else if (ix == 1) {
+		GParamSpec **props;
+		guint n_props, i;
+		props = gtk_widget_class_list_style_properties
+			  (widget_class, &n_props);
+		if (n_props) {
+			EXTEND (SP, n_props);
+			for (i = 0; i < n_props; i++)
+				PUSHs (sv_2mortal (newSVGParamSpec (props[i])));
+		}
+		g_free (props); /* must free even when n_props==0 */
+	}
+
+	g_type_class_unref (widget_class);
+
 
 #GtkClipboard* gtk_widget_get_clipboard (GtkWidget *widget, GdkAtom selection)
 GtkClipboard *