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
|
#!perl
#
# more derivation testing, ensuring that signals are inherited properly.
#
use strict;
use warnings;
use Glib;
use vars qw/@one_base_ok @one_inst_ok @two_base_ok @two_inst_ok
@three_base_ok @three_inst_ok @four_base_ok @four_inst_ok
@member_ok @signal_ok/;
# this looks a little hairy because i want to make sure that we test the
# order of operations. the begin block at the top defines a few named
# arrays of sequence numbers. the ok() function takes a string with the
# the name of the array (minus the _ok) from which to shift the next
# sequence number. this way we can change the order rather simply as we
# modify the test, and allow each callback to be run more than once.
BEGIN {
print "1..31\n";
@one_base_ok = (1,3,5);
@one_inst_ok = (8,11,12,14);
@two_base_ok = (2,6);
@two_inst_ok = (9,13);
@three_base_ok = (4);
@three_inst_ok = (15);
@four_base_ok = (7);
@four_inst_ok = (10);
@member_ok = (16..23);
@signal_ok = (24..31);
}
sub ok {
no strict 'refs';
my $condition = shift;
my $ary = \@{"$_[0]\_ok"};
my $seq = $ary->[0];
shift @$ary;
print "".($condition ? "ok" : "not ok")." $seq - $_[0]\n";
}
sub readwrite { [qw/readable writable/] }
sub makeparam {
my $name = shift;
Glib::ParamSpec->string ($name, $name, $name, '', [qw/readable writable/]);
}
#
# define several classes that form a hierarchy, deriving from one another.
#
package One;
use Glib::Object::Subclass
Glib::Object::,
signals => { one => {} },
properties => [ ::makeparam('one'), ],
;
sub INIT_BASE { ::ok(1, 'one_base'); }
sub INIT_INSTANCE { $_[0]{one} = 'one'; ::ok(1, 'one_inst'); }
sub one { shift->signal_emit ('one', @_); }
package Two;
sub INIT_BASE { ::ok(1, 'two_base'); }
use Glib::Object::Subclass
One::,
signals => { two => {} },
properties => [ ::makeparam ('two'), ],
;
sub INIT_INSTANCE { $_[0]{two} = 'two'; ::ok(1, 'two_inst'); }
sub two { shift->signal_emit ('two', @_); }
package Three;
sub INIT_BASE { ::ok(1, 'three_base'); }
use Glib::Object::Subclass
One::,
signals => { three => {} },
properties => [ ::makeparam ('three'), ],
;
sub INIT_INSTANCE { $_[0]{three} = 'three'; ::ok(1, 'three_inst'); }
sub three { shift->signal_emit ('three', @_); }
package Four;
sub INIT_BASE { ::ok(1, 'four_base'); }
use Glib::Object::Subclass
Two::,
signals => { four => {} },
properties => [ ::makeparam ('four'), ],
;
sub INIT_INSTANCE { $_[0]{four} = 'four'; ::ok(1, 'four_inst'); }
sub four { shift->signal_emit ('four', @_); }
package main;
my $four = Four->new;
my $one = One->new;
my $two = Two->new;
my $three = Three->new;
#
# the INIT_INSTANCE for each class should've run appropriately. let's
# verify that by testing that each instance variable contains what we
# think it should contain.
#
ok( $one->{one} eq 'one', 'member' );
ok( $two->{one} eq 'one', 'member' );
ok( $three->{one} eq 'one', 'member' );
ok( $four->{one} eq 'one', 'member' );
ok( $two->{two} eq 'two', 'member' );
ok( $four->{two} eq 'two', 'member' );
ok( $three->{three} eq 'three', 'member' );
ok( $four->{four} eq 'four', 'member' );
#
# we'll get complaints from GLib if we try to connect to non-existent
# signals. this verifies that signals we create for one type are
# still valid for derivatives of that type.
#
sub do_ok { ok (1, 'signal'); }
$one->signal_connect (one => \&do_ok);
$two->signal_connect (one => \&do_ok);
$three->signal_connect (one => \&do_ok);
$four->signal_connect (one => \&do_ok);
$two->signal_connect (two => \&do_ok);
$four->signal_connect (two => \&do_ok);
$three->signal_connect (three => \&do_ok);
$four->signal_connect (four => \&do_ok);
$one->one;
$two->one;
$three->one;
$four->one;
$two->two;
$four->two;
$three->three;
$four->four;
|
