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; |