File Coverage

blib/lib/CDDB.pm

Criterion	Covered	Total	%
statement	339	394	86.0
branch	111	210	52.8
condition	8	17	47.0
subroutine	28	29	96.5
pod	13	22	59.0
total	499	672	74.2

# Documentation and Copyright exist after __END__

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")
			? ''
			: pop(@lines)
		);
		push @{$self->{lines}}, map { decode('utf8', $_) } @lines;
	}

	$self->{frame} = $frame;

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

#------------------------------------------------------------------------------
# Receive a server response, and parse it into its numeric code and
# text message.  Return the code's first character, which usually
# indicates the response class (ok, error, information, warning,
# etc.).  Returns undef on failure.

sub response {
	my $self = shift;
	my ($code, $text);

	my $str = $self->getline();

	return unless defined($str);

	# Fail if the line we get isn't the proper format.
	return unless ( ($code, $text) = ($str =~ /^(\d+)\s*(.*?)\s*$/) );

	$self->{response_code} = $code;
	$self->{response_text} = $text;
	substr($code, 0, 1);
}

#------------------------------------------------------------------------------
# Accessors to retrieve the last response() call's code and text
# separately.

sub code {
	my $self = shift;
	$self->{response_code};
}

sub text {
	my $self = shift;
	$self->{response_text};
}

#------------------------------------------------------------------------------
# Helper to print stuff for debugging.

sub debug_print {
	my $self = shift;

	# Don't bother if not debugging.
	return unless $self->{debug};

	my $level = shift;
	my $text = join('', @_);
	print STDERR $text, "\n";
}

#------------------------------------------------------------------------------
# Read data until it's terminated by a single dot on its own line.
# Two dots at the start of a line are replaced by one.  Returns an
# ARRAY reference containing the lines received, or undef on error.

sub read_until_dot {
	my $self = shift;
	my @lines;

	while ('true') {
		my $line = $self->getline() or return;
		last if ($line =~ /^\.$/);
		$line =~ s/^\.\././;
		push @lines, $line;
	}

	\@lines;
}

#------------------------------------------------------------------------------
# Create an object to represent one or more cddbp sessions.

sub new {
	my $type = shift;
	my %param = @_;

	# Attempt to suss our hostname.
	my $hostname = &hostname();

	# Attempt to suss our login ID.
	my $login = $param{Login} || $ENV{LOGNAME} || $ENV{USER};
	if (not defined $login) {
		if (USING_WINDOWS) {
			carp(
				"Can't get login ID.  Use Login parameter or " .
				"set LOGNAME or USER environment variable.  Using default login " .
				"ID 'win32usr'"
			);
			$login = 'win32usr';
		}
		else {
			$login = getpwuid($>)
				or croak(
					"Can't get login ID.  " .
					"Set LOGNAME or USER environment variable and try again: $!"
				);
		}
	}

	# Debugging flag.
	my $debug = $param{Debug};
	$debug = 0 unless defined $debug;

	# Choose a particular cddbp host.
	my $host = $param{Host};
	$host = '' unless defined $host;

	# Choose a particular cddbp port.
	my $port = $param{Port};
	$port = 8880 unless $port;

	# Choose a particular cddbp submission address.
	my $submit_to = $param{Submit_Address};
	$submit_to = '[e-mail]' unless defined $submit_to;

	# Change the cddbp client name.
	my $client_name = $param{Client_Name};
	$client_name = 'CDDB.pm' unless defined $client_name;

	# Change the cddbp client version.
	my $client_version = $param{Client_Version};
	$client_version = $VERSION unless defined $client_version;

	# Whether to use utf-8 for submission
	my $utf8 = $param{Utf8};
	$utf8 = 1 unless defined $utf8;
	if ($utf8) {
		eval {
			require Encode;
			import Encode;
		};
		if ( $@ ) {
			carp 'Unable to load the Encode module, falling back to ascii';
			$utf8 = 0;
		}
	}

	eval 'sub encode { $_[1] };sub decode { $_[1] }' unless $utf8;

	# Change the cddbp protocol level.
	my $cddb_protocol = $param{Protocol_Version};
	$cddb_protocol = ($utf8 ? 6 : 1) unless defined $cddb_protocol;
	carp <
You have requested protocol level $cddb_protocol. However,
utf-8 support is only available starting from level 6
EOF

	# Mac Freaks Got Spaces!  Augh!
	$login =~ s/\s+/_/g;

	my $self = bless {
		hostname      => $hostname,
		login         => $login,
		mail_from     => undef,
		mail_host     => undef,
		libname       => $client_name,
		libver        => $client_version,
		cddbmail      => $submit_to,
		debug         => $debug,
		host          => $host,
		port          => $port,
		cddb_protocol => $cddb_protocol,
		utf8          => $utf8,
		lines         => [],
		frame         => '',
		response_code => '000',
		response_text => '',
	}, $type;

	$self;
}

#------------------------------------------------------------------------------
# Disconnect from a cddbp server.  This is needed sometimes when a
# server decides a session has performed enough requests.

sub disconnect {
	my $self = shift;
	if ($self->{handle}) {
		$self->command('quit');     # quit
		$self->response();          # wait for any response
		delete $self->{handle};     # close the socket
	}
	else {
		$self->debug_print( 0, '--- disconnect on unconnected handle' );
	}
}

#------------------------------------------------------------------------------
# Connect to a cddbp server.  Connecting and disconnecting are done
# transparently and are performed on the basis of need.  Furthermore,
# this routine will cycle through servers until one connects or it has
# exhausted all its possibilities.  Returns true if successful, or
# false if failed.

sub connect {
	my $self = shift;
	my $cddbp_host;

	# Try to get our hostname yet again, in case it failed during the
	# constructor call.
	unless (defined $self->{hostname}) {
		$self->{hostname} = &hostname() or croak "can't get hostname: $!";
	}

	# The handshake loop tries to complete an entire connection
	# negociation.  It loops until success, or until HOST returns
	# because all the hosts have failed us.

	HANDSHAKE: while ('true') {

		# Loop through the CDDB protocol hosts list up to twice in order
		# to find a server that will respond.  This implements a 2x retry.

		HOST: for (1..(@cddbp_hosts * 2)) {

			# Hard disconnect here to prevent recursion.
			delete $self->{handle};

			($self->{host}, $self->{port}) = @{$cddbp_hosts[$cddbp_host_selector]};

			# Assign the host we selected, and attempt a connection.
			$self->debug_print(
				0,
				"=== connecting to $self->{host} port $self->{port}"
			);
			$self->{handle} = new IO::Socket::INET(
				PeerAddr => $self->{host},
				PeerPort => $self->{port},
				Proto    => 'tcp',
				Timeout  => 30,
			);

			# The host did not answer.  Clean up after the failed attempt
			# and cycle to the next host.
			unless (defined $self->{handle}) {
				$self->debug_print(
					0,
					"--- error connecting to $self->{host} port $self->{port}: $!"
				);

				delete $self->{handle};
				$self->{host} = $self->{port} = '';

				# Try the next host in the list.  Wrap if necessary.
				$cddbp_host_selector = 0 if ++$cddbp_host_selector > @cddbp_hosts;

				next HOST;
			}

			# The host accepted our connection.  We'll push it back on the
			# list of known cddbp hosts so it can be tried later.  And we're
			# done with the host list cycle for now.
			$self->debug_print(
				0,
				"+++ successfully connected to $self->{host} port $self->{port}"
			);

			last HOST;
		}

		# Tried the whole list twice without success?  Time to give up.
		unless (defined $self->{handle}) {
			$self->debug_print( 0, "--- all cddbp servers failed to answer" );
			warn "No cddb protocol servers answer.  Is your network OK?\n"
				unless $self->{debug};
			return;
		}

		# Turn off buffering on the socket handle.
		select((select($self->{handle}), $|=1)[0]);

		# Get the server's banner message.  Try reconnecting if it's bad.
		my $code = $self->response();
		if ($code != 2) {
			$self->debug_print(
				0, "--- bad cddbp response: ",
				$self->code(), ' ', $self->text()
			);
			next HANDSHAKE;
		}

		# Say hello, and wait for a response.
		$self->command(
			'cddb hello',
			 $self->{login}, $self->{hostname},
			 $self->{libname}, $self->{libver}
		);
		$code = $self->response();
		if ($code == 4) {
			$self->debug_print(
				0, "--- the server denies us: ",
				$self->code(), ' ', $self->text()
			);
			return;
		}
		if ($code != 2) {
			$self->debug_print(
				0, "--- the server didn't handshake: ",
				$self->code(), ' ', $self->text()
			);
			next HANDSHAKE;
		}

		# Set the protocol level.
		if ($self->{cddb_protocol} != 1) {
			$self->command( 'proto', $self->{cddb_protocol} );
			$code = $self->response();
			if ($code != 2) {
				$self->debug_print(
					0, "--- can't set protocol level ",
					$self->{cddb_protocol}, ' ',
					$self->code(), ' ', $self->text()
				);
				return;
			}
		}

		# If we get here, everything succeeded.
		return 1;
	}
}

# Destroying the cddbp object disconnects from the server.

sub DESTROY {
	my $self = shift;
	$self->disconnect();
}

###############################################################################
# High-level cddbp functions.

#------------------------------------------------------------------------------
# Get a list of available genres.  Returns an array of genre names, or
# undef on failure.

sub get_genres {
	my $self = shift;
	my @genres;

	$self->command('cddb lscat');
	my $code = $self->response();
	return unless $code;

	if ($code == 2) {
		my $genres = $self->read_until_dot();
		return @$genres if defined $genres;
		return;
	}

	$self->debug_print(
		0, '--- error listing categories: ',
		$self->code(), ' ', $self->text()
	);
	return;
}

#------------------------------------------------------------------------------
# Calculate a cddbp ID based on a text table of contents.  The text
# format was chosen because it was straightforward and easy to
# generate.  In a scalar context, this returns just the cddbp ID.  In
# a list context it returns several things: a listref of track
# numbers, a listref of track lengths (MM:SS format), a listref of
# track offsets (in seconds), and the disc's total playing time in
# seconds.  In either context it returns undef on failure.

sub calculate_id {
	my $self = shift;
	my @toc = @_;

	my (
		$seconds_previous, $seconds_first, $seconds_last, $cddbp_sum,
		@track_numbers, @track_lengths, @track_offsets,
	);

	foreach my $line (@toc) {
		my ($track, $mm_begin, $ss_begin, $ff_begin) = split(/\s+/, $line, 4);
		my $frame_offset = (($mm_begin * 60 + $ss_begin) * 75) + $ff_begin;
		my $seconds_begin = int($frame_offset / 75);

		if (defined $seconds_previous) {
			my $elapsed = $seconds_begin - $seconds_previous;
			push(
				@track_lengths,
				sprintf("%02d:%02d", int($elapsed / 60), $elapsed % 60)
			);
		}
		else {
			$seconds_first = $seconds_begin;
		}

		# Track 999 was chosen for the lead-out information.
		if ($track == 999) {
			$seconds_last = $seconds_begin;
			last;
		}

		# Track 1000 was chosen for error information.
		if ($track == 1000) {
			$self->debug_print( 0, "error in TOC: $ff_begin" );
			return;
		}

		map { $cddbp_sum += $_; } split(//, $seconds_begin);
		push @track_offsets, $frame_offset;
		push @track_numbers, sprintf("%03d", $track);
		$seconds_previous = $seconds_begin;
	}

	# Calculate the ID.  Whee!
	my $id = sprintf(
		"%02x%04x%02x",
		($cddbp_sum % 255),
		$seconds_last - $seconds_first,
		 scalar(@track_offsets)
	);

	# In list context, we return several things.  Some of them are
	# useful for generating filenames or playlists (the padded track
	# numbers).  Others are needed for cddbp queries.
	return (
		$id, \@track_numbers, \@track_lengths, \@track_offsets, $seconds_last
	) if wantarray();

	# Just return the cddbp ID in scalar context.
	return $id;
}

#------------------------------------------------------------------------------
# Parse cdinfo's output so calculate_id() can eat it.

sub parse_cdinfo {
	my ($self, $command) = @_;
	open(FH, $command) or croak "could not open `$command': $!";

	my @toc;
	while () {
		if (/(\d+):\s+(\d+):(\d+):(\d+)/) {
			my @track = ($1,$2,$3,$4);
			$track[0] = 999 if /leadout/;
			push @toc, "@track";
		}
	}
	close FH;
	return @toc;
}

#------------------------------------------------------------------------------
# Get a list of discs that match a particular CD's table of contents.
# This accepts the TOC information as returned by calculate_id().  It
# will also accept information in mp3 format, but I forget what that
# is.  Pudge asked for it, so he'd know.

sub get_discs {
	my $self = shift;
	my ($id, $offsets, $total_seconds) = @_;

	# Accept the TOC in CDDB.pm format.
	my ($track_count, $offsets_string);
	if (ref($offsets) eq 'ARRAY') {
		$track_count = scalar(@$offsets);
		$offsets_string = join ' ', @$offsets;
	}

	# Accept the TOC in mp3 format, for pudge.
	else {
		$offsets =~ /^(\d+?)\s+(.*)$/;
		$track_count = $1;
		$offsets_string = $2;
	}

	# Make repeated attempts to query the server.  I do this to drive
	# the hidden server cycling.
	my $code;

	ATTEMPT: while ('true') {

		# Send a cddbp query command.
		$self->command(
			'cddb query', $id, $track_count,
			$offsets_string, $total_seconds
		) or return;

		# Get the response.  Try again if the server is temporarly
		# unavailable.
		$code = $self->response();
		next ATTEMPT if $self->code() == 417;
		last ATTEMPT;
	}

	# Return undef if there's a problem.
	return unless defined $code and $code == 2;

	# Single matching disc.
	if ($self->code() == 200) {
		my ($genre, $cddbp_id, $title) = (
			$self->text() =~ /^(\S+)\s*(\S+)\s*(.*?)\s*$/
		);
		return [ $genre, $cddbp_id, $title ];
	}

	# No matching discs.
	return if $self->code() == 202;

	# Multiple matching discs.
	# 210 Found exact matches, list follows (...)   [proto>=4]
	# 211 Found inexact matches, list follows (...) [proto>=1]
	if ($self->code() == 210 or $self->code() == 211) {
		my $discs = $self->read_until_dot();
		return unless defined $discs;

		my @matches;
		foreach my $disc (@$discs) {
			my ($genre, $cddbp_id, $title) = ($disc =~ /^(\S+)\s*(\S+)\s*(.*?)\s*$/);
			push(@matches, [ $genre, $cddbp_id, $title ]);
		}

		return @matches;
	}

	# What the heck?
	$self->debug_print(
		0, "--- unknown cddbp response: ",
		$self->code(), ' ', $self->text()
	);
	return;
}

#------------------------------------------------------------------------------
# A little helper to combine list-context calculate_id() with
# get_discs().

sub get_discs_by_toc {
	my $self = shift;
	my (@info, @discs);
	if (@info = $self->calculate_id(@_)) {
		@discs = $self->get_discs(@info[0, 3, 4]);
	}
	@discs;
}

#------------------------------------------------------------------------------
# A little helper to get discs from an existing query string.
# Contributed by Ron Grabowski.

sub get_discs_by_query {
	my ($self, $query) = @_;
	my (undef, undef, $cddbp_id, $tracks, @offsets) = split /\s+/, $query;
	my $total_seconds = pop @offsets;
	my @discs = $self->get_discs($cddbp_id, \@offsets, $total_seconds);
	return @discs;
}

#------------------------------------------------------------------------------
# Retrieve the database record for a particular genre/id combination.
# Returns a moderately complex hashref representing the cddbp record,
# or undef on failure.

sub get_disc_details {
	my $self = shift;
	my ($genre, $id) = @_;

	# Because cddbp only allows one detail query per connection, we
	# force a disconnect/reconnect here if we already did one.
	if (exists $self->{'got tracks before'}) {
		$self->disconnect();
		$self->connect() or return;
	}
	$self->{'got tracks before'} = 'yes';

	$self->command('cddb read', $genre, $id);
	my $code = $self->response();
	if ($code != 2) {
		$self->debug_print(
			0, "--- cddbp host could not read the disc record: ",
			$self->code(), ' ', $self->text()
		);
		return;
	}

	my $track_file;
	unless (defined($track_file = $self->read_until_dot())) {
		$self->debug_print( 0, "--- cddbp disc record interrupted" );
		return;
	}

	# Parse that puppy.
	return parse_xmcd_file($track_file, $genre);
}

# Arf!

sub parse_xmcd_file {
	my ($track_file, $genre) = @_;

	my %details = (
		offsets => [ ],
		seconds => [ ],
	);
	my $state = 'beginning';
	foreach my $line (@$track_file) {
		# Keep returned so-called xmcd record...
		$details{xmcd_record} .= $line . "\n";

		if ($state eq 'beginning') {
			if ($line =~ /track\s*frame\s*off/i) {
				$state = 'offsets';
			}
			next;
		}

		if ($state eq 'offsets') {
			if ($line =~ /^\#\s*(\d+)/) {
				push @{$details{offsets}}, $1;
				next;
			}
			$state = 'headers';
			# This passes through on purpose.
		}

		# This is not an elsif on purpose.
		if ($state eq 'headers') {
			if ($line =~ /^\#/) {
				$line =~ s/\s+/ /g;
				if (my ($header, $value) = ($line =~ /^\#\s*(.*?)\:\s*(.*?)\s*$/)) {
					$details{lc($header)} = $value;
				}
				next;
			}
			$state = 'data';
			# This passes through on purpose.
		}

		# This is not an elsif on purpose.
		if ($state eq 'data') {
			next unless (
				my ($tag, $idx, $val) = ($line =~ /^\s*(.+?)(\d*)\s*\=\s*(.+?)\s*$/)
			);
			$tag = lc($tag);

			if ($idx ne '') {
				$tag .= 's';
				$details{$tag} = [ ] unless exists $details{$tag};
				$details{$tag}->[$idx] .= $val;
				$details{$tag}->[$idx] =~ s/^\s+//;
				$details{$tag}->[$idx] =~ s/\s+$//;
				$details{$tag}->[$idx] =~ s/\s+/ /g;
			}
			else {
				$details{$tag} .= $val;
				$details{$tag} =~ s/^\s+//;
				$details{$tag} =~ s/\s+$//;
				$details{$tag} =~ s/\s+/ /g;
			}
		}
	}

	# Translate disc offsets into seconds.  This builds a virtual track
	# 0, which is the time from the beginning of the disc to the
	# beginning of the first song.  That time's used later to calculate
	# the final track's length.

	my $last_offset = 0;
	foreach (@{$details{offsets}}) {
		push @{$details{seconds}}, int(($_ - $last_offset) / 75);
		$last_offset = $_;
	}

	# Create the final track length from the disc length.  Remove the
	# virtual track 0 in the process.

	my $disc_length = $details{"disc length"};
	$disc_length =~ s/ .*$//;

	my $first_start = shift @{$details{seconds}};
	push(
		@{$details{seconds}},
		$disc_length - int($details{offsets}->[-1] / 75) + 1 - $first_start
	);

	# Add the genre, if we have it.
	$details{genre} = $genre;

	return \%details;
}

###############################################################################
# Evil voodoo e-mail submission stuff.

#------------------------------------------------------------------------------
# Return true/false whether the libraries needed to submit discs are
# present.

sub can_submit_disc {
	my $self = shift;
	$imported_mail;
}

#------------------------------------------------------------------------------
# Build an e-mail address, and return it.  Caches the last built
# address, and returns that on subsequent calls.

sub get_mail_address {
	my $self = shift;
	return $self->{mail_from} if defined $self->{mail_from};
	return $self->{mail_from} = $self->{login} . '@' . $self->{hostname};
}

#------------------------------------------------------------------------------
# Build an e-mail host, and return it.  Caches the last built e-mail
# host, and returns that on subsequent calls.

sub get_mail_host {
	my $self = shift;

	return $self->{mail_host} if defined $self->{mail_host};

	if (exists $ENV{SMTPHOSTS}) {
		$self->{mail_host} = $ENV{SMTPHOSTS};
	}
	elsif (defined inet_aton('mail')) {
		$self->{mail_host} = 'mail';
	}
	else {
		$self->{mail_host} = 'localhost';
	}
	return $self->{mail_host};
}

# Build a cddbp disc submission and try to e-mail it.

sub submit_disc {
	my $self = shift;
	my %params = @_;

	croak(
		"submit_disc needs Mail::Internet, Mail::Header, and MIME::QuotedPrint"
	) unless $imported_mail;

	# Try yet again to fetch the hostname.  Fail if we cannot.
	unless (defined $self->{hostname}) {
		$self->{hostname} = &hostname() or croak "can't get hostname: $!";
	}

	# Validate the required submission fields.  XXX Duplicated code.
	(exists $params{Genre})       or croak "submit_disc needs a Genre";
	(exists $params{Id})          or croak "submit_disc needs an Id";
	(exists $params{Artist})      or croak "submit_disc needs an Artist";
	(exists $params{DiscTitle})   or croak "submit_disc needs a DiscTitle";
	(exists $params{TrackTitles}) or croak "submit_disc needs TrackTitles";
	(exists $params{Offsets})     or croak "submit_disc needs Offsets";
	(exists $params{Revision})    or croak "submit_disc needs a Revision";
	if (exists $params{Year}) {
		unless ($params{Year} =~ /^\d{4}$/) {
			croak "submit_disc needs a 4 digit year";
		}
	}
	if (exists $params{GenreLong}) {
		unless ($params{GenreLong} =~ /^([A-Z][a-zA-Z0-9]*\s?)+$/) {
			croak(
				"GenreLong must start with a capital letter and contain only " .
				"letters and numbers"
			);
		}
	}

	# Try to find a mail host.  We could probably grab the MX record for
	# the current machine, but that would require yet more strange
	# modules.  TODO: Use Net::DNS if it's available (why not?) and just
	# bypass it if it isn't installed.

	$self->{mail_host} = $params{Host} if exists $params{Host};
	my $host = $self->get_mail_host();

	# Override the sender's e-mail address with whatever was specified
	# during the object's constructor call.
	$self->{mail_from} = $params{From} if exists $params{From};
	my $from = $self->get_mail_address();

	# Build the submission's headers.
	my $header = new Mail::Header;
	$header->add( 'MIME-Version' => '1.0' );
	my $charset = $self->{'utf8'} ? 'utf-8' : 'iso-8859-1';
	$header->add( 'Content-Type' => "text/plain; charset=$charset" );
	$header->add( 'Content-Disposition' => 'inline' );
	$header->add( 'Content-Transfer-Encoding' => 'quoted-printable' );
	$header->add( From    => $from );
	$header->add( To      => $self->{cddbmail} );
	# send a copy to ourselves if we are debugging
	$header->add( Cc => $from ) if $self->{debug};
	$header->add( Subject => "cddb $params{Genre} $params{Id}" );

	# Build the submission's body.
	my @message_body = (
		'# xmcd',
		'#',
		'# Track frame offsets:',
		map({ "#\t" . $_; } @{$params{Offsets}}),
		'#',
		'# Disc length: ' . (hex(substr($params{Id},2,4))+2) . ' seconds',
		'#',
		"# Revision: " . $params{Revision},
		'# Submitted via: ' . $self->{libname} . ' ' . $self->{libver},
		'#',
		'DISCID=' . $params{Id},
		'DTITLE=' . $params{Artist} . ' / ' . $params{DiscTitle},
	);

	# add year and genre
	if (exists $params{Year}) {
		push @message_body, 'DYEAR='.$params{Year};
	}
	if (exists $params{GenreLong}) {
		push @message_body, 'DGENRE='.$params{GenreLong};
	}

	# Dump the track titles.
	my $number = 0;
	foreach my $title (@{$params{TrackTitles}}) {
		my $copy = $title;
		while ($copy ne '') {
			push( @message_body, 'TTITLE' . $number . '=' . substr($copy, 0, 69));
			substr($copy, 0, 69) = '';
		}
		$number++;
	}

	# Dump extended information.
	push @message_body, 'EXTD=';
	push @message_body, map { "EXTT$_="; } (0..--$number);
	push @message_body, 'PLAYORDER=';

	# Translate the message body to quoted printable.  TODO: How can I
	# ensure that the quoted printable characters are within ISO-8859-1?
	# The cddbp submissions daemon will barf if it's not.
	foreach my $line (@message_body) {
		$line .= "\n";
		$line = MIME::QuotedPrint::encode_qp(encode('utf8', $line));
	}

	# Bundle the headers and body into an Internet mail.
	my $mail = new Mail::Internet(
		undef,
		Header => $header,
		Body   => \@message_body,
	);

	# Try to send it using the "mail" utility.  This is commented out:
	# it strips the MIME headers from the message, invalidating the
	# submission.

	#eval {
	#  die unless $mail->send( 'mail' );
	#};
	#return 1 unless $@;

	# Try to send it using "sendmail".
	eval {
		die unless $mail->send( 'sendmail' );
	};
	return 1 unless $@;

	# Try to send it by making a direct SMTP connection.
	eval {
		die unless $mail->send( smtp => Server => $host );
	};
	return 1 unless $@;

	# Augh!  Everything failed!
	$self->debug_print( 0, '--- could not find a way to submit a disc' );
	return;
}

1;

__END__