File Coverage

blib/lib/Tangence/Type.pm
Criterion Covered Total %
statement 391 413 94.6
branch 139 166 83.7
condition 25 42 59.5
subroutine 67 72 93.0
pod 1 1 100.0
total 623 694 89.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, 2013-2022 -- leonerd@leonerd.org.uk
5              
6 14     14   163 use v5.26;
  14         47  
7 14     14   629 use Object::Pad 0.57;
  14         8953  
  14         69  
8              
9             package Tangence::Type 0.30;
10 14     14   7606 class Tangence::Type :isa(Tangence::Meta::Type);
  14         36  
  14         444  
11              
12             =head1 NAME
13              
14             C - represent a C value type
15              
16             =head1 DESCRIPTION
17              
18             Objects in this class represent individual types that are sent over the wire
19             in L messages. This is a subclass of L which
20             provides additional methods that may be useful in server or client
21             implementations.
22              
23             =cut
24              
25             =head1 CONSTRUCTOR
26              
27             =head2 make
28              
29             $type = Tangence::Type->make( $primitive_sig )
30              
31             Returns an instance to represent a primitive type of the given signature.
32              
33             $type = Tangence::Type->make( list => $member_type )
34              
35             $type = Tangence::Type->make( dict => $member_type )
36              
37             Returns an instance to represent a list or dict aggregation containing members
38             of the given type.
39              
40             =cut
41              
42             sub make
43             {
44             # Subtle trickery is at work here
45             # Invoke our own superclass constructor, but pretend to be some higher
46             # subclass that's appropriate
47              
48 1015     1015 1 1539 shift;
49 1015 100       2394 if( @_ == 1 ) {
    100          
    50          
50 796         1497 my ( $type ) = @_;
51 796         1640 my $class = "Tangence::Type::Primitive::$type";
52 796 50       5800 $class->can( "make" ) or die "TODO: Need $class";
53              
54 796         2307 return $class->SUPER::make( $type );
55             }
56             elsif( $_[0] eq "list" ) {
57 140         217 shift;
58 140         501 return Tangence::Type::List->SUPER::make( list => @_ );
59             }
60             elsif( $_[0] eq "dict" ) {
61 79         127 shift;
62 79         271 return Tangence::Type::Dict->SUPER::make( dict => @_ );
63             }
64             else {
65 0         0 die "TODO: Not sure how to make a Tangence::Type->make( @_ )";
66             }
67             }
68              
69             =head1 METHODS
70              
71             =head2 default_value
72              
73             $value = $type->default_value
74              
75             Returns a value suitable to use as an initial value for object properties.
76              
77             =head2 pack_value
78              
79             $type->pack_value( $message, $value )
80              
81             Appends a value of this type to the end of a L.
82              
83             =head2 unpack_value
84              
85             $value = $type->unpack_value( $message )
86              
87             Removes a value of this type from the start of a L.
88              
89             =cut
90              
91             class Tangence::Type::List :isa(Tangence::Type)
92             {
93 14     14   8815 use Carp;
  14         35  
  14         927  
94 14     14   106 use Tangence::Constants;
  14         34  
  14         10598  
95              
96 13     13   36 method default_value { [] }
  13         42  
97              
98 129         172 method pack_value ( $message, $value )
  129         178  
  129         166  
  129         194  
99 129     129   243 {
100 129 100       413 ref $value eq "ARRAY" or croak "Cannot pack a list from non-ARRAY reference";
101              
102 128         384 $message->_pack_leader( DATA_LIST, scalar @$value );
103              
104 128         346 my $member_type = $self->member_type;
105 128         406 $member_type->pack_value( $message, $_ ) for @$value;
106             }
107              
108 129         186 method unpack_value ( $message )
  129         179  
  129         161  
109 129     129   232 {
110 129         321 my ( $type, $num ) = $message->_unpack_leader();
111 129 100       386 $type == DATA_LIST or croak "Expected to unpack a list but did not find one";
112              
113 128         384 my $member_type = $self->member_type;
114 128         201 my @values;
115 128         323 foreach ( 1 .. $num ) {
116 171         998 push @values, $member_type->unpack_value( $message );
117             }
118              
119 126         1474 return \@values;
120             }
121             }
122              
123             class Tangence::Type::Dict :isa(Tangence::Type)
124             {
125 14     14   1714 use Carp;
  14         28  
  14         795  
126 14     14   96 use Tangence::Constants;
  14         27  
  14         11666  
127              
128 0     0   0 method default_value { {} }
  0         0  
129              
130 71         112 method pack_value ( $message, $value )
  71         348  
  71         105  
  71         96  
131 71     71   504 {
132 71 100       1226 ref $value eq "HASH" or croak "Cannot pack a dict from non-HASH reference";
133              
134 70         241 my @keys = keys %$value;
135 70 100       847 @keys = sort @keys if $Tangence::Message::SORT_HASH_KEYS;
136              
137 70         229 $message->_pack_leader( DATA_DICT, scalar @keys );
138              
139 70         239 my $member_type = $self->member_type;
140 70         245 $message->pack_str( $_ ), $member_type->pack_value( $message, $value->{$_} ) for @keys;
141             }
142              
143 71         125 method unpack_value ( $message )
  71         105  
  71         93  
144 71     71   132 {
145 71         164 my ( $type, $num ) = $message->_unpack_leader();
146 71 100       277 $type == DATA_DICT or croak "Expected to unpack a dict but did not find one";
147              
148 70         186 my $member_type = $self->member_type;
149 70         123 my %values;
150 70         181 foreach ( 1 .. $num ) {
151 153         370 my $key = $message->unpack_str();
152 152         2738 $values{$key} = $member_type->unpack_value( $message );
153             }
154              
155 69         271 return \%values;
156             }
157             }
158              
159             class Tangence::Type::Primitive::bool :isa(Tangence::Type)
160             {
161 14     14   1604 use Carp;
  14         34  
  14         862  
162 14     14   94 use Tangence::Constants;
  14         28  
  14         8894  
163              
164 0     0   0 method default_value { "" }
  0         0  
165              
166 101         146 method pack_value ( $message, $value )
  101         153  
  101         134  
  101         126  
167 101     101   195 {
168 101 100       282 $message->_pack_leader( DATA_NUMBER, $value ? DATANUM_BOOLTRUE : DATANUM_BOOLFALSE );
169             }
170              
171 102         136 method unpack_value ( $message )
  102         145  
  102         124  
172 102     102   191 {
173 102         212 my ( $type, $num ) = $message->_unpack_leader();
174              
175 102 100       581 $type == DATA_NUMBER or croak "Expected to unpack a number(bool) but did not find one";
176 100 100       323 $num == DATANUM_BOOLFALSE and return !!0;
177 29 50       141 $num == DATANUM_BOOLTRUE and return !!1;
178 0         0 croak "Expected to find a DATANUM_BOOL subtype but got $num";
179             }
180             }
181              
182             class Tangence::Type::Primitive::_integral :isa(Tangence::Type)
183             {
184 14     14   1637 use Carp;
  14         29  
  14         848  
185 14     14   107 use Tangence::Constants;
  14         42  
  14         2988  
186              
187 14     14   107 use constant SUBTYPE => undef;
  14         36  
  14         14284  
188              
189 14     14   58 method default_value { 0 }
  14         47  
190              
191             my %format = (
192             DATANUM_UINT8, [ "C", 1 ],
193             DATANUM_SINT8, [ "c", 1 ],
194             DATANUM_UINT16, [ "S>", 2 ],
195             DATANUM_SINT16, [ "s>", 2 ],
196             DATANUM_UINT32, [ "L>", 4 ],
197             DATANUM_SINT32, [ "l>", 4 ],
198             DATANUM_UINT64, [ "Q>", 8 ],
199             DATANUM_SINT64, [ "q>", 8 ],
200             );
201              
202             sub _best_int_type_for ( $n )
203 667     667   811 {
  667         884  
  667         810  
204 667 100       1217 if( $n < 0 ) {
205 5 100       22 return DATANUM_SINT8 if $n >= -0x80;
206 2 50       7 return DATANUM_SINT16 if $n >= -0x8000;
207 2 50       10 return DATANUM_SINT32 if $n >= -0x80000000;
208 0         0 return DATANUM_SINT64;
209             }
210              
211 662 100       2108 return DATANUM_UINT8 if $n <= 0xff;
212 17 100       71 return DATANUM_UINT16 if $n <= 0xffff;
213 3 50       16 return DATANUM_UINT32 if $n <= 0xffffffff;
214 0         0 return DATANUM_UINT64;
215             }
216              
217 723         928 method pack_value ( $message, $value )
  723         910  
  723         944  
  723         857  
218 723     723   1282 {
219 723 100       1461 defined $value or croak "cannot pack_int(undef)";
220 722 100       1562 ref $value and croak "$value is not a number";
221 720 100       1481 $value == $value or croak "cannot pack_int(NaN)";
222 718 100 66     2632 $value == "+Inf" || $value == "-Inf" and croak "cannot pack_int(Inf)";
223              
224 716   66     2138 my $subtype = $self->SUBTYPE || _best_int_type_for( $value );
225 716         1979 $message->_pack_leader( DATA_NUMBER, $subtype );
226              
227 716         2308 $message->_pack( pack( $format{$subtype}[0], $value ) );
228             }
229              
230 724         913 method unpack_value ( $message )
  724         943  
  724         851  
231 724     724   1347 {
232 724         1476 my ( $type, $num ) = $message->_unpack_leader();
233              
234 724 100       1964 $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one";
235 719 50       1455 exists $format{$num} or croak "Expected an integer subtype but got $num";
236              
237 719 100       1860 if( my $subtype = $self->SUBTYPE ) {
238 51 50       131 $subtype == $num or croak "Expected integer subtype $subtype, got $num";
239             }
240              
241 719         1804 my ( $n ) = unpack( $format{$num}[0], $message->_unpack( $format{$num}[1] ) );
242              
243 719         2126 return $n;
244             }
245             }
246              
247             class Tangence::Type::Primitive::u8 :isa(Tangence::Type::Primitive::_integral)
248             {
249 14     14   1728 use constant SUBTYPE => Tangence::Constants::DATANUM_UINT8;
  14         33  
  14         2244  
250             }
251              
252             class Tangence::Type::Primitive::s8 :isa(Tangence::Type::Primitive::_integral)
253             {
254 14     14   1941 use constant SUBTYPE => Tangence::Constants::DATANUM_SINT8;
  14         28  
  14         2049  
255             }
256              
257             class Tangence::Type::Primitive::u16 :isa(Tangence::Type::Primitive::_integral)
258             {
259 14     14   2015 use constant SUBTYPE => Tangence::Constants::DATANUM_UINT16;
  14         38  
  14         2173  
260             }
261              
262             class Tangence::Type::Primitive::s16 :isa(Tangence::Type::Primitive::_integral)
263             {
264 14     14   1900 use constant SUBTYPE => Tangence::Constants::DATANUM_SINT16;
  14         40  
  14         1916  
265             }
266              
267             class Tangence::Type::Primitive::u32 :isa(Tangence::Type::Primitive::_integral)
268             {
269 14     14   1933 use constant SUBTYPE => Tangence::Constants::DATANUM_UINT32;
  14         43  
  14         2427  
270             }
271              
272             class Tangence::Type::Primitive::s32 :isa(Tangence::Type::Primitive::_integral)
273             {
274 14     14   1884 use constant SUBTYPE => Tangence::Constants::DATANUM_SINT32;
  14         35  
  14         2008  
275             }
276              
277             class Tangence::Type::Primitive::u64 :isa(Tangence::Type::Primitive::_integral)
278             {
279 14     14   1923 use constant SUBTYPE => Tangence::Constants::DATANUM_UINT64;
  14         45  
  14         1951  
280             }
281              
282             class Tangence::Type::Primitive::s64 :isa(Tangence::Type::Primitive::_integral)
283             {
284 14     14   1910 use constant SUBTYPE => Tangence::Constants::DATANUM_SINT64;
  14         27  
  14         1895  
285             }
286              
287             class Tangence::Type::Primitive::int :isa(Tangence::Type::Primitive::_integral)
288             {
289             # empty
290             }
291              
292             class Tangence::Type::Primitive::float :isa(Tangence::Type)
293             {
294 14     14   4466 use Carp;
  14         29  
  14         1010  
295 14     14   100 use Tangence::Constants;
  14         36  
  14         3317  
296              
297             my $TYPE_FLOAT16 = Tangence::Type->make( 'float16' );
298              
299 14     14   101 use constant SUBTYPE => undef;
  14         27  
  14         15738  
300              
301 0     0   0 method default_value { 0.0 }
  0         0  
302              
303             my %format = (
304             # pack, bytes, NaN
305             DATANUM_FLOAT32, [ "f>", 4, "\x7f\xc0\x00\x00" ],
306             DATANUM_FLOAT64, [ "d>", 8, "\x7f\xf8\x00\x00\x00\x00\x00\x00" ],
307             );
308              
309             sub _best_type_for ( $value )
310 7     7   13 {
  7         10  
  7         9  
311             # Unpack as 64bit float and see if it's within limits
312 7         25 my $float64BIN = pack "d>", $value;
313              
314             # float64 == 1 / 11 / 52
315 7         27 my $exp64 = ( unpack "L>", $float64BIN & "\x7f\xf0\x00\x00" ) >> (52-32);
316              
317             # Zero is smallest
318 7 50       20 return DATANUM_FLOAT16 if $exp64 == 0;
319              
320             # De-bias
321 7         11 $exp64 -= 1023;
322              
323             # Special values might as well be float16
324 7 100       17 return DATANUM_FLOAT16 if $exp64 == 1024;
325              
326             # Smaller types are OK if the exponent will fit and there's no loss of
327             # mantissa precision
328              
329 5 100 100     28 return DATANUM_FLOAT16 if abs($exp64) < 15 &&
330             ($float64BIN & "\x00\x00\x03\xff\xff\xff\xff\xff") eq "\x00"x8;
331              
332 3 100 66     20 return DATANUM_FLOAT32 if abs($exp64) < 127 &&
333             ($float64BIN & "\x00\x00\x00\x00\x1f\xff\xff\xff") eq "\x00"x8;
334              
335 2         8 return DATANUM_FLOAT64;
336             }
337              
338 15         22 method pack_value ( $message, $value )
  15         22  
  15         22  
  15         19  
339 15     15   77 {
340 15 50       36 defined $value or croak "cannot pack undef as float";
341 15 50       33 ref $value and croak "$value is not a number";
342              
343 15   66     64 my $subtype = $self->SUBTYPE || _best_type_for( $value );
344              
345 15 100       40 return $TYPE_FLOAT16->pack_value( $message, $value ) if $subtype == DATANUM_FLOAT16;
346              
347 11         34 $message->_pack_leader( DATA_NUMBER, $subtype );
348             $message->_pack( $value == $value ?
349 11 100       64 pack( $format{$subtype}[0], $value ) : $format{$subtype}[2]
350             );
351             }
352              
353 15         23 method unpack_value ( $message )
  15         21  
  15         17  
354 15     15   45 {
355 15         44 my ( $type, $num ) = $message->_unpack_leader( "peek" );
356              
357 15 50       34 $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one";
358 15 50 66     52 exists $format{$num} or $num == DATANUM_FLOAT16 or
359             croak "Expected a float subtype but got $num";
360              
361 15 100       47 if( my $subtype = $self->SUBTYPE ) {
362 8 50       16 $subtype == $num or croak "Expected float subtype $subtype, got $num";
363             }
364              
365 15 100       37 return $TYPE_FLOAT16->unpack_value( $message ) if $num == DATANUM_FLOAT16;
366              
367 11         26 $message->_unpack_leader; # no-peek
368              
369 11         34 my ( $n ) = unpack( $format{$num}[0], $message->_unpack( $format{$num}[1] ) );
370              
371 11         29 return $n;
372             }
373             }
374              
375             class Tangence::Type::Primitive::float16 :isa(Tangence::Type::Primitive::float)
376             {
377 14     14   1668 use Carp;
  14         31  
  14         891  
378 14     14   116 use Tangence::Constants;
  14         29  
  14         2875  
379              
380 14     14   92 use constant SUBTYPE => DATANUM_FLOAT16;
  14         46  
  14         13811  
381              
382             # TODO: This code doesn't correctly cope with Inf, -Inf or NaN
383              
384 10         14 method pack_value ( $message, $value )
  10         13  
  10         29  
  10         14  
385 10     10   38 {
386 10 50       24 defined $value or croak "cannot pack undef as float";
387 10 50       22 ref $value and croak "$value is not a number";
388              
389 10         39 my $float32 = unpack( "N", pack "f>", $value );
390              
391             # float32 == 1 / 8 / 23
392 10         21 my $sign = ( $float32 & 0x80000000 ) >> 31;
393 10         18 my $exp = ( ( $float32 & 0x7f800000 ) >> 23 ) - 127;
394 10         16 my $mant32 = ( $float32 & 0x007fffff );
395              
396             # float16 == 1 / 5 / 10
397 10         12 my $mant16;
398              
399 10 100       28 if( $exp == 128 ) {
    100          
    100          
400             # special value - Inf or NaN
401 4         7 $exp = 16;
402 4 100       9 $mant16 = $mant32 ? (1 << 9) : 0;
403 4 100       14 $sign = 0 if $mant16;
404             }
405             elsif( $exp > 15 ) {
406             # Too large - become Inf
407 1         2 $exp = 16;
408 1         4 $mant16 = 0;
409             }
410             elsif( $exp > -15 ) {
411 3         6 $mant16 = $mant32 >> 13;
412             }
413             else {
414             # zero or subnormal - become zero
415 2         4 $exp = -15;
416 2         4 $mant16 = 0;
417             }
418              
419 10         22 my $float16 = $sign << 15 |
420             ( $exp + 15 ) << 10 |
421             $mant16;
422              
423 10         28 $message->_pack_leader( DATA_NUMBER, DATANUM_FLOAT16 );
424 10         33 $message->_pack( pack "n", $float16 );
425             }
426              
427 10         15 method unpack_value ( $message )
  10         12  
  10         17  
428 10     10   26 {
429 10         26 my ( $type, $num ) = $message->_unpack_leader;
430              
431 10 50       31 $type == DATA_NUMBER or croak "Expected to unpack a number but did not find one";
432 10 50       19 $num == DATANUM_FLOAT16 or croak "Expected to unpack a float16 but found $num";
433              
434 10         29 my $float16 = unpack "n", $message->_unpack( 2 );
435              
436             # float16 == 1 / 5 / 10
437 10         22 my $sign = ( $float16 & 0x8000 ) >> 15;
438 10         25 my $exp = ( ( $float16 & 0x7c00 ) >> 10 ) - 15;
439 10         17 my $mant16 = ( $float16 & 0x03ff );
440              
441             # float32 == 1 / 8 / 23
442 10         11 my $mant32;
443              
444 10 100       26 if( $exp == 16 ) {
    100          
445             # special value - Inf or NaN
446 5         8 $exp = 128;
447 5 100       12 $mant32 = $mant16 ? (1 << 22) : 0;
448             }
449             elsif( $exp > -15 ) {
450 3         10 $mant32 = $mant16 << 13;
451             }
452             else {
453             # zero
454 2         4 $exp = -127;
455 2         4 $mant32 = 0;
456             }
457              
458 10         22 my $float32 = $sign << 31 |
459             ( $exp + 127 ) << 23 |
460             $mant32;
461              
462 10         45 return unpack( "f>", pack "N", $float32 );
463             }
464             }
465              
466             class Tangence::Type::Primitive::float32 :isa(Tangence::Type::Primitive::float)
467             {
468 14     14   1640 use Tangence::Constants;
  14         33  
  14         2841  
469              
470 14     14   98 use constant SUBTYPE => DATANUM_FLOAT32;
  14         34  
  14         2079  
471             }
472              
473             class Tangence::Type::Primitive::float64 :isa(Tangence::Type::Primitive::float)
474             {
475 14     14   1822 use Tangence::Constants;
  14         37  
  14         3053  
476              
477 14     14   134 use constant SUBTYPE => DATANUM_FLOAT64;
  14         37  
  14         2104  
478             }
479              
480             class Tangence::Type::Primitive::str :isa(Tangence::Type)
481             {
482 14     14   1928 use Carp;
  14         98  
  14         1022  
483 14     14   8432 use Encode qw( encode_utf8 decode_utf8 );
  14         151723  
  14         1173  
484 14     14   104 use Tangence::Constants;
  14         35  
  14         9514  
485              
486 1     1   3 method default_value { "" }
  1         2  
487              
488 532         759 method pack_value ( $message, $value )
  532         682  
  532         699  
  532         631  
489 532     532   909 {
490 532 100       1130 defined $value or croak "cannot pack_str(undef)";
491 531 100       1491 ref $value and croak "$value is not a string";
492 527         1099 my $octets = encode_utf8( $value );
493 527         4701 $message->_pack_leader( DATA_STRING, length($octets) );
494 527         1114 $message->_pack( $octets );
495             }
496              
497 530         659 method unpack_value ( $message )
  530         681  
  530         668  
498 530     530   896 {
499 530         1082 my ( $type, $num ) = $message->_unpack_leader();
500              
501 530 100       1653 $type == DATA_STRING or croak "Expected to unpack a string but did not find one";
502 525         1100 my $octets = $message->_unpack( $num );
503 525         1256 return decode_utf8( $octets );
504             }
505             }
506              
507             class Tangence::Type::Primitive::obj :isa(Tangence::Type)
508             {
509 14     14   1971 use Carp;
  14         34  
  14         984  
510 14     14   93 use Scalar::Util qw( blessed );
  14         35  
  14         837  
511 14     14   123 use Tangence::Constants;
  14         29  
  14         15881  
512              
513 0     0   0 method default_value { undef }
  0         0  
514              
515 61         79 method pack_value ( $message, $value )
  61         83  
  61         82  
  61         70  
516 61     61   129 {
517 61         140 my $stream = $message->stream;
518              
519 61 100 66     368 if( !defined $value ) {
    100 33        
    50          
520 38         67 $message->_pack_leader( DATA_OBJECT, 0 );
521             }
522             elsif( blessed $value and $value->isa( "Tangence::Object" ) ) {
523 21         151 my $id = $value->id;
524 21         59 my $preamble = "";
525              
526 21 50       64 $value->{destroyed} and croak "Cannot pack destroyed object $value";
527              
528 21 100       112 $message->packmeta_construct( $value ) unless $stream->peer_hasobj->{$id};
529              
530 21         92 $message->_pack_leader( DATA_OBJECT, 4 );
531 21         117 $message->_pack( pack( "N", $id ) );
532             }
533             elsif( blessed $value and $value->isa( "Tangence::ObjectProxy" ) ) {
534 2         12 $message->_pack_leader( DATA_OBJECT, 4 );
535 2         11 $message->_pack( pack( "N", $value->id ) );
536             }
537             else {
538 0         0 croak "Do not know how to pack a " . ref($value);
539             }
540             }
541              
542 61         89 method unpack_value ( $message )
  61         84  
  61         92  
543 61     61   103 {
544 61         129 my ( $type, $num ) = $message->_unpack_leader();
545              
546 61         155 my $stream = $message->stream;
547              
548 61 50       140 $type == DATA_OBJECT or croak "Expected to unpack an object but did not find one";
549 61 100       158 return undef unless $num;
550 23 50       104 if( $num == 4 ) {
551 23         77 my ( $id ) = unpack( "N", $message->_unpack( 4 ) );
552 23         138 return $stream->get_by_id( $id );
553             }
554             else {
555 0         0 croak "Unexpected number of bits to encode an OBJECT";
556             }
557             }
558             }
559              
560             class Tangence::Type::Primitive::any :isa(Tangence::Type)
561             {
562 14     14   1629 use Carp;
  14         31  
  14         835  
563 14     14   129 use Scalar::Util qw( blessed );
  14         30  
  14         717  
564 14     14   87 use Tangence::Constants;
  14         45  
  14         2598  
565              
566 14     14   623 use Syntax::Keyword::Match;
  14         862  
  14         143  
567              
568 14     14   11169 no if $] >= 5.035008, warnings => "experimental::builtin";
  14         209  
  14         106  
569 14     14   860 use constant HAVE_IS_BOOL => defined &builtin::is_bool;
  14         36  
  14         5559  
570              
571             my $TYPE_BOOL = Tangence::Type->make( 'bool' );
572             my $TYPE_INT = Tangence::Type->make( 'int' );
573             my $TYPE_FLOAT = Tangence::Type->make( 'float' );
574             my $TYPE_STR = Tangence::Type->make( 'str' );
575             my $TYPE_OBJ = Tangence::Type->make( 'obj' );
576             my $TYPE_ANY = Tangence::Type->make( 'any' );
577              
578             my $TYPE_LIST_ANY = Tangence::Type->make( list => $TYPE_ANY );
579             my $TYPE_DICT_ANY = Tangence::Type->make( dict => $TYPE_ANY );
580              
581 0     0   0 method default_value { undef }
  0         0  
582              
583 208         269 method pack_value ( $message, $value )
  208         272  
  208         284  
  208         244  
584 208     208   400 {
585 208 100 33     1747 if( !defined $value ) {
    100 66        
    50          
    100          
    100          
    50          
586 38         56 $TYPE_OBJ->pack_value( $message, undef );
587             }
588             elsif( !ref $value ) {
589 14     14   114 no warnings 'numeric';
  14         27  
  14         21129  
590              
591 20         34 my $is_numeric = do {
592 20         35 my $tmp = $value;
593              
594             # use X^X operator to distinguish actual numbers from strings
595             # If $tmp contains any non-ASCII bytes the it's definitely not a
596             # decimal representation of a number
597 20 100       224 $tmp =~ m/^[[:ascii:]]+$/ and ( $value ^ $value ) eq "0"
598             };
599              
600 20 100 66     174 if( HAVE_IS_BOOL && builtin::is_bool($value) ) {
    100          
601             $TYPE_BOOL->pack_value( $message, $value );
602             }
603             # test for integers, but exclude NaN
604 0 100       0 elsif( int($value) eq $value and $value == $value ) {
605 1         4 $TYPE_INT->pack_value( $message, $value );
606             }
607             elsif( $message->stream->_ver_can_num_float and $is_numeric ) {
608 2         16 $TYPE_FLOAT->pack_value( $message, $value );
609             }
610             else {
611 17         109 $TYPE_STR->pack_value( $message, $value );
612             }
613             }
614             elsif( blessed $value and $value->isa( "Tangence::Object" ) || $value->isa( "Tangence::ObjectProxy" ) ) {
615 0         0 $TYPE_OBJ->pack_value( $message, $value );
616             }
617 150         479 elsif( my $struct = eval { Tangence::Struct->for_perlname( ref $value ) } ) {
618 140         403 $message->pack_record( $value, $struct );
619             }
620             elsif( ref $value eq "ARRAY" ) {
621 5         23 $TYPE_LIST_ANY->pack_value( $message, $value );
622             }
623             elsif( ref $value eq "HASH" ) {
624 5         21 $TYPE_DICT_ANY->pack_value( $message, $value );
625             }
626             else {
627 0         0 croak "Do not know how to pack a " . ref($value);
628             }
629             }
630              
631 208         267 method unpack_value ( $message )
  208         269  
  208         250  
632 208     208   419 {
633 208         421 my $type = $message->_peek_leader_type();
634              
635             match( $type : == ) {
636             case( DATA_NUMBER ) {
637 3         8 my ( undef, $num ) = $message->_unpack_leader( "peek" );
638 3 50 33     30 if( $num >= DATANUM_BOOLFALSE and $num <= DATANUM_BOOLTRUE ) {
    100 66        
    50 33        
639 0         0 return $TYPE_BOOL->unpack_value( $message );
640             }
641             elsif( $num >= DATANUM_UINT8 and $num <= DATANUM_SINT64 ) {
642 1         4 return $TYPE_INT->unpack_value( $message );
643             }
644             elsif( $num >= DATANUM_FLOAT16 and $num <= DATANUM_FLOAT64 ) {
645 2         8 return $TYPE_FLOAT->unpack_value( $message );
646             }
647             else {
648 0         0 croak "Do not know how to unpack DATA_NUMBER subtype $num";
649             }
650             }
651             case( DATA_STRING ) {
652 17         64 return $TYPE_STR->unpack_value( $message );
653             }
654             case( DATA_OBJECT ) {
655 38         68 return $TYPE_OBJ->unpack_value( $message );
656             }
657             case( DATA_LIST ) {
658 5         18 return $TYPE_LIST_ANY->unpack_value( $message );
659             }
660             case( DATA_DICT ) {
661 5         18 return $TYPE_DICT_ANY->unpack_value( $message );
662             }
663             case( DATA_RECORD ) {
664 140         378 return $message->unpack_record( undef );
665             }
666 208 100       818 default {
    100          
    100          
    100          
    100          
    50          
667 0           croak "Do not know how to unpack record of type $type";
668             }
669             }
670             }
671             }
672              
673             =head1 AUTHOR
674              
675             Paul Evans
676              
677             =cut
678              
679             0x55AA;