File Coverage

blib/lib/Tangence/Message.pm
Criterion Covered Total %
statement 280 291 96.2
branch 41 60 68.3
condition 3 6 50.0
subroutine 46 46 100.0
pod 0 20 0.0
total 370 423 87.4


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 12     12   61124 use v5.26;
  12         45  
7 12     12   949 use Object::Pad 0.41;
  12         11365  
  12         61  
8              
9             package Tangence::Message 0.28;
10             class Tangence::Message;
11              
12 12     12   3329 use Carp;
  12         32  
  12         814  
13              
14 12     12   427 use Tangence::Constants;
  12         21  
  12         1927  
15              
16 12     12   1192 use Tangence::Class;
  12         24  
  12         416  
17 12     12   67 use Tangence::Meta::Method;
  12         20  
  12         294  
18 12     12   50 use Tangence::Meta::Event;
  12         20  
  12         376  
19 12     12   64 use Tangence::Property;
  12         18  
  12         522  
20 12     12   1207 use Tangence::Meta::Argument;
  12         42  
  12         334  
21 12     12   1523 use Tangence::Struct;
  12         30  
  12         406  
22 12     12   1145 use Tangence::Types;
  12         22  
  12         767  
23              
24 12     12   1758 use Tangence::Object;
  12         22  
  12         692  
25              
26 12     12   79 use List::Util 1.29 qw( pairmap );
  12         218  
  12         1288  
27 12     12   83 use Scalar::Util qw( weaken blessed );
  12         19  
  12         69407  
28              
29             # Normally we don't care about hash key order. But, when writing test scripts
30             # that will assert on the serialisation bytes, we do. Setting this to some
31             # true value will sort keys first
32             our $SORT_HASH_KEYS = 0;
33              
34 141     141 0 216 has $_stream :param :reader;
  141         327  
35 469     469 0 1983 has $_code :param :reader;
  469         1931  
36 415     415 0 28833 has $_payload :param :reader;
  415         1163  
37              
38 678         865 sub BUILDARGS ( $class, $stream, $code, $payload = "" )
  678         821  
  678         803  
  678         922  
39 678     678 0 15027 {
  678         722  
40 678         4320 return ( stream => $stream, code => $code, payload => $payload );
41             }
42              
43 1847         1895 method _pack_leader ( $type, $num )
  1847         1933  
  1847         1923  
  1847         1705  
44 1847     1847   2662 {
45 1847 100       2558 if( $num < 0x1f ) {
    50          
46 1838         4478 $_payload .= pack( "C", ( $type << 5 ) | $num );
47             }
48             elsif( $num < 0x80 ) {
49 9         35 $_payload .= pack( "CC", ( $type << 5 ) | 0x1f, $num );
50             }
51             else {
52 0         0 $_payload .= pack( "CN", ( $type << 5 ) | 0x1f, $num | 0x80000000 );
53             }
54             }
55              
56             method _peek_leader_type
57 2045     2045   2464 {
58 2045         2149 while(1) {
59 2087 50       3200 length $_payload or croak "Ran out of bytes before finding a leader";
60              
61 2087         3376 my ( $typenum ) = unpack( "C", $_payload );
62 2087         2643 my $type = $typenum >> 5;
63              
64 2087 100       4357 return $type unless $type == DATA_META;
65              
66 42         99 substr( $_payload, 0, 1, "" );
67              
68 42         74 my $num = $typenum & 0x1f;
69 42 100       137 if( $num == DATAMETA_CONSTRUCT ) {
    100          
    50          
70 20         240 $self->unpackmeta_construct;
71             }
72             elsif( $num == DATAMETA_CLASS ) {
73 20         76 $self->unpackmeta_class;
74             }
75             elsif( $num == DATAMETA_STRUCT ) {
76 2         7 $self->unpackmeta_struct;
77             }
78             else {
79 0         0 die sprintf("TODO: Data stream meta-operation 0x%02x", $num);
80             }
81             }
82             }
83              
84 1837         1898 method _unpack_leader ( $peek = 0 )
  1837         2000  
  1837         1778  
85 1837     1837   2438 {
86 1837         2508 my $type = $self->_peek_leader_type;
87 1837         2689 my ( $typenum ) = unpack( "C", $_payload );
88              
89 1837         2197 my $num = $typenum & 0x1f;
90              
91 1837         1958 my $len = 1;
92 1837 100       2678 if( $num == 0x1f ) {
93 9         17 ( $num ) = unpack( "x C", $_payload );
94              
95 9 50       19 if( $num < 0x80 ) {
96 9         13 $len = 2;
97             }
98             else {
99 0         0 ( $num ) = unpack( "x N", $_payload );
100 0         0 $num &= 0x7fffffff;
101 0         0 $len = 5;
102             }
103             }
104              
105 1837 100       3236 substr( $_payload, 0, $len ) = "" if !$peek;
106              
107 1837         3513 return $type, $num;
108             }
109              
110 1287         1354 method _pack ( $s )
  1287         1551  
  1287         1288  
111 1287     1287   1837 {
112 1287         2424 $_payload .= $s;
113             }
114              
115 1288         1347 method _unpack ( $num )
  1288         1351  
  1288         1241  
116 1288     1288   1915 {
117 1288 50       1935 length $_payload >= $num or croak "Can't pull $num bytes as there aren't enough";
118 1288         3313 return substr( $_payload, 0, $num, "" );
119             }
120              
121 16         25 method pack_bool ( $d )
  16         25  
  16         21  
122 16     16 0 48 {
123 16         81 TYPE_BOOL->pack_value( $self, $d );
124 16         59 return $self;
125             }
126              
127             method unpack_bool
128 16     16 0 40 {
129 16         68 return TYPE_BOOL->unpack_value( $self );
130             }
131              
132 473         566 method pack_int ( $d )
  473         583  
  473         520  
133 473     473 0 814 {
134 473         1490 TYPE_INT->pack_value( $self, $d );
135 469         1240 return $self;
136             }
137              
138             method unpack_int
139 472     472 0 1269 {
140 472         1142 return TYPE_INT->unpack_value( $self );
141             }
142              
143 294         348 method pack_str ( $d )
  294         378  
  294         338  
144 294     294 0 482 {
145 294         767 TYPE_STR->pack_value( $self, $d );
146 292         776 return $self;
147             }
148              
149             method unpack_str
150 294     294 0 475 {
151 294         732 return TYPE_STR->unpack_value( $self );
152             }
153              
154 161         180 method pack_record ( $rec, $struct = undef )
  161         188  
  161         184  
  161         175  
155 161     161 0 289 {
156 161 50 66     350 $struct ||= eval { Tangence::Struct->for_perlname( ref $rec ) } or
  21         99  
157             croak "No struct for " . ref $rec;
158              
159 161 100       402 $self->packmeta_struct( $struct ) unless $_stream->peer_hasstruct->{$struct->perlname};
160              
161 161         408 my @fields = $struct->fields;
162 161         363 $self->_pack_leader( DATA_RECORD, scalar @fields );
163 161         318 $self->pack_int( $_stream->peer_hasstruct->{$struct->perlname}->[1] );
164 161         281 foreach my $field ( @fields ) {
165 417         752 my $fieldname = $field->name;
166 417         709 $field->type->pack_value( $self, $rec->$fieldname );
167             }
168              
169 161         491 return $self;
170             }
171              
172 161         186 method unpack_record ( $struct = undef )
  161         185  
  161         180  
173 161     161 0 244 {
174 161         253 my ( $type, $num ) = $self->_unpack_leader();
175 161 50       320 $type == DATA_RECORD or croak "Expected to unpack a record but did not find one";
176              
177 161         284 my $structid = $self->unpack_int();
178 161         409 my $got_struct = $_stream->message_state->{id2struct}{$structid};
179 161 50       291 if( !$struct ) {
180 161         200 $struct = $got_struct;
181             }
182             else {
183 0 0       0 $struct->name eq $got_struct->name or
184             croak "Expected to unpack a ".$struct->name." but found ".$got_struct->name;
185             }
186              
187 161 50       372 $num == $struct->fields or croak "Expected ".$struct->name." to unpack from ".(scalar $struct->fields)." fields";
188              
189 161         198 my %values;
190 161         256 foreach my $field ( $struct->fields ) {
191 417         720 $values{$field->name} = $field->type->unpack_value( $self );
192             }
193              
194 161         363 return $struct->perlname->new( %values );
195             }
196              
197 20         31 method packmeta_construct ( $obj )
  20         37  
  20         43  
198 20     20 0 58 {
199 20         65 my $class = $obj->class;
200 20         59 my $id = $obj->id;
201              
202 20 100       129 $self->packmeta_class( $class ) unless $_stream->peer_hasclass->{$class->perlname};
203              
204 20         94 my $smashkeys = $class->smashkeys;
205              
206 20         78 $self->_pack_leader( DATA_META, DATAMETA_CONSTRUCT );
207 20         68 $self->pack_int( $id );
208 20         62 $self->pack_int( $_stream->peer_hasclass->{$class->perlname}->[2] );
209              
210 20 100       74 if( @$smashkeys ) {
211 11         102 my $smashdata = $obj->smash( $smashkeys );
212              
213 11         100 for my $prop ( @$smashkeys ) {
214 21         125 $_stream->_install_watch( $obj, $prop );
215             }
216              
217 11 50       89 if( $_stream->_ver_can_typed_smash ) {
218 11         64 $self->_pack_leader( DATA_LIST, scalar @$smashkeys );
219 11         31 foreach my $prop ( @$smashkeys ) {
220 21         64 $class->property( $prop )->overall_type->pack_value( $self, $smashdata->{$prop} );
221             }
222             }
223             else {
224 0         0 TYPE_LIST_ANY->pack_value( $self, [ map { $smashdata->{$_} } @$smashkeys ] );
  0         0  
225             }
226             }
227             else {
228 9         28 $self->_pack_leader( DATA_LIST, 0 );
229             }
230              
231 20         85 weaken( my $weakstream = $_stream );
232             $_stream->peer_hasobj->{$id} = $obj->subscribe_event(
233 2 50   2   27 destroy => sub { $weakstream->object_destroyed( @_ ) if $weakstream },
234 20         233 );
235             }
236              
237             method unpackmeta_construct
238 20     20 0 71 {
239 20         56 my $id = $self->unpack_int();
240 20         163 my $classid = $self->unpack_int();
241 20         79 my $class_perlname = $_stream->message_state->{id2class}{$classid};
242              
243 20         35 my ( $class, $smashkeys ) = @{ $_stream->peer_hasclass->{$class_perlname} };
  20         59  
244              
245 20         36 my $smasharr;
246 20 50       108 if( $_stream->_ver_can_typed_smash ) {
247 20         76 my ( $type, $num ) = $self->_unpack_leader;
248 20 50       62 $type == DATA_LIST or croak "Expected to unpack a LIST of smashed data";
249 20 50       76 $num == @$smashkeys or croak "Expected to unpack a LIST of " . ( scalar @$smashkeys ) . " elements";
250              
251 20         51 foreach my $prop ( @$smashkeys ) {
252 21         76 push @$smasharr, $class->property( $prop )->overall_type->unpack_value( $self );
253             }
254             }
255             else {
256 0         0 $smasharr = TYPE_LIST_ANY->unpack_value( $self );
257             }
258              
259 20         80 my $smashdata;
260 20         116 $smashdata->{$smashkeys->[$_]} = $smasharr->[$_] for 0 .. $#$smasharr;
261              
262 20         142 $_stream->make_proxy( $id, $class_perlname, $smashdata );
263             }
264              
265 20         29 method packmeta_class ( $class )
  20         63  
  20         24  
266 20     20 0 49 {
267 20         105 my @superclasses = grep { $_->name ne "Tangence.Object" } $class->direct_superclasses;
  1         3  
268              
269 20   33     65 $_stream->peer_hasclass->{$_->perlname} or $self->packmeta_class( $_ ) for @superclasses;
270              
271 20         66 $self->_pack_leader( DATA_META, DATAMETA_CLASS );
272              
273 20         92 my $smashkeys = $class->smashkeys;
274              
275 20         101 my $classid = ++$_stream->message_state->{next_classid};
276              
277 20         67 $self->pack_str( $class->name );
278 20         63 $self->pack_int( $classid );
279             my $classrec = Tangence::Struct::Class->new(
280             methods => {
281             pairmap {
282             $a => Tangence::Struct::Method->new(
283 28 100   28   136 arguments => [ map { $_->type->sig } $b->arguments ],
  28         85  
284             returns => ( $b->ret ? $b->ret->sig : "" ),
285             )
286 20         125 } %{ $class->direct_methods }
287             },
288             events => {
289             pairmap {
290             $a => Tangence::Struct::Event->new(
291 28     28   126 arguments => [ map { $_->type->sig } $b->arguments ],
  37         80  
292             )
293 20         103 } %{ $class->direct_events }
294             },
295             properties => {
296             pairmap {
297 83     83   245 $a => Tangence::Struct::Property->new(
298             dimension => $b->dimension,
299             type => $b->type->sig,
300             smashed => $b->smashed,
301             )
302 20         68 } %{ $class->direct_properties }
303             },
304 20         111 superclasses => [ map { $_->name } @superclasses ],
  1         3  
305             );
306 20         235 $self->pack_record( $classrec );
307              
308 20         73 TYPE_LIST_STR->pack_value( $self, $smashkeys );
309              
310 20         83 $_stream->peer_hasclass->{$class->perlname} = [ $class, $smashkeys, $classid ];
311             }
312              
313             method unpackmeta_class
314 20     20 0 43 {
315 20         62 my $name = $self->unpack_str();
316 20         497 my $classid = $self->unpack_int();
317 20         78 my $classrec = $self->unpack_record();
318              
319 20         247 my $class = Tangence::Meta::Class->new( name => $name );
320             $class->define(
321             methods => {
322             pairmap {
323             $a => Tangence::Meta::Method->new(
324             class => $class,
325             name => $a,
326             ret => $b->returns ? Tangence::Type->make_from_sig( $b->returns )
327             : undef,
328             arguments => [ map {
329 28         101 Tangence::Meta::Argument->new(
330             type => Tangence::Type->make_from_sig( $_ ),
331             )
332 28 100   28   125 } @{ $b->arguments } ],
  28         93  
333             )
334 20         74 } %{ $classrec->methods }
335             },
336              
337             events => {
338             pairmap {
339             $a => Tangence::Meta::Event->new(
340             class => $class,
341             name => $a,
342             arguments => [ map {
343 37         118 Tangence::Meta::Argument->new(
344             type => Tangence::Type->make_from_sig( $_ ),
345             )
346 28     28   77 } @{ $b->arguments } ],
  28         75  
347             )
348 20         101 } %{ $classrec->events }
349             },
350              
351             properties => {
352             pairmap {
353             # Need to use non-Meta:: Property so it can generate overall type
354             # using Tangence::Type instead of Tangence::Meta::Type
355 83     83   255 $a => Tangence::Property->new(
356             class => $class,
357             name => $a,
358             dimension => $b->dimension,
359             type => Tangence::Type->make_from_sig( $b->type ),
360             smashed => $b->smashed,
361             )
362 20         90 } %{ $classrec->properties }
363             },
364              
365 20         166 superclasses => do {
366             my @superclasses = map {
367 1         7 ( my $perlname = $_ ) =~ s/\./::/g;
368 1 50       3 $_stream->peer_hasclass->{$perlname}->[3] or croak "Unrecognised class $perlname";
369 20         58 } @{ $classrec->superclasses };
  20         91  
370              
371 20 100       123 @superclasses ? \@superclasses : [ Tangence::Class->for_name( "Tangence.Object" ) ]
372             },
373             );
374              
375 20         284 my $perlname = $class->perlname;
376              
377 20         111 my $smashkeys = TYPE_LIST_STR->unpack_value( $self );
378              
379 20         165 $_stream->peer_hasclass->{$perlname} = [ $class, $smashkeys, $classid, $class ];
380 20 50       63 if( defined $classid ) {
381 20         58 $_stream->message_state->{id2class}{$classid} = $perlname;
382             }
383             }
384              
385 2         4 method packmeta_struct ( $struct )
  2         3  
  2         2  
386 2     2 0 4 {
387 2         7 $self->_pack_leader( DATA_META, DATAMETA_STRUCT );
388              
389 2         10 my @fields = $struct->fields;
390              
391 2         12 my $structid = ++$_stream->message_state->{next_structid};
392 2         12 $self->pack_str( $struct->name );
393 2         7 $self->pack_int( $structid );
394 2         5 TYPE_LIST_STR->pack_value( $self, [ map { $_->name } @fields ] );
  4         11  
395 2         5 TYPE_LIST_STR->pack_value( $self, [ map { $_->type->sig } @fields ] );
  4         11  
396              
397 2         7 $_stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ];
398             }
399              
400             method unpackmeta_struct
401 2     2 0 4 {
402 2         5 my $name = $self->unpack_str();
403 2         40 my $structid = $self->unpack_int();
404 2         8 my $names = TYPE_LIST_STR->unpack_value( $self );
405 2         5 my $types = TYPE_LIST_STR->unpack_value( $self );
406              
407 2         9 my $struct = Tangence::Struct->make( name => $name );
408 2 50       7 if( !$struct->defined ) {
409             $struct->define(
410             fields => [
411 0         0 map { $names->[$_] => $types->[$_] } 0 .. $#$names
  0         0  
412             ]
413             );
414             }
415              
416 2         9 $_stream->peer_hasstruct->{$struct->perlname} = [ $struct, $structid ];
417 2         7 $_stream->message_state->{id2struct}{$structid} = $struct;
418             }
419              
420 21         30 method pack_all_sametype ( $type, @d )
  21         30  
  21         31  
  21         29  
421 21     21 0 43 {
422 21         91 $type->pack_value( $self, $_ ) for @d;
423              
424 21         60 return $self;
425             }
426              
427 21         35 method unpack_all_sametype ( $type )
  21         30  
  21         30  
428 21     21 0 68 {
429 21         32 my @data;
430 21         82 push @data, $type->unpack_value( $self ) while length $_payload;
431              
432 21         109 return @data;
433             }
434              
435             =head1 AUTHOR
436              
437             Paul Evans
438              
439             =cut
440              
441             0x55AA;