File Coverage

blib/lib/Tangence/Client.pm
Criterion Covered Total %
statement 125 134 93.2
branch 20 38 52.6
condition 3 4 75.0
subroutine 28 29 96.5
pod 5 13 38.4
total 181 218 83.0


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::Client 0.28;
7              
8 9     9   8460 use v5.26;
  9         29  
9 9     9   47 use warnings;
  9         17  
  9         278  
10 9     9   42 use experimental 'signatures';
  9         18  
  9         90  
11              
12 9     9   1312 use base qw( Tangence::Stream );
  9         17  
  9         1464  
13              
14 9     9   61 use Carp;
  9         19  
  9         561  
15              
16 9     9   52 use Tangence::Constants;
  9         23  
  9         1862  
17 9     9   57 use Tangence::Types;
  9         16  
  9         590  
18 9     9   4229 use Tangence::ObjectProxy;
  9         25  
  9         729  
19              
20 9     9   69 use Future 0.36; # ->retain
  9         178  
  9         298  
21              
22 9     9   48 use List::Util qw( max );
  9         17  
  9         569  
23              
24 9     9   52 use constant VERSION_MINOR_MIN => 3;
  9         19  
  9         13923  
25              
26             =head1 NAME
27              
28             C - mixin class for building a C client
29              
30             =head1 SYNOPSIS
31              
32             This class is a mixin, it cannot be directly constructed
33              
34             package Example::Client;
35             use base qw( Base::Client Tangence::Client );
36              
37             sub connect
38             {
39             my $self = shift;
40             $self->SUPER::connect( @_ );
41              
42             $self->tangence_connected;
43              
44             wait_for { defined $self->rootobj };
45             }
46              
47             sub tangence_write
48             {
49             my $self = shift;
50             $self->write( $_[0] );
51             }
52              
53             sub on_read
54             {
55             my $self = shift;
56             $self->tangence_readfrom( $_[0] );
57             }
58              
59             package main;
60              
61             my $client = Example::Client->new;
62             $client->connect( "server.location.here" );
63              
64             my $rootobj = $client->rootobj;
65              
66             =head1 DESCRIPTION
67              
68             This module provides mixin to implement a C client connection. It
69             should be mixed in to an object used to represent a single connection to a
70             server. It provides a central location in the client to store object proxies,
71             including to the root object and the registry, and coordinates passing
72             messages between the server and the object proxies it contains.
73              
74             This is a subclass of L which provides implementations of
75             the required C methods. A class mixing in C
76             must still provide the C method required for sending data to
77             the server.
78              
79             For an example of a class that uses this mixin, see
80             L.
81              
82             =cut
83              
84             =head1 PROVIDED METHODS
85              
86             The following methods are provided by this mixin.
87              
88             =cut
89              
90             # Accessors for Tangence::Message decoupling
91 131   100 131 0 1100 sub objectproxies { shift->{objectproxies} ||= {} }
92              
93             =head2 rootobj
94              
95             $rootobj = $client->rootobj
96              
97             Returns a L to the server's root object
98              
99             =cut
100              
101             sub rootobj
102             {
103 19     19 1 588 my $self = shift;
104 19 100       77 $self->{rootobj} = shift if @_;
105 19         53 return $self->{rootobj};
106             }
107              
108             =head2 registry
109              
110             $registry = $client->registry
111              
112             Returns a L to the server's object registry if one has
113             been received, or C if not.
114              
115             This method is now deprecated in favour of L. Additionally note
116             that currently the client will attempt to request the registry at connection
117             time, but a later version of this module will stop doing that, so users who
118             need access to it should call C.
119              
120             =cut
121              
122             sub registry
123             {
124 19     19 1 47 my $self = shift;
125 19 100       54 $self->{registry} = shift if @_;
126 19         75 return $self->{registry};
127             }
128              
129             =head2 get_registry
130              
131             $registry = $client->get_registry->get
132              
133             Returns a L that will yield a L to the server's
134             registry object.
135              
136             Note that not all servers may permit access to the registry.
137              
138             =cut
139              
140             sub get_registry
141             {
142 9     9 1 21 my $self = shift;
143              
144             $self->request(
145             request => Tangence::Message->new( $self, MSG_GETREGISTRY ),
146             )->then( sub {
147 9     9   724 my ( $message ) = @_;
148 9         28 my $code = $message->code;
149              
150 9 50       33 $code == MSG_RESULT or
151             return Future->fail( "Cannot get registry - code $code", tangence => $message );
152              
153 9         50 $self->registry( TYPE_OBJ->unpack_value( $message ) );
154 9         51 return Future->done( $self->registry );
155 9         65 });
156             }
157              
158             sub on_error
159             {
160 28     28 0 154 my $self = shift;
161 28 100       110 $self->{on_error} = shift if @_;
162 28         189 return $self->{on_error};
163             }
164              
165             =head2 tangence_connected
166              
167             $client->tangence_connected( %args )
168              
169             Once the base connection to the server has been established, this method
170             should be called to perform the initial work of requesting the root object and
171             the registry.
172              
173             It takes the following named arguments:
174              
175             =over 8
176              
177             =item do_init => BOOL
178              
179             Ignored. Maintained for compatibility with previous version that allowed this
180             to be disabled.
181              
182             =item on_root => CODE
183              
184             Optional callback to be invoked once the root object has been returned. It
185             will be passed a L to the root object.
186              
187             $on_root->( $rootobj )
188              
189             =item on_registry => CODE
190              
191             Optional callback to be invoked once the registry has been returned. It will
192             be passed a L to the registry.
193              
194             $on_registry->( $registry )
195              
196             Note that in the case that the server does not permit access to the registry
197             or an error occurs while requesting it, this is invoked with an empty list.
198              
199             $on_registry->()
200              
201             =item version_minor_min => INT
202              
203             Optional minimum minor version to negotiate with the server. This can be used
204             to require a higher minimum version than the client module itself supports, in
205             case the application requires features in a newer version than that.
206              
207             =back
208              
209             =cut
210              
211 9         18 sub tangence_connected ( $self, %args )
212 9     9 1 94 {
  9         15  
  9         16  
213 9   50     113 my $version_minor_min = max( VERSION_MINOR_MIN, $args{version_minor_min} || 0 );
214              
215             $self->request(
216             request => Tangence::Message->new( $self, MSG_INIT )
217             ->pack_int( VERSION_MAJOR )
218             ->pack_int( VERSION_MINOR )
219             ->pack_int( $version_minor_min ),
220              
221             on_response => sub {
222 9     9   36 my ( $message ) = @_;
223 9         45 my $code = $message->code;
224              
225 9 50       39 if( $code == MSG_INITED ) {
    0          
226 9         137 my $major = $message->unpack_int();
227 9         35 my $minor = $message->unpack_int();
228              
229 9         324 $self->minor_version( $minor );
230 9         73 $self->tangence_initialised( %args );
231             }
232             elsif( $code == MSG_ERROR ) {
233 0         0 my $msg = $message->unpack_str();
234 0         0 print STDERR "Cannot initialise stream - error $msg";
235             }
236             else {
237 0         0 print STDERR "Cannot initialise stream - code $code\n";
238             }
239             },
240 9         117 );
241             }
242              
243 9         58 sub tangence_initialised ( $self, %args )
244 9     9 0 23 {
  9         28  
  9         25  
245 9         54 my $request = Tangence::Message->new( $self, MSG_GETROOT );
246 9         35 TYPE_ANY->pack_value( $request, $self->identity );
247              
248             $self->request(
249             request => $request,
250              
251             on_response => sub {
252 9     9   24 my ( $message ) = @_;
253 9         31 my $code = $message->code;
254              
255 9 50       32 if( $code == MSG_RESULT ) {
    0          
256 9         51 $self->rootobj( TYPE_OBJ->unpack_value( $message ) );
257 9 50       162 $args{on_root}->( $self->rootobj ) if $args{on_root};
258             }
259             elsif( $code == MSG_ERROR ) {
260 0         0 my $msg = $message->unpack_str();
261 0         0 print STDERR "Cannot get root object - error $msg";
262             }
263             else {
264 0         0 print STDERR "Cannot get root object - code $code\n";
265             }
266             }
267 9         149 );
268              
269             $self->get_registry->then(
270             sub {
271 9     9   1364 my ( $registry ) = @_;
272 9 50       58 $args{on_registry}->( $registry ) if $args{on_registry};
273             },
274             sub {
275 0 0   0   0 $args{on_registry}->() if $args{on_registry};
276             }
277 9         110 )->retain;
278             }
279              
280 2         5 sub handle_request_EVENT ( $self, $token, $message )
  2         3  
281 2     2 0 4 {
  2         3  
  2         3  
282 2         7 my $objid = $message->unpack_int();
283              
284 2         11 $self->respond( $token, Tangence::Message->new( $self, MSG_OK ) );
285              
286 2 50       21 if( my $obj = $self->objectproxies->{$objid} ) {
287 2         9 $obj->handle_request_EVENT( $message );
288             }
289             }
290              
291 47         78 sub handle_request_UPDATE ( $self, $token, $message )
  47         63  
292 47     47 0 85 {
  47         66  
  47         65  
293 47         152 my $objid = $message->unpack_int();
294              
295 47         226 $self->respond( $token, Tangence::Message->new( $self, MSG_OK ) );
296              
297 47 50       389 if( my $obj = $self->objectproxies->{$objid} ) {
298 47         196 $obj->handle_request_UPDATE( $message );
299             }
300             }
301              
302 2         4 sub handle_request_DESTROY ( $self, $token, $message )
  2         4  
303 2     2 0 5 {
  2         4  
  2         4  
304 2         7 my $objid = $message->unpack_int();
305              
306 2 50       7 if( my $obj = $self->objectproxies->{$objid} ) {
307 2         10 $obj->destroy;
308 2         10 delete $self->objectproxies->{$objid};
309             }
310              
311 2         12 $self->respond( $token, Tangence::Message->new( $self, MSG_OK ) );
312             }
313              
314 20         29 sub get_by_id ( $self, $id )
315 20     20 0 35 {
  20         35  
  20         45  
316 20 50       81 return $self->objectproxies->{$id} if exists $self->objectproxies->{$id};
317              
318 0         0 croak "Have no proxy of object id $id";
319             }
320              
321 19         32 sub make_proxy ( $self, $id, $classname, $smashdata )
  19         35  
  19         31  
322 19     19 0 42 {
  19         25  
  19         28  
323 19 50       93 if( exists $self->objectproxies->{$id} ) {
324 0         0 croak "Already have an object id $id";
325             }
326              
327 19         39 my $class;
328 19 50       68 if( defined $classname ) {
329 19         71 $class = $self->peer_hasclass->{$classname}->[0];
330 19 50       60 defined $class or croak "Cannot construct a proxy for class $classname as no meta exists";
331             }
332              
333 19         73 my $obj = $self->objectproxies->{$id} =
334             Tangence::ObjectProxy->new(
335             client => $self,
336             id => $id,
337              
338             class => $class,
339              
340             on_error => $self->on_error,
341             );
342              
343 19 100       113 $obj->grab( $smashdata ) if defined $smashdata;
344              
345 19         69 return $obj;
346             }
347              
348             =head1 SUBCLASSING METHODS
349              
350             These methods are intended for implementation classes to override.
351              
352             =cut
353              
354             =head2 new_future
355              
356             $f = $client->new_future
357              
358             Returns a new L instance for basing asynchronous operations on.
359              
360             =cut
361              
362             sub new_future
363             {
364 66     66 1 283 return Future->new;
365             }
366              
367             =head1 AUTHOR
368              
369             Paul Evans
370              
371             =cut
372              
373             0x55AA;