File Coverage

File:lib/Device/Onkyo.pm
Coverage:80.4%

linestmtbrancondsubpodtimecode
1
4
4
4
5.32774469359453e+15
33
324
use strict;
2
4
4
4
48
20
532
use warnings;
3package 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
13use 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
43sub 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
68sub _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
80sub _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
93sub _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
112sub 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
132sub 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
168sub _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
175sub 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
202sub 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
211sub _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
223sub _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
229sub 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
245sub 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
258our %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  );
357foreach my $k (keys %command_map) {
358  $command_map{canon_command($k)} = delete $command_map{$k};
359}
360
361sub 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
3771;