Audio::Radio::Sirius - Control a Sirius satellite radio tuner

  use Audio::Radio::Sirius;
  use Win32::SerialPort; # or Device::SerialPort on Linux

  my $serial = new Win32::SerialPort('com1');
  my $tuner = new Audio::Radio::Sirius;

  $tuner->connect($serial);
  $tuner->power(1);
  $tuner->channel(184); # tune in the preview channel

  require Win32::SerialPort;

  my $serial_port = new Win32::SerialPort('com1');

  $tuner->connect($serial_port);

  $tuner->power(1); # Power on tuner.

  $tuner->gain(-6); # Mom's on the phone, turn down Howard Stern

  my $current_gain = $tuner->gain;

  my $result = $tuner->mute(0); # Unmute the tuner

  my $muted = $tuner->mute;

  my $current_channel = $tuner->channel;

  my $result = $tuner->channel(6, 1); # Tune to channel 7

  $tuner->channel(100); # Tune directly to channel 100

  $tuner->monitor(5); # spin 5 times

 $tuner->set_callback ('channel_update', \&channel);

 sub channel {
	my ($channel, $pid, $artist, $title, $composer) = @_;
	print "Channel $channel is now playing $title.\n";
 }

  $tuner->verbosity(1); #request all of these updates
  $current_verbosity=$tuner->verbosity;

package Audio::Radio::Sirius;

use 5.008;

use warnings;
use strict;

use Carp;
use Time::HiRes qw(sleep); # need to sleep for milliseconds in some receive loops

our $VERSION = '0.03';
our $AUTOLOAD;

our %DEFAULTS = (
	power 	=> 0,
	connected	=> 0,
	channel	=> 0,
	gain		=> 0,
	debug		=> 0,
	mute		=> 0,
	verbosity	=> 0,
	_sequence	=> 0,
	_serial	=> undef,
	_lastack	=> -1,
	_lastreq	=> -1,
	_callbacks	=> {
		'channel_update'	=> undef,
	},
	_buffer	=> '',
);

our %SETTABLE = (
	debug		=> 1,
);

our %COMMANDS = (
	poweroff		=> '000800',
	reset			=> '0009',
	poweron		=> '000803',
	volume		=> '0002',
	mute			=> '0003',
	channel		=> '000a', channel_suffix	=> '000b',
	request_signal	=> '4018',
	request_unkn1	=> '4017',
	request_sid		=> '4011',
	verbosity		=> '000d000000'
);

our %UPDATES = (
	'2008' 	=> {
		name		=> 'power',
		handler	=> undef
	},
	'2002'	=> {
		name		=> 'volume',
		handler	=> undef
	},
	'2003'	=> {
		name		=> 'mute',
		handler	=> undef
	},
	'200a'	=> {
		name		=> 'channel',
		handler	=> \&_channel_update,
		removefirst	=> 4
	},
	'200d'	=> {
		name		=> 'verbosity',
		handler	=> undef
	},
	'6011'	=> {
		name		=> 'reply_sid',
		handler	=> undef
	},
	'6017'	=> {
		name		=> 'reply_unkn1',
		handler	=> undef
	},
	'6018'	=> {
		name		=> 'reply_signal',
		handler	=> undef
	},
	'8001'	=> {
		name		=> 'channel_info',
		handler	=> \&_channel_item_update,
		removefirst	=> 2
	},
	'8002'	=> {
		# The way verbosity works now, we won't see PID info.  Verbosity must not include channel updates or it only sends those
		# (mostly because PIDs are part of channel updates).
		name		=> 'pid_info',
		handler	=> undef,
	},
	'8003'	=> {
		name		=> 'time_info',
		handler	=> \&_time_update,
		removefirst	=> 2
	},
	'8004'	=> {
		# 1 1 0 - acquiring signal
		# 1 0 0 - all's well
		# 2 1 0 - antenna disconnected
		# 2 0 1 - antenna back
		name		=> 'tuner_info',
		handler	=> undef,
		removefirst	=> 2
	},
	'8005'	=> {
		name		=> 'signal_info',
		handler	=> \&_signal_update,
		removefirst	=> 2
	},
);

our %TYPES = (
	command	=> '00',
	ack		=> '80',
	e_busy	=> '82',
	e_checksum	=> '83'
);

our %ITEM_TYPES = (
	0x1	=> 'artist',
	0x2	=> 'title',
	0x6	=> 'composer',
	0x86	=> 'pid'
);


our $START = 'a40300'; # Const that prefaces each command

 sub new {
 	my $class = shift;
	my $self = { %DEFAULTS };
	bless $self, $class;
 	return $self;
 }

sub AUTOLOAD {
	my $self = shift;
	my $type = ref($self) or croak "$self is not an object";

	my $name = $AUTOLOAD;
	$name =~ s/.*://; # Remove Audio::Radio::Sirius:: bit

	unless (exists $self->{$name}) { croak "$name is not a field in class $type"; }

	if (@_) {
		# setter
		if (defined($SETTABLE{$name}) ) { return $self->{$name} = shift; }
		else { croak "$name cannot be changed."; }
	} else {
		return $self->{$name};
	}
}

sub DESTROY {
	my $self = shift;

	if (defined($self->{_serial} )) {
		$self->{_serial}->close;
		undef $self->{_serial};
	}
}

sub connect {
	my $self = shift;
	if (!ref($self)) { croak "$self isn't an object"; }
	my ($connection) = @_;
	my $connectiontype = ref($connection);

	### TODO: switch to isa() here to allow derived classes
	if (($connectiontype eq "Win32::SerialPort")
		|| ($connectiontype eq "Device::SerialPort")) {
		$connection->baudrate(57600);
		$connection->parity('none');
		$connection->databits(8);
		$connection->stopbits(1);
		$connection->handshake('none');
#		$connection->read_const_time(150);
#		$connection->read_interval(50);
#		$connection->read_char_time(10);
#		$connection->write_char_time(10);
#		$connection->read_const_time(1000);
#		$connection->read_interval(5);
#		$connection->read_char_time(50);
#		$connection->write_char_time(0);
		if (!$connection->write_settings) {
			carp "Couldn't open connection: $_";
			return 0;
		}
		$self->{_serial} = $connection;
#		$self->_send_command($COMMANDS{'reset'});
#		if ( !$self->_send_command($COMMANDS{'poweroff'}) ) {
#			carp "Tuner didn't respond to poweroff command";
#			return 0;
#		}
		$self->{connected} = 1; # we're live
		return 1;
	} else {
		croak "Connect needs a Win32::SerialPort or a Device::SerialPort, got a $connectiontype";
	}
}

sub power {
### TODO: Needs accessor and turn off method
	my $self = shift;
	if (!ref($self)) { croak "$self isn't an object"; }
	my ($powerreq) = @_;

	if (!defined($powerreq)) { return $self->{'power'}; }
	if ($powerreq == 1) {
		my $current_gain = $self->{gain};
		my $current_mute = $self->{mute};
		if (!(
			$self->_send_command($COMMANDS{'reset'}) &&
			$self->_send_command($COMMANDS{'poweroff'}) &&
			$self->_send_command($COMMANDS{'poweron'}) &&
#			$self->_send_command('000c0000001700') && #useless
			$self->gain($current_gain) &&
			$self->_send_command($COMMANDS{'request_signal'}) &&
			$self->_send_command($COMMANDS{'request_sid'}) &&
			$self->mute($current_mute)
#			$self->{'power'} = 1
		)) {
			carp "Error - tuner failed to respond to power-up sequence.";
			return 0;
		}
	} else {
		$self->_send_command($COMMANDS{'poweroff'});
		$self->{'power'} = 0;
	}
}

sub gain {
	my $self = shift;
	if (!ref($self)) { croak "$self isn't an object"; }

	my ($gainreq) = @_;

	if (!defined($gainreq)) { return $self->{gain}; } # accessor

	# mutator
	if (!($gainreq <= 0) && ($gainreq >= -9)) {
		carp "Requested gain out of range: $gainreq.  Must be between -9 and 0.";
		return 0;
	}

	my $gainhex = $self->_num_to_signed_hex($gainreq);
	my $cmd = $COMMANDS{volume}.$gainhex;
	
	if (!$self->_send_command($cmd)) {
		carp "Tuner did not respond to gain setting.";
		return 0;
	}
	return 1;
}

sub mute {
	my $self = shift;
	if (!ref($self)) { croak "$self isn't an object"; }

	my ($mutereq) = @_;

	if (!defined($mutereq)) { return $self->{mute}; } # accessor

	if (!( ($mutereq == 0) || ($mutereq == 1) ) ) {
		carp "Mute must be either 0 or 1.";
		return 0;
	}

	my $mutehex = $self->_num_to_signed_hex($mutereq);
	my $cmd = $COMMANDS{'mute'} . $mutehex;
	if (!$self->_send_command($cmd)) {
		carp "Tuner did not respond to mute command.";
		return 0;
	}

	return 1;
}

sub channel {
	my $self = shift;
	if (!ref($self)) { croak "$self isn't an object"; }

	my ($chanreq, $offsetreq) = @_;
	my $offset = 0;

	if (!defined($chanreq)) { return $self->{channel}; } # accessor
	if (defined($offsetreq) && ($offsetreq =~ /0|1|-1/) ) { $offset = $offsetreq; }

	### TODO: Channel validation.

	# channel command: $COMMAND, channel, [0,1,-1], $COMMAND suffix
	my $chanhex = $self->_num_to_unsigned_hex($chanreq);
	my $offsethex = $self->_num_to_signed_hex($offset);
	my $cmd = $COMMANDS{channel} . $chanhex . $offsethex . $COMMANDS{channel_suffix};
	return $self->_send_command($cmd);	
}

sub monitor {
	my $self = shift;
	if (!ref($self)) { croak "$self isn't an object"; }

	my ($spins) = @_;

	if (!defined($spins)) { $spins = 1; }
	$spins = $spins * 20;
	foreach (1..$spins) {
		$self->_receive_if_waiting;
		sleep (.05); # chill .05 second
	}
}

sub set_callback {
	my $self = shift;
	if (!ref($self) eq 'CODE') { croak "$self isn't an object"; }
	my ($reqtype, $funcref) = @_;
	if (!ref $funcref) { croak "$funcref must be a reference to a function"; }
	if (!exists($DEFAULTS{'_callbacks'}{$reqtype}) ) { croak "$reqtype is not a supported update type"; }
	# validated enough for 'ya??

	$self->{'_callbacks'}{$reqtype} = $funcref;
}

sub verbosity {
	my $self = shift;
	if (!ref($self)) { croak "$self isn't an object"; }
	my ($verbreq) = @_;

	if (!defined($verbreq)) { return $self->{verbosity}; } # accessor
	if ($verbreq == 0) {
		# 0 = no verbosity, 1b = full verbosity
		my $cmd = $COMMANDS{verbosity}.'0000';
		$self->_send_command($cmd);
		$self->{verbosity} = $verbreq;
	}
	if ($verbreq == 1) {
		# 0 = no verbosity, 1b = full verbosity
#		my $cmd = $COMMANDS{verbosity}.'1b00';
		my $cmd = $COMMANDS{verbosity}.'1f00';
		$self->_send_command($cmd);
		$self->{verbosity} = $verbreq;
	}
}

sub _read {
	# _read works like read from $serial.  except better.
	# returns ($count, $data)
	# the tests for > 200000 check for the get_tick_count function wrapping
	# (happens every 43 days or something)
	my $self = shift;
	my ($count) = @_;
	my $debug = $self->{debug};
	my $serial = $self->{_serial};
	my $buffer = $self->{_buffer};
	my $buffer_count = length($buffer);

	my $data = '';
	my $data_count = 0;

	my $timeout = 100;
	my $start_ticks = $serial->get_tick_count;
	my $end_ticks = $start_ticks + $timeout;
	WAIT: while ( (($serial->status)[1] == 0) && ($buffer_count==0) ) { # loop while nothing is waiting
		if (($serial->get_tick_count > $end_ticks) || (($end_ticks - $serial->get_tick_count) > 200000)) {
			# last WAIT;
			return 0, $data; 
		}
		sleep .005;
		#print "hi $buffer_count\n";
	}

	# READ: while (($serial->status)[1] > 0) { # loop while data is waiting
	do {
		my $input = '';
		if ($buffer_count > 0) {
			$input = $buffer;
			$self->{_buffer} = '';
			$buffer_count = 0;
		}
		$input .= $serial->input;
		my $input_count = length($input);
		if ($input_count > 0) {
			$data .= $input;
			$data_count += $input_count;
			$end_ticks += 6; # bonus delay because we got something
		}
		sleep .001;
		#print "$data_count: $count\n";
	} until (($data_count >= $count) || ($serial->get_tick_count > $end_ticks) || 
		(($end_ticks - $serial->get_tick_count) > 200000)); 

	if ($data_count > $count) {
		$self->{_buffer} = substr($data, $count);
		return $count, substr($data, 0, $count);
	}
	#print "returning: $data\n";
	return $data_count, $data;
}

sub _receive_if_waiting {
	my $self = shift;
	if (!ref($self)) { croak "$self isn't an object"; }

	my $serial = $self->{_serial};
	my $waiting = ($serial->status)[1];
	if (defined($waiting) && $waiting > 6) { $self->_receive; }
}

sub _receive {
	my $self = shift;
	my $serial = $self->{_serial};
	my $debug = $self->{debug};
	READ: while (1) {
		#my ($headercount, $header) = $serial->read(6);
		my ($headercount, $header) = $self->_read(6);
		last READ if ($headercount == 0);
		if ($headercount < 6) {
			if ($debug) { 
				my $hexheader = $self->_pformat($header);
				print "Read error: headercount is $headercount: $hexheader\n"; 
			}
			next READ;
		}

		# handle escape escape in header (mostly)
		my $headerescapes  = $header =~ s/\x1b\x1b/\x1b/g;
		if ($headerescapes) { 
			# read even more
			if ($debug) { print "Fixing $headerescapes escape characters in header.\n"; }
			#my ($headercount2, $header2) = $serial->read($headerescapes);
			my ($headercount2, $header2) = $self->_read($headerescapes);
			next READ if ($headercount2 < $headerescapes); # :(
			$header .= $header2;
		}

		my ($start, $seq, $type, $length) = unpack('H6C1H2C1', $header);

		next READ if ($start ne $START); # oy
		
		# there's a special case that happens if length = 1b (the escape character).  we need to read 1 just to flush it.
		if ($length == 0x1b) {
			if ($debug) { print "Length 1b.  Flushing 1 character.\n"; }
			#$serial->read(1);
			$self->_read(1);
		}

		#my ($datacount, $data) = $serial->read($length+1); # read data and checksum
		my ($datacount, $data) = $self->_read($length+1); # read data and checksum
		next READ if ($datacount < $length + 1); # shouldn't happen
		# everything was read.
		# handle the escape character in the data sequence.  must be done before checksum.
		my $escapecount = $data =~ s/\x1b\x1b/\x1b/g;
		FIXESC: if ($escapecount) { 
			# read even more
			if ($debug) { print "Fixing $escapecount escape characters.\n"; }
			#my ($datacount2, $data2) = $serial->read($escapecount);
			my ($datacount2, $data2) = $self->_read($escapecount);
			next READ if ($datacount2 < $escapecount); # :(
			$data .= $data2;
			$escapecount = $data =~ s/\x1b\x1b/\x1b/g;
			if ($escapecount) { redo FIXESC; } # for the special times when we read more data due to escape chars and the data we read contains them... ugh
		}
		if ($debug >= 3) {print '<< '.$self->_pformat($header . $data)."\n"; }
		my $checksum = chop $data;
		my $calculated = $self->_checksum($header . $data);
		if ($calculated ne $checksum) {
			my ($calcval, $realval) = (ord($calculated), ord($checksum) );
			if ($debug) { print "Checksum didn't match - calc: $calcval act: $realval\n"; }
			$self->_send_checksum_error($seq);
			next READ; # this is also bad news :(
		}

		# start processing for real
		if ($type eq $TYPES{ack}) {
			$self->{_lastack} = $seq;
			if ($debug) { print "Got an ack for seq: $seq\n"; }
			next READ;
		}

		# ack it now before we go further.  the tuner is impatient.
		$self->_send_ack($seq);

		if ($type eq $TYPES{command}) {
			# did we get this already?
			if ($seq == $self->{_lastreq}) {
				# Tuner is repeating itself... This is bad.
				if ($debug > 2) { print "Not handling duplicate update seq $seq\n"; }
				next READ;
			}
			$self->{_lastreq} = $seq;
			# handle the update, then send an ack
			my $updatetype = unpack ('H4', $data);
			if (defined($UPDATES{$updatetype})) {
				# OK... I recognize this update.
				my $updatename = $UPDATES{$updatetype}{name};
				my $updatehandler = $UPDATES{$updatetype}{handler};
				if ($debug) {
					print "Received an update: $updatename\n";
				}
				if (defined($updatehandler)) {
					# some responses are identical but the identical part starts
					# somewhere after the command...  chop it off to the identical bits
					my $removefirst = $UPDATES{$updatetype}{removefirst};
					$data=substr($data,$removefirst);
					$self->$updatehandler($data);
				}
					
			} else {
				# unknown command.
				if ($debug) {
					my $datahex = $self->_pformat($data);
					print "Unknown update: $updatetype data: $datahex\n";
				}
			}
		}
	}
}

sub _channel_update {
	my $self = shift;
	my ($data) = @_;
	
	my ($channel, $categorynum, $shortchan, $longchan, $shortcat, $longcat);
	($channel, $categorynum, $shortchan, $longchan, $shortcat, $longcat, $data) = unpack ('C1xC1xxC1/aC/aC/aC/aa*', $data);

	$self->{channel} = $channel;

	$self->{categories}{$categorynum}{longname} = $longcat;
	$self->{categories}{$categorynum}{shortname} = $shortcat;
	$self->{channels}{$channel}{longname} = $longchan;
	$self->{channels}{$channel}{shortname} = $shortchan;

	$self->{channels}{$channel}{category} = $self->{categories}{$categorynum};
	$self->{categories}{$categorynum}{channels}{$channel} = $self->{channels}{$channel};

	# process left over items
	$self->_channel_items($channel, $data);

	# call handler
	$self->_call_channel_handler($channel);
}

sub _call_channel_handler {
	my $self = shift;
	my ($channel) = @_;

	# update handler: ($channel, $pid, $artist, $title, $composer)
	my $handler = $self->{'_callbacks'}{'channel_update'};
	if (ref($handler)) {
		&$handler (
			$channel,
			$self->{'channels'}{$channel}{'pid'},
			$self->{'channels'}{$channel}{'artist'},
			$self->{'channels'}{$channel}{'title'},
			$self->{'channels'}{$channel}{'composer'}
		);
	}
}

sub _signal_update {
	my $self = shift;
	my ($data) = @_;
	my $debug = $self->{debug};

	my ($overall, $sat, $terrestrial) = unpack ('CCC', $data);

	foreach my $signal ($overall, $sat, $terrestrial) {
		$signal = $signal * .33;
	}
	if ($debug>1) { print "Signal overall: $overall Sat: $sat Terrestrial: $terrestrial\n"; }
	$self->{signal}{overall} = $overall;
	$self->{signal}{sat} = $sat;
	$self->{signal}{terrestrial} = $terrestrial;
}

sub _time_update {
	my $self = shift;
	my ($data) = @_;
	my $debug = $self->{debug};

	my ($year, $month, $day, $hour, $minute, $second) = unpack ('nCCCCC', $data);
	if ($debug>1) { print "Time update: $year-$month-$day $hour:$minute:$second\n"; }

	# send to user functions as reverse list to conform with perl custom
}

sub _channel_item_update {
	my $self = shift;
	my ($data) = @_;

	my $channel;
	($channel, $data) = unpack ('C1a*', $data);
	$self->_channel_items($channel, $data);

	# call handler
	$self->_call_channel_handler($channel);
}

sub _channel_items {
	# multiple updates contain this stuff.  call this with $chan and $data.
	my $self = shift;
	my ($channel, $data) = @_;
	my $debug=$self->{debug};


	my $numitems;
	($numitems, $data) = unpack ('C1a*', $data);
	if ($numitems>0) {
		# there be items here
		# step 1 - clean out the old items
		foreach my $clean (values %ITEM_TYPES) {
			$self->{channels}{$channel}{$clean} = undef;
		}

		ITEM: foreach (1..$numitems) {
			my ($itemtype, $item, $typevar);
			($itemtype, $item, $data) = unpack ('C1C1/aa*', $data);
			$typevar = $ITEM_TYPES{$itemtype};
			if ($debug > 1) { print "Item type: $itemtype Info: $item\n"; }
			if (!defined($typevar)) {
				if ($debug) { print "Channel update contained unrecognized item: $itemtype: $item\n"; }
				next ITEM;
			}
			# store item
			$self->{channels}{$channel}{$typevar} = $item;
		}
	}
	my $remainder = length($data);
	if ($remainder > 0) { warn "Got a remainder when reading channel update."; }
}

sub _send_ack {
	my $self = shift;
	my ($seq) = @_;

	my $rawdata = pack('H6C1H2C1', $START, $seq, $TYPES{ack}, 0);
	my $checksum = $self->_checksum($rawdata);
	my $data = $rawdata.$checksum;
	if ($self->debug >= 3) {print '>> '.$self->_pformat($data)."\n"; }

	my $serial = $self->{_serial};
	my $count_out = $serial->write($data);
	warn "Not enough data written" unless ($count_out == length($data));
}

sub _send_checksum_error {
	my $self = shift;
	my ($seq) = @_;

	my $rawdata = pack('H6C1H2C1', $START, $seq, $TYPES{e_checksum}, 0);
	my $checksum = $self->_checksum($rawdata);
	my $data = $rawdata.$checksum;
	if ($self->debug >= 3) {print '>> '.$self->_pformat($data)."\n"; }

	my $serial = $self->{_serial};
	my $count_out = $serial->write($data);
	warn "Not enough data written" unless ($count_out == length($data));
}

sub _send_command {
	### TODO: Handle escape char (1B)
	# returns true/false results
	my $self = shift;
	my ($hexcommand) = @_;
	my $command = pack('H*', $hexcommand);
	my $cmdlength = length($command);
	my $sequence = $self->{_sequence};

	my $rawdata = pack('H6C1H2C1a*', $START, $sequence, $TYPES{command}, $cmdlength, $command);
	my $checksum = $self->_checksum($rawdata);
	# oddly enough the double escapes don't count as length.  don't change original length.
	my $data = pack('H6C1H2C1a*a1', $START, $sequence, $TYPES{command}, $cmdlength, $command, $checksum);

	# handle the escape character anywhere in the sent data.  must be done after checksum.
	$data =~ s/\x1b/\x1b\x1b/g;

	my $serial = $self->{_serial};

	my $attempts=0;
	SEND: foreach $attempts (1..5) {
		# send/retry logic
		if ($self->{debug}) { print "Sending command: $hexcommand sequence: $sequence\n"; }
		if ($self->debug >= 3) {print '>> '.$self->_pformat($data)."\n"; }
		$serial->write($data);
		$self->_receive;
		last SEND if ($self->{_lastack} == $sequence );
		# we're still here...  receiver is probably busy.  give it a bit.
		sleep(3);
	}

	$self->{_sequence} = ($self->{_sequence} + 1);
	if ($self->{_sequence} > 255) { $self->{_sequence} = 0; }
	
	if (($attempts == 3) && ($self->{lastack} != $sequence) ) {
		carp "Command not acknowledged by tuner after 3 attempts.";
		return 0;
	}
	return 1;
}


sub _checksum {
	# returns 1 byte (char) of checksum data
	# i can replace this with unpack.  just need to do the 256-result thing.
	# is there a bug here when $sum % 256 = 0?
	my $self = shift;
	my ($data) = @_;

	my $char;
	my $sum = 0;
	foreach $char (split(//, $data)) {
		$sum += ord($char);
	}
	if ( ($sum % 0x100) == 0) { return chr(0); }
	my $cs = 0x100 - ($sum % 0x100);
	return chr($cs);
}

sub _pformat {
	my $self = shift;
	my ($data) = @_;
	my $buffer = '';

	my $char;

	foreach $char (split(//, $data)) {
		$char = ord($char);
		if (($char >= 32) && ($char <= 126)) {
#			$buffer .= chr($char);
			$buffer .= sprintf ("0x%02x ", $char);
		} else {
			$buffer .= sprintf ("0x%02x ", $char);
		}
	}
	return $buffer;
}

sub _num_to_signed_hex {
	my $self = shift;
	my ($data) = @_;

	return (unpack('H2', pack ('c1', $data) ) );
}

sub _num_to_unsigned_hex {
	my $self = shift;
	my ($data) = @_;

	return (unpack('H2', pack ('C1', $data) ) );
}

1; # End of Audio::Radio::Sirius