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; |