1#!/usr/bin/perl -w 2 3=doc 4 5Tests for new property features. These should probably go into 4.t and 5.t, 6but the test suite is a mess of order-of-operations spaghetti tests and i 7don't really want to mess with that. Someday we'll have to overhaul this 8suite, but it's late on Sunday night and i don't have the energy to fix what 9ain't really broke. 10 11This stuff makes Glib::Object::Subclass's GET_PROPERTY()/SET_PROPERTY() 12replacements unnecessary. Any ideas how to obsolete its new() replacement? 13 14=cut 15 16use Test::More tests => 54; 17use Glib ':constants'; 18use Data::Dumper; 19use strict; 20 21# we'll test, for paranoia's sake, that things work the same both with and 22# without Glib::Object::Subclass; to simplify things, let's use the exact 23# same list of properties for both. however, since the GObjects take 24# ownership of the pspecs, we can't share them. just use the same code 25# to create them: 26sub make_properties { 27 # a basic one 28 Glib::ParamSpec->string ('name', '', '', 'Joe', G_PARAM_READWRITE), 29 # now with the new explicit handler syntax: 30 { 31 # with no handlers, this is the same as not using the hash 32 pspec => Glib::ParamSpec->string ('middle', '', '', 'Momma', 33 G_PARAM_READWRITE), 34 }, 35 { 36 pspec => Glib::ParamSpec->string ('nickname', '', '', 'Jimmy-John', 37 G_PARAM_READWRITE), 38 get => sub { ok(1, 'explicit getter for nickname'); 39 $_[0]->{nickname} }, 40 set => sub { ok(1, 'explicit setter for nickname'); 41 $_[0]->{nickname} = $_[1] }, 42 }, 43 { 44 # if you leave out a getter, you get the default behavior 45 pspec => Glib::ParamSpec->string ('surname', '', '', 'Jones', 46 G_PARAM_READWRITE), 47 set => sub { ok(1, 'explicit setter for surname'); 48 $_[0]->{surname} = $_[1] }, 49 }, 50 { 51 # same for leaving out a setter 52 pspec => Glib::ParamSpec->string ('title', '', '', 'Mr', 53 G_PARAM_READWRITE), 54 get => sub { ok(1, 'explicit getter for title'); 55 $_[0]->{title} }, 56 }, 57}; 58 59 60# create a new object type by hand (no Glib::Object::Subclass) 61 62Glib::Type->register_object ('Glib::Object', 'Foo', 63 properties => [ &make_properties ]); 64 65 66# now create one with Subclass, with the same properties. 67package Bar; 68use Glib::Object::Subclass 'Glib::Object', 69 properties => [ &main::make_properties ]; 70 71package main; 72 73sub prop_names { 74 map { UNIVERSAL::isa ($_, 'Glib::ParamSpec') 75 ? $_->get_name 76 : $_->{pspec}->get_name 77 } @_ 78} 79sub Glib::Object::_list_property_names { 80 prop_names $_[0]->list_properties 81} 82sub default_values { 83 map { $_->get_default_value } $_[0]->list_properties 84} 85 86 87my @names = prop_names &make_properties; 88 89 90# start tests 91 92is_deeply ([prop_names (Foo->list_properties)], \@names, 93 'props created correctly for Foo'); 94my $foo = Foo->new; 95isa_ok ($foo, 'Foo', 'it\'s a Foo'); 96is (scalar keys %$foo, 0, 'new Foo has no keys'); 97 98# initially all props should have all default values, except for the ones 99# with explicit getters, as the explicit getters don't handle default values. 100my @initial_values = default_values ('Foo'); 101$initial_values[2] = undef; 102$initial_values[4] = undef; 103my @values = $foo->get (@names); 104is_deeply ([$foo->get (@names)], \@initial_values, 105 'all defaults except for explicit ones'); 106is (scalar keys %$foo, 0, 'Foo still has no keys after get'); 107 108my @default_values = default_values ('Foo'); 109$foo->set (map { $names[$_], $default_values[$_] } 0..$#names); 110is (scalar keys %$foo, 5, 'new Foo has keys after setting'); 111is_deeply ([ map {$foo->{$_}} @names ], [ @default_values ], 112 'and they have values'); 113 114# now add a GET_PROPERTY and SET_PROPERTY that will be called when no 115# explicit ones are supplied. 116sub get_property { 117 ok (1, 'fallback GET_PROPERTY called'); 118 return 'fallback'; 119} 120sub set_property { 121 ok (1, 'fallback SET_PROPERTY called'); 122 $_[0]->{$_[1]->get_name} = 'fallback'; 123} 124{ 125no warnings; 126*Foo::GET_PROPERTY = \&get_property; 127*Foo::SET_PROPERTY = \&set_property; 128} 129 130# start over. 131$foo = Foo->new; 132isa_ok ($foo, 'Foo', 'it\'s a Foo'); 133is (scalar keys %$foo, 0, 'new Foo has no keys'); 134 135# with the overrides in place, none of the implicit keys will have values 136# in get, because Subclass's GET doesn't handle defaults. 137my @expected = map { defined $_ ? 'fallback' : undef } @initial_values; 138@values = $foo->get (@names); 139is_deeply ([$foo->get (@names)], \@expected, 140 'fallback called for implicit getters'); 141is (scalar keys %$foo, 0, 'Foo still has no keys after get'); 142 143@expected = @default_values; 144$expected[0] = 'fallback'; 145$expected[1] = 'fallback'; 146$expected[4] = 'fallback'; 147$foo->set (map { $names[$_], $default_values[$_] } 0..$#names); 148is (scalar keys %$foo, 5, 'new Foo has keys after setting'); 149is_deeply ([ map {$foo->{$_}} @names ], [ @expected ], 150 'and they have values'); 151 152 153 154 155# 156# now verify that Subclass still works as expected. 157# 158 159my $bar = Bar->new; 160is (scalar keys %$bar, 0, 'bar has no keys on creation'); 161@expected = @default_values; 162$expected[2] = undef; 163$expected[4] = undef; 164is_deeply ([$bar->get (@names)], \@expected, 165 'Subclass works just like registering by hand'); 166$bar->set (map { $names[$_], $default_values[$_] } 0..$#names); 167is (scalar keys %$bar, 5, 'new Foo has keys after setting'); 168is_deeply ([ map {$bar->{$_}} @names ], [ @default_values ], 169 'and they have values'); 170 171 172 173 174{ 175 # Prior to 1.240 a subclass of a class with a pspec/get/set did not reach 176 # the specified get/set funcs. 177 178 my @getter_args; 179 my @setter_args; 180 { 181 package BaseGetSet; 182 use Glib::Object::Subclass 183 'Glib::Object', 184 properties => [ 185 { 186 pspec => Glib::ParamSpec->string ('my-prop', 187 'My-Prop', 188 'Blurb one', 189 'default one', 190 ['readable','writable']), 191 get => sub { 192 @getter_args = @_; 193 }, 194 set => sub { 195 @setter_args = @_; 196 }, 197 }, 198 ]; 199 } 200 { 201 package SubGetSet; 202 use Glib::Object::Subclass 'BaseGetSet'; 203 } 204 my $obj = SubGetSet->new; 205 206 @getter_args = (); 207 @setter_args = (); 208 $obj->get ('my-prop'); 209 is_deeply (\@getter_args, [$obj], 'my-prop reaches BaseGetSet'); 210 is_deeply (\@setter_args, [], 'my-prop reaches BaseGetSet'); 211 212 @getter_args = (); 213 @setter_args = (); 214 $obj->set (my_prop => 'zzz'); 215 is_deeply (\@getter_args, [], 'my-prop reaches BaseGetSet'); 216 is_deeply (\@setter_args, [$obj,'zzz'], 'my-prop reaches BaseGetSet'); 217} 218 219 220{ 221 # Prior to 1.240 a class with a pspec/get/set which is subclassed with 222 # another separate pspec/get/set property called to the subclass get/set 223 # funcs, not the superclass ones. 224 225 my @baseone_getter_args; 226 my @baseone_setter_args; 227 { 228 package BaseOne; 229 use Glib::Object::Subclass 230 'Glib::Object', 231 properties => [ 232 { 233 pspec => Glib::ParamSpec->string ('prop-one', 234 'Prop-One', 235 'Blurb one', 236 'default one', 237 ['readable','writable']), 238 get => sub { 239 @baseone_getter_args = @_; 240 }, 241 set => sub { 242 # Test::More::diag('baseone setter'); 243 @baseone_setter_args = @_; 244 }, 245 }, 246 ]; 247 } 248 my @subtwo_getter_args; 249 my @subtwo_setter_args; 250 { 251 package SubTwo; 252 use Glib::Object::Subclass 253 'BaseOne', 254 properties => [ 255 { 256 pspec => Glib::ParamSpec->string ('prop-two', 257 'Prop-Two', 258 'Blurb two', 259 'default two', 260 ['readable','writable']), 261 get => sub { 262 @subtwo_getter_args = @_; 263 }, 264 set => sub { 265 # Test::More::diag('subtwo setter'); 266 @subtwo_setter_args = @_; 267 }, 268 }, 269 ]; 270 } 271 my $obj = SubTwo->new; 272 273 @baseone_getter_args = (); 274 @subtwo_getter_args = (); 275 $obj->get ('prop-two'); 276 is_deeply (\@baseone_getter_args, [], 'prop-two goes to subtwo'); 277 is_deeply (\@subtwo_getter_args, [$obj], 'prop-two goes to subtwo'); 278 279 @baseone_getter_args = (); 280 @subtwo_getter_args = (); 281 $obj->get ('prop-one'); 282 is_deeply (\@baseone_getter_args, [$obj], 'prop-one goes to baseone'); 283 is_deeply (\@subtwo_getter_args, [], 'prop-one goes to baseone'); 284 285 286 @baseone_setter_args = (); 287 @subtwo_setter_args = (); 288 $obj->set (prop_two => 'xyz'); 289 is_deeply (\@baseone_setter_args, [], 'prop-two goes to subtwo'); 290 is_deeply (\@subtwo_setter_args, [$obj,'xyz'], 'prop-two goes to subtwo'); 291 292 @baseone_setter_args = (); 293 @subtwo_setter_args = (); 294 $obj->set (prop_one => 'abc'); 295 is_deeply (\@baseone_setter_args, [$obj,'abc'], 'prop-one goes to baseone'); 296 is_deeply (\@subtwo_setter_args, [], 'prop-one goes to baseone'); 297} 298