#!/usr/bin/perl -w
#
# switcher-cmd.pl --- controls a Knox video switcher on the serial port.
# Run with no arguments for usage.
#
# Copyright © 2000, 2001, 2004, 2005 Jamie Zawinski <jwz@dnalounge.com>
#
# 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.
#
# Created: 9-Sep-2000


# Knox RS16x16 switcher protocol:
# ------------------------------
#
#  Status commands:
#
#    D          Print crosspoint status, as a multi-line table.
#    T          Lamp test.
#
#  Switching commands:
#  Inputs and outputs are numbered  01-16.  Number 00 means "off".
#
#    Vddss      Route video from SS to DD.
#    Addss      Route audio from SS to DD.
#    Bddss      Route both video and audio from SS to DD.
#    Bddvvaa    Route video from VV and audio from AA to output DD.
#
#  Salvo commands:
#  Route from one input to a range of outputs.
#
#    Yaabbss    Route video from SS to AA through BB.
#    Zaabbss    Route audio from SS to AA through BB.
#    Xaabbss    Route both video and audio from SS to AA through BB.
#
#  Delayed commands:
#
#    Fddss      Delayed route video from SS to DD.
#    Gddss      Delayed route audio from SS to DD.
#    Eddss      Delayed route both video and audio from SS to DD.
#    Eddvvaa    Delayed route video from VV and audio from AA to output DD.
#    EE         Execute all delayed commands.
#
#    Delayed commands are also executed when a V, A, or B command is sent.
#
#  Patterns:
#
#    There are 16 pattern storage areas.
#
#    Snn        Save current configuration to storage area NN.
#    Rnn        Load current configuration from storage area NN.
#
#  Sequencer:
#
#    The RS16x16 can cycle continuously through the 16 stored patterns.
#
#    Tnnn       Start cycling, with time interval of NNN (1-999).
#    N          Stop cycling.
#
# DIP switches 1 and 2 control baud rate:
#
#    00:  9600
#    01:  1200
#    10:  2400
#    11: 19200
#
# Switch 3 controls verbose answerback mode: if on, an implicit "D"
# follows every routing command.
#
# Switch 4 is whether the front panel keypad is locked out.
# Switches 5-8 are secret and undocumented, and should be off.
#
# Switch settings are only consulted at power-up time.
#
#
# Sometimes the serial port loses its mind and you have to use kermit
# to un-confuse it:
#
#   kermit
#   set line /dev/ttyS0
#   set speed 9600
#   connect
#   V0000
#   C-\ q


require 5;
use diagnostics;
use strict;

use POSIX;
use Socket;
use IO::Handle;

my $progname = $0; $progname =~ s@.*/@@g;
my $version = q{ $Revision: 1.16 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;


#my $device = "/dev/ttyS0";
my $device = "switcher.dnalounge.net:10001";
my $speed = B9600;  # 19200 seems to drop characters...

my $http_proxy = undef;

my $channels = 16;
my $buffers = 16;

my $high_priority_input = 8;  # If available, this input is used frequently.
                              # This kludge is so that the input that
                              # corresponds to my panning camera gets
                              # used more frequently than the other inputs,
                              # but only if it is enabled.

my $verbose = 0;
my $debug = 0;
my $do_syslog = 1;
my $state_file = undef;

my @current_map = ( 0, 0, 0, 0, 0, 0, 0, 0,
                    0, 0, 0, 0, 0, 0, 0, 0 );

sub error {
  my ($msg) = @_;
  print STDERR "$progname: $msg\n";
  system ("logger", "-t", $progname, $msg) if ($do_syslog);
  exit 1;
}

sub open_serial {

  if ($debug) {
    open (SERIAL, "+</dev/null");
    print STDERR "$progname: opened /dev/null (debug mode)\n"
      if ($verbose > 1);
    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');

    if (!socket(SERIAL, PF_INET, SOCK_STREAM, $proto)) {
      error ("socket: $!");
    }
    print STDERR "$progname: connecting to $device\n" if ($verbose > 1);
    if (!connect(SERIAL, $paddr)) {
      error ("connect: $device: $!");
    }

    print STDERR "$progname: connected to $device\n" if ($verbose > 1);

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

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

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

  } else {                               # local serial port

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

    print STDERR "$progname: opened $device\n" if ($verbose > 1);
    system ("logger", "-t", $progname, "opened $device") if ($do_syslog);

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

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

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

  # Flush any bits on the stream already.
  #
  my $buf = "";
  while (sysread(SERIAL, $buf, 1024)) {
    if ($verbose > 1) {
      $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";
      }
    }
  }

  ping_serial();
}

sub close_serial {
  return if $debug;
  close SERIAL || error ("$device: $!");
  print STDERR "$progname: closed $device\n" if ($verbose > 1);
  system ("logger", "-t", $progname, "closed $device") if ($do_syslog);
}


# Generate an error response, just to see if the serial port is alive.
#
sub ping_serial {
  print SERIAL "V0000\r\n" || error ("$device: $!");
  $_ = raw_reply();
  if (!defined($_) || $_ =~ m/^$/) {
    # try one more time
    print SERIAL "V0000\r\n" || error ("$device: $!");
    $_ = raw_reply();

    if (!defined($_) || $_ =~ m/^$/) {
      error ("$device appears to be unresponsive!");
    }
  }

  print STDERR "$progname: $device is alive.\n" if ($verbose > 1);
}


# the sleep() function is weak.  use select() instead.
sub my_sleep {
  my ($secs) = @_;
  select(undef, undef, undef, $secs);
}

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

  describe_raw_cmd ($cmd) if ($verbose);

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

  # Store this setting into the map.
  if ($cmd =~ m/^[BVAEFG](\d\d)(\d\d)$/) {
    $current_map[$1 - 1] = $2;
  }

  # the serial hardware on the switcher seems really flaky: it tends
  # to drop characters.  So, let's try waiting 1/20th second after
  # each command, and see if that helps any...
  #
  my_sleep 0.05;
}

# read a multi-line response.
#
sub raw_reply {

  return "" if $debug;

  my $result = "";

  my $wait = 0.5;

  # read a multi-line response.  If 1 second passes without a line being
  # printed, assume no more lines are coming.
  #
  while (1) {

    my $rin='';
    my $rout;
    vec($rin,fileno(SERIAL),1) = 1;

    my $nfound = select($rout=$rin, undef, undef, $wait);
    last unless $nfound;

    my $buf = '';
    while (sysread (SERIAL, $buf, 1024)) {
      $result .= $buf;
    }

#    # short circuit the delay -- if we see a DONE line, believe it.
#    last if ($result =~ m/[\r\n]DONE(\r\n|\r|\n)$/s);
  }

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

  # print what we got...
  #
  if ($verbose > 1) {
    foreach (split (/\n/, $result)) {
      print STDERR "$progname:  <<< $_\n";
    }
  }

  return $result;
}


sub parse_range {
  my ($range, $min, $max, $cmd) = @_;
  my @result = ();
  $range =~ s/\s+//g;
  foreach my $seg (split (/,/, $range)) {
    next if ($seg eq "");
    if ($seg =~ m/^(\d+)-(\d+)$/) {
      my $a = ($1 < $2 ? $1 : $2);
      my $b = ($1 < $2 ? $2 : $1);

      if ($a < $min || $a > $max) {
        print "$progname: $a out of range $min-$max: \"$cmd\"\n";
        usage();
      }
      if ($b < $min || $b > $max) {
        print "$progname: $b out of range $min-$max: \"$cmd\"\n";
        usage();
      }

      push @result, ($a .. $b);
    } elsif ($seg =~ m/^\d+$/) {

      $seg = 0 + $seg;
      if ($seg < $min || $seg > $max) {
        print "$progname: $seg out of range $min-$max: \"$cmd\"\n";
        usage();
      }

      push @result, $seg;

    } else {
      print STDERR "$progname: unparsable range: \"$range\": \"$cmd\"\n";
    }

  }

  return (sort { $a <=> $b } @result);
}


# If $high_priority_input is a member of the list, add it to the list
# a few more times.
#
sub prioritize_targets {
  my (@list) = @_;
  my $found_p = 0;
  foreach (@list) {
    if ($_ eq $high_priority_input) {
      $found_p = 1;
      last;
    }
  }

  if ($found_p) {
    my $n = int (($#list+1) * 0.3);
    $n = 2 if ($n < 2);
    while ($n--) {
      push @list, $high_priority_input;
    }
    @list = sort { $a <=> $b } @list;
  }

  return @list;
}


my $did_group = 0;

# Given a command string, returns a list of raw commands.
#
sub translate_command {
  my ($cmd) = @_;

  my $group = 0;
  my @result = ();

  if ($cmd =~ m/^STATUS$/i) {
    if ($did_group) {
      push @result, "EE";
      $did_group = 0;
    }
    push @result, "D";

  } elsif ($cmd =~ m/^TEST$/i) {
    if ($did_group) {
      push @result, "EE";
      $did_group = 0;
    }
    push @result, "T";

  } elsif ($cmd =~ m/^SLEEP\b/i) {
    if ($did_group) {
      push @result, "EE";
      $did_group = 0;
    }
    if ($cmd =~ m/^SLEEP[\s=]+(\.?\d+|\d+\.\d+)$/i) {
      my $secs = 0 + $1;
      push @result, "SLEEP $secs";
    } else {
      print STDERR "$progname: sleep command unparsable: $cmd\n";
      usage();
    }

  } elsif ($cmd =~ m/^SAVE\b/i) {

    if ($did_group) {
      push @result, "EE";
      $did_group = 0;
    }

    if ($cmd =~ m/^SAVE[\s=]+(\d+)$/i) {
      my $buffer = 0 + $1;
      error ("buffer number ($buffer) must be 1-$buffers")
        unless ($buffer >= 1 && $buffer <= $buffers);
      $buffer = sprintf("%02d", int($buffer));
      push @result, "S$buffer";
    } else {
      print STDERR "$progname: save command unparsable: $cmd\n";
      usage();
    }

  } elsif ($cmd =~ m/^LOAD\b/i) {

    if ($did_group) {
      push @result, "EE";
      $did_group = 0;
    }

    if ($cmd =~ m/^LOAD[\s=]+(\d+)$/i) {
      my $buffer = 0 + $1;
      error ("buffer number ($buffer) must be 1-$buffers")
        unless ($buffer >= 1 && $buffer <= $buffers);
      $buffer = sprintf("%02d", int($buffer));
      push @result, "R$buffer";

    } else {
      print STDERR "$progname: load command unparsable: $cmd\n";
      usage();
    }

  } elsif ($cmd =~ m/^CYCLE\b/i) {

    if ($did_group) {
      push @result, "EE";
      $did_group = 0;
    }

    if ($cmd =~ m/^CYCLE[\s=]+(\.?\d+|\d+\.\d+)$/i) {
      my $secs = 0 + $1;
      $secs = ($secs == 0 ? 0 : $secs < 1 ? 1 : int($secs + 0.5));

      if ($secs == 0) {
        push @result, "N";
      } else {
        push @result, "T$secs";
      }

    } else {
      print STDERR "$progname: cycle command unparsable: $cmd\n";
      usage();
    }

  } elsif ($cmd =~ m/^([^=]+)\s*=\s*([^=]+)$/) {

    my $s = $2;
    my $d = $1;
    my @s = parse_range ($s, 0, $channels, $cmd);
    my @d = parse_range ($d, 1, $channels, $cmd);

    @d = prioritize_targets (@d);

    foreach $d (@d) {
      if ($#s == 0) {      # simple assignment
        $s = $s[0];
      } else {             # random assignment
        $s = $s[rand($#s + 1)];
      }

      $did_group = 1;
      push @result, sprintf ("E%02d%02d", $d, $s);

      if ($verbose) {
        $d = " $d" if $d < 10;
        $s = " $s" if $s < 10;
      }
    }

  } else {
    print STDERR "$progname: unrecognized command: $cmd\n";
    usage();
  }

  return @result;
}


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

  if     ($cmd =~ m/^D$/s) {
    print STDERR "$progname: D     (display)\n";
  } elsif ($cmd =~ m/^T$/s) {
    print STDERR "$progname: T     (lamp test)\n";

  } elsif ($cmd =~ m/^B(\d\d)(\d\d)$/s) {
    print STDERR "$progname: B$1$2 (output $1 <= input $2)\n";
  } elsif ($cmd =~ m/^V(\d\d)(\d\d)$/s) {
    print STDERR "$progname: V$1$2 (output $1 <= input $2, video only)\n";
  } elsif ($cmd =~ m/^A(\d\d)(\d\d)$/s) {
    print STDERR "$progname: A$1$2 (output $1 <= input $2, audio only)\n";

  } elsif ($cmd =~ m/^E(\d\d)(\d\d)$/s) {
    print STDERR "$progname: E$1$2 (output $1 <= input $2)\n";
  } elsif ($cmd =~ m/^F(\d\d)(\d\d)$/s) {
    print STDERR "$progname: F$1$2 (output $1 <= input $2, video only)\n";
  } elsif ($cmd =~ m/^G(\d\d)(\d\d)$/s) {
    print STDERR "$progname: G$1$2 (output $1 <= input $2, audio only)\n";

  } elsif ($cmd =~ m/^EE$/s) {
    print STDERR "$progname: EE    (execute)\n";

  } elsif ($cmd =~ m/^S(\d\d)$/s) {
    print STDERR "$progname: S$1   (save $1)\n";
  } elsif ($cmd =~ m/^R(\d\d)$/s) {
    print STDERR "$progname: R$1   (restore $1)\n";

  } elsif ($cmd =~ m/^T(\d+)$/s) {
    print STDERR "$progname: T$1   (cycle $1)\n";
  } elsif ($cmd =~ m/^N$/s) {
    print STDERR "$progname: N     (cycle stop)\n";

  } else {
    error "internal error: unrecognised raw command: $cmd\n";
  }
}


my $last_file_date = 0;
my @last_file_cmds = 0;

sub read_file {
  my ($file) = @_;

  my @cmds = ();

  my @st = stat($file);
  if (!@st) {
    print STDERR "$progname: $file does not exist!\n";
    system ("logger", "-t", $progname, "$file does not exist") if ($do_syslog);
  } else {
    my $mtime = $st[9];
    if ($mtime == $last_file_date) {
      @cmds = @last_file_cmds;
    } else {

      local *IN;
      if (!open (IN, "<$file")) {
        print STDERR "$progname: tried to load $file and lost?\n";
        system ("logger", "-t", $progname, "$file lost") if ($do_syslog);
        @cmds = @last_file_cmds;
      } else {

        print STDERR "$progname: loading $file\n";
        system ("logger", "-t", $progname, "loaded $file") if ($do_syslog);

        my $body = "";
        while (<IN>) { $body .= $_; }
        close IN;

        $body =~ s/\#.*$//gm;  # delete comments

        $body =~ s/^\s*pancam\b.*$//gm;   # the "pancam" lines are not for us

        $body =~ s/\s+/ /gs;   # compress all whitespace
        $body =~ s/^\s+//gs;
        $body =~ s/\s+$//gs;

        @cmds = split (/ /, $body);

        $last_file_date = $mtime;
        @last_file_cmds = @cmds;
      }
    }
  }

  if ($#cmds < 0) {
    print STDERR "$progname: no commands!\n" if ($verbose);
    system ("logger", "-t", $progname, "no commands!") if ($do_syslog);
    @cmds = ("SLEEP 5");  # try again, in case it's a transitory failure
  }

  return @cmds;
}


sub save_settings {
  if (defined ($state_file)) {
    local *OUT;
    my $body = "";
    $body .= "# written by $progname on " . localtime() . "\n";
    $body .= join (" ", @current_map);
    $body .= "\n";
    open (OUT, ">$state_file") || error ("$state_file: $!");
    print OUT $body || error ("$state_file: $!");
    close OUT;
    print STDERR "$progname: wrote $state_file\n" if ($verbose > 1);
  }
}


sub usage {
  print STDERR "usage: $progname [--verbose] [--debug] [--device dev]\n";
  print STDERR "                 [--loop] [--save state-file ]\n";
  print STDERR "                 [--file cmdfile | commands... ]\n\n";
  print STDERR "Commands are:\n\n" .
    "       D = S           Send source S to destination D.\n" .
    "       D,E,F = S       Send source S to destinations D, E, and F.\n" .
    "       D-E = S         Send source S to destinations D through E.\n" .
    "       D-E = S-T       Randomize the source->destination assignments:\n" .
    "                       each destination D-E will come from a random\n" .
    "                       source in the range S-T.\n" .
    "       STATUS          Print out a grid of what's going where.\n" .
    "       SLEEP N         Pause for N seconds (may be a float).\n" .
    "       SAVE N          Save current settings to pattern buffer N " .
                           "(1-$buffers).\n" .
    "       LOAD N          Load settings from pattern buffer N " .
                           "(1-$buffers).\n" .
    "       CYCLE N         Cycle through all $buffers buffers " .
                           "(delay N seconds).\n" .
    "       CYCLE 0         Stop cycling.\n" .
    "\n" .
    "Destinations are integers in the range 1-$channels inclusive.\n" .
    "Likewise for sources, except that 0 means `off' (no signal).\n" .
    "All routing commands are executed simultaneously.\n" .
    "If `--loop' is used, the commands will be re-executed forever.\n" .
    "If `--file' is used, the commands are read from the file instead\n" .
    "of the command line; if the file is changed, it is reloaded.\n" .
    "(this is useful when `--loop' was also used: that way you can\n" .
    "change the set of looping commands without restarting.)\n";

  exit 1;
}


sub main {
  my (@cmds);

  my $loop_p = 0;
  my $file = undef;

  system ("logger", "-t", $progname, "starting") if ($do_syslog);

  while ($_ = $ARGV[0]) {
    shift @ARGV;
    if ($_ eq "--verbose") { $verbose++; }
    elsif ($_ eq "--debug") { $debug++; }
    elsif ($_ eq "--loop") { $loop_p++; }
    elsif ($_ eq "--device") { $device = shift @ARGV; }
    elsif ($_ eq "--file") { $file = shift @ARGV; }
    elsif ($_ eq "--save") { $state_file = shift @ARGV; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    elsif (m/^-/) { usage; }
    else {
      push @cmds, $_;
    }
  }

  if (defined($file)) {
    if ($#cmds >= 0) {
      error "can't specify --file and commands at the same time.";
    }
  } else {
    usage if ($#cmds < 0);
  }

  my $opened = 0;
  my $rep;

  while (1) {

    if (defined ($file)) {
      @cmds = read_file ($file);
    }

    my @raw_cmds = ();
    foreach (@cmds) {
      foreach (translate_command ($_)) {
        push @raw_cmds, $_;
      }
    }

    if ($did_group) {
      push @raw_cmds, "EE\n";
      $did_group = 0;
      print STDERR "$progname: EE    (end group)\n" if ($verbose);
    }

    open_serial() unless $opened;
    $opened = 1;

    foreach my $rcmd (@raw_cmds) {
      if ($rcmd =~ m/^SLEEP (.*)/) {
        save_settings();
        print STDERR "$progname: sleep $1\n" if ($verbose > 1);
        my_sleep $1;
      } else {
        raw_cmd ($rcmd);
      }

      if ($loop_p) {
        # just flush it
        my $buf = "";
        while (sysread(SERIAL, $buf, 1024)) {
          if ($verbose > 1) {
            $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";
            }
          }
        }
      } else {
        $rep = raw_reply ();
      }
    }

    save_settings();

    last unless $loop_p;
  }

  close_serial();
  $opened = 0;


  # if any of the output lines are the current mapping table, print them.
  #
  foreach (split (/[\r\n]/, $rep)) {
    s/[\r\n]+//g;
    next if m/^$/;
    next unless m/^\s+OUTPUT\s+(\d+)\s+VIDEO\s+(\d+)\s+AUDIO\s+(\d+)\s+$/;
    printf "  %02d: %02d\n", $1, $2;
  }
}

main;
exit (0);