File Coverage

blib/lib/Bifcode.pm
Criterion Covered Total %
statement 246 342 71.9
branch 112 140 80.0
condition 55 78 70.5
subroutine 57 57 100.0
pod 4 6 66.6
total 474 623 76.0


line stmt bran cond sub pod time code
1             package Bifcode;
2 7     7   20022 use 5.010;
  7         38  
3 7     7   50 use strict;
  4         5  
  4         68  
4 4     6   17 use warnings;
  7         22  
  7         95  
5 7     6   702 use boolean ();
  4         5771  
  4         115  
6 6         22 use Exporter::Tidy all => [
7             qw( encode_bifcode
8             decode_bifcode
9             force_bifcode
10             diff_bifcode)
11 4     6   3982 ];
  6         62  
12              
13             # ABSTRACT: Serialisation similar to Bencode + undef/UTF8
14              
15             our $VERSION = '2.000_8';
16             our $max_depth;
17             our @CARP_NOT = (__PACKAGE__);
18              
19             sub _croak {
20 75     75   314 require Carp;
21 73   33     142 my $type = shift // Carp::croak('usage: _croak($TYPE, [$msg])');
22 73         854 my %messages = (
23             Decode => 'garbage at',
24             DecodeBifcodeTerm => 'missing BIFCODE terminator at',
25             DecodeBytes => 'malformed BYTES length at',
26             DecodeBytesTrunc => 'unexpected BYTES end of data at',
27             DecodeBytesTerm => 'missing BYTES termination at',
28             DecodeDepth => 'nesting depth exceeded at',
29             DecodeTrunc => 'unexpected end of data at',
30             DecodeReal => 'malformed REAL data at',
31             DecodeRealTrunc => 'unexpected REAL end of data at',
32             DecodeInteger => 'malformed INTEGER data at',
33             DecodeIntegerTrunc => 'unexpected INTEGER end of data at',
34             DecodeTrailing => 'trailing garbage at',
35             DecodeUTF8 => 'malformed UTF8 string length at',
36             DecodeUTF8Trunc => 'unexpected UTF8 end of data at',
37             DecodeUTF8Term => 'missing UTF8 termination at',
38             DecodeUsage => undef,
39             DiffUsage => 'usage: diff_bifcode($b1, $b2, [$diff_args])',
40             EncodeBytesUndef => 'Bifcode::BYTES ref is undefined',
41             EncodeReal => undef,
42             EncodeRealUndef => 'Bifcode::REAL ref is undefined',
43             EncodeInteger => undef,
44             EncodeIntegerUndef => 'Bifcode::INTEGER ref is undefined',
45             DecodeKeyType => 'dict key is not BYTES or UTF8 at',
46             DecodeKeyDuplicate => 'duplicate dict key at',
47             DecodeKeyOrder => 'dict key not in sort order at',
48             DecodeKeyValue => 'dict key is missing value at',
49             EncodeUTF8Undef => 'Bifcode::UTF8 ref is undefined',
50             EncodeUnhandled => undef,
51             EncodeUsage => 'usage: encode_bifcode($arg)',
52             ForceUsage => 'ref and type must be defined',
53             );
54              
55 73         127 my $err = 'Bifcode::Error::' . $type;
56 75   66     244 my $msg = shift // $messages{$type}
      33        
57             // Carp::croak("Bifcode::_croak($type) has no message ");
58 75         6106 my $short = Carp::shortmess('');
59              
60 75   100     463 $msg =~ s! at$!' at input byte '. ( pos() // 0 )!e;
  51         177  
61              
62 6     6   39 eval qq[
  4     2   7  
  4     1   42  
  0     1   0  
  3     1   5114  
  3     1   18  
  73     1   8144  
  1     1   2  
  1     1   7  
  0     1   0  
  0     1   0  
  0     1   0  
  1     1   5  
  1     1   2  
  1     1   18  
  0     1   0  
  0     1   0  
  0     1   0  
  1     1   5  
  1     1   2  
  1     1   8  
  0     1   0  
  0     1   0  
  0     1   0  
  1     1   5  
  1     1   1  
  1     1   7  
  0     1   0  
  0     1   0  
  0     1   0  
  1     1   6  
  1     1   1  
  1     1   6  
  0     1   0  
  0     1   0  
  0     1   0  
  1     1   6  
  1     1   2  
  1     1   6  
  0     1   0  
  0         0  
  0         0  
  1         6  
  1         1  
  1         7  
  0         0  
  0         0  
  0         0  
  1         5  
  1         2  
  1         19  
  0         0  
  0         0  
  0         0  
  1         5  
  1         2  
  1         6  
  0         0  
  0         0  
  0         0  
  1         5  
  1         2  
  1         7  
  0         0  
  0         0  
  0         0  
  1         6  
  1         1  
  1         13  
  0         0  
  0         0  
  0         0  
  1         6  
  1         1  
  1         7  
  0         0  
  0         0  
  0         0  
  1         6  
  1         1  
  1         8  
  0         0  
  0         0  
  0         0  
  1         5  
  1         1  
  1         7  
  0         0  
  0         0  
  0         0  
  1         5  
  1         2  
  1         6  
  0         0  
  0         0  
  0         0  
  1         6  
  1         1  
  1         15  
  0         0  
  0         0  
  0         0  
  1         6  
  1         1  
  1         7  
  0         0  
  0         0  
  0         0  
  1         6  
  1         2  
  1         6  
  0         0  
  0         0  
  0         0  
  1         5  
  1         1  
  1         7  
  0         0  
  0         0  
  0         0  
  1         6  
  1         1  
  1         7  
  0         0  
  0         0  
  0         0  
  1         6  
  1         1  
  1         7  
  0         0  
  0         0  
  0         0  
  1         6  
  1         2  
  1         6  
  0         0  
  0         0  
  0         0  
  1         5  
  1         2  
  1         7  
  0         0  
  0         0  
  0         0  
  1         5  
  1         2  
  1         7  
  0         0  
  0         0  
  0         0  
  1         5  
  1         2  
  1         7  
  0         0  
  0         0  
  0         0  
  1         6  
  1         2  
  1         6  
  0         0  
  0         0  
  0         0  
  1         5  
  1         2  
  1         6  
  0            
  0            
  0            
63             package $err;
64             use overload
65             bool => sub { 1 },
66             '""' => sub { \${ \$_[0] } . ' (' . ( ref \$_[0] ) . ')$short' },
67             fallback => 1;
68             1;
69             ];
70              
71 73 50       174 die $@ if $@;
72 75         686 die bless \$msg, $err;
73             }
74              
75             my $chunk = qr/ \G (?|
76             (~,)
77             | (f,)
78             | (t,)
79             | (B|b|u) (?: ( 0 | [1-9] [0-9]* ) \. )?
80             | (i) (?: ( 0 | -? [1-9] [0-9]* ) , )?
81             | (r) (?: ( 0 | -? [1-9] [0-9]* )
82             \. ( 0 | [0-9]* [1-9] )
83             e ( (?: 0 | -? [1-9] ) [0-9]* ) ,
84             )?
85             | (\[)
86             | (\{)
87             ) /x;
88              
89             sub _decode_bifcode_key {
90              
91 35 100   35   98 unless (m/ \G (b|u) (?: ( 0 | [1-9] [0-9]* ) \. )? /gcx) {
92 6 50       30 _croak m/ \G \z /xgc ? 'DecodeTrunc' : 'DecodeKeyType';
93             }
94              
95 29 100       82 if ( $1 eq 'b' ) {
    50          
96 1   33     4 my $len = $2 // _croak 'DecodeBytes';
97 1 50       3 _croak 'DecodeBytesTrunc' if $len > length() - pos();
98              
99 3         12 my $data = substr $_, pos(), $len;
100 3         7 pos() = pos() + $len;
101              
102 3 50       24 _croak 'DecodeBytesTerm' unless m/ \G : /xgc;
103 1         2 return $data;
104             }
105             elsif ( $1 eq 'u' ) {
106 28   33     50 my $len = $2 // _croak 'DecodeUTF8';
107 28 50       50 _croak 'DecodeUTF8Trunc' if $len > length() - pos();
108              
109 30         70 utf8::decode( my $str = substr $_, pos(), $len );
110 30         46 pos() = pos() + $len;
111              
112 30 50       77 _croak 'DecodeUTF8Term' unless m/ \G : /xgc;
113 28         46 return $str;
114             }
115             }
116              
117             sub _decode_bifcode_chunk {
118 151 100   153   185 local $max_depth = $max_depth - 1 if defined $max_depth;
119              
120 151 100       786 unless (m/$chunk/gc) {
121 7 100       29 _croak m/ \G \z /xgc ? 'DecodeTrunc' : 'Decode';
122             }
123              
124 148 100       634 if ( $1 eq '~,' ) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    0          
125 10         33 return undef;
126             }
127             elsif ( $1 eq 'f,' ) {
128 3         25 return boolean::false;
129             }
130             elsif ( $1 eq 't,' ) {
131 3         7 return boolean::true;
132             }
133             elsif ( $1 eq 'b' ) {
134 6   66     44 my $len = $2 // _croak 'DecodeBytes';
135 6 100       26 _croak 'DecodeBytesTrunc' if $len > length() - pos();
136              
137 5         9 my $data = substr $_, pos(), $len;
138 5         20 pos() = pos() + $len;
139              
140 3 100       12 _croak 'DecodeBytesTerm' unless m/ \G , /xgc;
141 2         7 return $data;
142             }
143             elsif ( $1 eq 'u' ) {
144 40   100     88 my $len = $2 // _croak 'DecodeUTF8';
145 36 100       72 _croak 'DecodeUTF8Trunc' if $len > length() - pos();
146              
147 34         69 utf8::decode( my $str = substr $_, pos(), $len );
148 34         61 pos() = pos() + $len;
149              
150 33 100       95 _croak 'DecodeUTF8Term' unless m/ \G , /xgc;
151 31         89 return $str;
152             }
153             elsif ( $1 eq 'i' ) {
154 20 100       55 return 0 + $2 if defined $2;
155 9 100       34 _croak 'DecodeIntegerTrunc' if m/ \G \z /xgc;
156 8         12 _croak 'DecodeInteger';
157             }
158             elsif ( $1 eq 'r' ) {
159 12 100       23 if ( !defined $2 ) {
160 8 100       19 _croak 'DecodeRealTrunc' if m/ \G \z /xgc;
161 7         10 _croak 'DecodeReal';
162             }
163 3 100 66     18 _croak 'DecodeReal'
      100        
164             if $2 eq '0' # mantissa 0.
165             and $3 eq '0' # mantissa 0.0
166             and $4 ne '0'; # sign or exponent 0.0e0
167              
168 3         19 return 0.0 + ( $2 . '.' . $3 . 'e' . $4 );
169             }
170             elsif ( $1 eq '[' ) {
171 27 100 100     65 _croak 'DecodeDepth' if defined $max_depth and $max_depth < 0;
172              
173 23         32 my @list;
174 22         40 until (m/ \G \] /xgc) {
175 35         59 push @list, _decode_bifcode_chunk();
176             }
177 16         64 return \@list;
178             }
179             elsif ( $1 eq '{' ) {
180 30 100 100     72 _croak 'DecodeDepth' if defined $max_depth and $max_depth < 0;
181              
182 27         28 my $last_key;
183             my %hash;
184 27         63 until (m/ \G \} /xgc) {
185 35 100       95 _croak 'DecodeTrunc' if m/ \G \z /xgc;
186              
187 33         40 my $key = _decode_bifcode_key();
188              
189 29 100       46 _croak 'DecodeKeyDuplicate' if exists $hash{$key};
190 29 100 100     66 _croak 'DecodeKeyOrder'
191             if defined $last_key and $key lt $last_key;
192 28 100       40 _croak 'DecodeKeyValue' if m/ \G \} /xgc;
193              
194 27         31 $last_key = $key;
195 26         28 $hash{$key} = _decode_bifcode_chunk();
196             }
197 13         27 return \%hash;
198             }
199             elsif ( $1 eq 'B' ) {
200 0   0     0 my $len = $2 // _croak 'DecodeBifcode';
201 1 0       7 _croak 'DecodeBifcodeTrunc' if $len > length() - pos();
202              
203 1         2 my $res = _decode_bifcode_chunk();
204 1 0       6 _croak 'DecodeBifcodeTerm' unless m/ \G , /xgc;
205              
206 0         0 return $res;
207             }
208             }
209              
210             sub decode_bifcode {
211 94     95 1 55737 local $_ = shift;
212 94         102 local $max_depth = shift;
213              
214 95 100       206 _croak 'DecodeUsage', 'decode_bifcode: too many arguments' if @_;
215 94 100       137 _croak 'DecodeUsage', 'decode_bifcode: input undefined'
216             unless defined $_;
217 92 100       180 _croak 'DecodeUsage', 'decode_bifcode: only accepts bytes'
218             if utf8::is_utf8($_);
219              
220 90         114 my $deserialised_data = _decode_bifcode_chunk();
221 39 100       96 _croak 'DecodeTrailing', " For: $_" if $_ !~ m/ \G \z /xgc;
222 35         116 return $deserialised_data;
223             }
224              
225             my $number_qr = qr/\A ( 0 | -? [1-9] [0-9]* )
226             ( \. ( [0-9]+? ) 0* )?
227             ( e ( -? [0-9]+ ) )? \z/xi;
228              
229             sub _encode_bifcode {
230             map {
231 84 100 100 84   104 if ( !defined $_ ) {
  91 100       290  
    100          
    100          
    100          
    100          
    100          
    100          
    100          
232 5         19 '~' . ',';
233             }
234             elsif ( ( my $ref = ref $_ ) eq '' ) {
235 47 100       364 if ( $_ =~ $number_qr ) {
    100          
    50          
236 35 100 100     102 if ( defined $3 or defined $5 ) {
237              
238             # normalize to BIFCODE_REAL standards
239 25   100     135 my $x = 'r' . ( 0 + $1 ) # remove leading zeros
      100        
240             . '.' . ( $3 // 0 ) . 'e' . ( 0 + ( $5 // 0 ) ) . ',';
241 26         64 $x =~ s/ ([1-9]) (0+ e)/.${1}e/x; # remove trailing zeros
242 26         71 $x;
243             }
244             else {
245 11         42 'i' . $_ . ',';
246             }
247             }
248             elsif ( utf8::is_utf8($_) ) {
249 3         8 utf8::encode( my $str = $_ );
250 3         13 'u' . length($str) . '.' . $str . ',';
251             }
252             elsif ( $_ =~ m/^[\x{20}-\x{7E}]*$/ ) {
253 9         36 'u' . length($_) . '.' . $_ . ',';
254             }
255             else {
256 1         5 'b' . length($_) . '.' . $_ . ',';
257             }
258             }
259             elsif ( $ref eq 'ARRAY' ) {
260 6         34 '[' . join( '', map _encode_bifcode($_), @$_ ) . ']';
261             }
262             elsif ( $ref eq 'HASH' ) {
263             '{' . join(
264             '',
265 8         13 do {
266 7         8 my $k;
267 7         22 my @k = sort keys %$_;
268              
269             map {
270 15         20 $k = shift @k;
271              
272 15 100       34 if ( $k =~ m/^[\x{20}-\x{7E}]*$/ ) {
    50          
273 14         50 ( 'u' . length($k) . '.' . $k . ':', $_ );
274             }
275             elsif ( utf8::is_utf8($k) ) {
276 1         2 utf8::encode($k);
277 1         9 ( 'u' . length($k) . '.' . $k . ':', $_ );
278             }
279             else {
280 0         0 ( 'b' . length($k) . '.' . $k . ':', $_ );
281             }
282 7         17 } _encode_bifcode( @$_{@k} );
283             }
284             ) . '}';
285             }
286             elsif ( $ref eq 'SCALAR' or $ref eq 'Bifcode::BYTES' ) {
287 7   66     19 $$_ // _croak 'EncodeBytesUndef';
288 5         16 'b' . length($$_) . '.' . $$_ . ',';
289             }
290             elsif ( boolean::isBoolean($_) ) {
291 5 100       112 ( $_ ? 't' : 'f' ) . ',';
292             }
293             elsif ( $ref eq 'Bifcode::INTEGER' ) {
294 4   66     61 $$_ // _croak 'EncodeIntegerUndef';
295 3 100       19 _croak 'EncodeInteger', 'invalid integer: ' . $$_
296             unless $$_ =~ m/\A (?: 0 | -? [1-9] [0-9]* ) \z/x;
297 1         7 sprintf 'i%s,', $$_;
298             }
299             elsif ( $ref eq 'Bifcode::REAL' ) {
300 10   66     146 $$_ // _croak 'EncodeRealUndef';
301 9 100       69 _croak 'EncodeReal', 'invalid real: ' . $$_
302             unless $$_ =~ $number_qr;
303              
304 8   100     68 my $x = 'r' . ( 0 + $1 ) # remove leading zeros
      100        
305             . '.' . ( $3 // 0 ) . 'e' . ( 0 + ( $5 // 0 ) ) . ',';
306 7         15 $x =~ s/ ([1-9]) (0+ e)/.${1}e/x; # remove trailing zeros
307 7         23 $x;
308             }
309             elsif ( $ref eq 'Bifcode::UTF8' ) {
310 3   66     55 my $str = $$_ // _croak 'EncodeUTF8Undef';
311 3         10 utf8::encode($str);
312 3         10 'u' . length($str) . '.' . $str . ',';
313             }
314             else {
315 2         26 _croak 'EncodeUnhandled', 'unhandled data type: ' . $ref;
316             }
317             } @_;
318             }
319              
320             sub encode_bifcode {
321 69 50 33 70 1 32612 if ( ( @_ == 2 ) && pop ) {
    100          
322 0         0 my $b = (&_encode_bifcode)[0];
323 0         0 'B' . length($b) . '.' . $b . ',';
324             }
325             elsif ( @_ == 1 ) {
326 67         114 (&_encode_bifcode)[0];
327             }
328             else {
329 4         11 _croak 'EncodeUsage';
330             }
331             }
332              
333             sub force_bifcode {
334 17     17 1 4101 my $ref = shift;
335 16         18 my $type = shift;
336              
337 16 50 33     49 _croak 'ForceUsage' unless defined $ref and defined $type;
338 16         108 bless \$ref, 'Bifcode::' . uc($type);
339             }
340              
341             sub _expand_bifcode {
342 125     125   138 my $bifcode = shift;
343 125         690 $bifcode =~ s/ (
344             [\[\]\{\}]
345             | ~,
346             | (B|u|b) [0-9]+ \.
347             | r -? [0-9]+ \. [0-9]+ e -? [0-9]+ ,
348             | i [0-9]+ ,
349             ) /\n$1/gmx;
350 125         324 $bifcode =~ s/ \A \n //mx;
351 124         225 $bifcode . "\n";
352             }
353              
354             sub diff_bifcode {
355 64 100 100 65 1 8766 _croak 'DiffUsage' unless @_ >= 2 and @_ <= 3;
356 62         64 my $b1 = shift;
357 63         67 my $b2 = shift;
358 63   50     174 my $diff_args = shift || { STYLE => 'Unified' };
359              
360 63         789 require Text::Diff;
361              
362 62         7274 $b1 = _expand_bifcode($b1);
363 62         82 $b2 = _expand_bifcode($b2);
364 62         139 return Text::Diff::diff( \$b1, \$b2, $diff_args );
365             }
366              
367             # Looking for something like "B48." that may be truncated at any point
368             my $qr_bcbc = qr/
369             ^
370             ( # 1
371             B
372             (?:
373             \Z | (?:
374             ( 0 | [1-9][0-9]* ) # 2
375             ( \Z | (\.) ) # 3
376             )
377             )
378             )
379             /x;
380              
381             sub anyevent_read_type {
382 1     1 0 5 my ( $self, $cb, $maxdepth ) = @_;
383              
384             sub {
385 1 0   1   6 return unless defined $_[0]->{rbuf};
386              
387 0         0 $_[0]->{rbuf} =~ s/^[\r\n]*//;
388 0 0       0 return unless length $_[0]->{rbuf};
389              
390 0         0 $_[0]->{rbuf} =~ $qr_bcbc;
391              
392 1 0       6 if ( length $3 ) {
    0          
393             $_[0]->unshift_read(
394             chunk => length($1) + $2 + 1,
395             sub {
396 1         6 my $data = eval { decode_bifcode( $_[1], $maxdepth ) };
  0         0  
397 0 0       0 if ($@) {
398 0         0 $_[0]->_error( Errno::EBADMSG(), undef, $@ );
399             }
400             else {
401 1         5 $cb->( $_[0], $data );
402             }
403 1         2 1;
404             }
405 1         1 );
406 1         6 return 1;
407             }
408             elsif ( not length $1 ) {
409 0         0 $_[0]->_error( Errno::EBADMSG() );
410 0         0 return;
411             }
412             else {
413 0         0 return; # not enough data yet
414             }
415 1         2 };
416             }
417              
418             sub anyevent_write_type {
419 1     1 0 5 encode_bifcode( $_[1], 1 ) . "\n";
420             }
421              
422             1;
423              
424             __END__