File Coverage

blib/lib/Tangence/ObjectProxy.pm
Criterion Covered Total %
statement 400 449 89.0
branch 94 152 61.8
condition 31 67 46.2
subroutine 50 55 90.9
pod 17 25 68.0
total 592 748 79.1


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-2022 -- leonerd@leonerd.org.uk
5              
6 9     9   113 use v5.26;
  9         34  
7 9     9   52 use Object::Pad 0.66;
  9         117  
  9         54  
8              
9             package Tangence::ObjectProxy 0.30;
10             class Tangence::ObjectProxy;
11              
12 9     9   3117 use Carp;
  9         26  
  9         684  
13              
14 9     9   76 use Syntax::Keyword::Match 0.06;
  9         182  
  9         67  
15              
16 9     9   1105 use Future::AsyncAwait;
  9         16244  
  9         102  
17 9     9   496 use Future::Exception;
  9         24  
  9         325  
18              
19 9     9   49 use Tangence::Constants;
  9         26  
  9         1687  
20              
21 9     9   62 use Tangence::Types;
  9         18  
  9         651  
22              
23 9     9   73 use Scalar::Util qw( weaken );
  9         21  
  9         4379  
24              
25             =head1 NAME
26              
27             C - proxy for a C object in a
28             C
29              
30             =head1 DESCRIPTION
31              
32             Instances in this class act as a proxy for an object in the
33             L, allowing methods to be called, events to be subscribed
34             to, and properties to be watched.
35              
36             These objects are not directly constructed by calling the C class method;
37             instead they are returned by methods on L, or by methods on
38             other C instances. Ultimately every object proxy that a
39             client uses will come from either the proxy to the registry, or the root
40             object.
41              
42             =cut
43              
44 19     19 0 53 field $_client :param :weak :reader;
  19         62  
45 56     56 1 134 field $_id :param :reader;
  56         237  
46 0     0 1 0 field $_class :param :reader;
  0         0  
47              
48             field $_destroyed;
49              
50             field %_subscriptions;
51             field %_props;
52              
53             method destroy
54 2     2 0 7 {
55 2         6 $_destroyed = 1;
56              
57 2         5 foreach my $cb ( @{ $_subscriptions{destroy} } ) {
  2         7  
58 2         6 $cb->();
59             }
60             }
61              
62             =head1 METHODS
63              
64             The following methods documented in an C expression return L
65             instances.
66              
67             =cut
68              
69 9     9   77 use overload '""' => \&STRING;
  9         20  
  9         84  
70              
71             method STRING
72 114     114 0 232 {
73 114         397 return "Tangence::ObjectProxy[id=$_id]";
74             }
75              
76             =head2 id
77              
78             $id = $proxy->id
79              
80             Returns the object ID for the C object being proxied for.
81              
82             =cut
83              
84             # generated accessor
85              
86             =head2 classname
87              
88             $classname = $proxy->classname
89              
90             Returns the name of the class of the C object being proxied for.
91              
92             =cut
93              
94             method classname
95 6     6 1 18 {
96 6         15 return $_class->name;
97             }
98              
99             =head2 class
100              
101             $class = $proxyobj->class
102              
103             Returns the L object representing the class of this
104             object.
105              
106             =cut
107              
108             # generated accessor
109              
110             =head2 can_method
111              
112             $method = $proxy->can_method( $name )
113              
114             Returns the L object representing the named method, or
115             C if no such method exists.
116              
117             =cut
118              
119             method can_method
120 8     8 1 42 {
121 8         32 return $_class->method( @_ );
122             }
123              
124             =head2 can_event
125              
126             $event = $proxy->can_event( $name )
127              
128             Returns the L object representing the named event, or
129             C if no such event exists.
130              
131             =cut
132              
133             method can_event
134 13     13 1 956 {
135 13         51 return $_class->event( @_ );
136             }
137              
138             =head2 can_property
139              
140             $property = $proxy->can_property( $name )
141              
142             Returns the L object representing the named
143             property, or C if no such property exists.
144              
145             =cut
146              
147             method can_property
148 118     118 1 1131 {
149 118         363 return $_class->property( @_ );
150             }
151              
152             # Don't want to call it "isa"
153             method proxy_isa
154 0     0 0 0 {
155 0 0       0 if( @_ ) {
156 0         0 my ( $class ) = @_;
157 0         0 return !! grep { $_->name eq $class } $_class, $_class->superclasses;
  0         0  
158             }
159             else {
160 0         0 return $_class, $_class->superclasses
161             }
162             }
163              
164 10         30 method grab ( $smashdata )
  10         30  
  10         18  
165 10     10 0 36 {
166 10         29 foreach my $property ( keys %{ $smashdata } ) {
  10         69  
167 20         52 my $value = $smashdata->{$property};
168 20         88 my $dim = $self->can_property( $property )->dimension;
169              
170 20 50       71 if( $dim == DIM_OBJSET ) {
171             # Comes across in a LIST. We need to map id => obj
172 0         0 $value = { map { $_->id => $_ } @$value };
  0         0  
173             }
174              
175 20   50     131 my $prop = $_props{$property} ||= {};
176 20         69 $prop->{cache} = $value;
177             }
178             }
179              
180             =head2 call_method
181              
182             $result = await $proxy->call_method( $mname, @args )
183              
184             Calls the given method on the server object, passing in the given arguments.
185             Returns a L that will yield the method's result.
186              
187             =cut
188              
189 6         11 async method call_method ( $method, @args )
  6         11  
  6         12  
  6         10  
190 6         21 {
191             # Detect void-context legacy uses
192             defined wantarray or
193 6 50       30 croak "->call_method in void context no longer useful - it now returns a Future";
194              
195 6 100       20 my $mdef = $self->can_method( $method )
196             or croak "Class ".$self->classname." does not have a method $method";
197              
198 4         26 my $request = Tangence::Message->new( $_client, MSG_CALL )
199             ->pack_int( $self->id )
200             ->pack_str( $method );
201              
202 4         19 my @argtypes = $mdef->argtypes;
203 4         48 $argtypes[$_]->pack_value( $request, $args[$_] ) for 0..$#argtypes;
204              
205 4         34 my $message = await $_client->request( request => $request );
206              
207 3         219 my $code = $message->code;
208              
209 3 50       12 if( $code == MSG_RESULT ) {
210 3 100       11 my $result = $mdef->ret ? $mdef->ret->unpack_value( $message )
211             : undef;
212 3         72 return $result;
213             }
214             else {
215 0         0 Future::Exception->throw( "Unexpected response code $code", tangence => );
216             }
217 6     6 1 2463 }
218              
219             =head2 subscribe_event
220              
221             await $proxy->subscribe_event( $event, %callbacks )
222              
223             Subscribes to the given event on the server object, installing a callback
224             function which will be invoked whenever the event is fired.
225              
226             Takes the following named callbacks:
227              
228             =over 8
229              
230             =item on_fire => CODE
231              
232             Callback function to invoke whenever the event is fired
233              
234             $on_fire->( @args )
235              
236             The returned C it is guaranteed to be completed before any invocation
237             of the C event handler.
238              
239             =back
240              
241             =cut
242              
243 7         15 async method subscribe_event ( $event, %args )
  7         15  
  7         17  
  7         12  
244 7         30 {
245             # Detect void-context legacy uses
246             defined wantarray or
247 7 50       24 croak "->subscribe_event in void context no longer useful - it now returns a Future";
248              
249 7 50       42 ref( my $callback = delete $args{on_fire} ) eq "CODE"
250             or croak "Expected 'on_fire' as a CODE ref";
251              
252 7 100       32 $self->can_event( $event )
253             or croak "Class ".$self->classname." does not have an event $event";
254              
255 5 50       25 if( my $cbs = $_subscriptions{$event} ) {
256 0         0 push @$cbs, $callback;
257 0         0 return;
258             }
259              
260 5         14 my @cbs = ( $callback );
261 5         13 $_subscriptions{$event} = \@cbs;
262              
263 5 100       31 return if $event eq "destroy"; # This is automatically handled
264              
265 3         21 my $message = await $_client->request(
266             request => Tangence::Message->new( $_client, MSG_SUBSCRIBE )
267             ->pack_int( $self->id )
268             ->pack_str( $event )
269             );
270              
271 2         150 my $code = $message->code;
272              
273 2 50       14 if( $code == MSG_SUBSCRIBED ) {
274 2         13 return;
275             }
276             else {
277 0         0 Future::Exception->throw( "Unexpected response code $code", tangence => );
278             }
279 7     7 1 3533 }
280              
281 2         7 method handle_request_EVENT ( $message )
  2         4  
  2         2  
282 2     2 0 17 {
283 2         17 my $event = $message->unpack_str();
284 2 50       48 my $edef = $self->can_event( $event ) or return;
285              
286 2         8 my @args = map { $_->unpack_value( $message ) } $edef->argtypes;
  4         14  
287              
288 2 50       55 if( my $cbs = $_subscriptions{$event} ) {
289 2         8 foreach my $cb ( @$cbs ) { $cb->( @args ) }
  2         8  
290             }
291             }
292              
293             =head2 unsubscribe_event
294              
295             $proxy->unsubscribe_event( $event )
296              
297             Removes an event subscription on the given event on the server object that was
298             previously installed using C.
299              
300             =cut
301              
302 2         5 method unsubscribe_event ( $event )
  2         5  
  2         4  
303 2     2 1 1301 {
304 2 50       10 $self->can_event( $event )
305             or croak "Class ".$self->classname." does not have an event $event";
306              
307 2 50       14 return if $event eq "destroy"; # This is automatically handled
308              
309             $_client->request(
310             request => Tangence::Message->new( $_client, MSG_UNSUBSCRIBE )
311             ->pack_int( $self->id )
312             ->pack_str( $event ),
313              
314       2     on_response => sub {},
315 2         14 );
316             }
317              
318             =head2 get_property
319              
320             await $value = $proxy->get_property( $prop )
321              
322             Requests the current value of the property from the server object.
323              
324             =cut
325              
326 8         16 async method get_property ( $property )
  8         16  
  8         11  
327 8         24 {
328             # Detect void-context legacy uses
329             defined wantarray or
330 8 50       28 croak "->get_property in void context no longer useful - it now returns a Future";
331              
332 8 100       21 my $pdef = $self->can_property( $property )
333             or croak "Class ".$self->classname." does not have a property $property";
334              
335 6         46 my $message = await $_client->request(
336             request => Tangence::Message->new( $_client, MSG_GETPROP )
337             ->pack_int( $self->id )
338             ->pack_str( $property ),
339             );
340              
341 5         229 my $code = $message->code;
342              
343 5 50       19 if( $code == MSG_RESULT ) {
344 5         18 return $pdef->overall_type->unpack_value( $message );
345             }
346             else {
347 0         0 Future::Exception->throw( "Unexpected response code $code", tangence => );
348             }
349 8     8 1 983 }
350              
351             =head2 get_property_element
352              
353             await $value = $proxy->get_property_element( $property, $index_or_key )
354              
355             Requests the current value of an element of the property from the server
356             object.
357              
358             =cut
359              
360 4         8 async method get_property_element ( $property, $index_or_key )
  4         9  
  4         6  
  4         7  
361 4         16 {
362             # Detect void-context legacy uses
363             defined wantarray or
364 4 50       13 croak "->get_property_element in void context no longer useful - it now returns a Future";
365              
366 4 50       14 my $pdef = $self->can_property( $property )
367             or croak "Class ".$self->classname." does not have a property $property";
368              
369 4         27 my $request = Tangence::Message->new( $_client, MSG_GETPROPELEM )
370             ->pack_int( $self->id )
371             ->pack_str( $property );
372              
373             match( $pdef->dimension : == ) {
374             case( DIM_HASH ) {
375 2         10 $request->pack_str( $index_or_key );
376             }
377             case( DIM_ARRAY ), case( DIM_QUEUE ) {
378 2         9 $request->pack_int( $index_or_key );
379             }
380 4 100 33     37 default {
    50          
381 0         0 croak "Cannot get_property_element of a non hash, array or queue";
382             }
383             }
384              
385 4         18 my $message = await $_client->request(
386             request => $request,
387             );
388              
389 4         202 my $code = $message->code;
390              
391 4 50       13 if( $code == MSG_RESULT ) {
392 4         16 return $pdef->type->unpack_value( $message );
393             }
394             else {
395 0         0 Future::Exception->throw( "Unexpected response code $code", tangence => );
396             }
397 4     4 1 3509 }
398              
399             =head2 prop
400              
401             $value = $proxy->prop( $property )
402              
403             Returns the locally-cached value of a smashed property. If the named property
404             is not a smashed property, an exception is thrown.
405              
406             =cut
407              
408 17         30 method prop ( $property )
  17         30  
  17         25  
409 17     17 1 1660 {
410 17 50       57 if( exists $_props{$property}->{cache} ) {
411 17         128 return $_props{$property}->{cache};
412             }
413              
414 0         0 croak "$self does not have a cached property '$property'";
415             }
416              
417             =head2 set_property
418              
419             await $proxy->set_property( $prop, $value )
420              
421             Sets the value of the property in the server object.
422              
423             =cut
424              
425 9         21 async method set_property ( $property, $value )
  9         19  
  9         17  
  9         14  
426 9         32 {
427             # Detect void-context legacy uses
428             defined wantarray or
429 9 50       48 croak "->set_property in void context no longer useful - it now returns a Future";
430              
431 9 50       25 my $pdef = $self->can_property( $property )
432             or croak "Class ".$self->classname." does not have a property $property";
433              
434 9         71 my $request = Tangence::Message->new( $_client, MSG_SETPROP )
435             ->pack_int( $self->id )
436             ->pack_str( $property );
437 9         36 $pdef->overall_type->pack_value( $request, $value );
438              
439 9         52 my $message = await $_client->request(
440             request => $request,
441             );
442              
443 7         218 my $code = $message->code;
444              
445 7 50       26 if( $code == MSG_OK ) {
446 7         57 return;
447             }
448             else {
449 0         0 Future::Exception->throw( "Unexpected response code $code", tangence => );
450             }
451 9     9 1 6045 }
452              
453             =head2 watch_property
454              
455             await $proxy->watch_property( $property, %callbacks )
456              
457             =head2 watch_property_with_initial
458              
459             await $proxy->watch_property_with_initial( $property, %callbacks )
460              
461             Watches the given property on the server object, installing callback functions
462             which will be invoked whenever the property value changes. The latter form
463             additionally ensures that the server will send the current value of the
464             property as an initial update to the C event, atomically when it
465             installs the update watches.
466              
467             Takes the following named arguments:
468              
469             =over 8
470              
471             =item on_updated => CODE
472              
473             Optional. Callback function to invoke whenever the property value changes.
474              
475             $on_updated->( $new_value )
476              
477             If not provided, then individual handlers for individual change types must be
478             provided.
479              
480             =back
481              
482             The set of callback functions that are required depends on the type of the
483             property. These are documented in the C method of
484             L.
485              
486             =cut
487              
488 24         39 sub _watchcbs_from_args ( $pdef, %args )
489 24     24   42 {
  24         58  
  24         35  
490 24         47 my $callbacks = {};
491 24         51 my $on_updated = delete $args{on_updated};
492 24 100       83 if( $on_updated ) {
493 5 50       18 ref $on_updated eq "CODE" or croak "Expected 'on_updated' to be a CODE ref";
494 5         18 $callbacks->{on_updated} = $on_updated;
495             }
496              
497 24         56 foreach my $name ( @{ CHANGETYPES->{$pdef->dimension} } ) {
  24         82  
498             # All of these become optional if 'on_updated' is supplied
499 52 100 66     168 next if $on_updated and not exists $args{$name};
500              
501 37 50       165 ref( $callbacks->{$name} = delete $args{$name} ) eq "CODE"
502             or croak "Expected '$name' as a CODE ref";
503             }
504              
505 24         65 return $callbacks;
506             }
507              
508 5     5 1 2243 method watch_property { $self->_watch_property( shift, 0, @_ ) }
  5         31  
509 13     13 1 6037 method watch_property_with_initial { $self->_watch_property( shift, 1, @_ ) }
  13         53  
510              
511 18         30 async method _watch_property ( $property, $want_initial, %args )
  18         85  
  18         30  
  18         51  
  18         27  
512 18         49 {
513             # Detect void-context legacy uses
514             defined wantarray or
515 18 50       54 croak "->watch_property in void context no longer useful - it now returns a Future";
516              
517 18 50       48 my $pdef = $self->can_property( $property )
518             or croak "Class ".$self->classname." does not have a property $property";
519              
520 18         81 my $callbacks = _watchcbs_from_args( $pdef, %args );
521              
522             # Smashed properties behave differently
523 18         60 my $smash = $pdef->smashed;
524              
525 18 100       70 if( my $cbs = $_props{$property}->{cbs} ) {
526 3 50 33     24 if( $want_initial and !$smash ) {
    0 0        
527 3         15 my $value = await $self->get_property( $property );
528              
529 3 100       178 $callbacks->{on_set} and $callbacks->{on_set}->( $value );
530 3 100       24 $callbacks->{on_updated} and $callbacks->{on_updated}->( $value );
531 3         12 push @$cbs, $callbacks;
532 3         17 return;
533             }
534             elsif( $want_initial and $smash ) {
535 0         0 my $cache = $_props{$property}->{cache};
536 0 0       0 $callbacks->{on_set} and $callbacks->{on_set}->( $cache );
537 0 0       0 $callbacks->{on_updated} and $callbacks->{on_updated}->( $cache );
538 0         0 push @$cbs, $callbacks;
539 0         0 return;
540             }
541             else {
542 0         0 push @$cbs, $callbacks;
543 0         0 return;
544             }
545              
546 0         0 die "UNREACHED";
547             }
548              
549 15         47 $_props{$property}->{cbs} = [ $callbacks ];
550              
551 15 100       43 if( $smash ) {
552 2 50       6 if( $want_initial ) {
553 2         5 my $cache = $_props{$property}->{cache};
554 2 50       14 $callbacks->{on_set} and $callbacks->{on_set}->( $cache );
555 2 50       12 $callbacks->{on_updated} and $callbacks->{on_updated}->( $cache );
556             }
557              
558 2         21 return;
559             }
560              
561 13         87 my $request = Tangence::Message->new( $_client, MSG_WATCH )
562             ->pack_int( $self->id )
563             ->pack_str( $property )
564             ->pack_bool( $want_initial );
565              
566 13         75 my $message = await $_client->request( request => $request );
567              
568 12         371 my $code = $message->code;
569              
570 12 50       52 if( $code == MSG_WATCHING ) {
571 12         130 return;
572             }
573             else {
574 0         0 Future::Exception->throw( "Unexpected response code $code", tangence => );
575             }
576 18     18   37 }
577              
578             =head2 watch_property_with_cursor
579              
580             ( $cursor, $first_idx, $last_idx ) =
581             await $proxy->watch_property_with_cursor( $property, $from, %callbacks )
582              
583             A variant of C that installs a watch on the given property of
584             the server object, and additionally returns an cursor object that can be used
585             to lazily fetch the values stored in it.
586              
587             The C<$from> value indicates which end of the queue the cursor should start
588             from; C to start at index 0, or C to start at the
589             highest-numbered index. The cursor is created atomically with installing the
590             watch.
591              
592             =cut
593              
594             method watch_property_with_iter
595 0     0 0 0 {
596             # Detect void-context legacy uses
597             defined wantarray or
598 0 0       0 croak "->watch_property_with_iter in void context no longer useful - it now returns a Future";
599              
600 0         0 return $self->watch_property_with_cursor( @_ );
601             }
602              
603 6         16 async method watch_property_with_cursor ( $property, $from, %args )
  6         20  
  6         13  
  6         22  
  6         11  
604 6         21 {
605             match( $from : eq ) {
606 5         11 case( "first" ) { $from = CUSR_FIRST }
607 1         3 case( "last" ) { $from = CUSR_LAST }
608 6 100       33 default { croak "Unrecognised 'from' value $from" }
  0 50       0  
609             }
610              
611 6 50       30 my $pdef = $self->can_property( $property )
612             or croak "Class ".$self->classname." does not have a property $property";
613              
614 6         26 my $callbacks = _watchcbs_from_args( $pdef, %args );
615              
616             # Smashed properties behave differently
617 6         25 my $smashed = $pdef->smashed;
618              
619 6 50       33 if( my $cbs = $_props{$property}->{cbs} ) {
620 0         0 die "TODO: need to synthesize a second cursor for $self";
621             }
622              
623 6         22 $_props{$property}->{cbs} = [ $callbacks ];
624              
625 6 50       20 if( $smashed ) {
626 0         0 die "TODO: need to synthesize an cursor";
627             }
628              
629 6 50       18 $pdef->dimension == DIM_QUEUE or croak "Can only iterate on queue-dimension properties";
630              
631 6         36 my $message = await $_client->request(
632             request => Tangence::Message->new( $_client, MSG_WATCH_CUSR )
633             ->pack_int( $self->id )
634             ->pack_str( $property )
635             ->pack_int( $from ),
636             );
637              
638 6         219 my $code = $message->code;
639              
640 6 50       24 if( $code == MSG_WATCHING_CUSR ) {
641 6         23 my $cursor_id = $message->unpack_int();
642 6         20 my $first_idx = $message->unpack_int();
643 6         38 my $last_idx = $message->unpack_int();
644              
645 6         40 my $cursor = Tangence::ObjectProxy::_Cursor->new( $self, $cursor_id, $pdef->type );
646 6         67 return ( $cursor, $first_idx, $last_idx );
647             }
648             else {
649 0         0 Future::Exception->throw( "Unexpected response code $code", tangence => );
650             }
651 6     6 1 1079 }
652              
653 47         77 method handle_request_UPDATE ( $message )
  47         78  
  47         73  
654 47     47 0 92 {
655 47         123 my $prop = $message->unpack_str();
656 47         1030 my $how = TYPE_U8->unpack_value( $message );
657              
658 47 50       121 my $pdef = $self->can_property( $prop ) or return;
659 47         147 my $type = $pdef->type;
660 47         132 my $dim = $pdef->dimension;
661              
662 47   50     168 my $p = $_props{$prop} ||= {};
663              
664 47         95 my $dimname = DIMNAMES->[$dim];
665 47 50       256 if( my $code = $self->can( "_update_property_$dimname" ) ) {
666 47         143 $code->( $self, $p, $type, $how, $message );
667             }
668             else {
669 0         0 croak "Unrecognised property dimension $dim for $prop";
670             }
671              
672 47   66     260 $_->{on_updated} and $_->{on_updated}->( $p->{cache} ) for @{ $p->{cbs} };
  47         337  
673             }
674              
675 15         35 method _update_property_scalar ( $p, $type, $how, $message )
  15         25  
  15         20  
  15         27  
  15         23  
  15         27  
676 15     15   32 {
677             match( $how : == ) {
678             case( CHANGE_SET ) {
679 15         56 my $value = $type->unpack_value( $message );
680 15         38 $p->{cache} = $value;
681 15   33     25 $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} };
  15         123  
682             }
683 15 50       47 default {
684 0         0 croak "Change type $how is not valid for a scalar property";
685             }
686             }
687             }
688              
689 8         11 method _update_property_hash ( $p, $type, $how, $message )
  8         14  
  8         12  
  8         13  
  8         14  
  8         10  
690 8     8   19 {
691             match( $how : == ) {
692             case( CHANGE_SET ) {
693 2         10 my $value = Tangence::Type->make( dict => $type )->unpack_value( $message );
694 2         8 $p->{cache} = $value;
695 2   66     4 $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} };
  2         15  
696             }
697             case( CHANGE_ADD ) {
698 4         14 my $key = $message->unpack_str();
699 4         83 my $value = $type->unpack_value( $message );
700 4         11 $p->{cache}->{$key} = $value;
701 4   66     9 $_->{on_add} and $_->{on_add}->( $key, $value ) for @{ $p->{cbs} };
  4         22  
702             }
703             case( CHANGE_DEL ) {
704 2         9 my $key = $message->unpack_str();
705 2         44 delete $p->{cache}->{$key};
706 2   66     6 $_->{on_del} and $_->{on_del}->( $key ) for @{ $p->{cbs} };
  2         16  
707             }
708 8 100       34 default {
    100          
    50          
709 0         0 croak "Change type $how is not valid for a hash property";
710             }
711             }
712             }
713              
714 7         12 method _update_property_queue ( $p, $type, $how, $message )
  7         12  
  7         11  
  7         23  
  7         12  
  7         10  
715 7     7   25 {
716             match( $how : == ) {
717             case( CHANGE_SET ) {
718 1         6 my $value = Tangence::Type->make( list => $type )->unpack_value( $message );
719 1         4 $p->{cache} = $value;
720 1   33     2 $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} };
  1         24  
721             }
722             case( CHANGE_PUSH ) {
723 3         15 my @value = $message->unpack_all_sametype( $type );
724 3         8 push @{ $p->{cache} }, @value;
  3         11  
725 3   33     6 $_->{on_push} and $_->{on_push}->( @value ) for @{ $p->{cbs} };
  3         24  
726             }
727             case( CHANGE_SHIFT ) {
728 3         11 my $count = $message->unpack_int();
729 3         6 splice @{ $p->{cache} }, 0, $count, ();
  3         9  
730 3   33     8 $_->{on_shift} and $_->{on_shift}->( $count ) for @{ $p->{cbs} };
  3         20  
731             }
732 7 100       30 default {
    100          
    50          
733 0         0 croak "Change type $how is not valid for a queue property";
734             }
735             }
736             }
737              
738 13         20 method _update_property_array ( $p, $type, $how, $message )
  13         19  
  13         16  
  13         23  
  13         16  
  13         16  
739 13     13   24 {
740             match( $how : == ) {
741             case( CHANGE_SET ) {
742 4         19 my $value = Tangence::Type->make( list => $type )->unpack_value( $message );
743 4         12 $p->{cache} = $value;
744 4   66     20 $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} };
  4         36  
745             }
746             case( CHANGE_PUSH ) {
747 3         13 my @value = $message->unpack_all_sametype( $type );
748 3         8 push @{ $p->{cache} }, @value;
  3         9  
749 3   66     9 $_->{on_push} and $_->{on_push}->( @value ) for @{ $p->{cbs} };
  3         23  
750             }
751             case( CHANGE_SHIFT ) {
752 1         6 my $count = $message->unpack_int();
753 1         5 splice @{ $p->{cache} }, 0, $count, ();
  1         3  
754 1   33     12 $_->{on_shift} and $_->{on_shift}->( $count ) for @{ $p->{cbs} };
  1         10  
755             }
756             case( CHANGE_SPLICE ) {
757 2         9 my $start = $message->unpack_int();
758 2         10 my $count = $message->unpack_int();
759 2         11 my @value = $message->unpack_all_sametype( $type );
760 2         5 splice @{ $p->{cache} }, $start, $count, @value;
  2         9  
761 2   66     5 $_->{on_splice} and $_->{on_splice}->( $start, $count, @value ) for @{ $p->{cbs} };
  2         20  
762             }
763             case( CHANGE_MOVE ) {
764 3         13 my $index = $message->unpack_int();
765 3         12 my $delta = $message->unpack_int();
766             # it turns out that exchanging neighbours is quicker by list assignment,
767             # but other times it's generally best to use splice() to extract then
768             # insert
769 3 50       14 if( abs($delta) == 1 ) {
770 0         0 @{$p->{cache}}[$index,$index+$delta] = @{$p->{cache}}[$index+$delta,$index];
  0         0  
  0         0  
771             }
772             else {
773 3         7 my $elem = splice @{ $p->{cache} }, $index, 1, ();
  3         11  
774 3         6 splice @{ $p->{cache} }, $index + $delta, 0, ( $elem );
  3         175  
775             }
776 3   66     9 $_->{on_move} and $_->{on_move}->( $index, $delta ) for @{ $p->{cbs} };
  3         22  
777             }
778 13 100       75 default {
    100          
    100          
    100          
    50          
779 0         0 croak "Change type $how is not valid for an array property";
780             }
781             }
782             }
783              
784 4         6 method _update_property_objset ( $p, $type, $how, $message )
  4         8  
  4         5  
  4         8  
  4         6  
  4         5  
785 4     4   9 {
786             match( $how : == ) {
787             case( CHANGE_SET ) {
788             # Comes across in a LIST. We need to map id => obj
789 2         8 my $objects = Tangence::Type->make( list => $type )->unpack_value( $message );
790 2         8 $p->{cache} = { map { $_->id => $_ } @$objects };
  1         4  
791 2   33     5 $_->{on_set} and $_->{on_set}->( $p->{cache} ) for @{ $p->{cbs} };
  2         14  
792             }
793             case( CHANGE_ADD ) {
794             # Comes as object only
795 1         5 my $obj = $type->unpack_value( $message );
796 1         5 $p->{cache}->{$obj->id} = $obj;
797 1   33     3 $_->{on_add} and $_->{on_add}->( $obj ) for @{ $p->{cbs} };
  1         8  
798             }
799             case( CHANGE_DEL ) {
800             # Comes as ID number only
801 1         5 my $id = $message->unpack_int();
802 1         4 delete $p->{cache}->{$id};
803 1   33     3 $_->{on_del} and $_->{on_del}->( $id ) for @{ $p->{cbs} };
  1         8  
804             }
805 4 100       17 default {
    100          
    50          
806 0         0 croak "Change type $how is not valid for an objset property";
807             }
808             }
809             }
810              
811             =head2 unwatch_property
812              
813             $proxy->unwatch_property( $property )
814              
815             Removes a property watches on the given property on the server object that was
816             previously installed using C.
817              
818             =cut
819              
820 4         11 method unwatch_property ( $property )
  4         8  
  4         7  
821 4     4 1 4293 {
822 4 50       16 $self->can_property( $property )
823             or croak "Class ".$self->classname." does not have a property $property";
824              
825             # TODO: mark cursors as destroyed and invalid
826 4         53 delete $_props{$property};
827              
828             $_client->request(
829             request => Tangence::Message->new( $_client, MSG_UNWATCH )
830             ->pack_int( $self->id )
831             ->pack_str( $property ),
832              
833       4     on_response => sub {},
834 4         36 );
835             }
836              
837             class Tangence::ObjectProxy::_Cursor
838             {
839 9     9   95419 use Carp;
  9         21  
  9         738  
840 9     9   70 use Tangence::Constants;
  9         20  
  9         12112  
841              
842             =head1 CURSOR METHODS
843              
844             The following methods are availilable on the property cursor objects returned
845             by the C method.
846              
847             =cut
848              
849 0     0   0 field $obj :param :reader;
  0         0  
850 0     0   0 field $id :param :reader;
  0         0  
851             field $element_type :param;
852              
853 6         14 sub BUILDARGS ( $class, $obj, $id, $element_type )
  6         11  
  6         10  
854 6     6   15 {
  6         12  
  6         9  
855 6         56 return ( obj => $obj, id => $id, element_type => $element_type );
856             }
857              
858 18     18   34 method client { $obj->client }
  18         53  
859              
860             # TODO: Object::Pad probably should do this bit
861             method DESTROY
862 6     6   2484 {
863 6 50 33     71 return unless $obj and my $client = $self->client;
864              
865             $client->request(
866             request => Tangence::Message->new( $client, MSG_CUSR_DESTROY )
867             ->pack_int( $id ),
868              
869       6     on_response => sub {},
870 6         43 );
871             }
872              
873             =head2 next_forward
874              
875             ( $index, @more ) = await $cursor->next_forward( $count )
876              
877             =head2 next_backward
878              
879             ( $index, @more ) = await $cursor->next_backward( $count )
880              
881             Requests the next items from the cursor. C moves forwards
882             towards higher-numbered indices, and C moves backwards towards
883             lower-numbered indices. If C<$count> is unspecified, a default of 1 will
884             apply.
885              
886             The returned future wil yield the index of the first element returned, and the
887             new elements. Note that there may be fewer elements returned than were
888             requested, if the end of the queue was reached. Specifically, there will be no
889             new elements if the cursor is already at the end.
890              
891             =cut
892              
893             method next_forward
894 7     7   8711 {
895 7         41 $self->_next( CUSR_FWD, @_ );
896             }
897              
898             method next_backward
899 5     5   4718 {
900 5         20 $self->_next( CUSR_BACK, @_ );
901             }
902              
903 12         18 async method _next ( $direction, $count = 1 )
  12         20  
  12         19  
  12         16  
904 12         25 {
905             # Detect void-context legacy uses
906             defined wantarray or
907 12 50       36 croak "->next_forward/backward in void context no longer useful - it now returns a Future";
908              
909 12         31 my $client = $self->client;
910              
911 12         83 my $message = await $client->request(
912             request => Tangence::Message->new( $client, MSG_CUSR_NEXT )
913             ->pack_int( $id )
914             ->pack_int( $direction )
915             ->pack_int( $count || 1 ),
916             );
917              
918 12         460 my $code = $message->code;
919              
920 12 50       49 if( $code == MSG_CUSR_RESULT ) {
921             return (
922 12         50 $message->unpack_int(),
923             $message->unpack_all_sametype( $element_type ),
924             );
925             }
926             else {
927 0           Future::Exception->throw( "Unexpected response code $code", tangence => );
928             }
929 12     12   26 }
930             }
931              
932             =head1 AUTHOR
933              
934             Paul Evans
935              
936             =cut
937              
938             0x55AA;