#!/usr/bin/perl -w
# Copyright © 2006-2022 Jamie Zawinski <jwz@jwz.org>
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# the above copyright notice appear in all copies and that both that
# copyright notice and this permission notice appear in supporting
# documentation.  No representations are made about the suitability of this
# software for any purpose.  It is provided "as is" without express or 
# implied warranty.
#
# Speaks the Denon AVR/AVC control protocol language, over either serial
# or ethernet.  Lets you switch inputs, volume, etc. remotely.
#
# Examples:
#
#	tuner power=off
#	tuner input=dvr
#	tuner mute=on
#	tuner mute=off
#	tuner input=query			; to see what it is
#	tuner volume=query			; to see what it is
#	tuner volume='-40.5 dB'			; set to absolute value
#	tuner volume=up				; change by +0.5dB
#	tuner volume=down			; change by -0.5dB
#	tuner volume=up6			; change by +3dB (6 x 0.5)
#	tuner power=on input=tv volume=up	; multiple commands
#
#
# If you have an older model Denon with only a serial port, this code
# can talk to it over a serial cable.  Alternately, you can put a
# serial-to-ethernet adapter on it (e.g., a Lantronix UDS-10) and
# talk to it over the network.
#
# Turns out, the newer models also have a web server in them, so this code
# can talk to that directly, which is faster and less flaky.
#
# Tested with:
#  - Denon AVR-2805 tuner, which has only a serial port.
#  - Denon AVR-2313CI and AVR-X2000 tuners, which have ethernet.
#
# http://usa.denon.com/DocumentMaster/US/AVR-3808CISerialProtocol_Ver5.2.0a.pdf
#
# Created: 19-Nov-2006.

require 5;
use diagnostics;
use strict;

use POSIX;
use Socket;
use IO::Handle;
use Fcntl;
use Fcntl ':flock'; # import LOCK_* constants
use LWP::UserAgent;

my $progname = $0; $progname =~ s@.*/@@g;
my ($version) = ('$Revision: 1.18 $' =~ m/\s(\d[.\d]+)\s/s);

my $verbose = 0;
my $debug   = 0;

#my $device = "/dev/ttyS0";	# serial port
#my $device = "tuner:23";	# or hostname and tcp port
#my $device = "10.0.1.3:23";
my $device = "10.0.1.3:80";
my $speed = B9600;

my $native_ethernet_p = 1;	# Set this if Denon has built-in ethernet.
				# We insert more delays on older models.

my $serial_protocol_p = 0;	# If false, use HTTP POST instead of the
				# native protocol.  This may only work with
				# AVR-X2000.


my $http_proxy = undef;

# The manual says that after sending a command, "the response should be
# sent within 200 milliseconds of receiving the command."
#
# What it doesn't say is that after reading the response for one command,
# you have to wait nearly a FULL SECOND before sending a second command,
# and if you don't, BOTH commands are ignored!
#
my $command_delay = 0.95;

my $CONN;
my $first_open_p = 1;

sub open_serial() {

  if ($debug) {
    open ($CONN, '+<', "/dev/null");
    print STDERR "$progname: opened /dev/null (debug mode)\n"
      if ($verbose);
    return;
  }

  if ($device =~ m@^([^:/]+):([^:/.]+)$@) {   # host:port, not local serial

    my $host = $1;
    my $port = $2;

    my $host2 = $host;
    my $port2 = $port;
    if ($http_proxy) {
      $device = $http_proxy if $http_proxy;
      ($host2,$port2) = split(/:/, $device);
      $port2 = 80 unless $port2;
    }

    my ($remote, $iaddr, $paddr, $proto, $line);
    $remote = $host2;
    if ($port2 =~ /\D/) { $port2 = getservbyname($port2, 'tcp') }
    error ("unrecognised port: $port2") unless ($port2);
    $iaddr   = inet_aton($remote);
    error ("host not found: $remote") unless ($iaddr);
    $paddr = sockaddr_in($port2, $iaddr);
    $proto = getprotobyname('tcp');

    print STDERR "$progname: connecting to $device\n" if ($verbose);

    {
      my $secs = 2;		# If we're reconnecting, busy-wait trying to
      my $count = 0;		# connect for this many seconds.  But on the
      my $start = time();	# first connection attempt, only try once.

      local $SIG{ALRM} = sub { error ("connect: $device: timed out"); };
      alarm ($secs + 1);

      while (1) {
        $count++;
        error ("socket: $!")
          unless socket ($CONN, PF_INET, SOCK_STREAM, $proto);
        last if (connect($CONN, $paddr));
#        error ("connect: $device: $! (on first connect)")
#          if ($first_open_p);
        error ("connect: $device: $! (after $count tries)")
          if (time() >= $start + $secs);
      }
      $first_open_p = 0;

      print STDERR "$progname: connected to $device (after $count tries)\n"
        if ($verbose);
    }

    # Set unbuffered (is this necessary?)
    #
    select((select($CONN), $| = 1)[0]);

    # Set nonblocking
    #
    my $flags = fcntl($CONN, F_GETFL, 0) ||
      error ("can't get flags for the socket: $!");
    $flags = fcntl($CONN, F_SETFL, $flags | O_NONBLOCK) ||
      error ("can't set flags for the socket: $!");

    print STDERR "$progname: initialized connection\n" if ($verbose);

  } else {                               # local serial port

    #open ($CONN, '+<', $device) || error ("$device: $!")";
    sysopen ($CONN, $device, O_RDWR|O_NONBLOCK|O_NOCTTY|O_EXCL) ||
      error ("$device: $!");

    print STDERR "$progname: opened $device\n" if ($verbose);

    # Set unbuffered (is this necessary?)
    #
    select((select($CONN), $| = 1)[0]);

    # Set line speed
    #
    my $t =  POSIX::Termios->new;
    $t->getattr(fileno($CONN));
    $t->setispeed($speed);
    $t->setospeed($speed);
    $t->setattr(fileno($CONN), TCSANOW);

    print STDERR "$progname: initialized $device\n" if ($verbose);
  }

  # Flush any bits on the stream already.
  #
  my $buf = "";
  while (sysread($CONN, $buf, 1024)) {
    if ($verbose) {
      $buf =~ s/\r\n/\n/g;
      $buf =~ s/\r/\n/g;
      $buf =~ s/\n$//s;
      foreach (split (/\n/, $buf)) {
        $_ = sprintf "%-8s (flush)", $_;
        print STDERR "$progname: <<< $_\n";
      }
    }
  }
}

sub close_serial() {
  if ($debug) {
    print STDERR "$progname: close (debug)\n";
    return;
  }
  close $CONN || error ("$device: $!");
  print STDERR "$progname: closed $device\n" if ($verbose);
}


# Like sleep but is guaranteed to work on fractions of a second.
sub my_sleep($) {
  my ($secs) = @_;
  print STDERR "$progname:    sleep $secs\n" if ($verbose > 2);
  select(undef, undef, undef, $secs);
}


# write a one-line command.
#
sub raw_cmd($) {
  my ($cmd) = @_;
  $cmd =~ s/[\r\n]+$//gs;

  (print $CONN "$cmd\r\n") || error ("$device: $!");
  print STDERR "$progname:  >>> $cmd\n" if ($verbose > 1);
}

# read a response from a command.
# This is assumed to be a single line.
#
sub raw_reply() {

  return "" if $debug;

  my $wait = $command_delay;   # wait no longer than this long for a reply.

  my $result = "";
  while (1) {
    my $rin='';
    my $rout;
    vec($rin,fileno($CONN),1) = 1;

    my $nfound = select($rout=$rin, undef, undef, $wait);
    $wait = 0;
    last unless $nfound;
    my $buf = '';
    while (sysread ($CONN, $buf, 1024)) {
      $result .= $buf;
    }
  }

  # convert linebreaks.
  #
  $result =~ s/\r\n/\n/g;
  $result =~ s/\r/\n/g;

  # print what we got...
  #
  if ($verbose > 1) {
    if ($result =~ m/^\s*$/s) {
      print STDERR "$progname:  <<< no reply!\n";
      } else {
        foreach (split (/\n/, $result)) {
          print STDERR "$progname:  <<< $_\n";
        }
    }
  }

  return $result;
}


sub denon_raw_command($$$) {
  my ($cmd, $rawcmd, $queryp) = @_;

  raw_cmd ($rawcmd);
  my $result = raw_reply ();

  if ($queryp) {
    if ($result =~ m/^\s*$/s) {
      print STDOUT "$progname: $cmd = FAIL!\n";
    }

    foreach my $line (split (/\n/, $result)) {
      my $cmd2;
      ($cmd2, $line) = ($line =~ m/^(..)(.*)/s);
      if ($cmd2 eq 'MV') {
        my $n = $line;
        $n .= "0" if ($n =~ /^..$/);
        $line = sprintf ("%.1f dB", (800 - $n) / -10.0);
      }

      if    ($cmd2 eq 'PW') { $cmd2 = 'POWER';  }
      elsif ($cmd2 eq 'SI') { $cmd2 = 'INPUT';  }
      elsif ($cmd2 eq 'MU') { $cmd2 = 'MUTE';   }
      elsif ($cmd2 eq 'MV') { $cmd2 = 'VOLUME'; }

      print STDOUT "$progname: $cmd2 = $line\n";
    }
  }
}


sub denon_http_command($$$) {
  my ($cmd, $rawcmd, $queryp) = @_;

  my $ua = LWP::UserAgent->new;
  $ua->agent("$progname/$version");

  my $status_url = "http://$device/goform/formMainZone_MainZoneXml.xml";

  if ($rawcmd =~ m/\?$/) {				# Query commands
    my $url = $status_url;
    my $res = $ua->get ($url);
    my $ret = ($res && $res->code) || 'null';
    error ("$url: $ret") unless ($ret =~ m/^2\d\d/s);
    my $result = ($res && $res->content) || '';
    if ($rawcmd =~ m/^SI/s) {
      ($result =~ m@<InputFuncSelect><value>([^<>]+)@si) ||
        error ("unparsable: $result");
      $result = $1;
    } elsif ($rawcmd =~ m/^MU/s) {
      ($result =~ m@<Mute><value>([^<>]+)@si) ||
        error ("unparsable: $result");
      $result = $1;
    } elsif ($rawcmd =~ m/^PW/s) {
      ($result =~ m@<Power><value>([^<>]+)@si) ||
        error ("unparsable: $result");
      $result = $1;
    } elsif ($rawcmd =~ m/^MV/s) {
      ($result =~ m@<MasterVolume><value>([^<>]+)@si) ||
        error ("unparsable: $result");
      $result = $1;
    } else {
      error ("unknown raw cmd query \"$rawcmd\"");
    }

    print STDOUT "$progname: $cmd = $result\n";
    return $result;

  } else {

    if ($rawcmd =~ m/^SI(.*)/s) {
      # Input name has to be the original name (the "index" value in
      # "VideoSelectLists") and not the renamed value that is in
      # "InputFuncSelect".
      $rawcmd = "PutZone_InputFunction/$1";  # Input name
    } elsif ($rawcmd =~ m/^PW(.*)/s) {
      my $arg = $1;
      $arg = 'OFF' if ($arg =~ m/^STANDBY/);
      $rawcmd = "PutZone_OnOff/$arg";  # ON/OFF
    } elsif ($rawcmd =~ m/^MU(.*)/s) {
      $rawcmd = "PutVolumeMute/$1";  # ON/OFF
    } elsif ($rawcmd =~ m/^MV(.*)/s) {
      $rawcmd = "PutMasterVolumeSet/$1";  # dB
    } else {
      error ("unknown raw cmd \"$rawcmd\"");
    }

    print STDERR "$progname:  >>> $rawcmd\n" if ($verbose > 1);

    my $url = "http://$device/MainZone/index.put.asp";
    my $res = $ua->post ($url,
                         Content_Type => 'application/x-www-form-urlencoded',
                         Content => "cmd0=$rawcmd");
    my $ret = ($res && $res->code) || 'null';
    error ("$url: $ret") unless ($ret =~ m/^2\d\d/s);
    my $result = ($res && $res->content) || '';

    if ($verbose > 1) {
      if ($result =~ m/^\s*$/s) {
        print STDERR "$progname:  <<< no reply!\n";
      } else {
        foreach (split (/\n/, $result)) {
          print STDERR "$progname:  <<< $_\n";
        }
      }
    }
  }
}


# Converts a dB value to the integral range Denon uses.
#
sub db_to_raw($) {
  my ($arg) = @_;
  my $db = $arg;
  $db =~ s/^\+//;
  $db += 0.0;
  error ("dB must be in range -80.0 to -1.0, not \"$arg\"")
    unless ($db <= -1.0 && $db >= -80.0);

  #   +1.0 dB  810
  #   +0.5 dB  805
  #    0.0 dB  800
  #   -0.5 dB  795
  #   -1.0 dB  790
  #   -1.5 dB  785
  #   -2.0 dB  780
  #       ...
  #  -79.5 dB  005
  #  -80.0 dB  000
  #       ---  990

  return (800 - int ($db * -10));
}


sub current_volume() {
  raw_cmd ('MV?');
  my $result = raw_reply ();
  if ($result =~ m/^MV(\d+)$/m) {
    my $n = $1;
    $n .= '0' if ($n =~ m/^..$/);
    $result = $n;
  } else {
    print STDOUT "$progname: FAIL getting current volume!\n";
    exit 1;
  }

  if ($native_ethernet_p) {
    close_serial();
    open_serial();
  }

  return $result;
}


sub mutedp() {
  raw_cmd ('MU?');
  my $result = raw_reply ();
  if ($result =~ m/^MUOFF$/m) {
    $result = 0;
  } elsif ($result =~ m/^MUON$/m) {
    $result = 1;
  } else {
    print STDOUT "$progname: FAIL getting current mute state!\n";
    exit 1;
  }

  if ($native_ethernet_p) {
    close_serial();
    open_serial();
  }

  return $result;
}


sub denon_command($) {
  my ($cmd) = @_;

  $cmd = uc($cmd);
  my $arg = undef;

  local $SIG{ALRM} = sub { error ("command: $device: timed out"); };
  alarm (5);

  if ($cmd =~ m/^([^=]+)\s*=\s*(.*)$/si) {
    ($cmd, $arg) = ($1, $2);
    $arg = undef if ($arg eq '');
  }

  $arg = '?' if (defined($arg) && $arg eq 'QUERY');

  my $rawcmd;
  if ($cmd =~ m/^INPUT$/si) {
    $rawcmd = "SI";

    # aliases
    if (!defined($arg))                { $arg = '?';         }
    elsif ($arg =~ m/^(DBS)$/si)       { $arg = 'DBS/SAT';   }
    elsif ($arg =~ m/^(SAT)$/si)       { $arg = 'SAT/CBL';   }
    elsif ($arg =~ m/^VAUX|AUX$/si)    { $arg = 'V.AUX';     }
    elsif ($arg =~ m/^CDR|TAPE-?1$/si) { $arg = 'CDR/TAPE1'; }
    elsif ($arg =~ m/^MD|TAPE-?2$/si)  { $arg = 'MD/TAPE2';  }
    elsif ($arg =~ m/^(VCR)(\d)$/si)   { $arg = "$1-$2";     }
    elsif ($arg =~ m/^(NET|USB)$/si)   { $arg = 'NET/USB';   }
    elsif ($arg =~ m/^(TV)$/si)        { $arg = 'TV/CBL';    }

    error ("unknown input source: $arg")
      unless ($arg =~ m@^(\?|PHONO|CD|TUNER|DVD|HDP|VDP|TV/CBL|SAT|DBS/SAT|
			  SAT/CBL|VCR|VCR-[123]|DVR|V\.AUX|CDR/TAPE1|MD/TAPE2|
			  NET/USB|XM|IPOD|MAC|PS\d|FRONT PANEL)$@xsi);
    $rawcmd .= $arg;

  } elsif ($cmd =~ m/^MUTE$/si) {
    if (! defined($arg))          { $arg = 'ON';   }
    elsif ($arg =~ m/^ON$/si)     { $arg = 'ON';   }
    elsif ($arg =~ m/^OFF$/si)    { $arg = 'OFF';  }
    elsif ($arg =~ m/^\?$/si)     { $arg = '?';    }
    elsif ($arg =~ m/^TOGGLE$/si) { $arg = mutedp() ? 'OFF' : 'ON'; }
    else { error ("mute: on or off, not $arg"); }
    $rawcmd = "MU$arg";

  } elsif ($cmd =~ m/^UNMUTE$/si) {
    error ("unmute: no args allowed: $arg") if defined($arg);
    $rawcmd = "MUOFF";

  } elsif ($cmd =~ m/^POWER$/si) {
    if (! defined($arg))       { $arg = '?';       }
    elsif ($arg =~ m/^\?$/si)  { $arg = '?';       }
    elsif ($arg =~ m/^ON$/si)  { $arg = 'ON';      }
    elsif ($arg =~ m/^OFF$/si) { $arg = 'STANDBY'; }
    else { error ("power: on or off, not $arg");   }
    $rawcmd = "PW$arg";

  } elsif ($cmd =~ m/^VOL(UME)?$/si) {
    my $change;
    if (! defined($arg))              { $arg = '?';      }
    elsif ($arg =~ m/^\?$/si)         { $arg = '?';      }
    elsif ($arg =~ m/^UP\s*([\d.]+)?$/si)   { $arg = 'UP';
                                              $change = ($1 || 0.5); }
    elsif ($arg =~ m/^DOWN\s*([\d.]+)?$/si) { $arg = 'DOWN';
                                              $change = -($1 || 0.5); }
    elsif ($arg =~ m/^([-+]?\d+\.?\d*)\s*(dB)?$/si) {
      if ($serial_protocol_p) {
        $arg = sprintf("%03d", db_to_raw ($1));
        $arg =~ s/0$//;
      } else {
        $arg = $1;
      }
    }
    else { error ("volume: UP, DOWN, or 'NN dB', not $arg"); }

    if (defined ($change)) {

      system ("afplay /System/Library/Sounds/Ping.aiff &");

      if ($serial_protocol_p) {
        $arg = current_volume();
        $arg += $change * 10;
        $arg = sprintf("%03d", $arg);
        $arg =~ s/0$//;
      } else {
        $arg = denon_http_command ('VOLUME', 'MV?', 1);
        $arg += $change;
      }

      my_sleep ($command_delay * 1.5)  # WTF!  COME ON!
        if ($serial_protocol_p && !$native_ethernet_p);
    }

    $rawcmd = "MV$arg";
  } else {
    usage();
    exit 1;
  }

  my $queryp = 1 if ($arg eq '?' || $verbose);
  if ($serial_protocol_p) {
    denon_raw_command ($cmd, $rawcmd, $queryp);
  } else {
    denon_http_command ($cmd, $rawcmd, $queryp);
  }
}


sub error($) {
  my ($err) = @_;
  print STDERR "$progname: $err\n";
  exit 1;
}

sub usage() {
  print STDERR "usage: $progname [--verbose] [--lock] CMD=ARG ...\n" .
    "\n" .
    "    Commands:  Args:\n" .
    "\n" .
    "      INPUT    QUERY PHONO CD TUNER DVD VDP HDP DBS DVR SAT\n" .
    "               TV VCR VCR-1 VCR-2 VCR-3 AUX TAPE-1 TAPE-2\n" .
    "               NET USB XM IPOD\n" .
    "      MUTE     QUERY ON OFF TOGGLE\n" .
    "      POWER    QUERY ON OFF\n" .
    "      VOLUME   QUERY UP DOWN  \"NN dB\"" .
    "               UPn DOWNn (where 'n' is a dB value)\n" .
    "\n";
  exit 1;
}

sub main() {
  my $lock_p = 0;
  my @cmds;
  while ($#ARGV >= 0) {
    $_ = shift @ARGV;
    if (m/^--?verbose$/) { $verbose++; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif (m/^--?debug$/) { $debug++; }
    elsif (m/^--?lock$/) { $lock_p++; }
    elsif (m/^-[^\d]/) { usage; }
    else { push @cmds, $_; }
  }

  usage unless ($#cmds >= 0);

  my $lock;
  my $lockf = $ENV{HOME} . "/tmp/tuner.lock";
  if ($lock_p) {
    open ($lock, '+>>', $lockf)	|| error ("writing $lockf: $!");
#   flock ($lock, LOCK_EX)	|| error ("locking $lockf: $!");
    flock ($lock, LOCK_EX | LOCK_NB) || error ("already locked: $lockf");
    print STDERR "$progname: locked $lockf\n" if ($verbose > 1);
  }

  open_serial() if ($serial_protocol_p && !$native_ethernet_p);

  my $count = 0;
  foreach my $c (@cmds) {
    my_sleep ($command_delay) 
      if ($count > 0 && $serial_protocol_p && !$native_ethernet_p);
    open_serial() if ($serial_protocol_p && $native_ethernet_p);
    denon_command ($c);
    close_serial() if ($serial_protocol_p && $native_ethernet_p);
    $count++;
  }

  close_serial() if ($serial_protocol_p && !$native_ethernet_p);

  if ($lock) {
    flock ($lock, LOCK_UN) || error ("unlocking $lockf: $!");
    close ($lock);
    print STDERR "$progname: unlocked $lockf\n"
      if ($verbose > 1);
  }
}

main();
exit 0;