DNA Lounge Camera Control

#!/usr/bin/perl -w # Copyright © 2001-2008 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. # # Created: 28-Jul-2001. require 5; use diagnostics; use strict; use Socket; my $progname = $0; $progname =~ s@.*/@@g; my $version = q{ $Revision: 1.39 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/; my $verbose = 0; my $log_p = 1; my $remote_addr; my $config_file = "switcher.conf"; my $relay_url; my $check_nagios_cmd; #if (! (`uname -n` =~ m/^telomere/)) { # $relay_url = "http://telomere.dnalounge.net/switcher/"; #} #if (`uname -n` =~ m/^nucleus/) { # $check_nagios_cmd = './switcher-status.pl --html'; #} my $html_template = ' DNA Lounge Camera Control

Panning
Camera
Positions

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 platform

11: corner booth north

12: corner booth south

13: coat check balcony

14: north kiosks

15: ...

16: ...

Pan Delay:
Pancam All Off.

'; my @switcher_settings = (); my @pancam_settings = (); my $switcher_delay = 2; my $pancam_delay = 2; my $comment = undef; sub error { my ($err) = @_; if (defined($ENV{REQUEST_URI})) { print "Status: 400\n"; print "Content-Type: text/html\n"; print "\nError\n"; print "\n"; print "

Error: "; $err =~ s/&/&/g; $err =~ s//>/g; print "$err\n

\n"; if (0) { print "

\n"; foreach (sort keys(%ENV)) { $_ = "$_ = " . $ENV{$_}; s/&/&/g; s//>/g; print "$_ \n"; } print "

\n"; } exit (0); } else { print STDERR "$progname: $err\n"; exit 1; } } # Parse the HTTP POST data, where lines can be of the forms # c01_02=off # 1-16=3-12 # delay=5 # sub process_post_data { my ($data) = @_; print STDERR "$progname: reading submit data\n" if ($verbose); my $w = 16; my $h = 16; my $count = 0; foreach my $line (split (/&/, $data)) { print STDERR "$progname: $line\n" if ($verbose > 1); $_ = $line; my ($key, $val) = m/^([^=]+)=(.*)$/; if ($key eq "delay") { error "delay must be a number: $val" unless ($val =~ m/\d/ && $val =~ m/^\d*(\.\d*)?$/); $switcher_delay = 0 + $val; } elsif ($key eq "pancam_delay") { error "pancam_delay must be a number: $val" unless ($val =~ m/\d/ && $val =~ m/^\d*(\.\d*)?$/); $pancam_delay = 0 + $val; } elsif ($key =~ m/^c(\d\d?)_(\d\d?)$/) { if ($count == 0) { # if the first setter we see is of the cXX_YY form, zero out the grids, # since we're only going to get ones, not zeros. for (my $i = 0; $i < $w * $h; $i++) { $switcher_settings[$i] = 0; } for (my $i = 0; $i < $w; $i++) { $pancam_settings[$i] = 0; } print STDERR "$progname: reset grid\n" if ($verbose > 1); } my ($x, $y) = ($1, $2); if ($val eq 'off') { $val = 0; } elsif ($val eq 'on') { $val = 1; } else { error "unrecognized value: \"$val\" in \"$key=$val\"\n"; } error "out of range: $x\n" if ($x <= 0 || $x > $w); error "out of range: $y\n" if ($y <= 0 || $y > $h); $x--; $y--; $switcher_settings[$y * $w + $x] = $val; print STDERR "$progname: " . sprintf ("%02d,%02d = %d\n", $x, $y, $val) if ($verbose > 2); $count++; } elsif ($key =~ m/^pc(\d\d?)$/) { my $x = $1; if ($val eq 'off') { $val = 0; } elsif ($val eq 'on') { $val = 1; } else { error "unrecognized value: \"$val\" in \"$key=$val\"\n"; } error "out of range: $x\n" if ($x <= 0 || $x > $w); $x--; $pancam_settings[$x] = $val; print STDERR "$progname: " . sprintf ("pc%d = %d\n", $x, $val) if ($verbose > 2); $count++; } elsif ($key eq 'comment') { $comment = $val; $comment =~ s/\n+$//s; $comment =~ s/\n+/ /gs; } else { parse_setting_line ($line); $count++; } } } sub make_post_string { my $body = ""; my $w = 16; my $h = 16; # switcher settings for (my $y = 0; $y < $h; $y++) { for (my $x = 0; $x < $w; $x++) { my $k = sprintf ("c%d_%d", $x+1, $y+1); my $v = ($switcher_settings[($y * $w) + $x] ? "on" : "off"); $body .= "$k=$v\n"; } } $body .= "delay=$switcher_delay\n"; # pancam settings for (my $x = 0; $x < $w; $x++) { my $k = sprintf ("pc%d", $x+1); my $v = ($pancam_settings[$x] ? "on" : "off"); $body .= "$k=$v\n"; } $body .= "pancam delay=$pancam_delay\n"; $body .= "comment=$comment\n" if ($comment); $body =~ s/\n$//s; $body =~ s/\n/&/gs; return $body; } sub compress_bits { my (@bits) = @_; my $desc = ""; my $max = $#bits+1; for (my $i = 0; $i < $max; $i++) { my $checked = $bits[$i]; if ($checked) { my $i2; for ($i2 = $i+1; $i2 <= $max; $i2++) { $checked = $bits[$i2]; if (!$checked) { if ($i == $i2-1) { $desc .= "," . ($i+1); } elsif ($i == $i2-2) { $desc .= "," . ($i+1) . "," . ($i2); } else { $desc .= "," . ($i+1) . "-" . ($i2); } last; } } $i = $i2; } } $desc =~ s/^,//; return $desc; } sub uncompress_bits { my ($nums) = @_; my @result = (); foreach my $nn (split (',', $nums)) { $nn =~ s/\s*//g; if ($nn =~ m/^\d+$/) { push @result, 0 + $nn; } elsif ($nn =~ m/^(\d+)-(\d+)$/) { foreach ($1 .. $2) { push @result, $_; } } else { error "unparsable range: $nn"; } } return @result; } sub make_settings_string { my $w = 16; my $h = 16; my %results; # # switcher settings # for (my $x = 0; $x < $w; $x++) { my @bits = (); for (my $y = 0; $y < $h; $y++) { $bits[$y] = $switcher_settings[$y * $w + $x]; } my $desc = compress_bits (@bits); next if ($desc eq ''); $_ = $results{$desc}; my @vals = (defined($_) ? @{$_} : ()); push @vals, $x+1; $results{$desc} = \@vals; } my @results2 = (); foreach my $val (keys(%results)) { my @keys = @{$results{$val}}; my @bits = (); foreach (@keys) { $bits[$_ - 1] = 1; } my $keys = compress_bits (@bits); push @results2, "$keys=$val"; } # sort by the first number on the line @results2 = sort { my $aa = $a; $aa =~ s/^(\d+).*$/$1/; my $bb = $b; $bb =~ s/^(\d+).*$/$1/; return $aa <=> $bb; } @results2; # # pancam settings # { my @bits = (); for (my $x = 0; $x < $w; $x++) { $bits[$x] = $pancam_settings[$x]; } my $desc = compress_bits (@bits); push @results2, "pancam $desc"; } my $r = join ("\n", @results2); $r = "# $comment\n" . $r if defined($comment); return $r; } # Parse a line and store stuff into @switcher_settings. # # 1-16=3-12 (set to exactly 3-12) # 1-16-=3-12 (turn off 3-12) # 1-16+=3-12 (turn on 3-12) # # pancam 1,2,3 (same but for pancam instead of switcher) # sub parse_setting_line { my ($line) = @_; if ($line =~ m/\bpancam\b/) { parse_pancam_line ($line); return; } my $w = 16; my $h = 16; error "unparsable switcher line: $line" unless ($line =~ m@^\s*([-0-9,]+?)\s*([-+]?)=\s*([-0-9,]+)\s*$@); my ($keys, $mode, $vals) = ($1, $2, $3); $mode = ($mode eq '+' ? 1 : $mode eq '-' ? -1 : 0); my @vals2 = uncompress_bits ($vals); foreach my $key (uncompress_bits ($keys)) { my $x = $key-1; # zero out this column before we fill in the 1s. if ($mode == 0) { print STDERR "$progname: clearing col $x\n" if ($verbose > 2); for (my $y = 0; $y < $h; $y++) { $switcher_settings[$y * $w + $x] = 0; print STDERR "$progname: " . sprintf ("%02d,%02d = %d\n", $x, $y, 0) if ($verbose > 2); } } foreach my $val (@vals2) { my $y = $val-1; my $val = ($mode == -1 ? 0 : 1); @switcher_settings [$y * $w + $x] = $val; print STDERR "$progname: " . sprintf ("%02d,%02d = %d\n", $x, $y, $val) if ($verbose > 2); } } } sub parse_pancam_line { my ($line) = @_; my $h = 16; if ($line =~ m@^\s*pancam\s+delay\s*=?\s*(\d+)\s*$@) { $pancam_delay = $1; return; } error "unparsable pancam line: $line" unless ($line =~ m@^\s*pancam\s*([-+]?)=?\s*([-0-9,]*)\s*$@); my ($mode, $vals) = ($1, $2); $mode = ($mode eq '+' ? 1 : $mode eq '-' ? -1 : 0); my @vals2 = uncompress_bits ($vals); # zero out everything before we fill in the 1s. if ($mode == 0) { print STDERR "$progname: clearing pc\n" if ($verbose > 2); for (my $y = 0; $y < $h; $y++) { $pancam_settings[$y] = 0; print STDERR "$progname: " . sprintf ("pc%d = %d\n", $y+1, 0) if ($verbose > 2); } } foreach my $val (@vals2) { my $y = $val-1; my $val = ($mode == -1 ? 0 : 1); $pancam_settings[$y] = $val; print STDERR "$progname: " . sprintf ("pc%d = %d\n", $y+1, $val) if ($verbose > 2); } } # Parse the contents of the "settings" config file, which includes # lines of the form # # 1-16=3-12 # sleep=5 # sub parse_settings_string { my ($str) = @_; my $w = 16; my $h = 16; # zero out the grid. for (my $i = 0; $i < $w * $h; $i++) { $switcher_settings[$i] = 0; } for (my $i = 0; $i < $w; $i++) { $pancam_settings[$i] = 0; } foreach my $line (split ("\n", $str)) { if ($line =~ m/^\s*sleep\s*=\s*([\d.]+)\s*$/i) { $switcher_delay = 0 + $1; next; } elsif ($line =~ m/^\s*pancam\s+delay\s*=\s*([\d.]+)\s*$/i) { $pancam_delay = 0 + $1; next; } parse_setting_line ($line); } } sub read_config_file { my ($file) = @_; local *IN; my $body = ""; if ($relay_url) { $file = $relay_url; $file =~ s@/[^/]*$@/@; $file .= $config_file; open (IN, "wget -t1 -T5 -qO- $file |") || error "couldn't load URL $file"; } else { open (IN, "<$file") || error "couldn't read config file $file"; } print STDERR "$progname: reading $file\n" if ($verbose); while () { s/\#.*$//; s/\s+/ /g; s/^\s+//g; s/\s+$//g; $body .= "$_\n"; } close IN; $body =~ s/\n\n+/\n/gs; $body =~ s/^\s+//gs; $body =~ s/\s+$//gs; error ("configuration $file empty?") if ($body =~ m/^\s*$/s); parse_settings_string ($body); } sub write_config_file { my ($file) = @_; do_log() if ($log_p); if ($relay_url) { http_post ($relay_url, make_post_string()); } else { my $desc = make_settings_string(); my $body = ("# switcher config file\n" . "# written on " . localtime(time) . " by $progname $version\n" . "$desc\n" . "sleep=$switcher_delay\n" . "pancam delay=$pancam_delay\n"); local *OUT; open (OUT, ">$file") || error "couldn't write config file $file (as " . `whoami` . ")"; print OUT $body; close OUT; print STDERR "$progname: wrote $file\n" if ($verbose); } } sub http_post { my ($url, $data) = @_; my ($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4); $path = "" unless $path; my ($them,$port) = split(/:/, $serverstring); $port = 80 unless $port; my $iaddr = inet_aton($them) || error ("host not found: $them"); my $paddr = sockaddr_in($port, $iaddr); my $proto = getprotobyname('tcp'); local *S; socket(S, PF_INET, SOCK_STREAM, $proto) || error ("socket: $!"); connect(S, $paddr) || error ("$serverstring: $!"); select(S); $| = 1; select(STDOUT); print S "POST /$path HTTP/1.0\r\n"; print S "Host: $them\r\n"; print S "Content-Length: " . length($data) . "\r\n"; print S "\r\n"; print S $data; my $http = ; if ($http =~ m@^HTTP/1\.\d+ [23]0\d\s@) { close S; } else { my $err = $http; while () { $err .= $_; } error "$url reported:\n$err"; } print STDERR "$progname: posted $url\n" if ($verbose); } sub do_log { my $settings = make_settings_string(); foreach my $line (split (/\n/, $settings)) { system ("logger", "-t", $progname, "$remote_addr: $line"); } } sub draw_grid { my $html = $html_template; my $nagios = undef; if ($check_nagios_cmd) { $nagios = `$check_nagios_cmd`; $nagios =~ s@($1@xgsi; my $warning = ('

' . '' . 'WARNING: SWITCHER ERRORS!' . '' . '
Scroll down for details!' . '

'); $html =~ s/(]*?\bVALUE=\")[^\">]*/$1$switcher_delay/)) { error "internal error: coudln't find delay field?"; } if (! ($html =~ s/(NAME=\"pancam_delay\"[^>]*?\bVALUE=\")[^\">]*/$1$pancam_delay/)) { error "internal error: coudln't find pancam_delay field?"; } $html =~ s/%%REMOTE%%/$remote_addr/g; if ($nagios) { $html .= "\n

~~\n$nagios\n~~

\n"; } print "Content-Type: text/html\n"; print "Content-Length: " . length($html) . "\n"; print "\n"; print $html; print STDERR "$progname: wrote HTML\n" if ($verbose); } # Write a redirect back to this URL, to turn the POST into a GET. # sub write_redirect { my $url = "http://$ENV{HTTP_HOST}$ENV{REQUEST_URI}"; $url =~ s/\#.*$//; $url =~ s/\?.*$//; print "Status: 302\n"; print "Location: $url\n"; print "Content-Type: text/html\n"; print "\n"; print "$url\n"; print STDERR "$progname: redirected to $url\n" if ($verbose); } sub usage { print STDERR "usage: $progname [--verbose]\n"; exit 1; } sub main { $|=1; $progname = "switcher.cgi" if ($progname eq "index.cgi"); $remote_addr = ($ENV{REMOTE_ADDR} || "???"); # Only parse argv if we're not running as a CGI. # if (!defined ($ENV{REQUEST_URI})) { $remote_addr = "cmdline"; while ($_ = $ARGV[0]) { shift @ARGV; if ($_ eq "--verbose") { $verbose++; } elsif (m/^-v+$/) { $verbose += length($_)-1; } elsif (m/^-./) { usage; } else { usage; } } } if (defined($ENV{PATH_INFO}) && $ENV{PATH_INFO} ne "") { error ("extraneous crap in URL: $ENV{PATH_INFO}"); } if ($remote_addr =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { my $iaddr = inet_aton($remote_addr); my $name = gethostbyaddr($iaddr, AF_INET); $name =~ s/^([^.]+).*$/$1/ if ($name); $remote_addr = $name if ($name); } read_config_file($config_file); $ENV{REQUEST_METHOD} = '' unless defined ($ENV{REQUEST_METHOD}); $ENV{QUERY_STRING} = '' unless defined ($ENV{QUERY_STRING}); if ($ENV{REQUEST_METHOD} eq "POST" || $ENV{QUERY_STRING} ne "") { print STDERR "$progname: submit method: $ENV{REQUEST_METHOD}\n" if ($verbose); my $data = ''; if ($ENV{REQUEST_METHOD} eq "POST") { while () { $data .= $_; } } else { $data = $ENV{QUERY_STRING}; } process_post_data ($data); write_config_file($config_file); write_redirect (); } else { draw_grid (); } } main; exit 0;