File Coverage

blib/lib/WWW/Opentracker/Stats/Mode/TPBS/Bencode.pm
Criterion Covered Total %
statement 25 25 100.0
branch 2 4 50.0
condition n/a
subroutine 5 5 100.0
pod 1 1 100.0
total 33 35 94.2


line stmt bran cond sub pod time code
1             package WWW::Opentracker::Stats::Mode::TPBS::Bencode;
2              
3 3     3   35037 use strict;
  3         6  
  3         133  
4 3     3   15 use warnings;
  3         7  
  3         95  
5              
6 3     3   3715 use Bit::Vector;
  3         17002  
  3         792  
7 3     3   7772 use Convert::Bencode qw(bencode bdecode);
  3         11063  
  3         1115  
8              
9              
10             =head1 NAME
11              
12             WWW::Opentracker::Stats::Mode::TPBS::Bencode
13              
14             =head1 DESCRIPTION
15              
16             Decodes the bencoded TPBS statistics from Opentracker.
17              
18             =head1 METHODS
19              
20             =head2 decode_stats
21              
22             Args: $class, $payload
23              
24             Returns a HASHREF of the decoded stats structure.
25              
26             The structure looks something like this:
27              
28             $VAR1 => {
29             files => {
30             INFOHASH => {
31             incomplete => 2,
32             downloaded => 52,
33             complete => 71,
34             },
35             INFOHASH => ...
36             }
37             }
38              
39             =cut
40              
41             sub decode_stats {
42 2     2 1 1065 my ($class, $payload) = @_;
43              
44 2 50       8 return {} unless $payload;
45              
46 2         12 my $t = bdecode($payload);
47              
48 2 50       913 $t->{'files'} = {} unless defined $t->{'files'};
49              
50 2         5 my @replace = keys %{$t->{'files'}};
  2         9  
51            
52 2         6 for my $key (@replace) {
53 4         19 my $value = delete $t->{'files'}->{$key};
54 4         18 my $bin = unpack('B*', $key);
55            
56 4         44 my $v = Bit::Vector->new_Bin(160, $bin);
57 4         26 my $hex = $v->to_Hex;
58            
59 4         29 $t->{'files'}->{$hex} = $value;
60             }
61              
62 2         9 return $t;
63             }
64              
65              
66             =head1 SEE ALSO
67              
68             L,
69             L
70              
71              
72             =head1 AUTHOR
73              
74             Knut-Olav Hoven, Eknutolav@gmail.comE
75              
76             =head1 COPYRIGHT AND LICENSE
77              
78             Copyright (C) 2009 by Knut-Olav Hoven
79              
80             This library is free software; you can redistribute it and/or modify
81             it under the same terms as Perl itself, either Perl version 5.8.8 or,
82             at your option, any later version of Perl 5 you may have available.
83              
84             =cut
85              
86             1;