| File: | lib/Device/Onkyo.pm |
| Coverage: | 80.4% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | 4 4 4 | 5.32774469359453e+15 33 324 | use strict; | ||||
| 2 | 4 4 4 | 48 20 532 | use warnings; | ||||
| 3 | package Device::Onkyo; | ||||||
| 4 | |||||||
| 5 | 4 4 4 | 49 26 751 | use Carp qw/croak carp/; | ||||
| 6 | 4 4 4 | 1712 243422 3697 | use Device::SerialPort qw/:PARAM :STAT 0.07/; | ||||
| 7 | 4 4 4 | 68 21 3497 | use Fcntl; | ||||
| 8 | 4 4 4 | 2004 15727 612 | use IO::Select; | ||||
| 9 | 4 4 4 | 1278 7184 8446 | use Socket; | ||||
| 10 | 4 4 4 | 71 19 680 | use Symbol qw(gensym); | ||||
| 11 | 4 4 4 | 1949 11777 112 | use Time::HiRes; | ||||
| 12 | |||||||
| 13 | use constant { | ||||||
| 14 | 4 | 26695 | DEBUG => $ENV{DEVICE_ONKYO_DEBUG}, | ||||
| 15 | 4 4 | 1294 24 | }; | ||||
| 16 | |||||||
| 17 | # ABSTRACT: Perl module to control Onkyo/Intregra AV equipment | ||||||
| 18 | |||||||
| 19 - 41 | =head1 SYNOPSIS
my $onkyo = Device::Onkyo->new(device => 'discover');
$onkyo->power('on'); # switch on
$onkyo = Device::Onkyo->new(device => '/dev/ttyS0');
$onkyo->write('PWR01'); # switch on
while (1) {
my $message = $onkyo->read();
print $message, "\n";
}
$onkyo = Device::Onkyo->new(device => 'hostname:port');
$onkyo->write('PWR01'); # switch on
=head1 DESCRIPTION
Module for controlling Onkyo/Intregra AV equipment.
B<IMPORTANT:> This is an early release and the API is still subject to
change. The serial port usage is entirely untested.
=cut | ||||||
| 42 | |||||||
| 43 | sub new { | ||||||
| 44 | 4 | 1760528 | my ($pkg, %p) = @_; | ||||
| 45 | 4 | 600 | my $self = bless { | ||||
| 46 | _buf => '', | ||||||
| 47 | _q => [], | ||||||
| 48 | type => 'eISCP', | ||||||
| 49 | port => 60128, | ||||||
| 50 | baud => 9600, | ||||||
| 51 | discard_timeout => 1, | ||||||
| 52 | %p | ||||||
| 53 | }, $pkg; | ||||||
| 54 | 4 | 162 | unless (exists $p{filehandle}) { | ||||
| 55 | 2 | 110 | croak $pkg.q{->new: 'device' parameter is required} | ||||
| 56 | unless (exists $p{device}); | ||||||
| 57 | 1 | 68 | $self->_open(); | ||||
| 58 | } | ||||||
| 59 | 3 | 89 | $self; | ||||
| 60 | } | ||||||
| 61 | |||||||
| 62 | 0 | 0 | sub baud { shift->{baud} } | ||||
| 63 | |||||||
| 64 | 3 | 5797 | sub port { shift->{port} } | ||||
| 65 | |||||||
| 66 | 3 | 132 | sub filehandle { shift->{filehandle} } | ||||
| 67 | |||||||
| 68 | sub _open { | ||||||
| 69 | 1 | 22 | my $self = shift; | ||||
| 70 | 1 | 77 | if ($self->{device} =~ m![/\\]!) { | ||||
| 71 | 0 | 0 | $self->_open_serial_port(@_); | ||||
| 72 | } else { | ||||||
| 73 | 1 | 66 | if ($self->{device} eq 'discover') { | ||||
| 74 | 1 | 53 | $self->{device} = $self->discover; | ||||
| 75 | } | ||||||
| 76 | 1 | 17 | $self->_open_tcp_port(@_); | ||||
| 77 | } | ||||||
| 78 | } | ||||||
| 79 | |||||||
| 80 | sub _open_tcp_port { | ||||||
| 81 | 1 | 8 | my $self = shift; | ||||
| 82 | 1 | 21 | my $dev = $self->{device}; | ||||
| 83 | 1 | 6 | print STDERR "Opening $dev as tcp socket\n" if DEBUG; | ||||
| 84 | 1 1 | 27 83 | require IO::Socket::INET; import IO::Socket::INET; | ||||
| 85 | 1 | 2562 | if ($dev =~ s/:(\d+)$//) { | ||||
| 86 | 1 | 37 | $self->{port} = $1; | ||||
| 87 | } | ||||||
| 88 | 1 | 13 | my $fh = IO::Socket::INET->new($dev.':'.$self->port) or | ||||
| 89 | croak "TCP connect to '$dev' failed: $!"; | ||||||
| 90 | 1 | 1465 | return $self->{filehandle} = $fh; | ||||
| 91 | } | ||||||
| 92 | |||||||
| 93 | sub _open_serial_port { | ||||||
| 94 | 0 | 0 | my $self = shift; | ||||
| 95 | 0 | 0 | $self->{type} = 'ISCP'; | ||||
| 96 | 0 | 0 | my $fh = gensym(); | ||||
| 97 | 0 | 0 | my $s = tie (*$fh, 'Device::SerialPort', $self->{device}) || | ||||
| 98 | croak "Could not tie serial port to file handle: $!\n"; | ||||||
| 99 | 0 | 0 | $s->baudrate($self->baud); | ||||
| 100 | 0 | 0 | $s->databits(8); | ||||
| 101 | 0 | 0 | $s->parity("none"); | ||||
| 102 | 0 | 0 | $s->stopbits(1); | ||||
| 103 | 0 | 0 | $s->datatype("raw"); | ||||
| 104 | 0 | 0 | $s->write_settings(); | ||||
| 105 | |||||||
| 106 | 0 | 0 | sysopen($fh, $self->{device}, O_RDWR|O_NOCTTY|O_NDELAY) or | ||||
| 107 | croak "open of '".$self->{device}."' failed: $!\n"; | ||||||
| 108 | 0 | 0 | $fh->autoflush(1); | ||||
| 109 | 0 | 0 | return $self->{filehandle} = $fh; | ||||
| 110 | } | ||||||
| 111 | |||||||
| 112 | sub read { | ||||||
| 113 | 4 | 14349 | my ($self, $timeout) = @_; | ||||
| 114 | 4 | 56 | my $res = $self->read_one(\$self->{_buf}); | ||||
| 115 | 4 | 94 | return $res if (defined $res); | ||||
| 116 | 2 | 29 | $self->_discard_buffer_check(\$self->{_buf}) if ($self->{_buf} ne ''); | ||||
| 117 | 2 | 22 | my $fh = $self->filehandle; | ||||
| 118 | 2 | 71 | my $sel = IO::Select->new($fh); | ||||
| 119 | 2 | 354 | do { | ||||
| 120 | 2 | 26 | my $start = $self->_time_now; | ||||
| 121 | 2 | 56 | $sel->can_read($timeout) or return; | ||||
| 122 | 2 | 306 | my $bytes = sysread $fh, $self->{_buf}, 2048, length $self->{_buf}; | ||||
| 123 | 2 | 22 | $self->{_last_read} = $self->_time_now; | ||||
| 124 | 2 | 51 | $timeout -= $self->{_last_read} - $start if (defined $timeout); | ||||
| 125 | 2 | 675 | croak defined $bytes ? 'closed' : 'error: '.$! unless ($bytes); | ||||
| 126 | 1 | 16 | $res = $self->read_one(\$self->{_buf}); | ||||
| 127 | 1 | 12 | $self->_write_now() if (defined $res); | ||||
| 128 | 1 | 44 | return $res if (defined $res); | ||||
| 129 | } while (1); | ||||||
| 130 | } | ||||||
| 131 | |||||||
| 132 | sub read_one { | ||||||
| 133 | 6 | 65 | my ($self, $rbuf, $no_write) = @_; | ||||
| 134 | 6 | 75 | return unless ($$rbuf); | ||||
| 135 | |||||||
| 136 | 4 | 24 | print STDERR "rbuf=", (unpack "H*", $$rbuf), "\n" if DEBUG; | ||||
| 137 | |||||||
| 138 | 4 | 50 | if ($self->{type} eq 'eISCP') { | ||||
| 139 | 2 | 18 | my $length = length $$rbuf; | ||||
| 140 | 2 | 36 | return unless ($length >= 16); | ||||
| 141 | 2 | 119 | my ($magic, $header_size, | ||||
| 142 | $data_size, $version, $res1, $res2, $res3) = unpack 'a4 N N C4', $$rbuf; | ||||||
| 143 | 2 | 43 | croak "Unexpected magic: expected 'ISCP', got '$magic'\n" | ||||
| 144 | unless ($magic eq 'ISCP'); | ||||||
| 145 | 2 | 28 | return unless ($length >= $header_size+$data_size); | ||||
| 146 | 2 | 28 | substr $$rbuf, 0, $header_size, ''; | ||||
| 147 | 2 | 25 | carp(sprintf "Unexpected version: expected '0x01', got '0x%02x'\n", | ||||
| 148 | $version) unless ($version == 0x01); | ||||||
| 149 | 2 | 32 | carp(sprintf "Unexpected header size: expected '0x10', got '0x%02x'\n", | ||||
| 150 | $header_size) unless ($header_size == 0x10); | ||||||
| 151 | 2 | 21 | my $body = substr $$rbuf, 0, $data_size, ''; | ||||
| 152 | 2 | 29 | my $sd = substr $body, 0, 2, ''; | ||||
| 153 | 2 | 56 | $body =~ s/[\032\r\n]+$//; | ||||
| 154 | 2 | 26 | carp "Unexpected start/destination: expected '!1', got '$sd'\n" | ||||
| 155 | unless ($sd eq '!1'); | ||||||
| 156 | 2 | 38 | $self->_write_now unless ($no_write); | ||||
| 157 | 2 | 28 | return $body; | ||||
| 158 | } else { | ||||||
| 159 | 2 | 118 | return unless ($$rbuf =~ s/^(..)(....*?)[\032\r\n]+//); | ||||
| 160 | 2 | 38 | my ($sd, $body) = ($1, $2); | ||||
| 161 | 2 | 23 | carp "Unexpected start/destination: expected '!1', got '$sd'\n" | ||||
| 162 | unless ($sd eq '!1'); | ||||||
| 163 | 2 | 25 | $self->_write_now unless ($no_write); | ||||
| 164 | 2 | 20 | return $body; | ||||
| 165 | } | ||||||
| 166 | } | ||||||
| 167 | |||||||
| 168 | sub _time_now { | ||||||
| 169 | 5 | 167 | Time::HiRes::time | ||||
| 170 | } | ||||||
| 171 | |||||||
| 172 | # 4953 4350 0000 0010 0000 000b 0100 0000 ISCP............ | ||||||
| 173 | # 2178 4543 4e51 5354 4e0d 0a !xECNQSTN\r\n | ||||||
| 174 | |||||||
| 175 | sub discover { | ||||||
| 176 | 1 | 31 | my $self = shift; | ||||
| 177 | 1 | 22 | my $s; | ||||
| 178 | 1 | 307 | socket $s, PF_INET, SOCK_DGRAM, getprotobyname('udp'); | ||||
| 179 | 1 | 17 | setsockopt $s, SOL_SOCKET, SO_BROADCAST, 1; | ||||
| 180 | 1 | 70 | binmode $s; | ||||
| 181 | 1 | 106 | bind $s, sockaddr_in(0, inet_aton('0.0.0.0')); | ||||
| 182 | 1 | 105 | send($s, | ||||
| 183 | pack("a* N N N a*", | ||||||
| 184 | 'ISCP', 0x10, 0xb, 0x01000000, "!xECNQSTN\r\n"), | ||||||
| 185 | 0, | ||||||
| 186 | sockaddr_in($self->port, inet_aton('255.255.255.255'))); | ||||||
| 187 | 1 | 207 | my $sel = IO::Select->new($s); | ||||
| 188 | 1 | 334 | $sel->can_read(10) or die; | ||||
| 189 | 1 | 289 | my $sender = recv $s, my $buf, 2048, 0; | ||||
| 190 | 1 | 41 | croak 'error: '.$! unless (defined $sender); | ||||
| 191 | |||||||
| 192 | 1 | 119 | my ($port, $addr) = sockaddr_in($sender); | ||||
| 193 | 1 | 106 | my $ip = inet_ntoa($addr); | ||||
| 194 | 1 | 8 | my $b = $buf; | ||||
| 195 | 1 | 101 | my $msg = $self->read_one(\$b, 1); # don't uncork writes | ||||
| 196 | 1 | 38 | ($port) = ($msg =~ m!/(\d{5})/../[0-9a-f]{12}!i); | ||||
| 197 | 1 | 7 | print STDERR "discovered: $ip:$port (@$msg)\n" if DEBUG; | ||||
| 198 | 1 | 10 | $self->{port} = $port; | ||||
| 199 | 1 | 203 | return $ip.':'.$port; | ||||
| 200 | } | ||||||
| 201 | |||||||
| 202 | sub write { | ||||||
| 203 | 1 | 12 | my ($self, $cmd, $cb) = @_; | ||||
| 204 | 1 | 25 | print STDERR "queuing: $cmd\n" if DEBUG; | ||||
| 205 | 1 | 13 | my $str = $self->pack($cmd); | ||||
| 206 | 1 1 | 9 17 | push @{$self->{_q}}, [$str, $cmd, $cb]; | ||||
| 207 | 1 | 37 | $self->_write_now unless ($self->{_waiting}); | ||||
| 208 | 1 | 46 | 1; | ||||
| 209 | } | ||||||
| 210 | |||||||
| 211 | sub _write_now { | ||||||
| 212 | 5 | 34 | my $self = shift; | ||||
| 213 | 5 5 | 26 44 | my $rec = shift @{$self->{_q}}; | ||||
| 214 | 5 | 40 | my $wait_rec = delete $self->{_waiting}; | ||||
| 215 | 5 | 51 | if ($wait_rec) { | ||||
| 216 | 0 | 0 | $wait_rec->[1]->() if ($wait_rec->[1]); | ||||
| 217 | } | ||||||
| 218 | 5 | 50 | return unless (defined $rec); | ||||
| 219 | 1 | 13 | $self->_real_write(@$rec); | ||||
| 220 | 1 | 33 | $self->{waiting} = [ $self->_time_now, $rec ]; | ||||
| 221 | } | ||||||
| 222 | |||||||
| 223 | sub _real_write { | ||||||
| 224 | 1 | 13 | my ($self, $str, $desc, $cb) = @_; | ||||
| 225 | 1 | 60 | print STDERR "sending: $desc\n ", (unpack "H*", $str), "\n" if DEBUG; | ||||
| 226 | 1 | 23 | syswrite $self->filehandle, $str, length $str; | ||||
| 227 | } | ||||||
| 228 | |||||||
| 229 | sub pack { | ||||||
| 230 | 1 | 9 | my $self = shift; | ||||
| 231 | 1 | 15 | my $d = '!1'.$_[0]; | ||||
| 232 | 1 | 17 | if ($self->{type} eq 'eISCP') { | ||||
| 233 | # 4953 4350 0000 0010 0000 000a 0100 0000 ISCP............ | ||||||
| 234 | # 2131 4d56 4c32 381a 0d0a !1MVL28... | ||||||
| 235 | # 4953 4350 0000 0010 0000 000a 0100 0000 ISCP............ | ||||||
| 236 | # 2131 4d56 4c32 381a 0d0a | ||||||
| 237 | 1 | 10 | $d .= "\r"; | ||||
| 238 | 1 | 27 | pack("a* N N N a*", | ||||
| 239 | 'ISCP', 0x10, (length $d), 0x01000000, $d); | ||||||
| 240 | } else { | ||||||
| 241 | 0 | 0 | $d .= "\r\n"; | ||||
| 242 | } | ||||||
| 243 | } | ||||||
| 244 | |||||||
| 245 | sub canon_command { | ||||||
| 246 | 326 | 1641 | my $str = shift; | ||||
| 247 | 326 | 1830 | $str =~ tr/A-Z/a-z/; | ||||
| 248 | 326 | 1589 | $str =~ s/(?:question|query|qstn)/?/g; | ||||
| 249 | 326 | 1248 | $str =~ s/^master\ //g; | ||||
| 250 | 326 | 1500 | $str =~ s/volume/vol/g; | ||||
| 251 | 326 | 1260 | $str =~ s/centre/center/g; | ||||
| 252 | 326 | 1347 | $str =~ s/up/+/g; | ||||
| 253 | 326 | 1282 | $str =~ s/down/-/g; | ||||
| 254 | 326 | 3647 | $str =~ s/\s+//g; | ||||
| 255 | 326 | 3947 | $str; | ||||
| 256 | } | ||||||
| 257 | |||||||
| 258 | our %command_map = | ||||||
| 259 | ( | ||||||
| 260 | 'power on' => 'PWR01', | ||||||
| 261 | 'power off' => 'PWR00', | ||||||
| 262 | 'power standby' => 'PWR00', | ||||||
| 263 | 'power?' => 'PWRQSTN', | ||||||
| 264 | 'mute' => 'AMT00', | ||||||
| 265 | 'unmute' => 'AMT01', | ||||||
| 266 | 'toggle mute' => 'AMTTG', | ||||||
| 267 | 'mute?' => 'AMTQSTN', | ||||||
| 268 | 'speaker a on' => 'SPA01', | ||||||
| 269 | 'speaker a off' => 'SPA00', | ||||||
| 270 | 'toggle speaker a' => 'SPAUP', | ||||||
| 271 | 'speaker a?' => 'SPAQSTN', | ||||||
| 272 | 'speaker b on' => 'SPB01', | ||||||
| 273 | 'speaker b off' => 'SPB00', | ||||||
| 274 | 'toggle speaker b' => 'SPBUP', | ||||||
| 275 | 'speaker b?' => 'SPBQSTN', | ||||||
| 276 | 'volume+' => 'MVLUP', | ||||||
| 277 | 'volume-' => 'MVLDOWN', | ||||||
| 278 | 'volume?' => 'MVLQSTN', | ||||||
| 279 | |||||||
| 280 | 'front bass+' => 'TFRBUP', | ||||||
| 281 | 'front bass-' => 'TFRBDOWN', | ||||||
| 282 | 'front treble+' => 'TFRTUP', | ||||||
| 283 | 'front treble-' => 'TFRTDOWN', | ||||||
| 284 | 'front tone?' => 'TFRQSTN', | ||||||
| 285 | |||||||
| 286 | 'front wide bass+' => 'TFWBUP', | ||||||
| 287 | 'front wide bass-' => 'TFWBDOWN', | ||||||
| 288 | 'front wide treble+' => 'TFWTUP', | ||||||
| 289 | 'front wide treble-' => 'TFWTDOWN', | ||||||
| 290 | 'front wide tone?' => 'TFWQSTN', | ||||||
| 291 | |||||||
| 292 | 'front high bass+' => 'TFHBUP', | ||||||
| 293 | 'front high bass-' => 'TFHBDOWN', | ||||||
| 294 | 'front high treble+' => 'TFHTUP', | ||||||
| 295 | 'front high treble-' => 'TFHTDOWN', | ||||||
| 296 | 'front high tone?' => 'TFHQSTN', | ||||||
| 297 | |||||||
| 298 | 'center bass+' => 'TCTBUP', | ||||||
| 299 | 'center bass-' => 'TCTBDOWN', | ||||||
| 300 | 'center treble+' => 'TCTTUP', | ||||||
| 301 | 'center treble-' => 'TCTTDOWN', | ||||||
| 302 | 'center tone?' => 'TCTQSTN', | ||||||
| 303 | |||||||
| 304 | 'surround bass+' => 'TSRBUP', | ||||||
| 305 | 'surround bass-' => 'TSRBDOWN', | ||||||
| 306 | 'surround treble+' => 'TSRTUP', | ||||||
| 307 | 'surround treble-' => 'TSRTDOWN', | ||||||
| 308 | 'surround tone?' => 'TSRQSTN', | ||||||
| 309 | |||||||
| 310 | 'surround back bass+' => 'TSBBUP', | ||||||
| 311 | 'surround back bass-' => 'TSBBDOWN', | ||||||
| 312 | 'surround back treble+' => 'TSBTUP', | ||||||
| 313 | 'surround back treble-' => 'TSBTDOWN', | ||||||
| 314 | 'surround back tone?' => 'TSBQSTN', | ||||||
| 315 | |||||||
| 316 | 'subwoofer bass+' => 'TSWBUP', | ||||||
| 317 | 'subwoofer bass-' => 'TSWBDOWN', | ||||||
| 318 | 'subwoofer treble+' => 'TSWTUP', | ||||||
| 319 | 'subwoofer treble-' => 'TSWTDOWN', | ||||||
| 320 | 'subwoofer tone?' => 'TSWQSTN', | ||||||
| 321 | |||||||
| 322 | 'sleep off' => 'SLPOFF', | ||||||
| 323 | 'sleep?' => 'SLPQSTN', | ||||||
| 324 | |||||||
| 325 | 'display0' => 'DIF00', | ||||||
| 326 | 'display1' => 'DIF01', | ||||||
| 327 | 'display2' => 'DIF02', | ||||||
| 328 | 'display3' => 'DIF03', | ||||||
| 329 | 'display toggle' => 'DIFTG', | ||||||
| 330 | 'display?' => 'DIFQSTN', | ||||||
| 331 | |||||||
| 332 | 'dimmer bright' => 'DIM00', | ||||||
| 333 | 'dimmer dim' => 'DIM01', | ||||||
| 334 | 'dimmer dark' => 'DIM02', | ||||||
| 335 | 'dimmer off' => 'DIM03', | ||||||
| 336 | 'dimmer ledoff' => 'DIM08', | ||||||
| 337 | 'dimmer toggle' => 'DIMTG', | ||||||
| 338 | 'dimmer?' => 'DIMQSTN', | ||||||
| 339 | |||||||
| 340 | 'menu key' => 'OSDMENU', | ||||||
| 341 | 'up key' => 'OSDUP', | ||||||
| 342 | 'down key' => 'OSDDOWN', | ||||||
| 343 | 'right key' => 'OSDRIGHT', | ||||||
| 344 | 'left key' => 'OSDLEFT', | ||||||
| 345 | 'enter key' => 'OSDENTER', | ||||||
| 346 | 'exit key' => 'OSDEXIT', | ||||||
| 347 | 'audio key' => 'OSDAUDIO', | ||||||
| 348 | 'video key' => 'OSDVIDEO', | ||||||
| 349 | 'home key' => 'OSDHOME', | ||||||
| 350 | |||||||
| 351 | # 'memory store' => 'MEMSTR', | ||||||
| 352 | # 'memory recall' => 'MEMRCL', | ||||||
| 353 | # 'memory lock' => 'MEMLOCK', | ||||||
| 354 | # 'memory unlock' => 'MEMUNLK', | ||||||
| 355 | |||||||
| 356 | ); | ||||||
| 357 | foreach my $k (keys %command_map) { | ||||||
| 358 | $command_map{canon_command($k)} = delete $command_map{$k}; | ||||||
| 359 | } | ||||||
| 360 | |||||||
| 361 | sub command { | ||||||
| 362 | 10 | 38151 | my ($self, $cmd, $cb) = @_; | ||||
| 363 | 10 | 130 | my $canon = canon_command($cmd); | ||||
| 364 | 10 | 95 | my $str = $command_map{$canon}; | ||||
| 365 | 10 | 179 | if (defined $str) { | ||||
| 366 | 7 | 48 | $cmd = $str; | ||||
| 367 | } elsif ($canon =~ /^vol(100|[0-9][0-9]?)%?$/) { | ||||||
| 368 | 2 | 51 | $cmd = sprintf 'MVL%02x', $1; | ||||
| 369 | } elsif ($canon =~ /^sleep(90|[0-8][0-9]|[1-9])m\w+?$/) { | ||||||
| 370 | 0 | 0 | $cmd = sprintf 'SLP%02x', $1; | ||||
| 371 | } elsif ($cmd !~ /^[A-Z][A-Z][A-Z]/) { | ||||||
| 372 | 1 | 778 | croak ref($self)."->command: '$cmd' does not match /^[A-Z][A-Z][A-Z]/"; | ||||
| 373 | } | ||||||
| 374 | 9 | 264 | $self->write($cmd, $cb); | ||||
| 375 | } | ||||||
| 376 | |||||||
| 377 | 1; | ||||||