File Coverage

blib/lib/Tangence/Object.pm
Criterion Covered Total %
statement 289 304 95.0
branch 59 92 64.1
condition 7 11 63.6
subroutine 37 38 97.3
pod 13 22 59.0
total 405 467 86.7


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;