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, 2011-2021 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package Tangence::Server 0.28; |
7
|
|
|
|
|
|
|
|
8
|
9
|
|
|
9
|
|
26332
|
use v5.26; |
|
9
|
|
|
|
|
30
|
|
9
|
9
|
|
|
9
|
|
44
|
use warnings; |
|
9
|
|
|
|
|
11
|
|
|
9
|
|
|
|
|
240
|
|
10
|
9
|
|
|
9
|
|
43
|
use experimental 'signatures'; |
|
9
|
|
|
|
|
25
|
|
|
9
|
|
|
|
|
60
|
|
11
|
|
|
|
|
|
|
|
12
|
9
|
|
|
9
|
|
940
|
use base qw( Tangence::Stream ); |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
3632
|
|
13
|
|
|
|
|
|
|
|
14
|
9
|
|
|
9
|
|
81
|
use Carp; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
543
|
|
15
|
|
|
|
|
|
|
|
16
|
9
|
|
|
9
|
|
48
|
use Scalar::Util qw( weaken ); |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
426
|
|
17
|
9
|
|
|
9
|
|
50
|
use Sub::Util 1.40 qw( set_subname ); |
|
9
|
|
|
|
|
173
|
|
|
9
|
|
|
|
|
363
|
|
18
|
9
|
|
|
9
|
|
56
|
use Feature::Compat::Try; |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
64
|
|
19
|
|
|
|
|
|
|
|
20
|
9
|
|
|
9
|
|
845
|
use Tangence::Constants; |
|
9
|
|
|
|
|
26
|
|
|
9
|
|
|
|
|
1454
|
|
21
|
9
|
|
|
9
|
|
55
|
use Tangence::Types; |
|
9
|
|
|
|
|
22
|
|
|
9
|
|
|
|
|
493
|
|
22
|
9
|
|
|
9
|
|
3926
|
use Tangence::Server::Context; |
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
302
|
|
23
|
|
|
|
|
|
|
|
24
|
9
|
|
|
9
|
|
58
|
use Struct::Dumb; |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
75
|
|
25
|
|
|
|
|
|
|
struct CursorObject => [qw( cursor obj )]; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# We will accept any version back to 3 |
28
|
9
|
|
|
9
|
|
705
|
use constant VERSION_MINOR_MIN => 3; |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
36274
|
|
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
=head1 NAME |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
C - mixin class for building a C server |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=head1 SYNOPSIS |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
This class is a mixin, it cannot be directly constructed |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
package Example::Server; |
39
|
|
|
|
|
|
|
use base qw( Base::Server Tangence::Server ); |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
sub new |
42
|
|
|
|
|
|
|
{ |
43
|
|
|
|
|
|
|
my $class = shift; |
44
|
|
|
|
|
|
|
my %args = @_; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
my $registry = delete $args{registry}; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
my $self = $class->SUPER::new( %args ); |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
$self->registry( $registry ); |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
return $self; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub tangence_write |
56
|
|
|
|
|
|
|
{ |
57
|
|
|
|
|
|
|
my $self = shift; |
58
|
|
|
|
|
|
|
$self->write( $_[0] ); |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub on_read |
62
|
|
|
|
|
|
|
{ |
63
|
|
|
|
|
|
|
my $self = shift; |
64
|
|
|
|
|
|
|
$self->tangence_readfrom( $_[0] ); |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=head1 DESCRIPTION |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
This module provides mixin to implement a C server connection. It |
70
|
|
|
|
|
|
|
should be mixed in to an object used to represent a single connection from a |
71
|
|
|
|
|
|
|
client. It provides a location for the objects in server to store information |
72
|
|
|
|
|
|
|
about the client connection, and coordinates passing messages between the |
73
|
|
|
|
|
|
|
client and the objects in the server. |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
This is a subclass of L which provides implementations of |
76
|
|
|
|
|
|
|
the required C methods. A class mixing in C |
77
|
|
|
|
|
|
|
must still provide the C method required for sending data to the |
78
|
|
|
|
|
|
|
client. |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
For an example of a class that uses this mixin, see |
81
|
|
|
|
|
|
|
L. |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=cut |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
=head1 PROVIDED METHODS |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
The following methods are provided by this mixin. |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=cut |
90
|
|
|
|
|
|
|
|
91
|
9
|
|
100
|
9
|
0
|
49
|
sub subscriptions { shift->{subscriptions} ||= [] } |
92
|
49
|
|
100
|
49
|
0
|
348
|
sub watches { shift->{watches} ||= [] } |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=head2 registry |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
$server->registry( $registry ) |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
$registry = $server->registry |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
Accessor to set or obtain the L object for the server. |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=cut |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub registry |
105
|
|
|
|
|
|
|
{ |
106
|
75
|
|
|
75
|
1
|
1052
|
my $self = shift; |
107
|
75
|
100
|
|
|
|
199
|
$self->{registry} = shift if @_; |
108
|
75
|
|
|
|
|
347
|
return $self->{registry}; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub tangence_closed |
112
|
|
|
|
|
|
|
{ |
113
|
1
|
|
|
1
|
1
|
1472
|
my $self = shift; |
114
|
1
|
|
|
|
|
15
|
$self->SUPER::tangence_closed; |
115
|
|
|
|
|
|
|
|
116
|
1
|
50
|
|
|
|
10
|
if( my $subscriptions = $self->subscriptions ) { |
117
|
1
|
|
|
|
|
4
|
foreach my $s ( @$subscriptions ) { |
118
|
0
|
|
|
|
|
0
|
my ( $object, $event, $id ) = @$s; |
119
|
0
|
|
|
|
|
0
|
$object->unsubscribe_event( $event, $id ); |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
1
|
|
|
|
|
2
|
undef @$subscriptions; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
1
|
50
|
|
|
|
3
|
if( my $watches = $self->watches ) { |
126
|
1
|
|
|
|
|
3
|
foreach my $w ( @$watches ) { |
127
|
4
|
|
|
|
|
8
|
my ( $object, $prop, $id ) = @$w; |
128
|
4
|
|
|
|
|
11
|
$object->unwatch_property( $prop, $id ); |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
1
|
|
|
|
|
4
|
undef @$watches; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
1
|
50
|
|
|
|
15
|
if( my $cursors = $self->peer_hascursor ) { |
135
|
1
|
|
|
|
|
8
|
foreach my $cursorobj ( values %$cursors ) { |
136
|
0
|
|
|
|
|
0
|
$self->drop_cursorobj( $cursorobj ); |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
54
|
|
|
|
|
89
|
sub get_by_id ( $self, $id ) |
142
|
54
|
|
|
54
|
0
|
203
|
{ |
|
54
|
|
|
|
|
77
|
|
|
54
|
|
|
|
|
67
|
|
143
|
|
|
|
|
|
|
# Only permit the client to interact with objects they've already been |
144
|
|
|
|
|
|
|
# sent, so they cannot gain access by inventing object IDs |
145
|
54
|
100
|
|
|
|
156
|
$self->peer_hasobj->{$id} or |
146
|
|
|
|
|
|
|
die "Access not allowed to object with id $id\n"; |
147
|
|
|
|
|
|
|
|
148
|
48
|
50
|
|
|
|
141
|
my $obj = $self->registry->get_by_id( $id ) or |
149
|
|
|
|
|
|
|
die "No such object with id $id\n"; |
150
|
|
|
|
|
|
|
|
151
|
48
|
|
|
|
|
94
|
return $obj; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
4
|
|
|
|
|
6
|
sub handle_request_CALL ( $self, $token, $message ) |
|
4
|
|
|
|
|
5
|
|
155
|
4
|
|
|
4
|
0
|
9
|
{ |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
5
|
|
156
|
4
|
|
|
|
|
22
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
157
|
|
|
|
|
|
|
|
158
|
4
|
|
|
|
|
32
|
my $response; |
159
|
|
|
|
|
|
|
try { |
160
|
|
|
|
|
|
|
my $objid = $message->unpack_int(); |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
my $object = $self->get_by_id( $objid ); |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
$response = $object->handle_request_CALL( $ctx, $message ); |
165
|
|
|
|
|
|
|
} |
166
|
4
|
|
|
|
|
182
|
catch ( $e ) { |
167
|
|
|
|
|
|
|
return $ctx->responderr( $e ); |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
3
|
|
|
|
|
10
|
$ctx->respond( $response ); |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
3
|
|
|
|
|
7
|
sub handle_request_SUBSCRIBE ( $self, $token, $message ) |
|
3
|
|
|
|
|
3
|
|
174
|
3
|
|
|
3
|
0
|
6
|
{ |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
4
|
|
175
|
3
|
|
|
|
|
16
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
176
|
|
|
|
|
|
|
|
177
|
3
|
|
|
|
|
6
|
my $response; |
178
|
|
|
|
|
|
|
try { |
179
|
|
|
|
|
|
|
my $objid = $message->unpack_int(); |
180
|
|
|
|
|
|
|
my $event = $message->unpack_str(); |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
my $object = $self->get_by_id( $objid ); |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
weaken( my $weakself = $self ); |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
my $id = $object->subscribe_event( $event, |
187
|
|
|
|
|
|
|
set_subname "__SUBSCRIBE($event)__" => sub { |
188
|
2
|
50
|
|
2
|
|
6
|
$weakself or return; |
189
|
2
|
|
|
|
|
4
|
my $object = shift; |
190
|
|
|
|
|
|
|
|
191
|
2
|
|
|
|
|
23
|
my $message = $object->generate_message_EVENT( $weakself, $event, @_ ); |
192
|
|
|
|
|
|
|
$weakself->request( |
193
|
|
|
|
|
|
|
request => $message, |
194
|
2
|
|
|
|
|
9
|
on_response => sub { "IGNORE" }, |
195
|
2
|
|
|
|
|
34
|
); |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
); |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
push @{ $self->subscriptions }, [ $object, $event, $id ]; |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
$response = Tangence::Message->new( $self, MSG_SUBSCRIBED ) |
202
|
|
|
|
|
|
|
} |
203
|
3
|
|
|
|
|
6
|
catch ( $e ) { |
204
|
|
|
|
|
|
|
return $ctx->responderr( $e ); |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
2
|
|
|
|
|
10
|
$ctx->respond( $response ); |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
2
|
|
|
|
|
3
|
sub handle_request_UNSUBSCRIBE ( $self, $token, $message ) |
|
2
|
|
|
|
|
4
|
|
211
|
2
|
|
|
2
|
0
|
3
|
{ |
|
2
|
|
|
|
|
14
|
|
|
2
|
|
|
|
|
3
|
|
212
|
2
|
|
|
|
|
13
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
213
|
|
|
|
|
|
|
|
214
|
2
|
|
|
|
|
9
|
my $response; |
215
|
|
|
|
|
|
|
try { |
216
|
|
|
|
|
|
|
my $objid = $message->unpack_int(); |
217
|
|
|
|
|
|
|
my $event = $message->unpack_str(); |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
my $object = $self->get_by_id( $objid ); |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
my $edef = $object->can_event( $event ) or |
222
|
|
|
|
|
|
|
die "Object cannot respond to event $event\n"; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# Delete from subscriptions and obtain id |
225
|
|
|
|
|
|
|
my $id; |
226
|
|
|
|
|
|
|
@{ $self->subscriptions } = grep { $_->[0] == $object and $_->[1] eq $event and ( $id = $_->[2], 0 ) or 1 } |
227
|
|
|
|
|
|
|
@{ $self->subscriptions }; |
228
|
|
|
|
|
|
|
defined $id or |
229
|
|
|
|
|
|
|
die "Not subscribed to $event\n"; |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
$object->unsubscribe_event( $event, $id ); |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
$response = Tangence::Message->new( $self, MSG_OK ) |
234
|
|
|
|
|
|
|
} |
235
|
2
|
|
|
|
|
6
|
catch ( $e ) { |
236
|
|
|
|
|
|
|
return $ctx->responderr( $e ); |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
2
|
|
|
|
|
21
|
$ctx->respond( $response ); |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
5
|
|
|
|
|
11
|
sub handle_request_GETPROP ( $self, $token, $message ) |
|
5
|
|
|
|
|
10
|
|
243
|
5
|
|
|
5
|
0
|
11
|
{ |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
7
|
|
244
|
5
|
|
|
|
|
32
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
245
|
|
|
|
|
|
|
|
246
|
5
|
|
|
|
|
12
|
my $response; |
247
|
|
|
|
|
|
|
try { |
248
|
|
|
|
|
|
|
my $objid = $message->unpack_int(); |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
my $object = $self->get_by_id( $objid ); |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
$response = $object->handle_request_GETPROP( $ctx, $message ) |
253
|
|
|
|
|
|
|
} |
254
|
5
|
|
|
|
|
15
|
catch ( $e ) { |
255
|
|
|
|
|
|
|
return $ctx->responderr( $e ); |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
4
|
|
|
|
|
27
|
$ctx->respond( $response ); |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
4
|
|
|
|
|
6
|
sub handle_request_GETPROPELEM ( $self, $token, $message ) |
|
4
|
|
|
|
|
6
|
|
262
|
4
|
|
|
4
|
0
|
5
|
{ |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
5
|
|
263
|
4
|
|
|
|
|
18
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
264
|
|
|
|
|
|
|
|
265
|
4
|
|
|
|
|
8
|
my $response; |
266
|
|
|
|
|
|
|
try { |
267
|
|
|
|
|
|
|
my $objid = $message->unpack_int(); |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
my $object = $self->get_by_id( $objid ); |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
$response = $object->handle_request_GETPROPELEM( $ctx, $message ) |
272
|
|
|
|
|
|
|
} |
273
|
4
|
|
|
|
|
9
|
catch ( $e ) { |
274
|
|
|
|
|
|
|
return $ctx->responderr( $e ); |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
4
|
|
|
|
|
13
|
$ctx->respond( $response ); |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
|
280
|
9
|
|
|
|
|
13
|
sub handle_request_SETPROP ( $self, $token, $message ) |
|
9
|
|
|
|
|
12
|
|
281
|
9
|
|
|
9
|
0
|
14
|
{ |
|
9
|
|
|
|
|
11
|
|
|
9
|
|
|
|
|
11
|
|
282
|
9
|
|
|
|
|
36
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
283
|
|
|
|
|
|
|
|
284
|
9
|
|
|
|
|
19
|
my $response; |
285
|
|
|
|
|
|
|
try { |
286
|
|
|
|
|
|
|
my $objid = $message->unpack_int(); |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
my $object = $self->get_by_id( $objid ); |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
$response = $object->handle_request_SETPROP( $ctx, $message ) |
291
|
|
|
|
|
|
|
} |
292
|
9
|
|
|
|
|
20
|
catch ( $e ) { |
293
|
|
|
|
|
|
|
return $ctx->responderr( $e ); |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
7
|
|
|
|
|
24
|
$ctx->respond( $response ); |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
*handle_request_WATCH = \&_handle_request_WATCHany; |
300
|
|
|
|
|
|
|
*handle_request_WATCH_CUSR = \&_handle_request_WATCHany; |
301
|
19
|
|
|
|
|
27
|
sub _handle_request_WATCHany ( $self, $token, $message ) |
|
19
|
|
|
|
|
41
|
|
302
|
19
|
|
|
19
|
|
43
|
{ |
|
19
|
|
|
|
|
44
|
|
|
19
|
|
|
|
|
25
|
|
303
|
19
|
|
|
|
|
123
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
304
|
|
|
|
|
|
|
|
305
|
19
|
|
|
|
|
65
|
my ( $want_initial, $object, $prop ); |
306
|
|
|
|
|
|
|
|
307
|
19
|
|
|
|
|
0
|
my $response; |
308
|
|
|
|
|
|
|
try { |
309
|
|
|
|
|
|
|
my $objid = $message->unpack_int(); |
310
|
|
|
|
|
|
|
$prop = $message->unpack_str(); |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
$object = $self->get_by_id( $objid ); |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
my $pdef = $object->can_property( $prop ) or |
315
|
|
|
|
|
|
|
die "Object does not have property $prop\n"; |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
$self->_install_watch( $object, $prop ); |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
if( $message->code == MSG_WATCH ) { |
320
|
|
|
|
|
|
|
$want_initial = $message->unpack_bool(); |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
$response = Tangence::Message->new( $self, MSG_WATCHING ) |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
elsif( $message->code == MSG_WATCH_CUSR ) { |
325
|
|
|
|
|
|
|
my $from = $message->unpack_int(); |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
my $m = "cursor_prop_$prop"; |
328
|
|
|
|
|
|
|
my $cursor = $object->$m( $from ); |
329
|
|
|
|
|
|
|
my $id = $self->message_state->{next_cursorid}++; |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
$self->peer_hascursor->{$id} = CursorObject( $cursor, $object ); |
332
|
|
|
|
|
|
|
$response = Tangence::Message->new( $self, MSG_WATCHING_CUSR ) |
333
|
|
|
|
|
|
|
->pack_int( $id ) |
334
|
|
|
|
|
|
|
->pack_int( 0 ) # first index |
335
|
|
|
|
|
|
|
->pack_int( $#{ $object->${\"get_prop_$prop"} } ) # last index |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
} |
338
|
19
|
|
|
|
|
53
|
catch ( $e ) { |
339
|
|
|
|
|
|
|
return $ctx->responderr( $e ); |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
18
|
|
|
|
|
110
|
$ctx->respond( $response ); |
343
|
|
|
|
|
|
|
|
344
|
18
|
100
|
|
|
|
98
|
$self->_send_initial( $object, $prop ) if $want_initial; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
8
|
|
|
|
|
16
|
sub _send_initial ( $self, $object, $prop ) |
|
8
|
|
|
|
|
16
|
|
348
|
8
|
|
|
8
|
|
24
|
{ |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
12
|
|
349
|
8
|
|
|
|
|
25
|
my $m = "get_prop_$prop"; |
350
|
8
|
50
|
|
|
|
65
|
return unless( $object->can( $m ) ); |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
try { |
353
|
|
|
|
|
|
|
my $value = $object->$m(); |
354
|
|
|
|
|
|
|
my $message = $object->generate_message_UPDATE( $self, $prop, CHANGE_SET, $value ); |
355
|
|
|
|
|
|
|
$self->request( |
356
|
|
|
|
|
|
|
request => $message, |
357
|
8
|
|
|
8
|
|
43
|
on_response => sub { "IGNORE" }, |
358
|
|
|
|
|
|
|
); |
359
|
|
|
|
|
|
|
} |
360
|
8
|
|
|
|
|
22
|
catch ( $e ) { |
361
|
|
|
|
|
|
|
warn "$e during initial property fetch"; |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
4
|
|
|
|
|
7
|
sub handle_request_UNWATCH ( $self, $token, $message ) |
|
4
|
|
|
|
|
5
|
|
366
|
4
|
|
|
4
|
0
|
9
|
{ |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
7
|
|
367
|
4
|
|
|
|
|
17
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
368
|
|
|
|
|
|
|
|
369
|
4
|
|
|
|
|
24
|
my $response; |
370
|
|
|
|
|
|
|
try { |
371
|
|
|
|
|
|
|
my $objid = $message->unpack_int(); |
372
|
|
|
|
|
|
|
my $prop = $message->unpack_str(); |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
my $object = $self->get_by_id( $objid ); |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
my $pdef = $object->can_property( $prop ) or |
377
|
|
|
|
|
|
|
die "Object does not have property $prop\n"; |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# Delete from watches and obtain id |
380
|
|
|
|
|
|
|
my $id; |
381
|
|
|
|
|
|
|
@{ $self->watches } = grep { $_->[0] == $object and $_->[1] eq $prop and ( $id = $_->[2], 0 ) or 1 } |
382
|
|
|
|
|
|
|
@{ $self->watches }; |
383
|
|
|
|
|
|
|
defined $id or |
384
|
|
|
|
|
|
|
die "Not watching $prop\n"; |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
$object->unwatch_property( $prop, $id ); |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
$response = Tangence::Message->new( $self, MSG_OK ); |
389
|
|
|
|
|
|
|
} |
390
|
4
|
|
|
|
|
13
|
catch ( $e ) { |
391
|
|
|
|
|
|
|
return $ctx->responderr( $e ); |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
4
|
|
|
|
|
21
|
$ctx->respond( $response ); |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
|
397
|
12
|
|
|
|
|
18
|
sub handle_request_CUSR_NEXT ( $self, $token, $message ) |
|
12
|
|
|
|
|
18
|
|
398
|
12
|
|
|
12
|
0
|
27
|
{ |
|
12
|
|
|
|
|
14
|
|
|
12
|
|
|
|
|
13
|
|
399
|
12
|
|
|
|
|
24
|
my $cursor_id = $message->unpack_int(); |
400
|
|
|
|
|
|
|
|
401
|
12
|
|
|
|
|
54
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
402
|
|
|
|
|
|
|
|
403
|
12
|
50
|
|
|
|
43
|
my $cursorobj = $self->peer_hascursor->{$cursor_id} or |
404
|
|
|
|
|
|
|
return $ctx->responderr( "No such cursor with id $cursor_id" ); |
405
|
|
|
|
|
|
|
|
406
|
12
|
|
|
|
|
71
|
$cursorobj->cursor->handle_request_CUSR_NEXT( $ctx, $message ); |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
|
409
|
6
|
|
|
|
|
9
|
sub handle_request_CUSR_DESTROY ( $self, $token, $message ) |
|
6
|
|
|
|
|
11
|
|
410
|
6
|
|
|
6
|
0
|
8
|
{ |
|
6
|
|
|
|
|
6
|
|
|
6
|
|
|
|
|
18
|
|
411
|
6
|
|
|
|
|
17
|
my $cursor_id = $message->unpack_int(); |
412
|
|
|
|
|
|
|
|
413
|
6
|
|
|
|
|
31
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
414
|
|
|
|
|
|
|
|
415
|
6
|
|
|
|
|
21
|
my $cursorobj = delete $self->peer_hascursor->{$cursor_id}; |
416
|
6
|
|
|
|
|
33
|
$self->drop_cursorobj( $cursorobj ); |
417
|
|
|
|
|
|
|
|
418
|
6
|
|
|
|
|
31
|
$ctx->respond( Tangence::Message->new( $self, MSG_OK ) ); |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
6
|
|
|
|
|
8
|
sub drop_cursorobj ( $self, $cursorobj ) |
422
|
6
|
|
|
6
|
0
|
9
|
{ |
|
6
|
|
|
|
|
9
|
|
|
6
|
|
|
|
|
19
|
|
423
|
6
|
|
|
|
|
34
|
my $m = "uncursor_prop_" . $cursorobj->cursor->prop->name; |
424
|
6
|
|
|
|
|
22
|
$cursorobj->obj->$m( $cursorobj->cursor ); |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
|
427
|
9
|
|
|
|
|
27
|
sub handle_request_INIT ( $self, $token, $message ) |
|
9
|
|
|
|
|
14
|
|
428
|
9
|
|
|
9
|
0
|
16
|
{ |
|
9
|
|
|
|
|
22
|
|
|
9
|
|
|
|
|
14
|
|
429
|
9
|
|
|
|
|
45
|
my $major = $message->unpack_int(); |
430
|
9
|
|
|
|
|
35
|
my $minor_max = $message->unpack_int(); |
431
|
9
|
|
|
|
|
42
|
my $minor_min = $message->unpack_int(); |
432
|
|
|
|
|
|
|
|
433
|
9
|
|
|
|
|
100
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
434
|
|
|
|
|
|
|
|
435
|
9
|
50
|
|
|
|
37
|
if( $major != VERSION_MAJOR ) { |
436
|
0
|
|
|
|
|
0
|
return $ctx->responderr( "Major version $major not available" ); |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
# Don't accept higher than the minor version we recognise |
440
|
9
|
50
|
|
|
|
27
|
$minor_max = VERSION_MINOR if $minor_max > VERSION_MINOR; |
441
|
9
|
50
|
|
|
|
27
|
$minor_min = VERSION_MINOR_MIN if $minor_min < VERSION_MINOR_MIN; |
442
|
|
|
|
|
|
|
|
443
|
9
|
50
|
|
|
|
31
|
if( $minor_max < $minor_min ) { |
444
|
0
|
|
|
|
|
0
|
return $ctx->responderr( "No suitable minor version available" ); |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
# For unit tests or other synchronous cases, we need to set the version |
448
|
|
|
|
|
|
|
# -before- we send the message. But we'd better construct the response |
449
|
|
|
|
|
|
|
# message before setting the version, in case it makes a difference. |
450
|
9
|
|
|
|
|
55
|
my $response = Tangence::Message->new( $self, MSG_INITED ) |
451
|
|
|
|
|
|
|
->pack_int( $major ) |
452
|
|
|
|
|
|
|
->pack_int( $minor_max ); |
453
|
|
|
|
|
|
|
|
454
|
9
|
|
|
|
|
56
|
$self->minor_version( $minor_max ); |
455
|
|
|
|
|
|
|
|
456
|
9
|
|
|
|
|
34
|
$ctx->respond( $response ); |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
|
459
|
9
|
|
|
|
|
17
|
sub handle_request_GETROOT ( $self, $token, $message ) |
|
9
|
|
|
|
|
34
|
|
460
|
9
|
|
|
9
|
0
|
18
|
{ |
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
13
|
|
461
|
9
|
|
|
|
|
42
|
my $identity = TYPE_ANY->unpack_value( $message ); |
462
|
|
|
|
|
|
|
|
463
|
9
|
|
|
|
|
539
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
464
|
|
|
|
|
|
|
|
465
|
9
|
|
|
|
|
66
|
$self->identity( $identity ); |
466
|
|
|
|
|
|
|
|
467
|
9
|
|
|
|
|
49
|
my $root = $self->rootobj( $identity ); |
468
|
|
|
|
|
|
|
|
469
|
9
|
|
|
|
|
66
|
my $response = Tangence::Message->new( $self, MSG_RESULT ); |
470
|
9
|
|
|
|
|
83
|
TYPE_OBJ->pack_value( $response, $root ); |
471
|
|
|
|
|
|
|
|
472
|
9
|
|
|
|
|
85
|
$ctx->respond( $response ); |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
9
|
|
|
|
|
17
|
sub handle_request_GETREGISTRY ( $self, $token, $message ) |
|
9
|
|
|
|
|
15
|
|
476
|
9
|
|
|
9
|
0
|
19
|
{ |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
13
|
|
477
|
9
|
|
|
|
|
49
|
my $ctx = Tangence::Server::Context->new( $self, $token ); |
478
|
|
|
|
|
|
|
|
479
|
9
|
50
|
|
|
|
49
|
$self->permit_registry or |
480
|
|
|
|
|
|
|
return $ctx->responderr( "This client is not permitted access to the registry" ); |
481
|
|
|
|
|
|
|
|
482
|
9
|
|
|
|
|
51
|
my $response = Tangence::Message->new( $self, MSG_RESULT ); |
483
|
9
|
|
|
|
|
44
|
TYPE_OBJ->pack_value( $response, $self->registry ); |
484
|
|
|
|
|
|
|
|
485
|
9
|
|
|
|
|
46
|
$ctx->respond( $response ); |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
my %change_values = ( |
489
|
|
|
|
|
|
|
on_set => CHANGE_SET, |
490
|
|
|
|
|
|
|
on_add => CHANGE_ADD, |
491
|
|
|
|
|
|
|
on_del => CHANGE_DEL, |
492
|
|
|
|
|
|
|
on_push => CHANGE_PUSH, |
493
|
|
|
|
|
|
|
on_shift => CHANGE_SHIFT, |
494
|
|
|
|
|
|
|
on_splice => CHANGE_SPLICE, |
495
|
|
|
|
|
|
|
on_move => CHANGE_MOVE, |
496
|
|
|
|
|
|
|
); |
497
|
|
|
|
|
|
|
|
498
|
38
|
|
|
|
|
54
|
sub _install_watch ( $self, $object, $prop ) |
|
38
|
|
|
|
|
53
|
|
499
|
38
|
|
|
38
|
|
64
|
{ |
|
38
|
|
|
|
|
62
|
|
|
38
|
|
|
|
|
72
|
|
500
|
38
|
|
|
|
|
127
|
my $pdef = $object->can_property( $prop ); |
501
|
38
|
|
|
|
|
118
|
my $dim = $pdef->dimension; |
502
|
|
|
|
|
|
|
|
503
|
38
|
|
|
|
|
149
|
weaken( my $weakself = $self ); |
504
|
|
|
|
|
|
|
|
505
|
38
|
|
|
|
|
65
|
my %callbacks; |
506
|
38
|
|
|
|
|
55
|
foreach my $name ( @{ CHANGETYPES->{$dim} } ) { |
|
38
|
|
|
|
|
111
|
|
507
|
106
|
|
|
|
|
217
|
my $how = $change_values{$name}; |
508
|
|
|
|
|
|
|
$callbacks{$name} = set_subname "__WATCH($prop:$name)__" => sub { |
509
|
37
|
50
|
|
37
|
|
144
|
$weakself or return; |
510
|
37
|
|
|
|
|
70
|
my $object = shift; |
511
|
|
|
|
|
|
|
|
512
|
37
|
|
|
|
|
205
|
my $message = $object->generate_message_UPDATE( $weakself, $prop, $how, @_ ); |
513
|
|
|
|
|
|
|
$weakself->request( |
514
|
|
|
|
|
|
|
request => $message, |
515
|
37
|
|
|
|
|
160
|
on_response => sub { "IGNORE" }, |
516
|
37
|
|
|
|
|
291
|
); |
517
|
106
|
|
|
|
|
938
|
}; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
38
|
|
|
|
|
237
|
my $id = $object->watch_property( $prop, %callbacks ); |
521
|
|
|
|
|
|
|
|
522
|
38
|
|
|
|
|
67
|
push @{ $self->watches }, [ $object, $prop, $id ]; |
|
38
|
|
|
|
|
154
|
|
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
2
|
|
|
|
|
2
|
sub object_destroyed ( $self, $obj, @rest ) |
|
2
|
|
|
|
|
5
|
|
526
|
2
|
|
|
2
|
0
|
7
|
{ |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
3
|
|
527
|
2
|
50
|
|
|
|
8
|
if( my $subs = $self->subscriptions ) { |
528
|
2
|
|
|
|
|
5
|
my $i = 0; |
529
|
2
|
|
|
|
|
17
|
while( $i < @$subs ) { |
530
|
2
|
|
|
|
|
8
|
my $s = $subs->[$i]; |
531
|
|
|
|
|
|
|
|
532
|
2
|
50
|
|
|
|
7
|
$i++, next unless $s->[0] == $obj; |
533
|
|
|
|
|
|
|
|
534
|
2
|
|
|
|
|
6
|
my ( undef, $event, $id ) = @$s; |
535
|
2
|
|
|
|
|
9
|
$obj->unsubscribe_event( $event, $id ); |
536
|
|
|
|
|
|
|
|
537
|
2
|
|
|
|
|
9
|
splice @$subs, $i, 1; |
538
|
|
|
|
|
|
|
# No $i++ |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
|
542
|
2
|
50
|
|
|
|
7
|
if( my $watches = $self->watches ) { |
543
|
2
|
|
|
|
|
4
|
my $i = 0; |
544
|
2
|
|
|
|
|
8
|
while( $i < @$watches ) { |
545
|
8
|
|
|
|
|
11
|
my $w = $watches->[$i]; |
546
|
|
|
|
|
|
|
|
547
|
8
|
50
|
|
|
|
16
|
$i++, next unless $w->[0] == $obj; |
548
|
|
|
|
|
|
|
|
549
|
8
|
|
|
|
|
15
|
my ( undef, $prop, $id ) = @$w; |
550
|
8
|
|
|
|
|
21
|
$obj->unwatch_property( $prop, $id ); |
551
|
|
|
|
|
|
|
|
552
|
8
|
|
|
|
|
52
|
splice @$watches, $i, 1; |
553
|
|
|
|
|
|
|
# No $i++ |
554
|
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
|
} |
556
|
|
|
|
|
|
|
|
557
|
2
|
|
|
|
|
27
|
$self->SUPER::object_destroyed( $obj, @rest ); |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
=head1 OVERRIDEABLE METHODS |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
The following methods are provided but intended to be overridden if the |
563
|
|
|
|
|
|
|
implementing class wishes to provide different behaviour from the default. |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
=cut |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
=head2 rootobj |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
$rootobj = $server->rootobj( $identity ) |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
Invoked when a C message is received from the client, this method |
572
|
|
|
|
|
|
|
should return a L as root object for the connection. |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
The default implementation will return the object with ID 1; i.e. the first |
575
|
|
|
|
|
|
|
object created in the registry. |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
=cut |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
sub rootobj |
580
|
|
|
|
|
|
|
{ |
581
|
9
|
|
|
9
|
1
|
16
|
my $self = shift; |
582
|
|
|
|
|
|
|
|
583
|
9
|
|
|
|
|
27
|
return $self->registry->get_by_id( 1 ); |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
=head2 permit_registry |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
$allow = $server->permit_registry |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
Invoked when a C message is received from the client, this method |
591
|
|
|
|
|
|
|
should return a boolean to indicate whether the client is allowed to access |
592
|
|
|
|
|
|
|
the object registry. |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
The default implementation always permits this, but an overridden method may |
595
|
|
|
|
|
|
|
decide to disallow it in some situations. When disabled, a client will not be |
596
|
|
|
|
|
|
|
able to gain access to any serverside objects other than the root object, and |
597
|
|
|
|
|
|
|
(recursively) any other objects returned by methods, events or properties on |
598
|
|
|
|
|
|
|
objects already known. This can be used as a security mechanism. |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
=cut |
601
|
|
|
|
|
|
|
|
602
|
9
|
|
|
9
|
1
|
28
|
sub permit_registry { 1; } |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
=head1 AUTHOR |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
Paul Evans |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
=cut |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
0x55AA; |