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

# 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.13 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;

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

my $base_url = "http://cam.dnalounge.net/";
my @http_auth = ("admin", "switch");
my $http_proxy = undef;

my $uid = undef;
my %host_cache;

# 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 = $host_cache{$remote};
  if (! $iaddr) {
    $iaddr = inet_aton($remote);
    if (!$iaddr) {
      error ("host not found: $remote");
    }
    $host_cache{$remote} = $iaddr;
  }

  $paddr   = sockaddr_in($port2, $iaddr);


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

  $proto   = getprotobyname('tcp');
  if (!socket(S, PF_INET, SOCK_STREAM, $proto)) {
    error ("socket: $!");
  }
  if (!connect(S, $paddr)) {
    error ("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) {
    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");
  }

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


# Loads the given URL, processes redirects, returns 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;

  do {
    my ( $http, $head, $body ) = get_url_1 ($url, $referer, $user, $pass);

    $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");
      }

    } elsif ( $http =~ m@^HTTP/[0-9.]+ ([4-9][0-9][0-9].*)$@ ) {
#     error ("failed: $1 ($url)");
      return "error: $1";

    } else {
      return $body;
    }
  } while (1);
}


sub find_uid {
  my $url = $base_url . "cgi-bin/getuid?FILE=indexnw.html";

  my $loop_count = 0;
  my $max_loop_count = 0;
  my $retry_delay = 3;
  my $retry_inc = 3;

  do {
    $_ = get_url ($url, undef, @http_auth);
    if (m@/cgi-bin/[^\s\"<>\']+?[?&]UID=(\d+)\&@) {
      my $u = $1;
      print STDERR "$progname: found UID $u\n" if ($verbose > 2);
      return $u;
    }

    if ($max_loop_count > 0 &&
        $loop_count++ > $max_loop_count) {
      error ("too many UID tries ($loop_count): $url");
    }

    print STDERR "$progname: UID failure: retrying in $retry_delay...\n"
      if ($verbose);
    sleep ($retry_delay);
    $retry_delay = 0 if ($retry_delay >= 60);  # rachet back down
    $retry_delay += $retry_inc;

  } while (1);
}

sub position {
  my ($pos) = @_;
  
  my $loop_count = 0;
  my $max_loop_count = 4;

  do {
    $uid = find_uid() unless defined ($uid);

    my $url = $base_url . "cgi-bin/camctrlid?UID=$uid&PRESET=$pos";
    my $body = get_url ($url, undef, @http_auth);

    return if ($body =~ m/^\s*$/s);

    $uid = undef;
    if ($loop_count++ > $max_loop_count) {
      error ("too many UID tries ($loop_count): $body");
    }

  } while (1);
}


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;
my @last_file_data = ();

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

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

  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, @positions) = @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, @positions) = @last_file_data;
      } 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 comment lines

        foreach my $cmd (split (/\n/, $body)) {
          next unless ($cmd =~ m@\bpancam\b@);
          if ($cmd =~ m@^\s*pancam\s+=?\s*([-,\d]*)\s*$@) {
            my $s = $1;
            push @positions, parse_range ($s, 0, 16, $cmd);
          } 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, @positions);

        if ($verbose) {
          print STDERR "$progname: $file: delay: $delay\n";
          print STDERR "$progname: $file: positions: " .
            join (" ", @positions) . "\n";
        }
      }
    }
  }

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

  return @last_file_data;
}


sub save_state {
  my ($state_file, $pos) = @_;

  local *OUT;
  my $body = "";
  $body .= "# written by $progname on " . localtime() . "\n";
  $body .= "$pos\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 pancam {
  my ($file, $state_file, $delay, @positions) = @_;

  my $last = -1;
  my $pos = $last;

  while (1) {

    if (defined ($file)) {
      ($delay, @positions) = read_file ($file);
    }

    $uid = find_uid() unless defined ($uid);

    my $N = $#positions + 1;
    if ($N == 1) {
      $pos = $positions[0];
    } elsif ($N > 1) {
      $pos = $positions[int(rand($N))]
        while ($pos == $last);
    }
    position ($pos)
      if ($last != $pos);
    $last = $pos;

    save_state ($state_file, $pos)
      if defined ($state_file);

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



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

sub usage {
  print STDERR "usage: $progname [--verbose] [--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;

  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 ($_ eq "--verbose") { $verbose++; }
    elsif ($_ eq "--file") { $file = shift @ARGV; }
    elsif ($_ eq "--save") { $state_file = shift @ARGV; }
    elsif ($_ eq "--delay") { $delay = shift(@ARGV) + 0; }
    elsif (m/^-v+$/) { $verbose += length($_)-1; }
    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);

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

main;
exit 0;