1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
#!/usr/bin/perl -w
=doc
Tests for new property features. These should probably go into 4.t and 5.t,
but the test suite is a mess of order-of-operations spaghetti tests and i
don't really want to mess with that. Someday we'll have to overhaul this
suite, but it's late on Sunday night and i don't have the energy to fix what
ain't really broke.
This stuff makes Glib::Object::Subclass's GET_PROPERTY()/SET_PROPERTY()
replacements unnecessary. Any ideas how to obsolete its new() replacement?
=cut
use Test::More tests => 42;
use Glib ':constants';
use Data::Dumper;
use strict;
# we'll test, for paranoia's sake, that things work the same both with and
# without Glib::Object::Subclass; to simplify things, let's use the exact
# same list of properties for both. however, since the GObjects take
# ownership of the pspecs, we can't share them. just use the same code
# to create them:
sub make_properties {
# a basic one
Glib::ParamSpec->string ('name', '', '', 'Joe', G_PARAM_READWRITE),
# now with the new explicit handler syntax:
{
# with no handlers, this is the same as not using the hash
pspec => Glib::ParamSpec->string ('middle', '', '', 'Momma',
G_PARAM_READWRITE),
},
{
pspec => Glib::ParamSpec->string ('nickname', '', '', 'Jimmy-John',
G_PARAM_READWRITE),
get => sub { ok(1, 'explicit getter for nickname');
$_[0]->{nickname} },
set => sub { ok(1, 'explicit setter for nickname');
$_[0]->{nickname} = $_[1] },
},
{
# if you leave out a getter, you get the default behavior
pspec => Glib::ParamSpec->string ('surname', '', '', 'Jones',
G_PARAM_READWRITE),
set => sub { ok(1, 'explicit setter for surname');
$_[0]->{surname} = $_[1] },
},
{
# same for leaving out a setter
pspec => Glib::ParamSpec->string ('title', '', '', 'Mr',
G_PARAM_READWRITE),
get => sub { ok(1, 'explicit getter for title');
$_[0]->{title} },
},
};
# create a new object type by hand (no Glib::Object::Subclass)
Glib::Type->register_object ('Glib::Object', 'Foo',
properties => [ &make_properties ]);
# now create one with Subclass, with the same properties.
package Bar;
use Glib::Object::Subclass 'Glib::Object',
properties => [ &main::make_properties ];
package main;
sub prop_names {
map { UNIVERSAL::isa ($_, 'Glib::ParamSpec')
? $_->get_name
: $_->{pspec}->get_name
} @_
}
sub Glib::Object::_list_property_names {
prop_names $_[0]->list_properties
}
sub default_values {
map { $_->get_default_value } $_[0]->list_properties
}
my @names = prop_names &make_properties;
# start tests
is_deeply ([prop_names (Foo->list_properties)], \@names,
'props created correctly for Foo');
my $foo = Foo->new;
isa_ok ($foo, 'Foo', 'it\'s a Foo');
is (scalar keys %$foo, 0, 'new Foo has no keys');
# initially all props should have all default values, except for the ones
# with explicit getters, as the explicit getters don't handle default values.
my @initial_values = default_values ('Foo');
$initial_values[2] = undef;
$initial_values[4] = undef;
my @values = $foo->get (@names);
is_deeply ([$foo->get (@names)], \@initial_values,
'all defaults except for explicit ones');
is (scalar keys %$foo, 0, 'Foo still has no keys after get');
my @default_values = default_values ('Foo');
$foo->set (map { $names[$_], $default_values[$_] } 0..$#names);
is (scalar keys %$foo, 5, 'new Foo has keys after setting');
is_deeply ([ map {$foo->{$_}} @names ], [ @default_values ],
'and they have values');
# now add a GET_PROPERTY and SET_PROPERTY that will be called when no
# explicit ones are supplied.
sub get_property {
ok (1, 'fallback GET_PROPERTY called');
return 'fallback';
}
sub set_property {
ok (1, 'fallback SET_PROPERTY called');
$_[0]->{$_[1]->get_name} = 'fallback';
}
{
no warnings;
*Foo::GET_PROPERTY = \&get_property;
*Foo::SET_PROPERTY = \&set_property;
}
# start over.
$foo = Foo->new;
isa_ok ($foo, 'Foo', 'it\'s a Foo');
is (scalar keys %$foo, 0, 'new Foo has no keys');
# with the overrides in place, none of the implicit keys will have values
# in get, because Subclass's GET doesn't handle defaults.
my @expected = map { defined $_ ? 'fallback' : undef } @initial_values;
@values = $foo->get (@names);
is_deeply ([$foo->get (@names)], \@expected,
'fallback called for implicit getters');
is (scalar keys %$foo, 0, 'Foo still has no keys after get');
@expected = @default_values;
$expected[0] = 'fallback';
$expected[1] = 'fallback';
$expected[4] = 'fallback';
$foo->set (map { $names[$_], $default_values[$_] } 0..$#names);
is (scalar keys %$foo, 5, 'new Foo has keys after setting');
is_deeply ([ map {$foo->{$_}} @names ], [ @expected ],
'and they have values');
#
# now verify that Subclass still works as expected.
#
my $bar = Bar->new;
is (scalar keys %$bar, 0, 'bar has no keys on creation');
@expected = @default_values;
$expected[2] = undef;
$expected[4] = undef;
is_deeply ([$bar->get (@names)], \@expected,
'Subclass works just like registering by hand');
$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');
|
