[RFC] automatic property getters and setters

[muppet <scott asofyet org>]

as discussed a while back[1], here's a way to remove the need for
Glib::Object::Subclass to provide GET_PROPERTY/SET_PROPERTY.  this is
step one, providing a fallback; step two is adding the per-property
setters and getters that would take precedence over [SG]ET_PROPERTY and
this fallback.

this fallback does the same as the default behavior provided by
Subclass; provide property storage in the wrapper hash.  this goes a
step further for GETting, fetching a default value for the property if
one is available.  thus, the default value you give when creating
properties actually has a purpose.  :-)

attached is the patch that adds this fallback behavior to Glib HEAD (or
1.050), and a simple driver program.  the patch as provided includes
some debugging output which i think is the cause for the warnings from
the test suite.

your comments would be greatly appreciated.


[1] the thread starts here, with jan's suggestion:
http://mail.gnome.org/archives/gtk-perl-list/2004-May/msg00037.html
after discussion, this is roughly what i'm starting to implement:
http://mail.gnome.org/archives/gtk-perl-list/2004-May/msg00048.html

use Glib ':constants';
use Data::Dumper;
use strict;

Glib::Type->register_object ('Glib::Object', 'Foo',
	properties => [
		Glib::ParamSpec->object ('carmine', 'C', '', 'Glib::Object', G_PARAM_READWRITE),
		Glib::ParamSpec->string ('says', '', '', 'one boy', G_PARAM_READWRITE),
		Glib::ParamSpec->int ('one-boy', 'One', '', 0, 10, 2, G_PARAM_READWRITE),
		Glib::ParamSpec->int ('two-boy', 'Two', '', 0, 10, 4, G_PARAM_READWRITE),
	],
	);

sub _Foo::GET_PROPERTY {
	my ($self, $pspec) = @_;
	if (exists $self->{$pspec->get_name}) {
		return $pspec->{$pspec->get_name};
	} else {
		return $pspec->can ('get_default_value')
			? $pspec->get_default_value
			: undef;
	}
}

#my @props = map { $_->{name} } Foo->list_properties;

my $foo;
$foo = Foo->new;
$foo->_dumpprops;

$foo = Foo->new (one_boy => 3);
print Dumper($foo);
$foo->{'one-boy'} = 1;
$foo->{two_boy} = '2';
print Dumper($foo);

$foo->_dumpprops;

print Dumper($foo);

$foo->set (carmine => Foo->new, says => "now here are two");
$foo->_dumpprops;
print Dumper($foo);

sub Glib::Object::_dumpprops {
	my $self = shift;
	print "$self\n";
	map {
		printf "  %20s: %s\n", $_->{name}, $self->get ($_->{name});
	} $self->list_properties;
	#map { printf "  %20s: %s\n", $_, $self->get ($_) } @props;
}

? diff
? .diff.swp
? GType.i
? param_test.pl
? newprops.pl
? .GType.xs.swp
? .GParamSpec.xs.swp
? .param_test.pl.swp
? .GObject.xs.swp
Index: GObject.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GObject.xs,v
retrieving revision 1.45
diff -u -r1.45 GObject.xs
--- GObject.xs	9 Jun 2004 01:58:44 -0000	1.45
+++ GObject.xs	12 Jun 2004 03:31:37 -0000
@@ -732,6 +732,43 @@
 
 =cut
 
+/*
+ * $sv = $object->{name}
+ *
+ * if the key doesn't exist with name, convert - to _ and try again.
+ * that is, support both "funny-name" and "funny_name".
+ *
+ * if create is true, autovivify the key (and always return a value).
+ * if create is false, returns NULL is there is no such key.
+ */
+SV *
+_gperl_fetch_wrapper_key (GObject * object,
+                          const char * name,
+                          gboolean create)
+{
+	SV ** svp;
+	SV * svname;
+	HV * wrapper_hash;
+	wrapper_hash = g_object_get_qdata (object, wrapper_quark);
+	svname = newSVpv (name, strlen (name));
+	svp = hv_fetch (wrapper_hash, SvPV_nolen (svname), SvLEN (svname)-1,
+	                create);
+	if (!svp) {
+		/* the key doesn't exist with that name.  do s/-/_/g and
+		 * try again. */
+		register char * c;
+		for (c = SvPV_nolen (svname); c <= SvEND (svname) ; c++)
+			if (*c == '-')
+				*c = '_';
+		svp = hv_fetch (wrapper_hash,
+		                SvPV_nolen (svname), SvLEN (svname)-1,
+		                FALSE);
+	}
+	SvREFCNT_dec (svname);
+
+	return (svp ? *svp : NULL);
+}
+
 #if GPERL_THREAD_SAFE
 static void
 _inc_ref_and_count (GObject * key, gint value, gpointer user_data)
@@ -1014,7 +1051,6 @@
 		g_value_unset (&value);
 	}
 
-
 =for apidoc
 
 Emits a "notify" signal for the property I<$property> on I<$object>.
Index: GType.xs
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Glib/GType.xs,v
retrieving revision 1.62
diff -u -r1.62 GType.xs
--- GType.xs	9 Jun 2004 01:58:44 -0000	1.62
+++ GType.xs	12 Jun 2004 03:31:39 -0000
@@ -28,6 +28,11 @@
 #include "gperl.h"
 #include "gperl_marshal.h"
 
+/* private helper, defined in GObject.xs, not exported */
+extern SV * _gperl_fetch_wrapper_key (GObject * object,
+                                      const char * name,
+                                      gboolean create);
+
 /* for fundamental types */
 static GHashTable * types_by_package = NULL;
 static GHashTable * packages_by_type = NULL;
@@ -1112,11 +1117,73 @@
 	SvREFCNT_dec (class_name);
 }
 
+
+/* set value to the default value of the given pspec, if the pspec supports
+ * default values.
+ */
+static void
+get_default_property_value (GValue * value,
+                            GParamSpec * pspec)
+{
+	/* 
+	 * not all pspec types support a default value, and user code can
+	 * add pspec types; thus, glib does not provide a unified way to
+	 * get a default value for a param.  also, the default value member
+	 * may be at different offsets in the various param spec structs,
+	 * so to do this in pure C we'd have to create a whole slew of
+	 * helper functions to set the default values and put them in a
+	 * hash table (or an if-else tree -- since the type codes are dynamic,
+	 * we can't use them in a switch).  however, that would leave us with
+	 * code bloat and a maintenance problem, since we'd have to add code
+	 * for each new param type, and we'd never handle custom params.
+	 *
+	 * instead, let's use the existing infrastructure in the bindings,
+	 * and let perl's oo system do the hard work for us.  this will catch
+	 * any custom params as well (provided their default_value accessors
+	 * have been bound), at a slight cost in performance.
+	 */
+	const char * package;
+	GV * method = NULL;
+	HV * stash;
+	package = gperl_param_spec_package_from_type (G_PARAM_SPEC_TYPE (pspec));
+	if (!package)
+		croak ("Param spec type %s is not registered with GPerl",
+		       g_type_name (G_PARAM_SPEC_TYPE (pspec)));
+	stash = gv_stashpv (package, FALSE);
+	assert (stash)
+	method = gv_fetchmethod (stash, "get_default_value");
+
+	if (method) {
+		SV * sv;
+
+		dSP;
+		ENTER;
+		SAVETMPS;
+		PUSHMARK (SP);
+		PUSHs (sv_2mortal (newSVGParamSpec (pspec)));
+		PUTBACK;
+
+		call_sv ((SV *)GvCV (method), G_SCALAR);
+		SPAGAIN;
+
+		sv = POPs;
+		gperl_value_from_sv (value, sv);
+
+		PUTBACK;
+		FREETMPS;
+		LEAVE;
+
+	} else {
+		/* no method, so no way to fetch a default value.
+		 * do nothing. */
+	}
+}
+
 static void
 gperl_type_get_property (GObject * object,
-                         guint property_id,
-                         GValue * value,
-                         GParamSpec * pspec)
+		 guint property_id,
+		 GValue * value,
+		 GParamSpec * pspec)
 {
         HV *stash = gperl_object_stash_from_type (pspec->owner_type);
         SV **slot;
@@ -1130,6 +1197,8 @@
         if (slot && GvCV (*slot)) {
                   dSP;
 
+		  warn (G_STRLOC ": calling GET_PROPERTY on %s\n", SvPV_nolen ((SV*)g_object_get_data (object, "Perl-wrapper-object")));
+
                   ENTER;
                   SAVETMPS;
 
@@ -1148,7 +1217,19 @@
                   PUTBACK;
                   FREETMPS;
                   LEAVE;
-        }
+
+        } else {
+		/* no GET_PROPERTY; look in the wrapper hash. */
+		SV * val = _gperl_fetch_wrapper_key
+				(object, g_param_spec_get_name (pspec), FALSE);
+		if (val)
+			gperl_value_from_sv (value, val);
+		else {
+			/* no value in the wrapper hash.  get the pspec's
+			 * default, if it has one. */
+			get_default_property_value (value, pspec);
+		}
+	}
 }
 
 static void
@@ -1168,6 +1249,7 @@
         /* does the function exist? then call it. */
         if (slot && GvCV (*slot)) {
                   dSP;
+		  warn (G_STRLOC ": calling SET_PROPERTY on %p\n", object);
 
                   ENTER;
                   SAVETMPS;
@@ -1182,7 +1264,20 @@
 
                   FREETMPS;
                   LEAVE;
-        }
+
+        } else {
+		/* no SET_PROPERTY.  fall back to setting the value into
+		 * a key with the pspec's name in the wrapper hash. */
+		SV * val = _gperl_fetch_wrapper_key
+				(object, g_param_spec_get_name (pspec), TRUE);
+		warn (G_STRLOC ": wrapper key %p (%s)\n", val, val ? SvPV_nolen (val) : "NULL");
+		if (val) {
+			SV * newval = sv_2mortal (gperl_sv_from_value (value));
+			SvSetSV (val, newval);
+		} else {
+			/* XXX couldn't create the key.  what to do? */
+		}
+	}
 }
 
 static void