File Coverage

blib/lib/Google/ProtocolBuffers/CodecIV64.pm
Criterion Covered Total %
statement 68 68 100.0
branch 24 24 100.0
condition n/a
subroutine 17 17 100.0
pod 0 8 0.0
total 109 117 93.1


line stmt bran cond sub pod time code
1             ##
2             ## Warning, despite name of the file, subrotines from here belongs
3             ## to Google::ProtocolBuffers::Codec namespace
4             ##
5             package Google::ProtocolBuffers::Codec;
6 14     14   45 use strict;
  14         13  
  14         412  
7            
8 14     14   38 use warnings;
  14         13  
  14         277  
9 14     14   36 no warnings 'numeric';
  14         11  
  14         349  
10 14     14   34 use warnings FATAL => 'substr';
  14         12  
  14         295  
11 14     14   11804 use Math::BigInt;
  14         214405  
  14         92  
12            
13 14     14   133657 no warnings 'portable';
  14         17  
  14         450  
14 14     14   48 use constant MAX_UINT64 => 0xFFFF_FFFF_FFFF_FFFF;
  14         13  
  14         608  
15 14     14   46 use constant MAX_SINT64 => 0x7FFF_FFFF_FFFF_FFFF;
  14         19  
  14         522  
16 14     14   49 use constant MIN_SINT64 =>-0x8000_0000_0000_0000;
  14         13  
  14         6382  
17            
18             ## Signature of all encode_* subs:
19             ## encode_*($buffer, $value);
20             ## Encoded value of $value will be appended to $buffer, which is a string
21             ## passed by reference. No meaningfull value is returned, in case of errors
22             ## an exception it thrown.
23             ##
24             ## Signature of all encode_* subs:
25             ## my $value = decode_*($buffer, $position);
26             ## $buffer is a string passed by reference, no copy is performed and it
27             ## is not modified. $position is a number variable passed by reference
28             ## (index in the string $buffer where to start decoding of a value), it
29             ## is incremented by decode_* subs. In case of errors an exception is
30             ## thrown.
31            
32             sub decode_varint {
33 712     712 0 495 my $v = 0;
34 712         514 my $shift = 0;
35 712         479 my $l = length($_[0]);
36 712         500 while (1) {
37 1241 100       5201 die BROKEN_MESSAGE() if $_[1] >= $l;
38 1223         1052 my $b = ord(substr($_[0], $_[1]++, 1));
39 1223         924 $v += (($b & 0x7F) << $shift);
40 1223         676 $shift += 7;
41 1223 100       1555 last if ($b & 0x80)==0;
42 531 100       1086 die if $shift > 63;
43             }
44 692         808 return $v;
45             }
46            
47             ##
48             ## Both signed and unsigned 32/64 ints are encoded by this sub.
49             ## Must it be more restrictive and don't allow negative values for uint types?
50             ## Moreover, should we check that the number is an integer and not a float,
51             ## for example? And truncate int32 types to 32 bits?
52             ##
53             sub encode_int {
54 108 100   108 0 151 if ($_[1]>=0) {
55 93         599 encode_varint($_[0], $_[1]);
56             } else {
57             ## We need a positive 64 bit integer, which bit representation is
58             ## the same as of this negative value, static_cast(int64).
59             ## unpack('Q', pack('q', $_[1])) is slightly slower than
60             ## 2^64 + $v === (2^64-1) + $v + 1, for $v<0
61 15         122 encode_varint($_[0], (MAX_UINT64+$_[1])+1);
62             }
63             }
64            
65             sub decode_int {
66 115     115 0 127 my $v = decode_varint(@_);
67 107 100       149 if ($v>MAX_SINT64()) {
68 18         40 return ($v-MAX_UINT64())-1;
69             } else {
70 89         153 return $v;
71             }
72             }
73            
74             ##
75             ## $_[1]<<1 is subject to overflow: a value that fit into
76             ## Perl's int (IV) may need unsigned int (UV) to fit,
77             ## and I don't know how to make Perl do that cast.
78             ##
79             sub encode_sint {
80 30 100   30 0 93 if ($_[1]>=MAX_SINT64()) {
    100          
    100          
81 2         101 encode_varint($_[0], Math::BigInt->new($_[1])<<1);
82             } elsif ($_[1]<=MIN_SINT64) {
83 2         127 encode_varint($_[0], ((-Math::BigInt->new($_[1]))<<1)-1);
84             } elsif ($_[1]>=0) {
85 20         251 encode_varint($_[0], $_[1]<<1);
86             } else {
87 6         15 encode_varint($_[0], ((-$_[1])<<1)-1);
88             }
89             }
90            
91             sub encode_fixed64 {
92 15     15 0 44 $_[0] .= pack('V', $_[1] & 0xFFFF_FFFF);
93 15         744 $_[0] .= pack('V', $_[1] >> 32);
94             }
95            
96             sub decode_fixed64 {
97 18 100   18 0 227 die BROKEN_MESSAGE() if $_[1]+8 > length($_[0]);
98 17         41 my $a = unpack('V', substr($_[0], $_[1], 4));
99 17         27 my $b = unpack('V', substr($_[0], $_[1]+4, 4));
100 17         16 $_[1] += 8;
101 17         30 return $a | ($b<<32);
102             }
103            
104             sub encode_sfixed64 {
105 16 100   16 0 39 my $v = ($_[1]<0) ? (MAX_UINT64()+$_[1])+1 : $_[1];
106 16         560 $_[0] .= pack('V', $v & 0xFFFF_FFFF);
107 16         657 $_[0] .= pack('V', $v >> 32);
108             }
109            
110             sub decode_sfixed64 {
111 19 100   19 0 232 die BROKEN_MESSAGE() if $_[1]+8 > length($_[0]);
112 18         37 my $a = unpack('V', substr($_[0], $_[1], 4));
113 18         23 my $b = unpack('V', substr($_[0], $_[1]+4, 4));
114 18         17 $_[1] += 8;
115 18         19 $a |= $b<<32;
116 18 100       30 if ($a>MAX_SINT64()) {
117 4         11 return ($a-MAX_UINT64())-1;
118             } else {
119 14         24 return $a;
120             }
121             }
122            
123            
124            
125             1;