#!/usr/bin/perl -w
# Copyright © 2004-2011 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.

# Control script for the Panasonic WV-NS324 servo-mounted video camera.
# You can use this script to aim the camera at one of its presets from the
# command line.
#
# You can also point this script at the same config file that switcher-cmd.pl
# uses, and based on the commands in that file, the camera will be randomly
# pointed at a set of different preset positions.
#
# In this way, a single config file controls both the switcher and the
# robo-camera (and that file is written by the switcher.cgi web page.)
#
# Created:  6-Mar-2004.

require 5;
use diagnostics;
use strict;
use Socket;
use MIME::Base64;
require POSIX;

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

my $verbose = 0;
my $debug_p = 0;
my $do_syslog = 1;

my @base_urls = ("http://membrane.dnalounge.net:10013/",   # Cam 0
                 "http://membrane.dnalounge.net:10014/");  # Cam 1
my @http_auth = ("admin", "switch");
my $http_proxy = undef;


# Loads the given URL, returns: $http, $head, $body.
#
sub get_url_1($$;$$) {
  my ($url, $referer, $user, $pass) = @_;
  
  if (! ($url =~ m@^http://@i)) {
    error ("not an HTTP URL: $url");
  }

  my ($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4);
  $path = "" unless $path;

  my ($them,$port) = split(/:/, $serverstring);
  $port = 80 unless $port;

  my $them2 = $them;
  my $port2 = $port;
  if ($http_proxy) {
    $serverstring = $http_proxy if $http_proxy;
    $serverstring =~ s@^[a-z]+://@@;
    ($them2,$port2) = split(/:/, $serverstring);
    $port2 = 80 unless $port2;
  }

  my ($remote, $iaddr, $paddr, $proto, $line);
  $remote = $them2;
  if ($port2 =~ /\D/) { $port2 = getservbyname($port2, 'tcp') }
  if (!$port2) {
    error ("unrecognised port in $url");
  }

  $iaddr = inet_aton($remote);
#  error ("host not found: $remote") unless ($iaddr);
  die ("$progname: host not found: $remote") unless ($iaddr);
  $paddr   = sockaddr_in($port2, $iaddr);


  my $head = "";
  my $body = "";

  $proto   = getprotobyname('tcp');
  if (!socket(S, PF_INET, SOCK_STREAM, $proto)) {
#   error ("socket: $!");
    die ("$progname: socket: $!");
  }
  if (!connect(S, $paddr)) {
#   error ("connect($serverstring): $!");
    die ("$progname: connect $serverstring: $!");
  }

  select(S); $| = 1; select(STDOUT);

# my $cookie = $cookies{$them};

  my $user_agent = "$progname/$version";

  my $hdrs = ("GET " . ($http_proxy ? $url : "/$path") . " HTTP/1.0\r\n" .
              "Host: $them\r\n" .
              "User-Agent: $user_agent\r\n");
  if ($referer) {
    $hdrs .= "Referer: $referer\r\n";
  }
#  if ($cookie) {
#    my @cc = split(/\r?\n/, $cookie);
#    $hdrs .= "Cookie: " . join('; ', @cc) . "\r\n";
#  }
  if ($user) {
    error ("no password for $user") unless defined($pass);
    my $user_pass = encode_base64("$user:$pass");
    $hdrs .= "Authorization: Basic $user_pass\r\n";
  }
  $hdrs .= "\r\n";

  if ($verbose > 3) {
    foreach (split('\r?\n', $hdrs)) {
      print STDERR "  ==> $_\n";
    }
  }
  print S $hdrs;
  my $http = <S> || "";

  $_  = $http;
  s/[\r\n]+$//s;
  print STDERR "  <== $_\n" if ($verbose > 3);

  while (<S>) {
    $head .= $_;
    s/[\r\n]+$//s;
    last if m@^$@;
    print STDERR "  <== $_\n" if ($verbose > 3);

#    if (m@^Set-cookie:\s*([^;\r\n]+)@i) {
#      my $v = $1;
#      $cookies{$them} = $v;
#      print STDERR "cookie: $them = \"$v\"\n" if ($verbose > 3);
#    }
  }

  print STDERR "  <== \n" if ($verbose > 4);
  my $lines = 0;
  while (<S>) {
    s/\r\n/\n/gs;
    print STDERR "  <== $_" if ($verbose > 4);
    $body .= $_;
    $lines++;
  }

  print STDERR "  <== [ body ]: $lines lines, " . length($body) . " bytes\n"
    if ($verbose == 4);

  close S;

  if (!$http) {
#    error ("null response: $url");
    die ("$progname: null response: $url");
  }

  return ( $http, $head, $body );
}


# Loads the given URL, processes redirects, returns: $http, $head, $body.
#
sub get_url($;$$$) {
  my ($url, $referer, $user, $pass) = @_;

  print STDERR "$progname: loading $url\n" if ($verbose > 2);

  my $orig_url = $url;
  my $loop_count = 0;
  my $max_loop_count = 4;
  my $timeout = 5;

  do {
    my ($http, $head, $body);

    my $alarm = "alarm\n";
    eval {
      local $SIG{ALRM} = sub {
        print STDERR "$progname: timed out: $url\n" if ($verbose > 1);
        die $alarm;
      };
      alarm $timeout;
      ($http, $head, $body) = get_url_1 ($url, $referer, $user, $pass);
      alarm 0;

    };
    if ($@) {
      return ('', '', '');		# Return blank for all http errors
#      return ('', '', '') if ($@ eq $alarm);	# timed out
#      die $@;					# propagate errors
    }


    $http =~ s/[\r\n]+$//s;

    if ( $http =~ m@^HTTP/[0-9.]+ 30[123]@ ) {
      $_ = $head;

      my ( $location ) = m@^location:[ \t]*(.*)$@im;
      if ( $location ) {
        $location =~ s/[\r\n]$//;

        print STDERR "$progname: redirect from $url to $location\n"
          if ($verbose > 3);

        $referer = $url;
        $url = $location;

        if ($url =~ m@^/@) {
          $referer =~ m@^(http://[^/]+)@i;
          $url = $1 . $url;
        } elsif (! ($url =~ m@^[a-z]+:@i)) {
          $_ = $referer;
          s@[^/]+$@@g if m@^http://[^/]+/@i;
          $_ .= "/" if m@^http://[^/]+$@i;
          $url = $_ . $url;
        }

      } else {
        error ("no Location with \"$http\"");
      }

      if ($loop_count++ > $max_loop_count) {
        error ("too many redirects ($max_loop_count) from $orig_url");
      }

    } else {
      return ( $http, $head, $body );
    }
  } while (1);
}


# Find the UID for the given camera number.
#
sub find_uid($) {
  my ($which) = @_;
  my $b = $base_urls[$which];
  error ("camera number " . ($which+1) . " does not exist") unless $b;
  my $url = "${b}cgi-bin/getuid?FILE=indexnw.html";

  if ($debug_p) {
    print STDERR "$progname: not loading $url\n" if ($verbose > 2);
    return "DEBUG_$which";
  }

  my ( $http, $head, $body ) = 
    get_url ($url, undef, $http_auth[0], $http_auth[1]);

  if ($body =~ m@/cgi-bin/[^\s\"<>\']+?[?&]UID=(\d+)\&@) {
    my $u = $1;
    print STDERR "$progname: pancam" . ($which+1) . ": found UID $u\n" 
      if ($verbose > 2);
    return $u;
  } else {
    return undef;
  }
}


my @dead_cams = ();   # for error messages


# Aim the given camera at some position.
# If uid is not specified, it will be computed.
# Returns the UID used.
#
sub position($$;$) {
  my ($which, $pos, $uid) = @_;
  
  my $loop_count = 0;
  my $max_loop_count = 5;
  my $ok = 0;

  do {
    $loop_count++;
    $uid = find_uid ($which)
      unless $uid;

    if ($uid) {

      my $url = $base_urls[$which] . "cgi-bin/camctrlid?UID=$uid&PRESET=$pos";

      if ($debug_p) {
        print STDERR "$progname: not loading $url\n" if ($verbose > 2);
        $ok = 1;

      } else {
        my ($http, $head, $body) = 
          get_url ($url, undef,  $http_auth[0], $http_auth[1]);

        if ($http =~ m@^HTTP/[\d.]+ 204\b@si) {	# "no contents" - good.

          print STDERR "$progname: pancam" . ($which+1) . ": pos $pos\n"
            if ($verbose);
          $ok = 1;

        } else {

          $http = "null response" unless $http;
          print STDERR "$progname: pancam" . ($which+1) .
            ": \"$http\" on $url: retrying...\n"
              if ($verbose);
        }
      }

    }

    # If we got here, we failed to get either UID or the page.
    # Try again after a delay.
    sleep (2) unless $ok;

  } while (!$ok && $loop_count < $max_loop_count);

  if ($ok && $dead_cams[$which]) {		# Dead cam came back to life.

    my $t = $dead_cams[$which];
    my $m = "pancam" . ($which+1) . ": responding again ($t tries)";
    print STDERR "$progname: $m\n";
    system ("logger", "-t", $progname, $m) if ($do_syslog);
    $dead_cams[$which] = 0;

  } elsif ($dead_cams[$which]) {		# Dead cam still dead.

    $dead_cams[$which] += $loop_count;
    $uid = undef;

  } elsif (!$ok && !$dead_cams[$which]) {	# Live cam died.

    my $t = $loop_count + ($dead_cams[$which] || 0);
    my $m = "pancam" . ($which+1) . " not responding ($t tries)";
    print STDERR "$progname: $m\n";
    system ("logger", "-t", $progname, $m) if ($do_syslog);
    $dead_cams[$which] = $t;
    $uid = undef;
  }

  return $uid;
}


# Given a numeric range string like "1,3-5", parses it out to "1, 3, 4, 5".
# Error if outside range [min, max].
#
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);
}


my $last_file_date = 0;   # ctime
my @last_file_data = ();  # ( ( cam 1 numbers ), ( cam 2 numbers ) ... )

# Read the switcher.conf file if it has changed since last read,
# and parse out the pancam-related lines.
#
sub read_file($) {
  my ($file) = @_;

  my $delay = undef;
  my @cams = ();

  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) {
      ($delay, @cams) = @last_file_data;
    } 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);
        ($delay, @cams) = @last_file_data;
      } else {

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

        local $/ = undef;  # read entire file
        my $body = <IN>;
        close IN;

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

        foreach my $cmd (split (/\n/, $body)) {
          next unless ($cmd =~ m@\bpancam@);
          if ($cmd =~ m@^\s*pancam(\d*)\s+=?\s*([-,\d]*)\s*$@) {
            my ($w, $s) = ($1, $2);
            $w = 1 unless $w;
            $w--;

            my $ref = $cams[$w];
            my @positions = ($ref ? @$ref : ());
            push @positions, parse_range ($s, 0, 16, $cmd);
            $cams[$w] = \@positions;

          } elsif ($cmd =~ m@^\s*pancam\s+delay\s*=?\s*([\d]+)\s*$@) {
            $delay = $1;
          } else {
            error ("unparsable pancam line: $cmd\n");
          }
        }

        $delay = 2 unless defined ($delay);

        $last_file_date = $mtime;
        @last_file_data = ($delay, @cams);

        if ($verbose) {
          print STDERR "$progname: $file: delay: $delay\n";
          my $i = 1;
          foreach my $ref (@cams) {
            my @positions = ($ref ? @$ref : ());
            print STDERR "$progname: $file: pancam$i positions: " .
              join (" ", @positions) . "\n";
            $i++;
          }
        }
      }
    }
  }

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

  return @last_file_data;
}


# Write the switcher.state file.
#
sub save_state($@) {
  my ($state_file, @positions) = @_;

  my $body = "";
  my $p = join(" ", @positions);
  $body .= "# written by $progname on " . localtime() . "\n";
  $body .=  "$p\n";

  if ($debug_p) {
    $body =~ s/^/\t/gm;
    print STDERR "$progname: not writing $state_file:\n$body"
      if ($verbose > 2);
  } else {
    local *OUT;
    open (OUT, ">$state_file") || error ("$state_file: $!");
    (print OUT $body) || error ("$state_file: $!");
    close OUT;
    print STDERR "$progname: wrote $state_file: $p\n" if ($verbose > 1);
  }
}


# If a single position was specified on the command line,
# set the given camera to that position.
#
# If multiple positions were specified on the command line,
# set the given camera to those positions at random, in a loop.
# Does not return.
#
# If a config file was specified, randomize the positions of all
# of the cameras specified in that state file, in a loop.  Does not
# return.
#
sub pancam($$$$@) {
  my ($file, $state_file, $which, $delay, @cmdline_positions) = @_;

  my @cams = ();

  if (! defined($file)) {
    $cams[$which] = \@cmdline_positions;
  }

  my @lasts = ();
  my @uids = ();

  my $max_n = -1;

  while (1) {

    ($delay, @cams) = read_file ($file) 
      if (defined ($file));

    my $i = -1;
    foreach my $ref (@cams) {
      $i++;
      next unless defined($ref);
      my @positions = @$ref;

      my $pos = -1;
      my $N = $#positions + 1;
      $max_n = $N if ($N > $max_n);

      if ($N == 1) {
        $pos = $positions[0];
      } elsif ($N > 1) {
        do {
          $pos = $positions[int(rand($N))];
        } while ($pos == ($lasts[$i] || -1));
      }

      if ($pos != ($lasts[$i] || -1)) {
        $uids[$i] = position ($i, $pos, $uids[$i]);
      }

      $lasts[$i] = $pos;
    }

    save_state ($state_file, @lasts)
      if defined ($state_file);

    return if ($max_n <= 1 && !defined ($file));
    sleep ($delay);
  }
}


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

sub signal_cleanup($) {
  my ($sig) = @_;
  print STDERR "$progname: " . (defined($sig)
                          ? "caught signal $sig."
                          : "exiting.")
                       . "\n";
  exit 1;
}

END { print STDERR "$progname: EXIT\n"; }

$SIG{HUP}  = \&signal_cleanup;
$SIG{INT}  = \&signal_cleanup;
$SIG{QUIT} = \&signal_cleanup;
$SIG{ABRT} = \&signal_cleanup;
$SIG{KILL} = \&signal_cleanup;
$SIG{TERM} = \&signal_cleanup;


sub usage() {
  print STDERR "usage: $progname [--verbose] [--which N] [--file config-file]\n" .
    "\t[--delay secs] position ...\n";
  exit 1;
}

sub main() {
  my $delay = 2;
  my @positions = ();
  my $file = undef;
  my $state_file = undef;
  my $which = undef;

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

  error ("LANG is $ENV{LANG} -- UTF is no good, man!")
    if ($ENV{LANG} && $ENV{LANG} =~ m/utf/i);

  while ($#ARGV >= 0) {
    $_ = shift @ARGV;
    if (m/^--?verbose$/)  { $verbose++; }
    elsif (m/^-v+$/)      { $verbose += length($_)-1; }
    elsif (m/^--?debug$/) { $debug_p++; }
    elsif (m/^--?file$/)  { $file = shift @ARGV; }
    elsif (m/^--?save$/)  { $state_file = shift @ARGV; }
    elsif (m/^--?delay$/) { $delay = shift(@ARGV) + 0; }
    elsif (m/^--?which$/) { $which = shift(@ARGV) + 0; }
    elsif (m/^-./)        { usage; }
    elsif (m/^\d+$/ )     { push @positions, int($_); }
    else                  { usage; }
  }

  usage unless (defined($file) || $#positions >= 0);

  error "can't specify --file and positions at the same time."
    if (defined($file) && $#positions >= 0);
  error "can't specify --file and --which at the same time."
    if (defined($file) && defined($which));

  if (!defined($which)) {
    $which = 0;
  } else {
    my $N = $#base_urls+1;
    error ("--which must be in range [1-$N]\n") 
      if ($which < 1 || $which > $N);
    $which--;
  }

  pancam ($file, $state_file, $which, $delay, @positions);
}

main();
print STDERR "$progname: EOF EXIT\n";
exit 0;