view release on metacpan or  search on metacpan

lib/CDDB.pm  view on Meta::CPAN

package CDDB;
require 5.001;

use strict;
use vars qw($VERSION);
use Carp;

$VERSION = '1.220';

BEGIN {
	if ($^O eq 'MSWin32') {
		eval 'sub USING_WINDOWS () { 1 }';
	}
	else {
		eval 'sub USING_WINDOWS () { 0 }';
	}
}

use IO::Socket;
use Sys::Hostname;

# A list of known freedb servers.  I've stopped using Gracenote's CDDB
# because they never return my e-mail about becoming a developer.  To
# top it off, they've started denying CDDB.pm users.
# TODO: Fetch the list from freedb.freedb.org, which is a round-robin
# for all the others anyway.

my $cddbp_host_selector = 0;

my @cddbp_hosts = (
	[ 'localhost'         => 8880 ],
	[ 'freedb.freedb.org' => 8880 ],
	[ 'us.freedb.org',    => 8880 ],
	[ 'ca.freedb.org',    => 8880 ],
	[ 'ca2.freedb.org',   => 8880 ],
	[ 'uk.freedb.org'     => 8880 ],
	[ 'no.freedb.org'     => 8880 ],
	[ 'de.freedb.org'     => 8880 ],
	[ 'at.freedb.org'     => 8880 ],
	[ 'freedb.freedb.de'  => 8880 ],
);

#------------------------------------------------------------------------------
# Determine whether we can submit changes by e-mail.

my $imported_mail = 0;
eval {
	require Mail::Internet;
	require Mail::Header;
	require MIME::QuotedPrint;
	$imported_mail = 1;
};

#------------------------------------------------------------------------------
# Determine whether we can use HTTP for requests and submissions.

my $imported_http = 0;
eval {
	require LWP;
	require HTTP::Request;
	$imported_http = 1;
};

#------------------------------------------------------------------------------
# Send a command.  If we're not connected, try to connect first.
# Returns 1 if the command is sent ok; 0 if there was a problem.

sub command {
	my $self = shift;
	my $str = join(' ', @_);

	unless ($self->{handle}) {
		$self->connect() or return 0;
	}

	$self->debug_print(0, '>>> ', $str);

	my $len = length($str .= "\x0D\x0A");

	local $SIG{PIPE} = 'IGNORE' unless ($^O eq 'MacOS');
	return 0 unless(syswrite($self->{handle}, $str, $len) == $len);
	return 1;
}

#------------------------------------------------------------------------------
# Retrieve a line from the server.  Uses a buffer to allow for
# ungetting lines.  Returns the next line or undef if there is a
# problem.

sub getline {
	my $self = shift;

	if (@{$self->{lines}}) {
		my $line = shift @{$self->{lines}};
		$self->debug_print(0, '<<< ', $line);
		return $line;
	}

	my $socket = $self->{handle};
	return unless defined $socket;

	my $fd = fileno($socket);
	return unless defined $fd;

	vec(my $rin = '', $fd, 1) = 1;
	my $timeout = $self->{timeout} || undef;
	my $frame   = $self->{frame};

	until (@{$self->{lines}}) {

		# Fail if the socket is inactive for the timeout period.  Fail
		# also if sysread returns nothing.

		return unless select(my $rout=$rin, undef, undef, $timeout);
		return unless defined sysread($socket, my $buf='', 1024);

		$frame .= $buf;
		my @lines = split(/\x0D?\x0A/, $frame);
		$frame = (
			(length($buf) == 0 || substr($buf, -1, 1) eq "\x0A")