File Coverage

blib/lib/WWW/Xunlei.pm
Criterion Covered Total %
statement 181 208 87.0
branch 23 40 57.5
condition 9 18 50.0
subroutine 39 43 90.7
pod 3 7 42.8
total 255 316 80.7


line stmt bran cond sub pod time code
1             package WWW::Xunlei;
2              
3 1     1   116519 use strict;
  1         2  
  1         22  
4 1     1   3 use warnings;
  1         1  
  1         22  
5              
6 1     1   3 use LWP::UserAgent;
  1         4  
  1         26  
7 1     1   2 use HTTP::Request;
  1         2  
  1         13  
8 1     1   5 use URI::Escape;
  1         1  
  1         45  
9 1     1   571 use JSON;
  1         9093  
  1         4  
10              
11 1     1   109 use File::Basename;
  1         1  
  1         151  
12 1     1   5 use File::Path qw/mkpath/;
  1         1  
  1         43  
13 1     1   470 use Time::HiRes qw/gettimeofday/;
  1         963  
  1         5  
14 1     1   567 use POSIX qw/strftime/;
  1         4893  
  1         6  
15 1     1   867 use Digest::MD5 qw(md5_hex);
  1         1  
  1         63  
16 1     1   675 use Term::ANSIColor qw/:constants/;
  1         7408  
  1         821  
17 1     1   804 use Data::Dumper;
  1         6681  
  1         82  
18              
19 1     1   542 use WWW::Xunlei::Downloader;
  1         3  
  1         57  
20              
21             our $DEBUG;
22              
23 1     1   7 use constant URL_LOGIN => 'http://login.xunlei.com/';
  1         2  
  1         84  
24 1     1   6 use constant URL_REMOTE => 'http://homecloud.yuancheng.xunlei.com/';
  1         2  
  1         61  
25 1         49 use constant DEFAULT_USER_AGENT =>
26             "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.11; rv:41.0) "
27 1     1   4 . "Gecko/20100101 Firefox/41.0";
  1         2  
28 1     1   5 use constant URL_LOGIN_REFER => 'http://i.xunlei.com/login/2.5/?r_d=1';
  1         1  
  1         44  
29 1     1   4 use constant BUSINESS_TYPE => '113';
  1         2  
  1         53  
30 1     1   4 use constant V => '2';
  1         1  
  1         45  
31 1     1   4 use constant CT => '0';
  1         1  
  1         1542  
32              
33             sub new {
34 1     1 1 491 my $class = shift;
35 1         3 my ( $user, $pass, %options ) = @_;
36 1         4 my $self = {
37             'ua' => undef,
38             'json' => undef,
39             'user' => $user,
40             'pass' => md5pass($pass),
41             };
42              
43 1         3 my $cookie_file = $options{'cookie_file'};
44 1         8 $self->{'ua'} = LWP::UserAgent->new;
45 1         2353 $self->{'ua'}->cookie_jar( { file => $cookie_file } );
46 1         26332 $self->{'ua'}->agent(DEFAULT_USER_AGENT);
47              
48 1         111 $self->{'json'} = JSON->new->allow_nonref;
49              
50 1         6 bless $self, $class;
51 1         6 return $self;
52             }
53              
54             sub list_downloaders {
55 3     3 1 172 my $self = shift;
56              
57 3         8 my $parameters = { 'type' => 0, };
58              
59 3         11 my $res = $self->_yc_request( 'listPeer', $parameters );
60              
61 3 50       12 if ( $res->{'rtn'} != 0 ) {
62 0         0 die "Unable to get the Downloader List: $@";
63             }
64              
65 3         4 my @downloaders;
66 3         5 for my $p ( @{ $res->{'peerList'} } ) {
  3         9  
67 3         25 push @downloaders, WWW::Xunlei::Downloader->new( $self, $p );
68             }
69              
70 3 100       28 return wantarray ? @downloaders : \@downloaders;
71             }
72              
73             sub get_downloader {
74 1     1 0 541 my $self = shift;
75            
76 1         3 my $name = shift;
77              
78 1         4 my @downloaders = grep { $_->{'name'} eq $name } $self->list_downloaders();
  1         11  
79 1 50       6 die "No such Downloader named >>$name<<" unless @downloaders;
80 1         5 return shift @downloaders;
81             }
82              
83             sub bind {
84 0     0 1 0 my $self = shift;
85              
86 0         0 my ( $key, $name ) = @_;
87              
88 0         0 my $parameters = {
89             'boxname' => $name,
90             'key' => $key,
91             };
92              
93 0         0 my $res = $self->_yc_request( 'bind', $parameters );
94             }
95              
96             sub unbind {
97 0     0 0 0 my $self = shift;
98 0         0 my $pid = shift;
99              
100 0         0 my $res = $self->_yc_request( 'unbind', { 'pid' => $pid } );
101             }
102              
103             sub _login {
104 0     0   0 my $self = shift;
105 0         0 my $res;
106 0 0       0 if ( $self->_is_session_expired ) {
107 0         0 $res = $self->_form_login;
108             }
109             else {
110 0         0 $res = $self->_session_login;
111             }
112              
113 0 0       0 die "Login Error: $res" if ( $res != 0 );
114 0         0 $self->_set_auto_login();
115 0         0 $self->_save_cookie();
116             }
117              
118             sub _form_login {
119 1     1   2 my $self = shift;
120 1         4 my $verify_code = uc $self->_get_verify_code();
121 1         5 $self->_debug( "Verify Code: " . $verify_code );
122 1         11 my $password = md5_hex( $self->{'pass'} . $verify_code );
123             my $parameters = {
124 1         7 'u' => $self->{'user'},
125             'p' => $password,
126             'verifycode' => $verify_code,
127             };
128              
129             # $self->{'ua'}->post(join( '/', URL_LOGIN, 'sec2login/'), $parameters);
130 1         5 $self->_request( 'POST', URL_LOGIN . 'sec2login/', $parameters );
131              
132 1         5 return $self->_get_cookie('blogresult');
133             }
134              
135             sub _session_login {
136 1     1   2 my $self = shift;
137 1         5 my $parameters = { 'sessionid' => $self->_get_cookie('_x_a_') };
138 1         6 $self->_request( 'GET', URL_LOGIN . 'sessionid/', $parameters );
139 1         4 return $self->_get_cookie('blogresult');
140             }
141              
142             sub _is_logged_in {
143 11     11   15 my $self = shift;
144 11   33     30 return ( $self->_get_cookie('sessionid')
145             && $self->_get_cookie('userid') );
146             }
147              
148             sub _is_session_expired {
149 3     3   346 my $self = shift;
150              
151             my $session_expired_time
152             = $self->{'ua'}
153 3         12 ->{'cookie_jar'}{'COOKIES'}{'.xunlei.com'}{'/'}{'_x_a_'}[5];
154 3 100       18 return 1 unless $session_expired_time;
155 1         10 return (gettimeofday)[0] > $session_expired_time;
156             }
157              
158             sub _get_verify_code {
159 2     2   3010 my $self = shift;
160             my $parameters = {
161 2         31 'u' => $self->{'user'},
162             'business_type' => BUSINESS_TYPE,
163             'cachetime' => int( gettimeofday() * 1000 ),
164             };
165 2         11 $self->_request( 'GET', URL_LOGIN . 'check/', $parameters );
166 2         10 my $check_result = $self->_get_cookie('check_result');
167 2         10 my $verify_code = ( split( ':', $check_result ) )[1];
168 2         16 return $verify_code;
169             }
170              
171             sub _set_auto_login {
172 2     2   4 my $self = shift;
173 2         8 my $sessionid = $self->_get_cookie('sessionid');
174 2         8 $self->_set_cookie( '_x_a_', $sessionid, 604800 );
175             }
176              
177             sub _delete_temp_cookies {
178 0     0   0 my $self = shift;
179             my @login_cookie
180 0         0 = qw/VERIFY_KEY verify_type check_n check_e logindetail result/;
181 0         0 for my $c (@login_cookie) {
182 0         0 $self->_delete_cookie($c);
183             }
184             }
185              
186             sub _get_cookie {
187 33     33   1836 my $self = shift;
188 33         49 my ( $key, $domain, $path ) = @_;
189 33   50     136 $domain ||= ".xunlei.com";
190 33   50     110 $path ||= "/";
191 33         198 $self->{'ua'}->{'cookie_jar'}->{'COOKIES'}{$domain}{'/'}{$key}[1];
192             }
193              
194             sub _set_cookie {
195 5     5   2852 my $self = shift;
196 5         14 my ( $key, $value, $expire, $domain, $path ) = @_;
197 5   50     35 $domain ||= ".xunlei.com";
198 5   50     23 $path ||= "/";
199 5         24 $self->{'ua'}->{'cookie_jar'}
200             ->set_cookie( undef, $key, $value, $path, $domain, undef,
201             undef, undef, $expire );
202 5         154 $self->{'ua'}->{'cookie_jar'}->{'COOKIES'}{$domain}{$path}{$key};
203             }
204              
205             sub _save_cookie {
206 5     5   450 my $self = shift;
207              
208 5         16 $self->_delete_cookie('blogresult');
209 5         60 my $cookie_file = $self->{'ua'}->{'cookie_jar'}->{'file'};
210 5 100       23 return unless $cookie_file;
211 3         200 my $cookie_path = dirname($cookie_file);
212 3 100       105 if ( !-d $cookie_path ) {
213 1         233 mkpath($cookie_path);
214             }
215 3         21 $self->{'ua'}->{'cookie_jar'}->save();
216             }
217              
218             sub _delete_cookie {
219 7     7   466 my $self = shift;
220 7         14 my ( $key, $domain, $path ) = @_;
221 7   50     33 $domain ||= ".xunlei.com";
222 7   50     27 $path ||= "/";
223 7         36 $self->{'ua'}->{'cookie_jar'}->clear($domain, $path, $key);
224             }
225              
226             sub _yc_request {
227 9     9   17 my $self = shift;
228 9         16 my ( $action, $parameters, $data ) = @_;
229              
230 9 50       25 my $method = $data ? 'POST' : 'GET';
231 9         22 my $uri = URL_REMOTE . $action;
232 9         21 $parameters->{'v'} = V;
233 9         21 $parameters->{'ct'} = CT;
234              
235 9 50       22 $self->_login unless $self->_is_logged_in;
236 9         32 my $res = $self->_request( $method, $uri, $parameters, $data );
237 9 50       33 if ( $res->{'rtn'} != 0 ) {
238              
239             # Todo: Handling not login failed here.
240 0         0 die "Request Error: $res->{'rtn'}";
241             }
242              
243 9         114 return $res;
244             }
245              
246             sub _request {
247 13     13   23 my $self = shift;
248 13         26 my ( $method, $uri, $parameters, $postdata ) = @_;
249 13         14 my ( $form_string, $payload );
250 13 50       36 if ($parameters) {
251 13         34 $form_string = urlencode($parameters);
252             }
253              
254 13 100 66     63 if ( $method ne 'GET' && !$postdata ) {
255              
256             # use urlencode parameters as post data when posting login form.
257 1         3 $payload = $form_string;
258             }
259             else {
260 12         26 $uri .= '?' . $form_string;
261 12 50       34 if ( ref $postdata ) {
262 0         0 $payload = $self->{'json'}->encode($postdata);
263 0         0 $payload = urlencode( { 'json' => $payload } );
264             }
265             }
266              
267 13         76 my $request = HTTP::Request->new( $method => $uri, undef, $payload );
268 13         10249 $request->header( 'Content-Type' => 'application/x-www-form-urlencoded' );
269 13         744 $self->_debug($request);
270 13         72 my $response = $self->{'ua'}->request($request);
271 13 50       33000 die $response->code . ":" . $response->message
272             unless $response->is_success;
273 13         166 my $content = $response->content;
274              
275 13         142 $self->_debug($content);
276              
277 13         35 $content =~ s/\s$//g;
278 13 100       39 return "" unless ( length($content) );
279              
280 9 50       245 return $self->{'json'}->decode($content) if ( $content =~ /\s*[\[\{\"]/ );
281             }
282              
283             sub urlencode {
284 13     13 0 17 my $data = shift;
285              
286 13         17 my @parameters;
287 13         56 for my $key ( keys %$data ) {
288             push @parameters,
289 53         490 join( '=', map { uri_escape_utf8($_) } $key, $data->{$key} );
  106         813  
290             }
291 13         182 my $encoded_data = join( '&', @parameters );
292 13         35 return $encoded_data;
293             }
294              
295             sub md5pass {
296 1     1 0 1 my $pass = shift;
297 1 50       3 if ( $pass !~ /^[0-9a-f]{32}$/i ) {
298 1         6 $pass = md5_hex( md5_hex($pass) );
299             }
300 1         3 return $pass;
301             }
302              
303             sub _debug {
304 27     27   37 my $self = shift;
305 27         32 my $message = shift;
306 27 50       79 if ($DEBUG) {
307 0 0         if ( ref $message ) { $message = Dumper($message); }
  0            
308 0           my $date = strftime( "%Y-%m-%d %H:%M:%S", localtime );
309              
310             #$date .= sprintf(".%03f", current_timestamp());
311 0           print BLUE "[ $date ] ", GREEN $message, RESET "\n";
312             }
313             }
314              
315             1;
316              
317             =pod
318              
319             =encoding UTF-8
320              
321             =head1 NAME
322              
323             WWW::Xunlei - Perl API For Official Xunlei Remote API.
324              
325             =head1 VERSION
326              
327             version 0.06
328              
329             =head1 SYNOPSIS
330              
331             use WWW::Xunlei;
332             my $client = WWW::Xunlei->new("username", "password");
333             # use the first downloader;
334             my $downloader = $client->list_downloaders()->[0];
335             # create a remote task;
336             $downloader->create_task("http://www.cpan.org/src/5.0/perl-5.22.0.tar.gz");
337              
338             =head1 DESCRIPTION
339              
340             C is a Perl Wrapper of Xunlei Remote Downloader API.
341             L
342              
343             =head1 METHODS
344              
345             =head2 new( $username, $password, [cookie_file=>'/path/to/cookie'])
346              
347             create a Xunlei client. Load or save Cookies to a plain text file with
348             C option. The default session expire time is 7 days.
349              
350             =head2 bind($key, [$name])
351              
352             Bind a new downloader with a activation code. The new downloader's name can
353             be defined with the optional argument C<$name>.
354              
355             =head2 list_downloaders
356              
357             List all the downloaders binding with your account. Return a list of
358             C object.
359              
360             ==method list_downloader($name)
361              
362             Get the downloader of which the name is $name.
363             Return a C object.
364              
365             =head1 AUTHOR
366              
367             Zhu Sheng Li
368              
369             =head1 COPYRIGHT AND LICENSE
370              
371             This software is Copyright (c) 2015 by Zhu Sheng Li.
372              
373             This is free software, licensed under:
374              
375             The MIT (X11) License
376              
377             =cut
378              
379             __END__