File Coverage

blib/lib/Device/Denon/DN1400F.pm

Criterion	Covered	Total	%
statement	24	238	10.0
branch	0	88	0.0
condition	0	2	0.0
subroutine	8	39	20.5
pod	0	26	0.0
total	32	393	8.1

package Device::Denon::DN1400F;

use 5.006;
use strict;
use vars qw(@ISA $VERSION @EXPORT_OK %EXPORT_TAGS %COMMANDS);
use warnings;
use Exporter;
use Data::Dumper;
use Device::SerialPort qw(:PARAM :STAT);
use Time::HiRes qw(usleep time);

@ISA = qw(Exporter);
@EXPORT_OK = qw();
%EXPORT_TAGS = ('all' => \@EXPORT_OK);
$VERSION = '0.02';

%COMMANDS = (
	MOVE_FRONT				=> {
			Command	=> [ qw(ID 0xb2) ],
			Answer	=> [ qw(0x80 ID) ],
			Busy	=> [ qw(INVD ID) ],
				},
	CLEAR_CHANGER_BUFFER	=> {
			Command	=> [ qw(ID 0xC0) ],
			Answer	=> [ qw(0x80 ID) ],
			Busy	=> [ qw(INVD ID) ],
				},
	_1BYTE_ERROR_CODE		=> {
			Command	=> [ qw(ID 0xC1) ],
			Answer	=> [ qw(ERR0 ID) ],
			Busy	=> [ qw(INVD ID) ],
				},
	_2BYTE_ERROR_CODE		=> {
			Command	=> [ qw(ID 0xC2) ],
			Answer	=> [ qw(ERR0 ERR1 ID) ],
			Busy	=> [ qw(INVD ID) ],
				},
	DISC_NUMBER				=> {
			Command	=> [ qw(ID 0xC3) ],
			Answer	=> [ qw(DNO_F DNO_R ID) ],
			Busy	=> [ qw(INVD ID) ],
				},
	SELECT_A_DISC			=> {
			Command	=> [ qw(ID 0xC4 DSCP DSCN DID) ],
			Answer	=> [ qw(CST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	RETURN_A_DISC			=> {
			Command	=> [ qw(ID 0xC5 DSCP DSCN DID) ],
			Answer	=> [ qw(CST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	RETURN_ALL_DISC			=> {
			Command	=> [ qw(ID 0xC6) ],
			Answer	=> [ qw(CST0 ID) ],
			Busy	=> [ qw(INVD ID) ],
				},
	RESET_DN_1400F			=> {
			Command	=> [ qw(ID 0xCA) ],
			Answer	=> [ qw() ],
			Busy	=> [ qw(INVD ID) ],
				},
	CHANGER_MICON_VERSION	=> {
			Command	=> [ qw(ID 0xCB 0x00) ],
			Answer	=> [ qw(VER0 VER1 ID) ],
			Busy	=> [ qw(INVD ID) ],
				},
	DISCNUMBER_CHANGER_STATUS=>{
			Command	=> [ qw(ID 0xCC) ],
			Answer	=> [ qw(DSCP_0 DSCN_0 CST0_0
							DSCP_1 DSCN_1 CST0_1 CST1 ID)],
			Busy	=> [ qw(INVD ID) ],
				},
	DRIVE_STATUS			=> {
			Command	=> [ qw(ID 0xCB DID) ],
			Answer	=> [ qw(DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	DRIVE_MICON_VERSION		=> {
			Command	=> [ qw(ID 0xD1 DID) ],
			Answer	=> [ qw(VER0 VER1 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	DRIVE_STATUS_SERVOONOFF	=> {
			Command	=> [ qw(ID 0xD2 DID) ],
			Answer	=> [ qw(DST0 DST1 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	SUB_CODE_QMODE3			=> {
			Command	=> [ qw(ID 0xD6 DID) ],
			Answer	=> [ qw(DST0 CTR_L),
						map{"ISRC_$_"}(0..7),
						qw(AFR_M ID DID)],
			Busy	=> [ qw(INVD ID DID) ],
				},
	SUB_CODE_QMODE2			=> {
			Command	=> [ qw(ID 0xD7 DID) ],
			Answer	=> [ qw(DST0 CTR_L),
						map{"UPC_$_"}(0..7),
						qw(AFR_M ID DID)],
			Busy	=> [ qw(INVD ID DID) ],
				},
	SUB_CODE_QCHANNEL		=> {
			Command	=> [ qw(ID 0xD9 DID) ],
			Answer	=> [ qw(DST0 CTRL TNO INX MIN SEC FRM 0x00
							AMIN ASEC AFRM ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	ALL_TOC_DATA			=> {
			Command	=> [ qw(ID 0xDA DID) ],
			Answer	=> [ qw(0xA0 PMIN 0x00 0x00 CTRL
							YADDA EOT 0x00
							YADDA DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
			Variable=> 1,
				},
	SHORT_TOC_DATA			=> {
			Command	=> [ qw(ID 0xDB DID) ],
			Answer	=> [ qw(0xA0 PMIN 0x00 0x00
							CTRL YADDA EOT DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
			Variable=> 1,
				},
	PLAY_AUDIO			=> {
			Command	=> [ qw(ID 0xE2 AMIN ASEC AFRM TNO INX MODE DID) ],
			Answer	=> [ qw(DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	AUDIO_SCAN			=> {
			Command	=> [ qw(ID 0xE3 AMIN ASEC AFRM TNO INX MODE DID) ],
			Answer	=> [ qw(DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	PAUSE					=> {
			Command	=> [ qw(ID 0xE5 MODE DID) ],	# Docs are buggy
			Answer	=> [ qw(DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	SEEK					=> {
			Command	=> [ qw(ID 0xE6 AMIN ASEC AFRM DID) ],
			Answer	=> [ qw(DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	STOP					=> {
			Command	=> [ qw(ID 0xE7 DID) ],
			Answer	=> [ qw(DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	# 25-26 reserved
	TRACK_SEARCH		=> {
			Command	=> [ qw(ID 0xEC AMIN ASEC AFRM TNO INX MODE DID) ],
			Answer	=> [ qw(DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	AUDIO_CHANNEL_CONTROL	=> {
			Command	=> [ qw(ID 0xED) ],
			Answer	=> [ qw(CST0 ID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	# 29 reserved
	FADE_INOUT_PLAY		=> {
			Command	=> [ qw(ID 0xF2 AMIN ASEC AFRM TNO INX MODE DID) ],
			Answer	=> [ qw(DST0 ID DID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
	SYSTEM_MICON_VERSION	=> {
			Command	=> [ qw(ID 0xF3) ],
			Answer	=> [ qw(VER0 VER1 ID) ],
			Busy	=> [ qw(INVD ID DID) ],
				},
		);


sub new {
	my $class = shift;
	my $self = ($#_ == 0) ? { %{ (shift) } } : { @_ };

	die "No SerialPort specified" unless $self->{SerialPort};

	# Device::SerialPort->debug(1);

	my $port = new Device::SerialPort(
					$self->{SerialPort},
					0,
					undef);
	die "Failed to open device $self->{SerialPort}" unless $port;

	$port->user_msg(1);
	$port->error_msg(1);
	# $port->debug(1);

	$port->baudrate(19200);
	$port->parity("even");
	$port->parity_enable("yes");
	$port->databits(8);
	$port->stopbits(1);
	$port->handshake("none");

	$port->write_settings or die "Failed to write settings\n";

	$port->status;

	$self->{Port} = $port;

	$self->{LastCommand} = time;

	return bless $self, $class;
}

sub commands {
	return keys(%COMMANDS);
}

sub _cmd {
	my $self = shift;
	my $command = shift;
	my $args = ($#_ == 0) ? { %{ (shift) } } : { @_ };

	# We can't send the commands to it too fast. It confuses it.
	while (time - $self->{LastCommand} < 0.2) {
		usleep(50);
	}
	$self->{LastCommand} = time;

	my $data = $COMMANDS{$command};
	die "No such command $command" unless $data;

	print "Executing command $command\n";

	my @template = @{ $data->{Command} };
	my @bytes = ();
	foreach (@template) {
		if ($_ =~ /^0x[[:xdigit:]]+$/) {
			push(@bytes, hex($_));
		}
		elsif ($_ eq 'ID') {
			push(@bytes, $self->{Id} + 0x50);
		}
		else {
			die "No value for required parameter $_"
							unless exists $args->{$_};
			print "$_ = $args->{$_}\n";
			push(@bytes, $args->{$_});
		}
	}

	my @hex = map { sprintf("%2.2x", $_) } @bytes;
	my $string = pack("C*", @bytes);
	my $count = $self->{Port}->write($string);
	print "<< @hex\n";
	die "Wrote only $count bytes" unless $count == length $string;

	return { } if $command eq 'RESET_DN_1400F';

	my $prefix;
	my $timer = 0;
	while (1) {
		usleep(10);
		($count, $prefix) = $self->{Port}->read(1);
		last if $count;
		die "Got no response to command!" if ++$timer > 100;
	}

	if ($prefix eq "\xdd") {
		print "Response is an error code.\n";
		@template = @{ $data->{Busy} };
	}
	else {
		@template = @{ $data->{Answer} };
	}

	my $readlength;
	if ($data->{Variable}) {
		# Wait long enough for the data to come down the line.
		usleep(400000);
		# Long enough for ALL_TOC_DATA. In theory we should read
		# and lex, rather than trying to slurp, then we would know
		# when the end of the data is.
		$readlength = 1000;
	}
	else {
		$readlength = scalar(@template) - 1;
	}

	($count, $string) = $self->{Port}->read($readlength);
	my @response = unpack("C*", $prefix . $string);

	@hex = map { sprintf("%2.2x", $_) } @response;
	print ">> @hex\n";

	# A slight kludge to get this out of the system.
	return { Data => \@response } if $data->{Variable};

	die "Reponse template not same size as response"
					unless @template == @response;

	my %out = map { $template[$_] => $response[$_] } (0..$#template);
	return \%out;
}

sub command {
	my $self = shift;
	my $response = $self->_cmd(@_);
	$self->print_response($response);
	return $response;
}

my %ID = map { $_ + 0x50 => "Unit $_" } (0..15);

my %CST0 = (
	0x80	=> "Command complete, reception normally completed.",
	0x81	=> "No Disc",
	0x82	=> "Busy, Disc transport section is in disc transport processing",
	0x83	=> "Completed Disc Set with No Error",
	0x84	=> "Reserved",
	0x85	=> "Reserved",
	0x86	=> "Reserved",
	0x8A	=> "Initial Busy, After power on and Reset DN-1400F",
	0x8B	=> "Changer Error",
	0x8C	=> "Disc Rack in not set",
	0x8E	=> "Wait transportation",
	0x8F	=> "Changer Error",
	0xDD	=> "INVD, Command Busy or Invalid Command",
		);

my %DST0 = (
	0xB0	=> "Ready, Reception normally completed.",
	0xB1	=> "Fade In / Out Play, In the process of fade in/out play",
	0xB2	=> "Seek, In the process of search.",
	0xB3	=> "Reserved",
	0xB4	=> "Pause, Pause condition during audio play.",
	0xB5	=> "Scan, In the process of scan play execution.",
	0xB6	=> "Play, In the process of audio play.",
	0xB7	=> "Reserved",
	0xB8	=> "Disc Change. Disc has been changed.",
	0xB9	=> "No Disc, Disc is not set in the disc loading section.",
	0xBA	=> "Reserved",
	0xBB	=> "Seek Error",
	0xBC	=> "EOT: End of TOC",
	0xBF	=> "CD-ROM Data Area",
	0xD0	=> "RAM Error (CD-DRIVE Hardware Error)",
	0xD1	=> "FOK Error (CD-DRIVE Hardware Error)",
	0xD2	=> "FZC Error (CD-DRIVE Hardware Error)",
	0xD3	=> "GFS Error (CD-DRIVE Hardware Error)",
	0xD5	=> "Slide Error (CD-DRIVE Hardware Error)",
	0xD6	=> "Eject Sequence Error (CD-DRIVE Hardware Error)",
	0xD7	=> "Gain Control Error (CD-DRIVE Hardware Error)",
	0xD8	=> "Reserved",
	0xD9	=> "Reserved",
	0xDA	=> "Reserved",
	0xDB	=> "Invalid Command or Invalid Parameter",
	0xDC	=> "Invalid Parameter",
	0xDD	=> "INVD: Command busy or Invalid Command.",
		);

my %DST1 = (
	0x00	=> "Servo off",
	0x01	=> "Servo on",
		);

my %DID = (
	0x00	=> "Drive 1: Front",
	0x01	=> "Drive 2: Rear",
		);

my %ERR = (
	0x00	=> "No error",
		);

sub print_response_item {
	my ($self, $response, $key, $values) = @_;
	if (exists $response->{$key}) {
		my $value = $values
				? ($values->{$response->{$key}} || "VALUE UNKNOWN!")
				: $response->{$key};
		print "* $key: " .
				sprintf("%x", $response->{$key}) . " : $value\n";
		delete $response->{$key};
	}
}

sub print_response {
	my ($self, $response) = @_;

	my %copy = %$response;
	$self->print_response_item(\%copy, "ID", \%ID);
	$self->print_response_item(\%copy, "DID", \%DID);
	$self->print_response_item(\%copy, "CST0", \%CST0);
	$self->print_response_item(\%copy, "DST0", \%DST0);
	$self->print_response_item(\%copy, "DST1", \%DST1);
	$self->print_response_item(\%copy, "DID", \%DID);
	$self->print_response_item(\%copy, "ERR0", \%ERR);
	$self->print_response_item(\%copy, "ERR1", \%ERR);
	foreach (keys %copy) {
		if ($_ =~ /^0x/) {
			if (hex($_) != $response->{$_}) {
				print "Expected $_, got " .
								sprintf("%2.2x\n", $response->{$_});
			}
		}
		else {
			$self->print_response_item(\%copy, $_, undef);
		}
	}
}

sub _dscpn {
	my $discno = shift;

	my ($dscp, $dscn);

	if ($discno < 0) {
		die "Invalid disc number $discno\n";
	}
	elsif ($discno <= 50) {
		$dscp = 0;
		$dscn = $discno - 1;
	}
	elsif ($discno <= 100) {
		$dscp = 1;
		$dscn = $discno - 51;
	}
	elsif ($discno <= 150) {
		$dscp = 2;
		$dscn = $discno - 101;
	}
	elsif ($discno <= 200) {
		$dscp = 3;
		$dscn = $discno - 151;
	}
	else {
		die "Invalid disc number $discno\n";
	}

	return ($dscp, $dscn);
}

sub _discno {
	my ($dscp, $dscn) = @_;
	return -1 if $dscp == 255;
	return $dscp * 50 + $dscn + 1;
}

sub _from_bcd {
	my $val = shift;
	return 0+ sprintf("%x", $val);
}

# Interpreting a number as hex essentially codes it as BCD.
sub _to_bcd {
	my $val = shift;
	return hex($val);
}

sub move_front {
	my ($self) = @_;
	return $self->command('MOVE_FRONT');
}

sub clear_changer_buffer {
	my ($self) = @_;
	return $self->command('CLEAR_CHANGER_BUFFER');
}

sub debug {
	my ($self) = @_;
	$self->command('_1BYTE_ERROR_CODE');
	$self->command('_2BYTE_ERROR_CODE');
}

sub loaded_discs {
	my ($self) = @_;
	my $response = $self->command('DISC_NUMBER');
	return ($response->{DNO_F}, $response->{DNO_R});
}

sub load_disc {
	my ($self, $drive, $discno, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	($args->{DSCP}, $args->{DSCN}) = _dscpn($discno);
	return $self->command('SELECT_A_DISC', $args);
}

sub unload_disc {
	my ($self, $drive, $discno, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	($args->{DSCP}, $args->{DSCN}) = _dscpn($discno);
	return $self->command('RETURN_A_DISC', $args);
}

sub unload_discs {
	my ($self) = @_;
	return $self->command('RETURN_ALL_DISC');
}

sub reset {
	my ($self) = @_;
	return $self->command('RESET_DN_1400F');
}

# Calling this immediately after loaded_discs barfs. Firmware bug?
sub changer_version {
	my ($self) = @_;
	# This command seems to be broken on mine.
	my $response = $self->command('CHANGER_MICON_VERSION');
	return ($response->{VER0}, $response->{VER1})
}

sub status {
	my ($self) = @_;
	# This command seems to be broken on mine.
	my $response = $self->command('DISCNUMBER_CHANGER_STATUS');
	return {
				Disc0	=> _discno($response->{DSCP_0},
									$response->{DSCN_0}),
				Disc1	=> _discno($response->{DSCP_1},
									$response->{DSCN_1}),
				Status0	=> $CST0{$response->{CST0_0}},
				Status1	=> $CST0{$response->{CST0_1}},
					};
}

# As far as I can work out, the firmware on this one is buggy too.
sub drive_status {
	my ($self, $drive, $args) = @_;
	die "Buggy firmware in the drive_status command.";
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	my $response = $self->command('DRIVE_STATUS', $args);
}

sub drive_version {
	my ($self, $drive, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	my $response = $self->command('DRIVE_MICON_VERSION', $args);
}

sub drive_status_servo_onoff {
	my ($self, $drive, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	my $response = $self->command('DRIVE_STATUS_SERVOONOFF', $args);
}

sub drive_subcode_qchannel {
	my ($self, $drive, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	my $response = $self->command('SUB_CODE_QCHANNEL', $args);
	return {
		Status		=> $DST0{$response->{DST0}},
		QControl	=> $response->{CTRL} >> 4,
		QAddress	=> $response->{CTRL} & 0xf,
		Track		=> _from_bcd($response->{TNO}),
		Index		=> _from_bcd($response->{INX}),
		Minute		=> _from_bcd($response->{MIN}),
		Second		=> _from_bcd($response->{SEC}),
		Frame		=> _from_bcd($response->{FRM}),
		AbsoluteMinute	=> _from_bcd($response->{AMIN}),
		AbsoluteSecond	=> _from_bcd($response->{ASEC}),
		AbsoluteFrame	=> _from_bcd($response->{AFRM}),
			};
}

sub toc_data_long {
	my ($self, $drive, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	my $response = $self->command('ALL_TOC_DATA', $args);
	return $response->{Data};
}

sub toc_data_short {
	my ($self, $drive, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	my $response = $self->command('SHORT_TOC_DATA', $args);
	return $response->{Data};
}

sub drive_play {
	my ($self, $drive, $track, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	$args->{TNO} = _to_bcd($track);
	$args->{MODE} = 0x29;
	$args->{INX} = 1;	# What is this?
	foreach (qw(AMIN ASEC AFRM)) {
		$args->{$_} = 0 unless exists $args->{$_};
	}
	return $self->command('PLAY_AUDIO', $args);
}

sub drive_scan {
	my ($self, $drive, $track, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	$args->{TNO} = _to_bcd($track);
	$args->{MODE} = 0x29;
	$args->{INX} = 1;	# What is this?
	foreach (qw(AMIN ASEC AFRM)) {
		$args->{$_} = 0 unless exists $args->{$_};
	}
	return $self->command('AUDIO_SCAN', $args);
}

sub drive_pause {
	my ($self, $drive, $mode, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	$args->{MODE} = $mode ? 0x01 : 0x00;
	return $self->command('PAUSE', $args);
}

sub drive_stop {
	my ($self, $drive, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	return $self->command('STOP', $args);
}

sub drive_search {
	my ($self, $drive, $track, $args) = @_;
	$args = {} unless ref($args) eq 'HASH';
	$args->{DID} = $drive;
	$args->{TNO} = _to_bcd($track);
	$args->{MODE} = 0x29;
	$args->{INX} = 1;	# What is this?
	foreach (qw(AMIN ASEC AFRM)) {
		$args->{$_} = 0 unless exists $args->{$_};
	}
	return $self->command('TRACK_SEARCH', $args);
}

1;

__END__