Panning Camera %%WHICH%% Control

#!/usr/bin/perl -w # Copyright © 2004-2013 Jamie Zawinski # # 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 page for the Panasonic WV-NS324 servo-mounted video camera. # # This camera has a built-in web server, with controls that let you manually # zoom, save positions as presets, etc. Those web pages have some problems, # however. They've overly complicated (many commands are spread out across # multiple pages), but most importantly, the "joystick" control on the web # pages (by which you actually move the camera) doesn't work in Mozilla or # Safari (it was coded for MSIE and Netscape 4.x only.) # # So, I wrote my own UI for camera control, that works by posting to the # underlying "control" URLs on the camera, bypassing the on-camera user # interface. This is it. Works pretty good. # # Created: 7-Mar-2004. require 5; use diagnostics; use strict; use Socket; use MIME::Base64; require POSIX; BEGIN { push @INC, "/var/www/dnalounge/utils/"; } use dna_auth; use Menuify; # DNA::Menuify DNA::Menuify->import qw(error url_unquote); my $progname = $0; $progname =~ s@.*/@@g; my $version = q{ $Revision: 1.47 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/; my $verbose = 0; my $debug_p = 0; my @int_base_urls = ("http://cam1.dnalounge.net/", "http://cam2.dnalounge.net/"); my @ext_base_urls = ("http://membrane.dnalounge.net:10013/", "http://membrane.dnalounge.net:10014/"); my @http_auth = ("admin", "switch"); my $http_proxy = undef; my $image_width = 320; my $image_height = 240; my $frameset_html = ' Panning Camera %%WHICH%% Control '; my @cheat_sheet_html = ( # # Camera 1 # '

01: stage very wide
02: stage center close
03: stage left close
04: stage right close

05: dance floor wide
06: gogo platform north
07: gogo platform south
08: straight down

09: balcony bar
10: dj booth
11: corner booth north
12: corner booth south

13: coat check balcony
14: rear stage riser
15: ...
16: ...

', # # Camera 2 # '

01: stage wide right
02: stage center right
03: in front of stage right
04: dance floor right wide

05: benches south
06: benches north
07: gogo platform north
08: gogo platform south

09: gogo platform south down
10: ...
11: ...
12: ...

13: ...
14: ...
15: ...
16: ...

'); # 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); $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) { 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 = || ""; $_ = $http; s/[\r\n]+$//s; print STDERR " <== $_\n" if ($verbose > 3); while () { $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/\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: $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 ('', '', '') if ($@ eq $alarm); # timed out die "fuck $@"; # 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 = $ext_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; } } sub this_url() { my $url = (($ENV{HTTPS} ? "https://" : "http://") . ($ENV{SERVER_NAME} || 'example.com')); $url .= ":" . $ENV{SERVER_PORT} unless (!$ENV{SERVER_PORT} || $ENV{SERVER_PORT} eq '80' || $ENV{SERVER_PORT} eq '443'); $url .= ($ENV{REQUEST_URI} || '/blort/'); return $url; } sub write_redirect($) { my ($url) = @_; print STDOUT "Location: $url\r\n"; print STDOUT "Content-Type: text/plain\r\n\r\n$url\r\n"; } sub write_html_and_headers($) { my ($body) = @_; my $L = length ($body); print STDOUT "Content-Type: text/html\r\n"; print STDOUT "Content-Length: $L\r\n"; print STDOUT "\r\n"; print STDOUT $body; } sub write_control_html($$) { my ($uid, $which) = @_; my $body = ''; $body .= ' Panning Camera ' . ($which+1) . ' Control

rotate
'; my @values = (-12, -8, -1, 0, 1, 8, 12); for (my $y = 0; $y <= $#values; $y++) { $body .= " \n"; for (my $x = 0; $x <= $#values; $x++) { my $xx = $values[$x]; my $yy = $values[$y]; if ($xx == 0 && $yy == 0) { $body .= " \n"; } else { my $url = ($int_base_urls[$which] . "cgi-bin/directctrl" . "?PAN=" . $xx . "&TILT=" . $yy); $body .= " \n"; } } $body .= " \n"; } $body .= '
##
zoom
'; @values = (-4, -3, -2, 0, 2, 3, 4); for (my $x = 0; $x <= $#values; $x++) { my $xx = $values[$x]; if ($xx == 0) { $body .= " \n"; } else { my $url = ($int_base_urls[$which] . "cgi-bin/directctrl" . "?ZOOM=" . $xx); my $t = ($xx < 0 ? '<<' : '>>'); $body .= " \n"; } } $body .= '

$t

move to
preset
'; for (my $y = 0; $y < 4; $y++) { $body .= " \n"; for (my $x = 0; $x < 4; $x++) { my $i = ($y * 4) + $x + 1; my $url = ($int_base_urls[$which] . "cgi-bin/camctrl?PRESET=" . $i); $body .= " \n"; } $body .= " \n"; } $body .= '
$i
save as
preset
'; for (my $y = 0; $y < 4; $y++) { $body .= " \n"; for (my $x = 0; $x < 4; $x++) { my $i = ($y * 4) + $x + 1; my $url = ($int_base_urls[$which] . "cgi-bin/camposiset" . "?UID=" . $uid . "&PRESETSET=" . $i); $body .= " \n"; } $body .= " \n"; } $body .= '
$i

focus
'; { my $url = $int_base_urls[$which] . "cgi-bin/directctrl?FOCUS="; $body .= " \n"; $body .= " \n"; $body .= " \n"; } $body .= '

<< >>

autofocus
'; { my $url = $int_base_urls[$which] . "cgi-bin/camctrl?AF="; $body .= " \n"; $body .= " \n"; $body .= " \n"; } $body .= '

on off

brightness '; { my $url = $int_base_urls[$which] . "cgi-bin/camctrl?IRIS="; $body .= " \n"; $body .= " \n"; $body .= " \n"; $body .= " \n"; $body .= " \n"; } $body .= '

dark light reset

pan '; { my $url = $int_base_urls[$which] . "cgi-bin/camctrl?ATPAN="; $body .= " \n"; $body .= " \n"; $body .= " \n"; } $body .= '

start stop

save pan points '; { my $url = $int_base_urls[$which] . "cgi-bin/camposiset?"; $body .= " \n"; $body .= " \n"; $body .= " \n"; $body .= " \n"; $body .= " \n"; } $body .= '

one two reverse

Toggle Self-Clean '; { my $url = this_url(); $url =~ s/\?.*$//; $body .= "Reload\n"; } $body .= '

'; write_html_and_headers ($body); } sub write_image_html($$) { my ($uid, $which) = @_; my $body = ''; $body .= ' Camera Image '; my $url = $int_base_urls[$which] . "cgi-bin/cameraid?UID=$uid"; $body .= "
\n"; $body .= " \n"; $body .= " \n"; $body .= "
\n"; $body .= " ; } elsif (defined($ENV{QUERY_STRING})) { $args = $ENV{QUERY_STRING}; } foreach (split (/&/, $args)) { my ($key, $val) = m/^([^=]+)=(.*)$/; error ("unparsable args") unless (defined ($key) && defined ($val)); $key = url_unquote ($key); $val = url_unquote ($val); if ($key =~ m/^UID$/i) { error ("multiple `uid' arguments are not allowed.") if (defined($uid)); $uid = $val; } elsif ($key =~ m/^page$/i) { error ("multiple `page' arguments are not allowed.") if (defined($page)); $page = $val; } elsif ($key =~ m/^cam$/i) { error ("multiple `cam' arguments are not allowed.") if (defined($which)); $which = $val + 0; } else { error ("unknown option: $key."); } } $page = 'main' unless defined ($page); $which = 1 unless $which; $which--; error ("no camera number " . ($which+1)) if ($which > $#int_base_urls); write_html ($uid, $which, $page); } main(); exit 0;