[perl-Glib] Fix subclassing with {pspec, get, set}-style properties

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

commit 594d7fb7addd68239ce55faa1448f8cf5549b46c
Author: Kevin Ryde <user42 zip com au>
Date:   Tue Nov 9 06:12:02 2010 +1100

    Fix subclassing with {pspec, get, set}-style properties
    
    Previously setting such a property defined by a superclass did not
    reach those get/set funcs but instead the GET_PROPERTY/SET_PROPERTY
    (in the superclass).  Or if the subclass had another get/set funcs
    property (of a different name) at the same position N in the
    properties list then the subclass funcs were reached instead of the
    superclass ones.
    
    https://bugzilla.gnome.org/show_bug.cgi?id=634350

 GType.xs |    9 +++-
 NEWS     |    1 +
 t/f.t    |  130 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 136 insertions(+), 4 deletions(-)
---
diff --git a/GType.xs b/GType.xs
index 3f36241..e4b0d25 100644
--- a/GType.xs
+++ b/GType.xs
@@ -1549,7 +1549,7 @@ gperl_type_get_property (GObject * object,
 	SV **slot;
 	SV * getter;
 
-	prop_handler_lookup (G_OBJECT_TYPE (object), property_id, NULL, &getter);
+	prop_handler_lookup (pspec->owner_type, property_id, NULL, &getter);
 	if (getter) {
 		dSP;
 		ENTER;
@@ -1617,7 +1617,7 @@ gperl_type_set_property (GObject * object,
 	SV ** slot;
 	SV  * setter;
 
-	prop_handler_lookup (G_OBJECT_TYPE (object), property_id, &setter, NULL);
+	prop_handler_lookup (pspec->owner_type, property_id, &setter, NULL);
 	if (setter) {
 		dSP;
 		ENTER;
@@ -2128,7 +2128,10 @@ are both optional in the hash form.  For example:
       ]
    );
 
-You can mix the two declaration styles as you like.
+You can mix the two declaration styles as you like.  If you have
+individual C<get_foo> / C<set_foo> methods with the operative code for
+a property then the C<get>/C<set> form is a handy way to go straight
+to that.
 
 =item interfaces => ARRAYREF
 
diff --git a/NEWS b/NEWS
index 271367f..53ee9d1 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,7 @@ Overview of changes in the next unstable release of Glib
 ========================================================
 
 * Fix fetching default values for unichar properties of custom subclasses.
+* Fix subclassing with {pspec, get, set}-style properties.
 
 Overview of changes in Glib 1.230
 =================================
diff --git a/t/f.t b/t/f.t
index 3e274af..edb1ff7 100644
--- a/t/f.t
+++ b/t/f.t
@@ -13,7 +13,7 @@ replacements unnecessary.  Any ideas how to obsolete its new() replacement?
 
 =cut
 
-use Test::More tests => 42;
+use Test::More tests => 54;
 use Glib ':constants';
 use Data::Dumper;
 use strict;
@@ -167,3 +167,131 @@ $bar->set (map { $names[$_], $default_values[$_] } 0..$#names);
 is (scalar keys %$bar, 5, 'new Foo has keys after setting');
 is_deeply ([ map {$bar->{$_}} @names ], [ @default_values ],
            'and they have values');
+
+
+
+
+{
+  # Prior to 1.240 a subclass of a class with a pspec/get/set did not reach
+  # the specified get/set funcs.
+
+  my @getter_args;
+  my @setter_args;
+  {
+    package BaseGetSet;
+    use Glib::Object::Subclass
+      'Glib::Object',
+      properties => [
+		     {
+		      pspec => Glib::ParamSpec->string ('my-prop',
+							'My-Prop',
+							'Blurb one',
+							'default one',
+							['readable','writable']),
+		      get => sub {
+			@getter_args = @_;
+		      },
+		      set => sub {
+			@setter_args = @_;
+		      },
+		     },
+		    ];
+  }
+  {
+    package SubGetSet;
+    use Glib::Object::Subclass 'BaseGetSet';
+  }
+  my $obj = SubGetSet->new;
+
+  @getter_args = ();
+  @setter_args = ();
+  $obj->get ('my-prop');
+  is_deeply (\ getter_args, [$obj], 'my-prop reaches BaseGetSet');
+  is_deeply (\ setter_args, [],     'my-prop reaches BaseGetSet');
+
+  @getter_args = ();
+  @setter_args = ();
+  $obj->set (my_prop => 'zzz');
+  is_deeply (\ getter_args, [],           'my-prop reaches BaseGetSet');
+  is_deeply (\ setter_args, [$obj,'zzz'], 'my-prop reaches BaseGetSet');
+}
+
+
+{
+  # Prior to 1.240 a class with a pspec/get/set which is subclassed with
+  # another separate pspec/get/set property called to the subclass get/set
+  # funcs, not the superclass ones.
+
+  my @baseone_getter_args;
+  my @baseone_setter_args;
+  {
+    package BaseOne;
+    use Glib::Object::Subclass
+      'Glib::Object',
+      properties => [
+		     {
+		      pspec => Glib::ParamSpec->string ('prop-one',
+							'Prop-One',
+							'Blurb one',
+							'default one',
+							['readable','writable']),
+		      get => sub {
+			@baseone_getter_args = @_;
+		      },
+		      set => sub {
+			# Test::More::diag('baseone setter');
+			@baseone_setter_args = @_;
+		      },
+		     },
+		    ];
+  }
+  my @subtwo_getter_args;
+  my @subtwo_setter_args;
+  {
+    package SubTwo;
+    use Glib::Object::Subclass
+      'BaseOne',
+      properties => [
+		     {
+		      pspec => Glib::ParamSpec->string ('prop-two',
+							'Prop-Two',
+							'Blurb two',
+							'default two',
+							['readable','writable']),
+		      get => sub {
+			@subtwo_getter_args = @_;
+		      },
+		      set => sub {
+			# Test::More::diag('subtwo setter');
+			@subtwo_setter_args = @_;
+		      },
+		     },
+		    ];
+  }
+  my $obj = SubTwo->new;
+
+  @baseone_getter_args = ();
+  @subtwo_getter_args = ();
+  $obj->get ('prop-two');
+  is_deeply (\ baseone_getter_args, [],     'prop-two goes to subtwo');
+  is_deeply (\ subtwo_getter_args,  [$obj], 'prop-two goes to subtwo');
+
+  @baseone_getter_args = ();
+  @subtwo_getter_args = ();
+  $obj->get ('prop-one');
+  is_deeply (\ baseone_getter_args, [$obj], 'prop-one goes to baseone');
+  is_deeply (\ subtwo_getter_args,  [],     'prop-one goes to baseone');
+
+
+  @baseone_setter_args = ();
+  @subtwo_setter_args = ();
+  $obj->set (prop_two => 'xyz');
+  is_deeply (\ baseone_setter_args, [],           'prop-two goes to subtwo');
+  is_deeply (\ subtwo_setter_args,  [$obj,'xyz'], 'prop-two goes to subtwo');
+
+  @baseone_setter_args = ();
+  @subtwo_setter_args = ();
+  $obj->set (prop_one => 'abc');
+  is_deeply (\ baseone_setter_args, [$obj,'abc'], 'prop-one goes to baseone');
+  is_deeply (\ subtwo_setter_args,  [],           'prop-one goes to baseone');
+}