1package Audio::Scrobbler; 2 3use 5.006; 4use strict; 5use bytes; 6 7=head1 NAME 8 9Audio::Scrobbler - Perl interface to audioscrobbler.com/last.fm 10 11=head1 SYNOPSIS 12 13 use Audio::Scrobbler; 14 15 $scrob = new Audio::Scrobbler(cfg => { ... }); 16 17 $scrob->handshake(); 18 $scrob->submit(artist => "foo", album => "hello", track => "world", 19 length => 180); 20 21=head1 DESCRIPTION 22 23The C<Audio::Scrobbler> module provides a Perl interface to the track 24submission API of Last.fm's AudioScrobbler - 25http://www.audioscrobbler.com/. So far, only track submissions are 26handled; the future plans include access to the various statistics. 27 28=cut 29 30use Digest::MD5 qw/md5_hex/; 31use LWP::UserAgent; 32 33our @ISA = qw(); 34 35our $VERSION = '0.01'; 36 37sub err($ $); 38sub handshake($); 39 40sub get_ua($); 41 42sub URLEncode($); 43sub URLDecode($); 44 45=head1 METHODS 46 47The C<Audio::Scrobbler> class defines the following methods: 48 49=over 4 50 51=item * new ( cfg => { ... } ) 52 53Create a new C<Audio::Scrobbler> object and initialize it with 54the provided configuration parameters. The parameters themselves 55are discussed in the description of the L<handshake> and L<submit> 56methods below. 57 58=cut 59 60sub new 61{ 62 my $proto = shift; 63 my $class = ref $proto || $proto; 64 my $self = { }; 65 my %args = @_; 66 67 if (exists($args{'cfg'}) && ref $args{'cfg'} eq 'HASH') { 68 $self->{'cfg'} = $args{'cfg'}; 69 } else { 70 $self->{'cfg'} = { }; 71 } 72 $self->{'cfg'} = $args{'cfg'} || { }; 73 $self->{'ua'} = undef; 74 $self->{'req'} = { }; 75 $self->{'err'} = undef; 76 bless $self, $class; 77 return $self; 78} 79 80=item * err (message) 81 82Retrieves or sets the description of the last error encountered in 83the operation of this C<Audio::Scrobbler> object. 84 85=cut 86 87sub err($ $) 88{ 89 my ($self, $err) = @_; 90 91 $self->{'err'} = $err if $err; 92 return $self->{'err'}; 93} 94 95=item * handshake () 96 97Perfors a handshake with the AudioScrobbler API via a request to 98http://post.audioscrobbler.com/. 99 100This method requires that the following configuration parameters be set: 101 102=over 4 103 104=item * progname 105 106The name of the program (or plug-in) performing the AudioScrobbler handshake. 107 108=item * progver 109 110The version of the program (or plug-in). 111 112=item * username 113 114The username of the user's AudioScrobbler registration. 115 116=back 117 118If the handshake is successful, the method returns a true value, and 119the L<submit> method may be invoked. Otherwise, an appropriate error 120message may be retrieved via the L<err> method. 121 122If the B<fake> configuration parameter is set, the L<handshake> method 123does not actually perform the handshake with the AudioScrobbler API, 124just simulates a successful handshake and returns a true value. 125 126If the B<verbose> configuration parameter is set, the L<handshake> 127method reports its progress with diagnostic messages to the standard output. 128 129=cut 130 131sub handshake($) 132{ 133 my ($self) = @_; 134 my ($ua, $req, $resp, $c, $s); 135 my (@lines); 136 137 delete $self->{'nexturl'}; 138 delete $self->{'md5ch'}; 139 140 $ua = $self->get_ua() or return undef; 141 $s = 'hs=true&p=1.1&c='. 142 URLEncode($self->{'cfg'}{'progname'}).'&v='. 143 URLEncode($self->{'cfg'}{'progver'}).'&u='. 144 URLEncode($self->{'cfg'}{'username'}); 145 print "RDBG about to send the handshake request: $s\n" 146 if $self->{'cfg'}{'verbose'}; 147 if ($self->{'cfg'}{'fake'}) { 148 print "RDBG faking it...\n" if $self->{'cfg'}{'verbose'}; 149 $self->{'md5ch'} = 'furrfu'; 150 $self->{'nexturl'} = 'http://furrfu.furrblah/furrquux'; 151 return 1; 152 } 153 $req = new HTTP::Request('GET', "http://post.audioscrobbler.com/?$s"); 154 if (!$req) { 155 $self->err('Could not create the handshake request object'); 156 return undef; 157 } 158 $resp = $ua->request($req); 159 print "RDBG resp is $resp, success is ".$resp->is_success()."\n" 160 if $self->{'cfg'}{'verbose'}; 161 if (!$resp) { 162 $self->err('Could not get a handshake response'); 163 return undef; 164 } elsif (!$resp->is_success()) { 165 $self->err('Could not complete the handshake: '. 166 $resp->status_line()); 167 return undef; 168 } 169 $c = $resp->content(); 170 print "RDBG resp content is:\n$c\nRDBG ====\n" 171 if $self->{'cfg'}{'verbose'}; 172 @lines = split /[\r\n]+/, $c; 173 $_ = $lines[0]; 174SWITCH: 175 { 176 /^FAILED\s+(.*)/ && do { 177 $self->err("Could not complete the handshake: $1"); 178 return undef; 179 }; 180 /^BADUSER\b/ && do { 181 $self->err('Could not complete the handshake: invalid username'); 182 return undef; 183 }; 184 /^UPTODATE\b/ && do { 185 $self->{'md5ch'} = $lines[1]; 186 $self->{'nexturl'} = $lines[2]; 187 last SWITCH; 188 }; 189 /^UPDATE\s+(.*)/ && do { 190 # See if we care. (FIXME) 191 $self->{'md5ch'} = $lines[1]; 192 $self->{'nexturl'} = $lines[2]; 193 last SWITCH; 194 }; 195 $self->err("Unrecognized handshake response: $_"); 196 return undef; 197 } 198 print "RDBG MD5 challenge '$self->{md5ch}', nexturl '$self->{nexturl}'\n" 199 if $self->{'cfg'}{'verbose'}; 200 return 1; 201} 202 203=item * submit ( info ) 204 205Submits a single track to the AudioScrobbler API. This method may only 206be invoked after a successful L<handshake>. The track information is 207contained in the hash referenced by the B<info> parameter; the following 208elements are used: 209 210=over 4 211 212=item * title 213 214The track's title. 215 216=item * artist 217 218The name of the artist performing the track. 219 220=item * length 221 222The duration of the track in seconds. 223 224=item * album 225 226The name of the album (optional). 227 228=back 229 230Also, the L<submit> method requires that the following configuration 231parameters be set for this C<Audio::Scrobbler> object: 232 233=over 4 234 235=item * username 236 237The username of the user's AudioScrobbler registration. 238 239=item * password 240 241The password for the AudioScrobbler registration. 242 243=back 244 245If the submission is successful, the method returns a true value. 246Otherwise, an appropriate error message may be retrieved via the L<err> 247method. 248 249If the B<fake> configuration parameter is set, the L<submit> method 250does not actually submit the track information to the AudioScrobbler API, 251just simulates a successful submission and returns a true value. 252 253If the B<verbose> configuration parameter is set, the L<submit> 254method reports its progress with diagnostic messages to the standard output. 255 256=cut 257 258sub submit($ \%) 259{ 260 my ($self, $info) = @_; 261 my ($ua, $req, $resp, $s, $c, $datestr, $md5resp); 262 my (@t, @lines); 263 264 # A couple of sanity checks - those never hurt 265 if (!defined($self->{'nexturl'}) || !defined($self->{'md5ch'})) { 266 $self->err('Cannot submit without a successful handshake'); 267 return undef; 268 } 269 if (!defined($info->{'title'}) || !defined($info->{'album'}) || 270 !defined($info->{'artist'}) || !defined($info->{'length'}) || 271 $info->{'length'} !~ /^\d+$/) { 272 $self->err('Missing or incorrect submission info fields'); 273 return undef; 274 } 275 276 # Init... 277 @t = gmtime(); 278 $datestr = sprintf('%04d-%02d-%02d %02d:%02d:%02d', 279 $t[5] + 1900, $t[4] + 1, @t[3, 2, 1, 0]); 280 # Let's hope md5_hex() always returns lowercase hex stuff 281 $md5resp = md5_hex( 282 md5_hex($self->{'cfg'}{'password'}).$self->{'md5ch'}); 283 284 # Let's roll? 285 $req = HTTP::Request->new('POST', $self->{'nexturl'}); 286 if (!$req) { 287 $self->err('Could not create the submission request object'); 288 return undef; 289 } 290 $req->content_type('application/x-www-form-urlencoded; charset="UTF-8"'); 291 $s = 'u='.URLEncode($self->{'cfg'}{'username'}). 292 "&s=$md5resp&a[0]=".URLEncode($info->{'artist'}). 293 '&t[0]='.URLEncode($info->{'title'}). 294 '&b[0]='.URLEncode($info->{'album'}). 295 '&m[0]='. 296 '&l[0]='.$info->{'length'}. 297 '&i[0]='.URLEncode($datestr). 298 "\r\n"; 299 $req->content($s); 300 print "RDBG about to send a submission request:\n".$req->content(). 301 "\n===\n" if $self->{'cfg'}{'verbose'}; 302 if ($self->{'cfg'}{'fake'}) { 303 print "RDBG faking it...\n" if $self->{'cfg'}{'verbose'}; 304 return 1; 305 } 306 307 $ua = $self->get_ua() or return undef; 308 $resp = $ua->request($req); 309 if (!$resp) { 310 $self->err('Could not get a submission response object'); 311 return undef; 312 } elsif (!$resp->is_success()) { 313 $self->err('Could not complete the submission: '. 314 $resp->status_line()); 315 return undef; 316 } 317 $c = $resp->content(); 318 print "RDBG response:\n$c\n===\n" if $self->{'cfg'}{'verbose'}; 319 @lines = split /[\r\n]+/, $c; 320 $_ = $lines[0]; 321SWITCH: 322 { 323 /^OK\b/ && last SWITCH; 324 /^FAILED\s+(.*)/ && do { 325 $self->err("Submission failed: $1"); 326 return undef; 327 }; 328 /^BADUSER\b/ && do { 329 $self->err('Incorrest username or password'); 330 return undef; 331 }; 332 $self->err('Unrecognized submission response: '.$_); 333 return undef; 334 } 335 print "RDBG submit() just fine and dandy!\n" 336 if $self->{'cfg'}{'verbose'}; 337 return 1; 338} 339 340=back 341 342There are also several methods and functions for the module's internal 343use: 344 345=over 4 346 347=item * get_ua () 348 349Creates or returns the cached C<LWP::UserAgent> object used by 350the C<Audio::Scrobbler> class for access to the AudioScrobbler API. 351 352=cut 353 354sub get_ua($) 355{ 356 my ($self) = @_; 357 my ($ua); 358 359 $self->{'ua'} ||= new LWP::UserAgent(); 360 if (!$self->{'ua'}) { 361 $self->err('Could not create a LWP UserAgent object'); 362 return undef; 363 } 364 $self->{'ua'}->agent('scrobbler-helper/1.0pre1 '. 365 $self->{'ua'}->_agent()); 366 return $self->{'ua'}; 367} 368 369=item * URLDecode (string) 370 371Decode a URL-encoded string. 372 373Obtained from http://glennf.com/writing/hexadecimal.url.encoding.html 374 375=cut 376 377sub URLDecode($) { 378 my $theURL = $_[0]; 379 $theURL =~ tr/+/ /; 380 $theURL =~ s/%([a-fA-F0-9]{2,2})/chr(hex($1))/eg; 381 $theURL =~ s/<!--(.|\n)*-->//g; 382 return $theURL; 383} 384 385=item * URLEncode (string) 386 387Return the URL-encoded representation of a string. 388 389Obtained from http://glennf.com/writing/hexadecimal.url.encoding.html 390 391=cut 392 393sub URLEncode($) { 394 my $theURL = $_[0]; 395 $theURL =~ s/([^a-zA-Z0-9_])/'%' . uc(sprintf("%2.2x",ord($1)));/eg; 396 return $theURL; 397} 398 399=back 400 401=head1 TODO 402 403=over 4 404 405=item * 406 407Do something with UPDATE responses to the handshake. 408 409=item * 410 411Honor INTERVAL in some way. 412 413=item * 414 415Figure out a way to cache unsuccesful submissions for later retrying. 416 417=item * 418 419Web services - stats! 420 421=back 422 423=head1 SEE ALSO 424 425B<scrobbler-helper(1)> 426 427=over 4 428 429=item * http://www.last.fm/ 430 431=item * http://www.audioscrobbler.com/ 432 433=item * http://www.audioscrobbler.net/ 434 435=back 436 437The home site of the C<Audio::Scrobbler> module is 438http://devel.ringlet.net/audio/Audio-Scrobbler/ 439 440=head1 AUTHOR 441 442Peter Pentchev, E<lt>roam@ringlet.netE<gt> 443 444=head1 COPYRIGHT AND LICENSE 445 446Copyright (C) 2005, 2006 by Peter Pentchev. 447 448This library is free software; you can redistribute it and/or modify 449it under the same terms as Perl itself, either Perl version 5.8.7 or, 450at your option, any later version of Perl 5 you may have available. 451 452$Id: Scrobbler.pm 88 2006-01-02 09:16:32Z roam $ 453 454=cut 455 4561; 457