line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
# or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# (C) Paul Evans, 2010-2021 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package Tangence::Object 0.28; |
7
|
|
|
|
|
|
|
|
8
|
14
|
|
|
14
|
|
167
|
use v5.26; |
|
14
|
|
|
|
|
41
|
|
9
|
14
|
|
|
14
|
|
66
|
use warnings; |
|
14
|
|
|
|
|
25
|
|
|
14
|
|
|
|
|
385
|
|
10
|
14
|
|
|
14
|
|
69
|
use experimental 'signatures'; |
|
14
|
|
|
|
|
24
|
|
|
14
|
|
|
|
|
69
|
|
11
|
|
|
|
|
|
|
|
12
|
14
|
|
|
14
|
|
2047
|
use Carp; |
|
14
|
|
|
|
|
47
|
|
|
14
|
|
|
|
|
902
|
|
13
|
|
|
|
|
|
|
|
14
|
14
|
|
|
14
|
|
4350
|
use Syntax::Keyword::Match; |
|
14
|
|
|
|
|
7541
|
|
|
14
|
|
|
|
|
71
|
|
15
|
|
|
|
|
|
|
|
16
|
14
|
|
|
14
|
|
1370
|
use Tangence::Constants; |
|
14
|
|
|
|
|
25
|
|
|
14
|
|
|
|
|
2194
|
|
17
|
|
|
|
|
|
|
|
18
|
14
|
|
|
14
|
|
3596
|
use Tangence::Types; |
|
14
|
|
|
|
|
34
|
|
|
14
|
|
|
|
|
890
|
|
19
|
|
|
|
|
|
|
|
20
|
14
|
|
|
14
|
|
4166
|
use Tangence::Class; |
|
14
|
|
|
|
|
33
|
|
|
14
|
|
|
|
|
50579
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
Tangence::Class->declare( |
23
|
|
|
|
|
|
|
__PACKAGE__, |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
events => { |
26
|
|
|
|
|
|
|
destroy => { |
27
|
|
|
|
|
|
|
args => [], |
28
|
|
|
|
|
|
|
}, |
29
|
|
|
|
|
|
|
}, |
30
|
|
|
|
|
|
|
); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=head1 NAME |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
C - base class for accessible objects in a C server |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=head1 DESCRIPTION |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
This class acts as a base class for the accessible objects in a L |
39
|
|
|
|
|
|
|
server. All the objects actually created and made accessible to clients will |
40
|
|
|
|
|
|
|
be subclasses of this one, including internally-created objects such as |
41
|
|
|
|
|
|
|
L. |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
These objects are not directly constructed by calling the C class method; |
44
|
|
|
|
|
|
|
instead the C should be used to construct one. |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
=cut |
47
|
|
|
|
|
|
|
|
48
|
25
|
|
|
|
|
42
|
sub new ( $class, %args ) |
49
|
25
|
|
|
25
|
0
|
204
|
{ |
|
25
|
|
|
|
|
95
|
|
|
25
|
|
|
|
|
48
|
|
50
|
25
|
50
|
|
|
|
101
|
defined( my $id = delete $args{id} ) or croak "Need a id"; |
51
|
25
|
50
|
|
|
|
88
|
my $registry = delete $args{registry} or croak "Need a registry"; |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
my $self = bless { |
54
|
|
|
|
|
|
|
id => $id, |
55
|
|
|
|
|
|
|
registry => $registry, |
56
|
25
|
|
66
|
|
|
173
|
meta => $args{meta} || Tangence::Class->for_perlname( $class ), |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
event_subs => {}, # {$event} => [ @cbs ] |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
properties => {}, # {$prop} => T:P::Instance struct |
61
|
|
|
|
|
|
|
}, $class; |
62
|
|
|
|
|
|
|
|
63
|
25
|
|
|
|
|
159
|
my $properties = $self->class->properties; |
64
|
25
|
|
|
|
|
87
|
foreach my $prop ( keys %$properties ) { |
65
|
117
|
|
|
|
|
601
|
my $meth = "new_prop_$prop"; |
66
|
117
|
|
|
|
|
349
|
$self->$meth(); |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
25
|
|
|
|
|
344
|
return $self; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=head1 METHODS |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
=cut |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=head2 destroy |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
$obj->destroy |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
Requests that the object destroy itself, informing all clients that are aware |
81
|
|
|
|
|
|
|
of it. Once they all report that they have dropped the object, the object is |
82
|
|
|
|
|
|
|
deconstructed for real. |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
Not to be confused with Perl's own C method. |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
=cut |
87
|
|
|
|
|
|
|
|
88
|
2
|
|
|
|
|
3
|
sub destroy ( $self, %args ) |
89
|
2
|
|
|
2
|
1
|
439
|
{ |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
4
|
|
90
|
2
|
|
|
|
|
6
|
$self->{destroying} = 1; |
91
|
|
|
|
|
|
|
|
92
|
2
|
|
|
|
|
4
|
my $outstanding = 1; |
93
|
|
|
|
|
|
|
|
94
|
2
|
|
|
|
|
4
|
my $on_destroyed = $args{on_destroyed}; |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
my $incsub = sub { |
97
|
2
|
|
|
2
|
|
5
|
$outstanding++ |
98
|
2
|
|
|
|
|
7
|
}; |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
my $decsub = sub { |
101
|
4
|
100
|
|
4
|
|
15
|
--$outstanding and return; |
102
|
2
|
|
|
|
|
13
|
$self->_destroy_really; |
103
|
2
|
50
|
|
|
|
18
|
$on_destroyed->() if $on_destroyed; |
104
|
2
|
|
|
|
|
9
|
}; |
105
|
|
|
|
|
|
|
|
106
|
2
|
|
|
|
|
4
|
foreach my $cb ( @{ $self->{event_subs}->{destroy} } ) { |
|
2
|
|
|
|
|
8
|
|
107
|
2
|
|
|
|
|
8
|
$cb->( $self, $incsub, $decsub ); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
2
|
|
|
|
|
6
|
$decsub->(); |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub _destroy_really |
114
|
|
|
|
|
|
|
{ |
115
|
2
|
|
|
2
|
|
4
|
my $self = shift; |
116
|
|
|
|
|
|
|
|
117
|
2
|
|
|
|
|
18
|
$self->registry->destroy_object( $self ); |
118
|
|
|
|
|
|
|
|
119
|
2
|
|
|
|
|
27
|
undef %$self; # Now I am dead |
120
|
2
|
|
|
|
|
6
|
$self->{destroyed} = 1; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
=head2 id |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
$id = $obj->id |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
Returns the object's C ID number |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
=cut |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
sub id |
132
|
|
|
|
|
|
|
{ |
133
|
106
|
|
|
106
|
1
|
3809
|
my $self = shift; |
134
|
106
|
|
|
|
|
333
|
return $self->{id}; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=head2 describe |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
$description = $obj->describe |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
Returns a textual description of the object, for internal debugging purposes. |
142
|
|
|
|
|
|
|
Subclasses are encouraged to override this method to return something more |
143
|
|
|
|
|
|
|
descriptive within their domain of interest |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=cut |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sub describe |
148
|
|
|
|
|
|
|
{ |
149
|
12
|
|
|
12
|
1
|
31
|
my $self = shift; |
150
|
12
|
|
|
|
|
57
|
return ref $self; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=head2 registry |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
$registry = $obj->registry |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
Returns the L that constructed this object. |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
=cut |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
sub registry |
162
|
|
|
|
|
|
|
{ |
163
|
3
|
|
|
3
|
1
|
9
|
my $self = shift; |
164
|
3
|
|
|
|
|
17
|
return $self->{registry}; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
11
|
|
|
|
|
24
|
sub smash ( $self, $smashkeys ) |
168
|
11
|
|
|
11
|
0
|
33
|
{ |
|
11
|
|
|
|
|
19
|
|
|
11
|
|
|
|
|
20
|
|
169
|
11
|
50
|
33
|
|
|
83
|
return undef unless $smashkeys and @$smashkeys; |
170
|
|
|
|
|
|
|
|
171
|
11
|
|
|
|
|
22
|
my @keys; |
172
|
11
|
50
|
|
|
|
44
|
if( ref $smashkeys eq "HASH" ) { |
173
|
0
|
|
|
|
|
0
|
@keys = keys %$smashkeys; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
else { |
176
|
11
|
|
|
|
|
37
|
@keys = @$smashkeys; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
return { map { |
180
|
11
|
|
|
|
|
36
|
my $m = "get_prop_$_"; |
|
21
|
|
|
|
|
108
|
|
181
|
21
|
|
|
|
|
112
|
$_ => $self->$m() |
182
|
|
|
|
|
|
|
} @keys }; |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
=head2 class |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
$class = $obj->class |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
Returns the L object representing the class of this |
190
|
|
|
|
|
|
|
object. |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=cut |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
sub class |
195
|
|
|
|
|
|
|
{ |
196
|
273
|
|
|
273
|
1
|
414
|
my $self = shift; |
197
|
273
|
50
|
|
|
|
1373
|
return ref $self ? $self->{meta} : Tangence::Class->for_perlname( $self ); |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=head2 can_method |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
$method = $obj->can_method( $name ) |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
Returns the L object representing the named method, or |
205
|
|
|
|
|
|
|
C if no such method exists. |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
=cut |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
sub can_method |
210
|
|
|
|
|
|
|
{ |
211
|
5
|
|
|
5
|
1
|
510
|
my $self = shift; |
212
|
5
|
|
|
|
|
13
|
return $self->class->method( @_ ); |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
=head2 can_event |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
$event = $obj->can_event( $name ) |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
Returns the L object representing the named event, or |
220
|
|
|
|
|
|
|
C if no such event exists. |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=cut |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub can_event |
225
|
|
|
|
|
|
|
{ |
226
|
48
|
|
|
48
|
1
|
529
|
my $self = shift; |
227
|
48
|
|
|
|
|
124
|
return $self->class->event( @_ ); |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=head2 can_property |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
$property = $obj->can_property( $name ) |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
Returns the L object representing the named |
235
|
|
|
|
|
|
|
property, or C if no such property exists. |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
=cut |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub can_property |
240
|
|
|
|
|
|
|
{ |
241
|
170
|
|
|
170
|
1
|
696
|
my $self = shift; |
242
|
170
|
|
|
|
|
405
|
return $self->class->property( @_ ); |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
sub smashkeys |
246
|
|
|
|
|
|
|
{ |
247
|
1
|
|
|
1
|
0
|
497
|
my $self = shift; |
248
|
1
|
|
|
|
|
3
|
return $self->class->smashkeys; |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
=head2 fire_event |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
$obj->fire_event( $event, @args ) |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
Fires the named event on the object. Each event subscription function will be |
256
|
|
|
|
|
|
|
invoked with the given arguments. |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
=cut |
259
|
|
|
|
|
|
|
|
260
|
18
|
|
|
|
|
27
|
sub fire_event ( $self, $event, @args ) |
|
18
|
|
|
|
|
44
|
|
261
|
18
|
|
|
18
|
1
|
344
|
{ |
|
18
|
|
|
|
|
40
|
|
|
18
|
|
|
|
|
33
|
|
262
|
18
|
50
|
|
|
|
61
|
$event eq "destroy" and croak "$self cannot fire destroy event directly"; |
263
|
|
|
|
|
|
|
|
264
|
18
|
50
|
|
|
|
80
|
$self->can_event( $event ) or croak "$self has no event $event"; |
265
|
|
|
|
|
|
|
|
266
|
18
|
100
|
|
|
|
86
|
my $sublist = $self->{event_subs}->{$event} or return; |
267
|
|
|
|
|
|
|
|
268
|
3
|
|
|
|
|
9
|
foreach my $cb ( @$sublist ) { |
269
|
3
|
|
|
|
|
9
|
$cb->( $self, @args ); |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
=head2 subscribe_event |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
$id = $obj->subscribe_event( $event, $callback ) |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
Subscribes an event-handling callback CODE ref to the named event. When the |
278
|
|
|
|
|
|
|
event is fired by C this callback will be invoked, being passed |
279
|
|
|
|
|
|
|
the object reference and the event's arguments. |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
$callback->( $obj, @args ) |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
Returns an opaque ID value that can be used to remove this subscription by |
284
|
|
|
|
|
|
|
calling C. |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
=cut |
287
|
|
|
|
|
|
|
|
288
|
23
|
|
|
|
|
43
|
sub subscribe_event ( $self, $event, $callback ) |
|
23
|
|
|
|
|
36
|
|
289
|
23
|
|
|
23
|
1
|
536
|
{ |
|
23
|
|
|
|
|
34
|
|
|
23
|
|
|
|
|
36
|
|
290
|
23
|
50
|
|
|
|
122
|
$self->can_event( $event ) or croak "$self has no event $event"; |
291
|
|
|
|
|
|
|
|
292
|
23
|
|
100
|
|
|
139
|
my $sublist = ( $self->{event_subs}->{$event} ||= [] ); |
293
|
|
|
|
|
|
|
|
294
|
23
|
|
|
|
|
55
|
push @$sublist, $callback; |
295
|
|
|
|
|
|
|
|
296
|
23
|
|
|
|
|
53
|
my $ref = \@{$sublist}[$#$sublist]; # reference to last element |
|
23
|
|
|
|
|
79
|
|
297
|
23
|
|
|
|
|
119
|
return $ref + 0; # force numeric context |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
=head2 unsubscribe_event |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
$obj->unsubscribe_event( $event, $id ) |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
Removes an event-handling callback previously registered with |
305
|
|
|
|
|
|
|
C. |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
=cut |
308
|
|
|
|
|
|
|
|
309
|
6
|
|
|
|
|
9
|
sub unsubscribe_event ( $self, $event, $id ) |
|
6
|
|
|
|
|
8
|
|
310
|
6
|
|
|
6
|
1
|
11
|
{ |
|
6
|
|
|
|
|
9
|
|
|
6
|
|
|
|
|
7
|
|
311
|
6
|
50
|
|
|
|
20
|
my $sublist = $self->{event_subs}->{$event} or return; |
312
|
|
|
|
|
|
|
|
313
|
6
|
|
|
|
|
9
|
my $index; |
314
|
6
|
|
|
|
|
30
|
for( $index = 0; $index < @$sublist; $index++ ) { |
315
|
4
|
50
|
|
|
|
9
|
last if \@{$sublist}[$index] + 0 == $id; |
|
4
|
|
|
|
|
16
|
|
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
6
|
|
|
|
|
35
|
splice @$sublist, $index, 1, (); |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
=head2 watch_property |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
$id = $obj->watch_property( $prop, %callbacks ) |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
Watches a named property for changes, registering a set of callback functions |
326
|
|
|
|
|
|
|
to be invoked when the property changes in certain ways. The set of callbacks |
327
|
|
|
|
|
|
|
required depends on the dimension of the property being watched. |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
For all property types: |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
$on_set->( $obj, $value ) |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
For hash properties: |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
$on_add->( $obj, $key, $value ) |
336
|
|
|
|
|
|
|
$on_del->( $obj, $key ) |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
For queue properties: |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
$on_push->( $obj, @values ) |
341
|
|
|
|
|
|
|
$on_shift->( $obj, $count ) |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
For array properties: |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
$on_push->( $obj, @values ) |
346
|
|
|
|
|
|
|
$on_shift->( $obj, $count ) |
347
|
|
|
|
|
|
|
$on_splice->( $obj, $index, $count, @values ) |
348
|
|
|
|
|
|
|
$on_move->( $obj, $index, $delta ) |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
For objset properties: |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
$on_add->( $obj, $added_object ) |
353
|
|
|
|
|
|
|
$on_del->( $obj, $deleted_object_id ) |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
Alternatively, a single callback may be installed that is invoked after any |
356
|
|
|
|
|
|
|
change of the property, being passed the new value entirely: |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
$on_updated->( $obj, $value ) |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
Returns an opaque ID value that can be used to remove this watch by calling |
361
|
|
|
|
|
|
|
C. |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
=cut |
364
|
|
|
|
|
|
|
|
365
|
47
|
|
|
|
|
71
|
sub watch_property ( $self, $prop, %callbacks ) |
|
47
|
|
|
|
|
71
|
|
366
|
47
|
|
|
47
|
1
|
2693
|
{ |
|
47
|
|
|
|
|
84
|
|
|
47
|
|
|
|
|
63
|
|
367
|
47
|
50
|
|
|
|
100
|
my $pdef = $self->can_property( $prop ) or croak "$self has no property $prop"; |
368
|
|
|
|
|
|
|
|
369
|
47
|
|
|
|
|
90
|
my $callbacks = {}; |
370
|
47
|
|
|
|
|
66
|
my $on_updated; |
371
|
|
|
|
|
|
|
|
372
|
47
|
100
|
|
|
|
116
|
if( $callbacks{on_updated} ) { |
373
|
4
|
|
|
|
|
8
|
$on_updated = delete $callbacks{on_updated}; |
374
|
4
|
50
|
|
|
|
9
|
ref $on_updated eq "CODE" or croak "Expected 'on_updated' to be a CODE ref"; |
375
|
4
|
50
|
|
|
|
8
|
keys %callbacks and croak "Expected no key other than 'on_updated'"; |
376
|
4
|
|
|
|
|
6
|
$callbacks->{on_updated} = $on_updated; |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
else { |
379
|
43
|
|
|
|
|
63
|
foreach my $name ( @{ CHANGETYPES->{$pdef->dimension} } ) { |
|
43
|
|
|
|
|
121
|
|
380
|
121
|
50
|
|
|
|
369
|
ref( $callbacks->{$name} = delete $callbacks{$name} ) eq "CODE" |
381
|
|
|
|
|
|
|
or croak "Expected '$name' as a CODE ref"; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
|
385
|
47
|
|
|
|
|
221
|
my $watchlist = $self->{properties}->{$prop}->callbacks; |
386
|
|
|
|
|
|
|
|
387
|
47
|
|
|
|
|
313
|
push @$watchlist, $callbacks; |
388
|
|
|
|
|
|
|
|
389
|
47
|
100
|
|
|
|
129
|
$on_updated->( $self, $self->{properties}->{$prop}->value ) if $on_updated; |
390
|
|
|
|
|
|
|
|
391
|
47
|
|
|
|
|
97
|
my $ref = \@{$watchlist}[$#$watchlist]; # reference to last element |
|
47
|
|
|
|
|
102
|
|
392
|
47
|
|
|
|
|
152
|
return $ref + 0; # force numeric context |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
=head2 unwatch_property |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
$obj->unwatch_property( $prop, $id ) |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
Removes the set of callback functions previously registered with |
400
|
|
|
|
|
|
|
C. |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
=cut |
403
|
|
|
|
|
|
|
|
404
|
16
|
|
|
|
|
21
|
sub unwatch_property ( $self, $prop, $id ) |
|
16
|
|
|
|
|
22
|
|
405
|
16
|
|
|
16
|
1
|
19
|
{ |
|
16
|
|
|
|
|
19
|
|
|
16
|
|
|
|
|
20
|
|
406
|
16
|
50
|
|
|
|
47
|
my $watchlist = $self->{properties}->{$prop}->callbacks or return; |
407
|
|
|
|
|
|
|
|
408
|
16
|
|
|
|
|
93
|
my $index; |
409
|
16
|
|
|
|
|
45
|
for( $index = 0; $index < @$watchlist; $index++ ) { |
410
|
14
|
50
|
|
|
|
19
|
last if \@{$watchlist}[$index] + 0 == $id; |
|
14
|
|
|
|
|
48
|
|
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
16
|
|
|
|
|
58
|
splice @$watchlist, $index, 1, (); |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
### Message handling |
417
|
|
|
|
|
|
|
|
418
|
3
|
|
|
|
|
5
|
sub handle_request_CALL ( $self, $ctx, $message ) |
|
3
|
|
|
|
|
4
|
|
419
|
3
|
|
|
3
|
0
|
4
|
{ |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
3
|
|
420
|
3
|
|
|
|
|
9
|
my $method = $message->unpack_str(); |
421
|
|
|
|
|
|
|
|
422
|
3
|
50
|
|
|
|
67
|
my $mdef = $self->can_method( $method ) or die "Object cannot respond to method $method\n"; |
423
|
|
|
|
|
|
|
|
424
|
3
|
|
|
|
|
8
|
my $m = "method_$method"; |
425
|
3
|
50
|
|
|
|
17
|
$self->can( $m ) or die "Object cannot run method $method\n"; |
426
|
|
|
|
|
|
|
|
427
|
3
|
|
|
|
|
11
|
my @args = map { $_->unpack_value( $message ) } $mdef->argtypes; |
|
4
|
|
|
|
|
11
|
|
428
|
|
|
|
|
|
|
|
429
|
3
|
|
|
|
|
47
|
my $result = $self->$m( $ctx, @args ); |
430
|
|
|
|
|
|
|
|
431
|
3
|
|
|
|
|
31
|
my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT ); |
432
|
3
|
100
|
|
|
|
14
|
$mdef->ret->pack_value( $response, $result ) if $mdef->ret; |
433
|
|
|
|
|
|
|
|
434
|
3
|
|
|
|
|
12
|
return $response; |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
2
|
|
|
|
|
4
|
sub generate_message_EVENT ( $self, $conn, $event, @args ) |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
4
|
|
438
|
2
|
|
|
2
|
0
|
4
|
{ |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
3
|
|
439
|
2
|
50
|
|
|
|
15
|
my $edef = $self->can_event( $event ) or die "Object cannot respond to event $event"; |
440
|
|
|
|
|
|
|
|
441
|
2
|
|
|
|
|
12
|
my $response = Tangence::Message->new( $conn, MSG_EVENT ) |
442
|
|
|
|
|
|
|
->pack_int( $self->id ) |
443
|
|
|
|
|
|
|
->pack_str( $event ); |
444
|
|
|
|
|
|
|
|
445
|
2
|
|
|
|
|
11
|
my @argtypes = $edef->argtypes; |
446
|
2
|
|
|
|
|
13
|
$argtypes[$_]->pack_value( $response, $args[$_] ) for 0..$#argtypes; |
447
|
|
|
|
|
|
|
|
448
|
2
|
|
|
|
|
7
|
return $response; |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
|
451
|
4
|
|
|
|
|
8
|
sub handle_request_GETPROP ( $self, $ctx, $message ) |
|
4
|
|
|
|
|
17
|
|
452
|
4
|
|
|
4
|
0
|
7
|
{ |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
6
|
|
453
|
4
|
|
|
|
|
24
|
my $prop = $message->unpack_str(); |
454
|
|
|
|
|
|
|
|
455
|
4
|
50
|
|
|
|
101
|
my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop"; |
456
|
|
|
|
|
|
|
|
457
|
4
|
|
|
|
|
17
|
my $m = "get_prop_$prop"; |
458
|
4
|
50
|
|
|
|
23
|
$self->can( $m ) or die "Object cannot get property $prop\n"; |
459
|
|
|
|
|
|
|
|
460
|
4
|
|
|
|
|
33
|
my $result = $self->$m(); |
461
|
|
|
|
|
|
|
|
462
|
4
|
|
|
|
|
47
|
my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT ); |
463
|
4
|
|
|
|
|
20
|
$pdef->overall_type->pack_value( $response, $result ); |
464
|
|
|
|
|
|
|
|
465
|
4
|
|
|
|
|
19
|
return $response; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
|
468
|
4
|
|
|
|
|
5
|
sub handle_request_GETPROPELEM ( $self, $ctx, $message ) |
|
4
|
|
|
|
|
7
|
|
469
|
4
|
|
|
4
|
0
|
7
|
{ |
|
4
|
|
|
|
|
5
|
|
|
4
|
|
|
|
|
5
|
|
470
|
4
|
|
|
|
|
11
|
my $prop = $message->unpack_str(); |
471
|
|
|
|
|
|
|
|
472
|
4
|
50
|
|
|
|
80
|
my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop"; |
473
|
4
|
|
|
|
|
14
|
my $dim = $pdef->dimension; |
474
|
|
|
|
|
|
|
|
475
|
4
|
|
|
|
|
11
|
my $m = "get_prop_$prop"; |
476
|
4
|
50
|
|
|
|
19
|
$self->can( $m ) or die "Object cannot get property $prop\n"; |
477
|
|
|
|
|
|
|
|
478
|
4
|
|
|
|
|
6
|
my $result; |
479
|
|
|
|
|
|
|
match( $dim : == ) { |
480
|
|
|
|
|
|
|
case( DIM_QUEUE ), case( DIM_ARRAY ) { |
481
|
2
|
|
|
|
|
8
|
my $idx = $message->unpack_int(); |
482
|
2
|
|
|
|
|
11
|
$result = $self->$m()->[$idx]; |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
case( DIM_HASH ) { |
485
|
2
|
|
|
|
|
8
|
my $key = $message->unpack_str(); |
486
|
2
|
|
|
|
|
55
|
$result = $self->$m()->{$key}; |
487
|
|
|
|
|
|
|
} |
488
|
4
|
100
|
66
|
|
|
27
|
default { |
|
|
50
|
|
|
|
|
|
489
|
0
|
|
|
|
|
0
|
die "Property $prop cannot fetch elements"; |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
|
493
|
4
|
|
|
|
|
38
|
my $response = Tangence::Message->new( $ctx->stream, MSG_RESULT ); |
494
|
4
|
|
|
|
|
17
|
$pdef->type->pack_value( $response, $result ); |
495
|
|
|
|
|
|
|
|
496
|
4
|
|
|
|
|
14
|
return $response; |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
8
|
|
|
|
|
12
|
sub handle_request_SETPROP ( $self, $ctx, $message ) |
|
8
|
|
|
|
|
10
|
|
500
|
8
|
|
|
8
|
0
|
15
|
{ |
|
8
|
|
|
|
|
11
|
|
|
8
|
|
|
|
|
9
|
|
501
|
8
|
|
|
|
|
19
|
my $prop = $message->unpack_str(); |
502
|
|
|
|
|
|
|
|
503
|
8
|
50
|
|
|
|
147
|
my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop\n"; |
504
|
|
|
|
|
|
|
|
505
|
8
|
|
|
|
|
23
|
my $value = $pdef->overall_type->unpack_value( $message ); |
506
|
|
|
|
|
|
|
|
507
|
7
|
|
|
|
|
21
|
my $m = "set_prop_$prop"; |
508
|
7
|
50
|
|
|
|
37
|
$self->can( $m ) or die "Object cannot set property $prop\n"; |
509
|
|
|
|
|
|
|
|
510
|
7
|
|
|
|
|
27
|
$self->$m( $value ); |
511
|
|
|
|
|
|
|
|
512
|
7
|
|
|
|
|
44
|
return Tangence::Message->new( $self, MSG_OK ); |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
45
|
|
|
|
|
76
|
sub generate_message_UPDATE ( $self, $conn, $prop, $how, @args ) |
|
45
|
|
|
|
|
72
|
|
|
45
|
|
|
|
|
67
|
|
|
45
|
|
|
|
|
61
|
|
516
|
45
|
|
|
45
|
0
|
92
|
{ |
|
45
|
|
|
|
|
88
|
|
|
45
|
|
|
|
|
97
|
|
517
|
45
|
50
|
|
|
|
149
|
my $pdef = $self->can_property( $prop ) or die "Object does not have property $prop\n"; |
518
|
45
|
|
|
|
|
163
|
my $dim = $pdef->dimension; |
519
|
|
|
|
|
|
|
|
520
|
45
|
|
|
|
|
273
|
my $message = Tangence::Message->new( $conn, MSG_UPDATE ) |
521
|
|
|
|
|
|
|
->pack_int( $self->id ) |
522
|
|
|
|
|
|
|
->pack_str( $prop ); |
523
|
45
|
|
|
|
|
493
|
TYPE_U8->pack_value( $message, $how ); |
524
|
|
|
|
|
|
|
|
525
|
45
|
|
|
|
|
137
|
my $dimname = DIMNAMES->[$dim]; |
526
|
45
|
100
|
|
|
|
257
|
if( $how == CHANGE_SET ) { |
|
|
50
|
|
|
|
|
|
527
|
22
|
|
|
|
|
56
|
my ( $value ) = @args; |
528
|
22
|
|
|
|
|
105
|
$pdef->overall_type->pack_value( $message, $value ); |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
elsif( my $code = $self->can( "_generate_message_UPDATE_$dimname" ) ) { |
531
|
23
|
|
|
|
|
87
|
$code->( $self, $message, $how, $pdef, @args ); |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
else { |
534
|
0
|
|
|
|
|
0
|
croak "Unrecognised property dimension $dim for $prop"; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
|
537
|
45
|
|
|
|
|
144
|
return $message; |
538
|
|
|
|
|
|
|
} |
539
|
|
|
|
|
|
|
|
540
|
0
|
|
|
|
|
0
|
sub _generate_message_UPDATE_scalar ( $self, $message, $how, $pdef, @args ) |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
541
|
0
|
|
|
0
|
|
0
|
{ |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
542
|
0
|
|
|
|
|
0
|
croak "Change type $how is not valid for a scalar property"; |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
6
|
|
|
|
|
10
|
sub _generate_message_UPDATE_hash ( $self, $message, $how, $pdef, @args ) |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
18
|
|
|
6
|
|
|
|
|
8
|
|
546
|
6
|
|
|
6
|
|
30
|
{ |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
10
|
|
547
|
|
|
|
|
|
|
match( $how : == ) { |
548
|
|
|
|
|
|
|
case( CHANGE_ADD ) { |
549
|
4
|
|
|
|
|
11
|
my ( $key, $value ) = @args; |
550
|
4
|
|
|
|
|
13
|
$message->pack_str( $key ); |
551
|
4
|
|
|
|
|
16
|
$pdef->type->pack_value( $message, $value ); |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
case( CHANGE_DEL ) { |
554
|
2
|
|
|
|
|
5
|
my ( $key ) = @args; |
555
|
2
|
|
|
|
|
5
|
$message->pack_str( $key ); |
556
|
|
|
|
|
|
|
} |
557
|
6
|
100
|
|
|
|
43
|
default { |
|
|
50
|
|
|
|
|
|
558
|
0
|
|
|
|
|
0
|
croak "Change type $how is not valid for a hash property"; |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
|
563
|
6
|
|
|
|
|
9
|
sub _generate_message_UPDATE_queue ( $self, $message, $how, $pdef, @args ) |
|
6
|
|
|
|
|
7
|
|
|
6
|
|
|
|
|
9
|
|
|
6
|
|
|
|
|
9
|
|
564
|
6
|
|
|
6
|
|
10
|
{ |
|
6
|
|
|
|
|
9
|
|
|
6
|
|
|
|
|
7
|
|
565
|
|
|
|
|
|
|
match( $how : == ) { |
566
|
|
|
|
|
|
|
case( CHANGE_PUSH ) { |
567
|
3
|
|
|
|
|
11
|
$message->pack_all_sametype( $pdef->type, @args ); |
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
case( CHANGE_SHIFT ) { |
570
|
3
|
|
|
|
|
7
|
my ( $count ) = @args; |
571
|
3
|
|
|
|
|
8
|
$message->pack_int( $count ); |
572
|
|
|
|
|
|
|
} |
573
|
6
|
100
|
|
|
|
23
|
default { |
|
|
50
|
|
|
|
|
|
574
|
0
|
|
|
|
|
0
|
croak "Change type $how is not valid for a queue property"; |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
|
579
|
9
|
|
|
|
|
17
|
sub _generate_message_UPDATE_array ( $self, $message, $how, $pdef, @args ) |
|
9
|
|
|
|
|
13
|
|
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
11
|
|
580
|
9
|
|
|
9
|
|
12
|
{ |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
24
|
|
581
|
|
|
|
|
|
|
match( $how : == ) { |
582
|
|
|
|
|
|
|
case( CHANGE_PUSH ) { |
583
|
3
|
|
|
|
|
12
|
$message->pack_all_sametype( $pdef->type, @args ); |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
case( CHANGE_SHIFT ) { |
586
|
1
|
|
|
|
|
2
|
my ( $count ) = @args; |
587
|
1
|
|
|
|
|
4
|
$message->pack_int( $count ); |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
case( CHANGE_SPLICE ) { |
590
|
2
|
|
|
|
|
8
|
my ( $start, $count, @values ) = @args; |
591
|
2
|
|
|
|
|
10
|
$message->pack_int( $start ); |
592
|
2
|
|
|
|
|
7
|
$message->pack_int( $count ); |
593
|
2
|
|
|
|
|
11
|
$message->pack_all_sametype( $pdef->type, @values ); |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
case( CHANGE_MOVE ) { |
596
|
3
|
|
|
|
|
10
|
my ( $index, $delta ) = @args; |
597
|
3
|
|
|
|
|
10
|
$message->pack_int( $index ); |
598
|
3
|
|
|
|
|
9
|
$message->pack_int( $delta ); |
599
|
|
|
|
|
|
|
} |
600
|
9
|
100
|
|
|
|
45
|
default { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
601
|
0
|
|
|
|
|
0
|
croak "Change type $how is not valid for an array property"; |
602
|
|
|
|
|
|
|
} |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
|
606
|
2
|
|
|
|
|
5
|
sub _generate_message_UPDATE_objset ( $self, $message, $how, $pdef, @args ) |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
3
|
|
607
|
2
|
|
|
2
|
|
4
|
{ |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
3
|
|
608
|
|
|
|
|
|
|
match( $how : == ) { |
609
|
|
|
|
|
|
|
case( CHANGE_ADD ) { |
610
|
1
|
|
|
|
|
3
|
my ( $value ) = @args; |
611
|
1
|
|
|
|
|
4
|
$pdef->type->pack_value( $message, $value ); |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
case( CHANGE_DEL ) { |
614
|
1
|
|
|
|
|
3
|
my ( $id ) = @args; |
615
|
1
|
|
|
|
|
5
|
$message->pack_int( $id ); |
616
|
|
|
|
|
|
|
} |
617
|
2
|
100
|
|
|
|
12
|
default { |
|
|
50
|
|
|
|
|
|
618
|
0
|
|
|
|
|
|
croak "Change type $how is not valid for an objset property"; |
619
|
|
|
|
|
|
|
} |
620
|
|
|
|
|
|
|
} |
621
|
|
|
|
|
|
|
} |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
=head1 AUTHOR |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
Paul Evans |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
=cut |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
0x55AA; |