blib/lib/VK/MP3.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 93 | 93 | 100.0 |
branch | 17 | 22 | 77.2 |
condition | 8 | 15 | 53.3 |
subroutine | 17 | 17 | 100.0 |
pod | 3 | 3 | 100.0 |
total | 138 | 150 | 92.0 |
line | stmt | bran | cond | sub | pod | time | code | |||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
1 | package VK::MP3; | |||||||||||||
2 | ||||||||||||||
3 | 1 | 1 | 1139 | use strict; | ||||||||||
1 | 2 | |||||||||||||
1 | 48 | |||||||||||||
4 | 1 | 1 | 6 | use warnings; | ||||||||||
1 | 2 | |||||||||||||
1 | 37 | |||||||||||||
5 | 1 | 1 | 25 | use utf8; | ||||||||||
1 | 2 | |||||||||||||
1 | 8 | |||||||||||||
6 | ||||||||||||||
7 | 1 | 1 | 1112 | use LWP; | ||||||||||
1 | 45 | |||||||||||||
1 | 102 | |||||||||||||
8 | 1 | 1 | 969 | use LWP::Protocol::https; | ||||||||||
1 | 2213959 | |||||||||||||
1 | 474 | |||||||||||||
9 | 1 | 1 | 3309 | use HTML::Entities; | ||||||||||
1 | 10203 | |||||||||||||
1 | 114 | |||||||||||||
10 | 1 | 1 | 12 | use URI::Escape; | ||||||||||
1 | 1 | |||||||||||||
1 | 62 | |||||||||||||
11 | 1 | 1 | 1810 | use JSON::XS qw/decode_json/; | ||||||||||
1 | 33158 | |||||||||||||
1 | 100 | |||||||||||||
12 | 1 | 1 | 1216 | use Encode; | ||||||||||
1 | 19018 | |||||||||||||
1 | 1466 | |||||||||||||
13 | ||||||||||||||
14 | our $VERSION = 0.09; | |||||||||||||
15 | ||||||||||||||
16 | sub new { | |||||||||||||
17 | 4 | 4 | 1 | 3752 | my ($class, %args) = @_; | |||||||||
18 | 4 | 100 | 9 | die 'USAGE: VK::MP3->new(login => ..., password => ...)' | ||||||||||
19 | unless _valid_new_args(\%args); | |||||||||||||
20 | ||||||||||||||
21 | 3 | 8 | my $self = { | |||||||||||
22 | ua => _create_ua(), | |||||||||||||
23 | login => $args{login}, | |||||||||||||
24 | password => $args{password}, | |||||||||||||
25 | }; | |||||||||||||
26 | 3 | 13 | bless $self, $class; | |||||||||||
27 | ||||||||||||||
28 | 3 | 100 | 8 | die 'ERROR: login failed' unless($self->_login()); | ||||||||||
29 | ||||||||||||||
30 | 1 | 3 | return $self; | |||||||||||
31 | } | |||||||||||||
32 | ||||||||||||||
33 | sub search { | |||||||||||||
34 | 3 | 3 | 1 | 1936 | my ($self, $query) = @_; | |||||||||
35 | ||||||||||||||
36 | 3 | 12 | my $res = $self->{ua}->get('http://vk.com/search?c[section]=audio&c[q]='.uri_escape_utf8($query)); | |||||||||||
37 | 3 | 100 | 326 | die 'LWP: '.$res->status_line unless $res->is_success; | ||||||||||
38 | ||||||||||||||
39 | 2 | 90 | my @matches = $res->decoded_content =~ m' 40 | |||||||||||
41 | 2 | 141 | my @rslt; | |||||||||||
42 | 2 | 9 | push @rslt, $self->_parse_found_item($_) for(@matches); | |||||||||||
43 | 2 | 5 | @rslt = grep { defined $_ } @rslt; | |||||||||||
3 | 9 | |||||||||||||
44 | ||||||||||||||
45 | 2 | 12 | return \@rslt; | |||||||||||
46 | } | |||||||||||||
47 | ||||||||||||||
48 | sub get_playlist { | |||||||||||||
49 | 1 | 1 | 1 | 17261 | my ($self) = @_; | |||||||||
50 | 1 | 2 | my $res; | |||||||||||
51 | ||||||||||||||
52 | 1 | 25 | $res = $self->{ua}->post('http://vk.com/audio', { | |||||||||||
53 | act => 'load_audios_silent', | |||||||||||||
54 | al => 1, | |||||||||||||
55 | gid => 0, | |||||||||||||
56 | id => $self->{id}, | |||||||||||||
57 | please_dont_ddos => '2', | |||||||||||||
58 | }, | |||||||||||||
59 | ); | |||||||||||||
60 | 1 | 50 | 93 | die 'LWP: '.$res->status_line unless $res->is_success; | ||||||||||
61 | ||||||||||||||
62 | 1 | 60 | my $json_str = (split //, $res->decoded_content)[5]; | |||||||||||
63 | 1 | 89 | $json_str =~ s/'/"/gs; | |||||||||||
64 | 1 | 7 | $json_str = Encode::encode('utf-8', $json_str); | |||||||||||
65 | 1 | 237 | my $json = decode_json($json_str); | |||||||||||
66 | 1 | 50 | 33 | 14 | return 'Invalid response' unless defined $json->{all} && ref($json->{all}) eq 'ARRAY'; | |||||||||
67 | ||||||||||||||
68 | 1 | 3 | my @rslt; | |||||||||||
69 | 1 | 3 | for my $item(@{$json->{all}}) { | |||||||||||
1 | 5 | |||||||||||||
70 | 3 | 50 | 33 | 11 | next unless ref $item eq 'ARRAY' && scalar @{$item} > 7; | |||||||||
3 | 14 | |||||||||||||
71 | 3 | 25 | my $name = decode_entities($item->[5].' – '.$item->[6]); | |||||||||||
72 | 3 | 33 | $name =~ s/(^\s+|\s+$)//g; | |||||||||||
73 | 3 | 15 | my $rslt_item = { | |||||||||||
74 | name => $name, | |||||||||||||
75 | duration => $item->[3], | |||||||||||||
76 | link => $item->[2], | |||||||||||||
77 | }; | |||||||||||||
78 | 3 | 9 | push @rslt, $rslt_item; | |||||||||||
79 | } | |||||||||||||
80 | 1 | 10 | return \@rslt; | |||||||||||
81 | } | |||||||||||||
82 | ||||||||||||||
83 | sub _parse_found_item { | |||||||||||||
84 | 3 | 3 | 7 | my ($self, $str) = @_; | ||||||||||
85 | 3 | 87 | my ($name) = $str =~ m{ (.*?) }si; |
|||||||||||
86 | 3 | 50 | 9 | return undef unless $name; | ||||||||||
87 | ||||||||||||||
88 | 3 | 84 | $name =~ s/<[^>]+>//g; | |||||||||||
89 | 3 | 19 | $name =~ s/ ?\([^\(]*$//; | |||||||||||
90 | 3 | 31 | $name = decode_entities($name); | |||||||||||
91 | ||||||||||||||
92 | 1 | 1 | 7 | my ($duration) = $str =~ m{ (\d+:\d+) }i; |
||||||||||
1 | 1 | |||||||||||||
1 | 13 | |||||||||||||
3 | 97 | |||||||||||||
93 | 3 | 75122 | my ($link) = $str =~ m{value="(http://[^",]+\.mp3)}i; | |||||||||||
94 | ||||||||||||||
95 | 3 | 100 | 12 | if($duration) { | ||||||||||
96 | 2 | 8 | my ($min, $sec) = split /:/, $duration, 2; | |||||||||||
97 | 2 | 7 | $duration = $min * 60 + $sec; | |||||||||||
98 | } else { | |||||||||||||
99 | 1 | 2 | $duration = 0; | |||||||||||
100 | } | |||||||||||||
101 | ||||||||||||||
102 | 3 | 45 | return { name => $name, duration => $duration, link => $link }; | |||||||||||
103 | } | |||||||||||||
104 | ||||||||||||||
105 | sub _login { | |||||||||||||
106 | 3 | 3 | 4 | my $self = shift; | ||||||||||
107 | 3 | 27 | my $res = $self->{ua}->post('https://login.vk.com/?act=login', { | |||||||||||
108 | email => $self->{login}, | |||||||||||||
109 | pass => $self->{password}, | |||||||||||||
110 | }); | |||||||||||||
111 | ||||||||||||||
112 | 3 | 100 | 66 | 173 | if( $res->is_success && | |||||||||
66 | ||||||||||||||
113 | ($res->decoded_content =~ /var\s+vk\s*=\s*\{[^\{\}]*?id\s*\:\s*(\d+)/i | |||||||||||||
114 | || $res->decoded_content =~ m#login\.vk\.com/\?act=logout#i ) ) { | |||||||||||||
115 | 1 | 83 | $self->{id} = $1; | |||||||||||
116 | 1 | 4 | return 1; | |||||||||||
117 | } | |||||||||||||
118 | 2 | 254 | return 0; | |||||||||||
119 | } | |||||||||||||
120 | ||||||||||||||
121 | sub _create_ua { | |||||||||||||
122 | 3 | 3 | 13 | my $ua = LWP::UserAgent->new(); | ||||||||||
123 | ||||||||||||||
124 | 3 | 9 | push @{ $ua->requests_redirectable }, 'POST'; | |||||||||||
3 | 25 | |||||||||||||
125 | 3 | 182 | $ua->cookie_jar( {} ); | |||||||||||
126 | ||||||||||||||
127 | 3 | 185 | return $ua; | |||||||||||
128 | } | |||||||||||||
129 | ||||||||||||||
130 | sub _valid_new_args { | |||||||||||||
131 | 4 | 4 | 6 | my $args = shift; | ||||||||||
132 | 4 | 50 | 15 | return 0 unless ref($args) eq 'HASH'; | ||||||||||
133 | 4 | 8 | for(qw/login password/) { | |||||||||||
134 | 7 | 100 | 66 | 49 | return 0 unless defined($args->{$_}) && (ref($args->{$_}) eq ''); | |||||||||
135 | } | |||||||||||||
136 | 3 | 9 | return 1; | |||||||||||
137 | } | |||||||||||||
138 | ||||||||||||||
139 | 1; | |||||||||||||
140 | ||||||||||||||
141 | __END__ |