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