line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
2
|
|
|
2
|
|
131230
|
use 5.006; |
|
2
|
|
|
|
|
24
|
|
2
|
2
|
|
|
2
|
|
13
|
use strict; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
62
|
|
3
|
2
|
|
|
2
|
|
12
|
use warnings; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
144
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Bencode; |
6
|
|
|
|
|
|
|
$Bencode::VERSION = '1.501'; |
7
|
|
|
|
|
|
|
# ABSTRACT: BitTorrent serialisation format |
8
|
|
|
|
|
|
|
|
9
|
2
|
|
|
2
|
|
1543
|
use Exporter::Tidy all => [qw( bencode bdecode )]; |
|
2
|
|
|
|
|
24
|
|
|
2
|
|
|
|
|
14
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our ( $DEBUG, $do_lenient_decode, $max_depth, $undef_encoding ); |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
sub croak { |
14
|
42
|
|
|
42
|
0
|
62
|
my ( @c, $i ); |
15
|
42
|
|
66
|
|
|
871
|
1 while ( @c = caller $i++ ) and $c[0] eq __PACKAGE__; |
16
|
42
|
50
|
|
|
|
107
|
@c or @c = caller; |
17
|
42
|
|
|
|
|
331
|
die @_, " at $c[1] line $c[2].\n"; |
18
|
|
|
|
|
|
|
} |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
sub _bdecode_string { |
21
|
|
|
|
|
|
|
|
22
|
139
|
100
|
|
139
|
|
418
|
if ( m/ \G ( 0 | [1-9] \d* ) : /xgc ) { |
23
|
57
|
|
|
|
|
109
|
my $len = $1; |
24
|
|
|
|
|
|
|
|
25
|
57
|
100
|
|
|
|
127
|
croak 'unexpected end of string data starting at ', 0+pos |
26
|
|
|
|
|
|
|
if $len > length() - pos(); |
27
|
|
|
|
|
|
|
|
28
|
55
|
|
|
|
|
84
|
my $str = substr $_, pos(), $len; |
29
|
55
|
|
|
|
|
124
|
pos() = pos() + $len; |
30
|
|
|
|
|
|
|
|
31
|
55
|
0
|
|
|
|
108
|
warn "STRING (length $len)", $len < 200 ? " [$str]" : () if $DEBUG; |
|
|
50
|
|
|
|
|
|
32
|
|
|
|
|
|
|
|
33
|
55
|
|
|
|
|
131
|
return $str; |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
else { |
36
|
82
|
|
|
|
|
112
|
my $pos = pos(); |
37
|
82
|
100
|
|
|
|
218
|
if ( m/ \G -? 0? \d+ : /xgc ) { |
38
|
4
|
|
|
|
|
9
|
pos() = $pos; |
39
|
4
|
|
|
|
|
34
|
croak 'malformed string length at ', 0+pos; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
78
|
|
|
|
|
352
|
return; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub _bdecode_chunk { |
47
|
113
|
50
|
|
113
|
|
189
|
warn 'decoding at ', 0+pos if $DEBUG; |
48
|
|
|
|
|
|
|
|
49
|
113
|
100
|
|
|
|
170
|
local $max_depth = $max_depth - 1 if defined $max_depth; |
50
|
|
|
|
|
|
|
|
51
|
113
|
100
|
|
|
|
160
|
if ( defined( my $str = _bdecode_string() ) ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
52
|
30
|
|
|
|
|
96
|
return $str; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
elsif ( m/ \G i /xgc ) { |
55
|
22
|
100
|
|
|
|
56
|
croak 'unexpected end of data at ', 0+pos if m/ \G \z /xgc; |
56
|
|
|
|
|
|
|
|
57
|
21
|
100
|
|
|
|
93
|
m/ \G ( 0 | -? [1-9] \d* ) e /xgc |
58
|
|
|
|
|
|
|
or croak 'malformed integer data at ', 0+pos; |
59
|
|
|
|
|
|
|
|
60
|
14
|
50
|
|
|
|
25
|
warn "INTEGER $1" if $DEBUG; |
61
|
14
|
|
|
|
|
50
|
return $1; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
elsif ( m/ \G l /xgc ) { |
64
|
24
|
50
|
|
|
|
60
|
warn 'LIST' if $DEBUG; |
65
|
|
|
|
|
|
|
|
66
|
24
|
100
|
100
|
|
|
74
|
croak 'nesting depth exceeded at ', 0+pos |
67
|
|
|
|
|
|
|
if defined $max_depth and $max_depth < 0; |
68
|
|
|
|
|
|
|
|
69
|
20
|
|
|
|
|
27
|
my @list; |
70
|
20
|
|
|
|
|
39
|
until ( m/ \G e /xgc ) { |
71
|
27
|
50
|
|
|
|
40
|
warn 'list not terminated at ',0+pos,', looking for another element' if $DEBUG; |
72
|
27
|
|
|
|
|
49
|
push @list, _bdecode_chunk(); |
73
|
|
|
|
|
|
|
} |
74
|
14
|
|
|
|
|
36
|
return \@list; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
elsif ( m/ \G d /xgc ) { |
77
|
25
|
50
|
|
|
|
54
|
warn 'DICT' if $DEBUG; |
78
|
|
|
|
|
|
|
|
79
|
25
|
100
|
100
|
|
|
73
|
croak 'nesting depth exceeded at ', 0+pos |
80
|
|
|
|
|
|
|
if defined $max_depth and $max_depth < 0; |
81
|
|
|
|
|
|
|
|
82
|
22
|
|
|
|
|
34
|
my $last_key; |
83
|
|
|
|
|
|
|
my %hash; |
84
|
22
|
|
|
|
|
51
|
until ( m/ \G e /xgc ) { |
85
|
28
|
50
|
|
|
|
42
|
warn 'dict not terminated at ',0+pos,', looking for another pair' if $DEBUG; |
86
|
|
|
|
|
|
|
|
87
|
28
|
100
|
|
|
|
62
|
croak 'unexpected end of data at ', 0+pos |
88
|
|
|
|
|
|
|
if m/ \G \z /xgc; |
89
|
|
|
|
|
|
|
|
90
|
26
|
|
|
|
|
38
|
my $key = _bdecode_string(); |
91
|
26
|
100
|
|
|
|
52
|
defined $key or croak 'dict key is not a string at ', 0+pos; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
croak 'duplicate dict key at ', 0+pos |
94
|
25
|
100
|
|
|
|
46
|
if exists $hash{ $key }; |
95
|
|
|
|
|
|
|
|
96
|
24
|
100
|
100
|
|
|
116
|
croak 'dict key not in sort order at ', 0+pos |
|
|
|
100
|
|
|
|
|
97
|
|
|
|
|
|
|
if not( $do_lenient_decode ) and defined $last_key and $key lt $last_key; |
98
|
|
|
|
|
|
|
|
99
|
23
|
100
|
|
|
|
51
|
croak 'dict key is missing value at ', 0+pos |
100
|
|
|
|
|
|
|
if m/ \G e /xgc; |
101
|
|
|
|
|
|
|
|
102
|
22
|
|
|
|
|
28
|
$last_key = $key; |
103
|
22
|
|
|
|
|
40
|
$hash{ $key } = _bdecode_chunk(); |
104
|
|
|
|
|
|
|
} |
105
|
12
|
|
|
|
|
31
|
return \%hash; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
else { |
108
|
6
|
100
|
|
|
|
51
|
croak m/ \G \z /xgc ? 'unexpected end of data' : 'garbage', ' at ', 0+pos; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
sub bdecode { |
113
|
64
|
|
|
64
|
1
|
37573
|
local $_ = shift; |
114
|
64
|
|
|
|
|
91
|
local $do_lenient_decode = shift; |
115
|
64
|
|
|
|
|
79
|
local $max_depth = shift; |
116
|
64
|
|
|
|
|
109
|
my $deserialised_data = _bdecode_chunk(); |
117
|
31
|
100
|
|
|
|
105
|
croak 'trailing garbage at ', 0+pos if $_ !~ m/ \G \z /xgc; |
118
|
26
|
|
|
|
|
119
|
return $deserialised_data; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub _bencode; |
122
|
|
|
|
|
|
|
sub _bencode { |
123
|
|
|
|
|
|
|
map |
124
|
|
|
|
|
|
|
+( ( not defined ) ? ( $undef_encoding or croak 'unhandled data type' ) |
125
|
|
|
|
|
|
|
: ( not ref ) ? ( m/\A (?: 0 | -? [1-9] \d* ) \z/x ? 'i' . $_ . 'e' : length . ':' . $_ ) |
126
|
|
|
|
|
|
|
: ( 'SCALAR' eq ref ) ? ( length $$_ ) . ':' . $$_ # escape hatch -- use this to avoid num/str heuristics |
127
|
|
|
|
|
|
|
: ( 'ARRAY' eq ref ) ? 'l' . ( join '', _bencode @$_ ) . 'e' |
128
|
30
|
100
|
66
|
30
|
|
358
|
: ( 'HASH' eq ref ) ? 'd' . do { my @k = sort keys %$_; join '', map +( length $k[0] ) . ':' . ( shift @k ) . $_, _bencode @$_{ @k } } . 'e' |
|
4
|
50
|
|
|
|
20
|
|
|
4
|
100
|
|
|
|
12
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
129
|
|
|
|
|
|
|
: croak 'unhandled data type' |
130
|
|
|
|
|
|
|
), @_ |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub bencode { |
134
|
21
|
100
|
|
21
|
1
|
10067
|
my $undef_mode = @_ == 2 ? pop : 'str'; |
135
|
21
|
100
|
|
|
|
57
|
$undef_mode = 'str' unless defined $undef_mode; |
136
|
21
|
100
|
|
|
|
65
|
local $undef_encoding |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
137
|
|
|
|
|
|
|
= 'str' eq $undef_mode ? '0:' |
138
|
|
|
|
|
|
|
: 'num' eq $undef_mode ? 'i0e' |
139
|
|
|
|
|
|
|
: 'die' eq $undef_mode ? undef |
140
|
|
|
|
|
|
|
: croak qq'undef_mode argument must be "str", "num", "die" or undefined, not "$undef_mode"'; |
141
|
18
|
50
|
|
|
|
44
|
croak 'need exactly one or two arguments' if @_ != 1; |
142
|
18
|
|
|
|
|
33
|
( &_bencode )[0]; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
bdecode( 'i1e' ); |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
__END__ |